diff --git a/.github/ci.sh b/.github/ci.sh index 48d6b1a610..f9649239a2 100755 --- a/.github/ci.sh +++ b/.github/ci.sh @@ -103,7 +103,6 @@ haddock() { saw:saw-core-sbv saw:saw-core-aig saw:saw-core-coq - saw:heapster saw:saw-central saw:saw-script saw:saw-server diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index b1194b0be2..00d046f2cd 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -194,7 +194,6 @@ jobs: cryptol-saw-core-tests crux-mir-comp-tests saw-core-coq-tests - heapster-prover-tests dest: dist-tests # In the next 2 steps, we upload to different names depending on whether @@ -470,94 +469,6 @@ jobs: publish_dir: gh-pages keep_files: true - mr-solver-tests: - needs: [build] - strategy: - fail-fast: false - matrix: - os: [ubuntu-24.04, macos-14] - runs-on: ${{ matrix.os }} - steps: - - uses: actions/checkout@v4 - with: - submodules: true - - - shell: bash - run: .github/ci.sh install_system_deps - env: - BUILD_TARGET_OS: ${{ matrix.os }} - BUILD_TARGET_ARCH: ${{ runner.arch }} - - - uses: actions/download-artifact@v4 - with: - name: "${{ matrix.os }}-bins" - path: dist/bin - - - name: Update PATH to include SAW - shell: bash - run: | - chmod +x dist/bin/* - echo $GITHUB_WORKSPACE/dist/bin >> $GITHUB_PATH - - - working-directory: examples/mr_solver - shell: bash - run: | - saw monadify.saw - saw mr_solver_unit_tests.saw - - heapster-tests: - needs: [build] - strategy: - fail-fast: false - matrix: - os: [ubuntu-24.04, macos-14] - runs-on: ${{ matrix.os }} - steps: - - uses: actions/checkout@v4 - with: - submodules: true - - - shell: bash - run: .github/ci.sh install_system_deps - env: - BUILD_TARGET_OS: ${{ matrix.os }} - BUILD_TARGET_ARCH: ${{ runner.arch }} - - - uses: actions/download-artifact@v4 - with: - name: "${{ matrix.os }}-bins" - path: dist/bin - - - name: Update PATH to include SAW - shell: bash - run: | - chmod +x dist/bin/* - echo $GITHUB_WORKSPACE/dist/bin >> $GITHUB_PATH - - - uses: ocaml/setup-ocaml@v3 - with: - ocaml-compiler: "4.14" - - - run: opam repo add coq-released https://coq.inria.fr/opam/released - - - run: opam install -y coq=8.15.2 coq-bits=1.1.0 - - # If you change the entree-specs commit below, make sure you update the - # documentation in saw-core-coq/README.md accordingly. - - run: opam pin -y entree-specs https://github.com/GaloisInc/entree-specs.git#f104f6b3e6fe5987d543d90265cdc52f532de5fe - - # FIXME: the following steps generate Coq libraries for the SAW core to - # Coq translator and builds them; if we do other Coq tests, these steps - # should become their own build artifact, to avoid re-compiling the Coq - # libraries - - working-directory: saw-core-coq/coq - shell: bash - run: opam exec -- make -j - - - working-directory: heapster/examples - shell: bash - run: opam exec -- make -j - crux-mir-comp-tests: needs: [build] strategy: @@ -1092,7 +1003,6 @@ jobs: runs-on: ubuntu-24.04 needs: - build - - heapster-tests - crux-mir-comp-tests - saw-remote-api-tests - cabal-test diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 0371b2966d..9dce60c4f8 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -255,8 +255,6 @@ The top-level repository directories are: solver queries using the [What4](https://github.com/GaloisInc/what4) library. -* `heapster` - The Heapster tool. - * `saw-central` - A library containing the bulk of SAW. * `saw-script` - A library containing the SAWScript interpreter. diff --git a/build.sh b/build.sh index 8a9abf4037..85f582bcc9 100755 --- a/build.sh +++ b/build.sh @@ -84,8 +84,7 @@ tgt_build() { test-suite:integration-tests test-suite:saw-core-tests \ test-suite:crux-mir-comp-tests \ test-suite:cryptol-saw-core-tests \ - test-suite:saw-core-coq-tests \ - test-suite:heapster-prover-tests + test-suite:saw-core-coq-tests echo "rm -rf bin && mkdir bin" rm -rf bin && mkdir bin diff --git a/cabal.project b/cabal.project index 56a0c555d4..0c6b6e1d68 100644 --- a/cabal.project +++ b/cabal.project @@ -42,11 +42,6 @@ packages: deps/rme/rme deps/rme/rme-what4 -source-repository-package - type: git - location: https://github.com/eddywestbrook/hobbits.git - tag: 70963e0e3eba2b16f6fc030acb582e8100955e47 - -- enable ghc >= 9.8's additional build parallelism semaphore: true diff --git a/crucible-mir-comp/src/Mir/Compositional/Convert.hs b/crucible-mir-comp/src/Mir/Compositional/Convert.hs index 5a46cea429..db8698dbc6 100644 --- a/crucible-mir-comp/src/Mir/Compositional/Convert.hs +++ b/crucible-mir-comp/src/Mir/Compositional/Convert.hs @@ -156,7 +156,6 @@ termToReg sym varMap term shp0 = do where go :: forall tp'. TypeShape tp' -> SValue sym -> IO (RegValue sym tp') go shp sv = case (shp, sv) of - (UnitShape _, SAW.VUnit) -> return () (PrimShape _ BaseBoolRepr, SAW.VBool b) -> return b (PrimShape _ (BaseBVRepr w), SAW.VWord (W4.DBV e)) | Just Refl <- testEquality (W4.exprType e) (BaseBVRepr w) -> return e @@ -167,8 +166,8 @@ termToReg sym varMap term shp0 = do _ -> fail $ "termToReg: type error: need to produce " ++ show (shapeType shp) ++ ", but simulator returned a vector containing " ++ show x buildBitVector w bits - (TupleShape _ elems, _) -> do - svs <- reverse <$> tupleToListRev (length elems) [] sv + (TupleShape _ elems, SAW.VTuple thunks) -> do + svs <- mapM SAW.force $ toList thunks buildMirAggregate sym elems svs $ \_ _ shp' sv' -> go shp' sv' (ArrayShape (M.TyArray _ n) _ shp', SAW.VVector thunks) -> do svs <- mapM SAW.force $ toList thunks @@ -191,21 +190,6 @@ termToReg sym varMap term shp0 = do _ -> error $ "termToReg: type error: need to produce " ++ show (shapeType shp) ++ ", but simulator returned " ++ show sv - -- | Convert an `SValue` tuple (built from nested `VPair`s) into a list of - -- the inner `SValue`s, in reverse order. - tupleToListRev :: Int -> [SValue sym] -> SValue sym -> IO [SValue sym] - tupleToListRev 2 acc (SAW.VPair x y) = do - x' <- SAW.force x - y' <- SAW.force y - return $ y' : x' : acc - tupleToListRev n acc (SAW.VPair x xs) | n > 2 = do - x' <- SAW.force x - xs' <- SAW.force xs - tupleToListRev (n - 1) (x' : acc) xs' - tupleToListRev n _ _ | n < 2 = error $ "bad tuple size " ++ show n - tupleToListRev n _ v = error $ "termToReg: expected tuple of " ++ show n ++ - " elements, but got " ++ show v - -- | Build a bitvector from a vector of bits. The length of the vector is -- required to match `tw`. buildBitVector :: forall tw. (1 <= tw) => diff --git a/cryptol-saw-core/saw/Cryptol.sawcore b/cryptol-saw-core/saw/Cryptol.sawcore index ace146af90..ddf183f160 100644 --- a/cryptol-saw-core/saw/Cryptol.sawcore +++ b/cryptol-saw-core/saw/Cryptol.sawcore @@ -21,11 +21,11 @@ bvExp n x y = foldr Bool (Vec n Bool) n (bvNat n 1) (reverse n Bool y); -updFst : (a b : sort 0) -> (a -> a) -> (a * b) -> (a * b); -updFst a b f x = (f x.(1), x.(2)); +updFst : (a b : sort 0) -> (a -> a) -> #(a, b) -> #(a, b); +updFst a b f x = (f x.0, x.1); -updSnd : (a b : sort 0) -> (b -> b) -> (a * b) -> (a * b); -updSnd a b f x = (x.(1), f x.(2)); +updSnd : (a b : sort 0) -> (b -> b) -> #(a, b) -> #(a, b); +updSnd a b f x = (x.0, f x.1); -------------------------------------------------------------------------------- -- Extended natural numbers @@ -313,23 +313,25 @@ fun_cong a b c d eq_ab eq_cd = (eq_cong (sort 0) a b eq_ab (sort 0) (\ (x:sort 0) -> (x -> c))) (eq_cong (sort 0) c d eq_cd (sort 0) (\ (x:sort 0) -> (b -> x))); -pair_cong : (a : sort 0) -> (a' : sort 0) -> (b : sort 0) -> (b' : sort 0) -> - Eq (sort 0) a a' -> Eq (sort 0) b b' -> Eq (sort 0) (a * b) (a' * b'); +pair_cong : + (a : sort 0) -> (a' : sort 0) -> + (b : sort 0) -> (b' : sort 0) -> + Eq (sort 0) a a' -> Eq (sort 0) b b' -> Eq (sort 0) #(a, b) #(a', b'); pair_cong a a' b b' eq_a eq_b = trans - (sort 0) (a * b) (a' * b) (a' * b') - (eq_cong (sort 0) a a' eq_a (sort 0) (\ (x:sort 0) -> (x * b))) - (eq_cong (sort 0) b b' eq_b (sort 0) (\ (x:sort 0) -> (a' * x))); + (sort 0) #(a, b) #(a', b) #(a', b') + (eq_cong (sort 0) a a' eq_a (sort 0) (\ (x:sort 0) -> #(x, b))) + (eq_cong (sort 0) b b' eq_b (sort 0) (\ (x:sort 0) -> #(a', x))); pair_cong1 : (a : sort 0) -> (a' : sort 0) -> (b : sort 0) -> - Eq (sort 0) a a' -> Eq (sort 0) (a * b) (a' * b); + Eq (sort 0) a a' -> Eq (sort 0) #(a, b) #(a', b); pair_cong1 a a' b eq_a = - (eq_cong (sort 0) a a' eq_a (sort 0) (\ (x:sort 0) -> (x * b))); + (eq_cong (sort 0) a a' eq_a (sort 0) (\ (x:sort 0) -> #(x, b))); pair_cong2 : (a : sort 0) -> (b : sort 0) -> (b' : sort 0) -> - Eq (sort 0) b b' -> Eq (sort 0) (a * b) (a * b'); + Eq (sort 0) b b' -> Eq (sort 0) #(a, b) #(a, b'); pair_cong2 a b b' eq_b = - (eq_cong (sort 0) b b' eq_b (sort 0) (\ (x:sort 0) -> (a * x))); + (eq_cong (sort 0) b b' eq_b (sort 0) (\ (x:sort 0) -> #(a, x))); axiom unsafeAssert_same_Num : (n : Num) -> Eq (Eq Num n n) (unsafeAssert Num n n) (Refl Num n); @@ -347,105 +349,105 @@ eListSel a n = -- List comprehensions from : (a b : isort 0) -> (m n : Num) -> seq m a -> (a -> seq n b) -> - seq (tcMul m n) (a * b); + seq (tcMul m n) #(a, b); from a b m n = Num#rec - (\ (m:Num) -> seq m a -> (a -> seq n b) -> seq (tcMul m n) (a * b)) + (\ (m:Num) -> seq m a -> (a -> seq n b) -> seq (tcMul m n) #(a, b)) (\ (m:Nat) -> Num#rec (\ (n:Num) -> Vec m a -> (a -> seq n b) -> - seq (tcMul (TCNum m) n) (a * b)) + seq (tcMul (TCNum m) n) #(a, b)) -- Case 1: (TCNum m, TCNum n) (\ (n:Nat) -> \ (xs : Vec m a) -> \ (k : a -> Vec n b) -> - join m n (a * b) - (map a (Vec n (a * b)) + join m n #(a, b) + (map a (Vec n #(a, b)) (\ (x : a) -> - map b (a * b) (\ (y : b) -> (x, y)) n (k x)) + map b #(a, b) (\ (y : b) -> (x, y)) n (k x)) m xs)) -- Case 2: n = (TCNum m, TCInf) (natCase (\ (m':Nat) -> (Vec m' a -> (a -> Stream b) -> - seq (if0Nat Num m' (TCNum 0) TCInf) (a * b))) + seq (if0Nat Num m' (TCNum 0) TCInf) #(a, b))) (\ (xs : Vec 0 a) -> - \ (k : a -> Stream b) -> EmptyVec (a * b)) + \ (k : a -> Stream b) -> EmptyVec #(a, b)) (\ (m' : Nat) -> \ (xs : Vec (Succ m') a) -> \ (k : a -> Stream b) -> - (\ (x : a) -> streamMap b (a * b) (\ (y:b) -> (x, y)) (k x)) + (\ (x : a) -> streamMap b #(a, b) (\ (y:b) -> (x, y)) (k x)) (at (Succ m') a xs 0)) m) n) (Num#rec - (\ (n:Num) -> Stream a -> (a -> seq n b) -> seq (tcMul TCInf n) (a * b)) + (\ (n:Num) -> Stream a -> (a -> seq n b) -> seq (tcMul TCInf n) #(a, b)) -- Case 3: (TCInf, TCNum n) (\ (n:Nat) -> natCase (\ (n':Nat) -> (Stream a -> (a -> Vec n' b) -> - seq (if0Nat Num n' (TCNum 0) TCInf) (a * b))) + seq (if0Nat Num n' (TCNum 0) TCInf) #(a, b))) (\ (xs : Stream a) -> - \ (k : a -> Vec 0 b) -> EmptyVec (a * b)) + \ (k : a -> Vec 0 b) -> EmptyVec #(a, b)) (\ (n' : Nat) -> \ (xs : Stream a) -> \ (k : a -> Vec (Succ n') b) -> streamJoin - (a * b) n' + #(a, b) n' (streamMap - a (Vec (Succ n') (a * b)) + a (Vec (Succ n') #(a, b)) (\ (x:a) -> - map b (a * b) (\ (y:b) -> (x, y)) (Succ n') (k x)) + map b #(a, b) (\ (y:b) -> (x, y)) (Succ n') (k x)) xs)) n) -- Case 4: (TCInf, TCInf) (\ (xs : Stream a) -> \ (k : a -> Stream b) -> - (\ (x : a) -> streamMap b (a * b) (\ (y : b) -> (x, y)) (k x)) + (\ (x : a) -> streamMap b #(a, b) (\ (y : b) -> (x, y)) (k x)) (streamGet a xs 0)) n) m; -mlet : (a b : isort 0) -> (n : Num) -> a -> (a -> seq n b) -> seq n (a * b); +mlet : (a b : isort 0) -> (n : Num) -> a -> (a -> seq n b) -> seq n #(a, b); mlet a b n = Num#rec - (\ (n:Num) -> a -> (a -> seq n b) -> seq n (a * b)) + (\ (n:Num) -> a -> (a -> seq n b) -> seq n #(a, b)) (\ (n:Nat) -> \ (x:a) -> \ (f:a -> Vec n b) -> - map b (a * b) (\ (y : b) -> (x, y)) n (f x)) + map b #(a, b) (\ (y : b) -> (x, y)) n (f x)) (\ (x:a) -> \ (f:a -> Stream b) -> - streamMap b (a * b) (\ (y : b) -> (x, y)) (f x)) + streamMap b #(a, b) (\ (y : b) -> (x, y)) (f x)) n; seqZip : (a b : isort 0) -> (m n : Num) -> seq m a -> seq n b -> - seq (tcMin m n) (a * b); + seq (tcMin m n) #(a, b); seqZip a b m n = Num#rec - (\ (m:Num) -> seq m a -> seq n b -> seq (tcMin m n) (a * b)) + (\ (m:Num) -> seq m a -> seq n b -> seq (tcMin m n) #(a, b)) (\ (m : Nat) -> Num#rec - (\ (n:Num) -> Vec m a -> seq n b -> seq (tcMin (TCNum m) n) (a * b)) + (\ (n:Num) -> Vec m a -> seq n b -> seq (tcMin (TCNum m) n) #(a, b)) (\ (n:Nat) -> zip a b m n) (\ (xs:Vec m a) -> \ (ys:Stream b) -> - gen m (a * b) (\ (i : Nat) -> (at m a xs i, streamGet b ys i))) + gen m #(a, b) (\ (i : Nat) -> (at m a xs i, streamGet b ys i))) n) (Num#rec - (\ (n:Num) -> Stream a -> seq n b -> seq (tcMin TCInf n) (a * b)) + (\ (n:Num) -> Stream a -> seq n b -> seq (tcMin TCInf n) #(a, b)) (\ (n:Nat) -> \ (xs:Stream a) -> \ (ys:Vec n b) -> - gen n (a * b) (\ (i : Nat) -> (streamGet a xs i, at n b ys i))) - (streamMap2 a b (a * b) (\ (x:a) -> \ (y:b) -> (x, y))) + gen n #(a, b) (\ (i : Nat) -> (streamGet a xs i, at n b ys i))) + (streamMap2 a b #(a, b) (\ (x:a) -> \ (y:b) -> (x, y))) n) m; -zipSame : (a b : isort 0) -> (n : Nat) -> Vec n a -> Vec n b -> Vec n (a * b); -zipSame a b n x y = gen n (a*b) (\ (i : Nat) -> (at n a x i, at n b y i)); +zipSame : (a b : isort 0) -> (n : Nat) -> Vec n a -> Vec n b -> Vec n #(a, b); +zipSame a b n x y = gen n #(a, b) (\ (i : Nat) -> (at n a x i, at n b y i)); -seqZipSame : (a b : isort 0) -> (n : Num) -> seq n a -> seq n b -> seq n (a * b); +seqZipSame : (a b : isort 0) -> (n : Num) -> seq n a -> seq n b -> seq n #(a, b); seqZipSame a b n = Num#rec - (\ (n : Num) -> seq n a -> seq n b -> seq n (a * b)) + (\ (n : Num) -> seq n a -> seq n b -> seq n #(a, b)) (\ (n : Nat) -> zipSame a b n) - (streamMap2 a b (a*b) (\ (x:a) -> \ (y:b) -> (x,y))) + (streamMap2 a b #(a, b) (\ (x:a) -> \ (y:b) -> (x,y))) n; -------------------------------------------------------------------------------- @@ -466,13 +468,27 @@ unitUnary _ = (); unitBinary : #() -> #() -> #(); unitBinary _ _ = (); -pairUnary : (a b : sort 0) -> (a -> a) -> (b -> b) -> (a * b) -> (a * b); -pairUnary a b f g xy = (f (fst a b xy), g (snd a b xy)); - -pairBinary : (a b : sort 0) -> (a -> a -> a) -> (b -> b -> b) - -> (a * b) -> (a * b) -> (a * b); -pairBinary a b f g x12 y12 = (f (fst a b x12) (fst a b y12), - g (snd a b x12) (snd a b y12)); +pairUnary : + (t : sort 0) -> + (ts : TypeList) -> + (t -> t) -> + (Tuple ts -> Tuple ts) -> + Tuple (TypeCons t ts) -> Tuple (TypeCons t ts); +pairUnary t ts f g x = + consTuple t ts + (f (headTuple t ts x)) + (g (tailTuple t ts x)); + +pairBinary : + (t : sort 0) -> + (ts : TypeList) -> + (t -> t -> t) -> + (Tuple ts -> Tuple ts -> Tuple ts) -> + Tuple (TypeCons t ts) -> Tuple (TypeCons t ts) -> Tuple (TypeCons t ts); +pairBinary t ts f g x y = + consTuple t ts + (f (headTuple t ts x) (headTuple t ts y)) + (g (tailTuple t ts x) (tailTuple t ts y)); funBinary : (a b : sort 0) -> (b -> b -> b) -> (a -> b) -> (a -> b) -> (a -> b); funBinary a b op f g x = op (f x) (g x); @@ -528,16 +544,24 @@ unitLe _ _ = True; unitLt : #() -> #() -> Bool; unitLt _ _ = False; -pairCmp : (a b : sort 0) -> (a -> a -> Bool -> Bool) -> (b -> b -> Bool -> Bool) - -> a * b -> a * b -> Bool -> Bool; -pairCmp a b f g x12 y12 k = - f (fst a b x12) (fst a b y12) (g (snd a b x12) (snd a b y12) k); +pairCmp : + (t : sort 0) -> + (ts : TypeList) -> + (t -> t -> Bool -> Bool) -> + (Tuple ts -> Tuple ts -> Bool -> Bool) -> + Tuple (TypeCons t ts) -> Tuple (TypeCons t ts) -> Bool -> Bool; +pairCmp t ts f g x12 y12 k = + f (headTuple t ts x12) (headTuple t ts y12) + (g (tailTuple t ts x12) (tailTuple t ts y12) k); pairLt : - (a b : sort 0) -> (a -> a -> Bool -> Bool) -> (b -> b -> Bool) -> - a * b -> a * b -> Bool; -pairLt a b f g x y = - f (fst a b x) (fst a b y) (g (snd a b x) (snd a b y)); + (t : sort 0) -> + (ts : TypeList) -> + (t -> t -> Bool -> Bool) -> + (Tuple ts -> Tuple ts -> Bool) -> + Tuple (TypeCons t ts) -> Tuple (TypeCons t ts) -> Bool; +pairLt t ts f g x y = + f (headTuple t ts x) (headTuple t ts y) (g (tailTuple t ts x) (tailTuple t ts y)); -------------------------------------------------------------------------------- -- Dictionaries and overloading @@ -586,7 +610,7 @@ PEqSeqBool n = PEqUnit : PEq #(); PEqUnit = { eq = \ (x y : #()) -> True }; -PEqPair : (a b : sort 0) -> PEq a -> PEq b -> PEq (a * b); +PEqPair : (t : sort 0) -> (ts : TypeList) -> PEq t -> PEq (Tuple ts) -> PEq (Tuple (TypeCons t ts)); PEqPair a b pa pb = { eq = pairEq a b pa.eq pb.eq }; @@ -638,7 +662,10 @@ PCmpSeqBool n = PCmpUnit : PCmp #(); PCmpUnit = { cmpEq = PEqUnit, cmp = unitCmp, le = unitLe, lt = unitLt }; -PCmpPair : (a b : sort 0) -> PCmp a -> PCmp b -> PCmp (a * b); +PCmpPair : + (t : sort 0) -> + (ts : TypeList) -> + PCmp t -> PCmp (Tuple ts) -> PCmp (Tuple (TypeCons t ts)); PCmpPair a b pa pb = { cmpEq = PEqPair a b pa.cmpEq pb.cmpEq , cmp = pairCmp a b pa.cmp pb.cmp @@ -685,7 +712,12 @@ PSignedCmpSeqBool n = PSignedCmpUnit : PSignedCmp #(); PSignedCmpUnit = { signedCmpEq = PEqUnit, scmp = unitCmp, sle = unitLe, slt = unitLt }; -PSignedCmpPair : (a b : sort 0) -> PSignedCmp a -> PSignedCmp b -> PSignedCmp (a * b); +PSignedCmpPair : + (t : sort 0) -> + (ts : TypeList) -> + PSignedCmp t -> + PSignedCmp (Tuple ts) -> + PSignedCmp (Tuple (TypeCons t ts)); PSignedCmpPair a b pa pb = { signedCmpEq = PEqPair a b pa.signedCmpEq pb.signedCmpEq , scmp = pairCmp a b pa.scmp pb.scmp @@ -804,9 +836,12 @@ PLogicUnit = , not = unitUnary }; -PLogicPair : (a b : sort 0) -> PLogic a -> PLogic b -> PLogic (a * b); +PLogicPair : + (t : sort 0) -> + (ts : TypeList) -> + PLogic t -> PLogic (Tuple ts) -> PLogic (Tuple (TypeCons t ts)); PLogicPair a b pa pb = - { logicZero = (pa.logicZero, pb.logicZero) + { logicZero = consTuple a b pa.logicZero pb.logicZero , and = pairBinary a b pa.and pb.and , or = pairBinary a b pa.or pb.or , xor = pairBinary a b pa.xor pb.xor @@ -923,14 +958,17 @@ PRingUnit = , int = \ (i : Integer) -> () }; -PRingPair : (a b : sort 0) -> PRing a -> PRing b -> PRing (a * b); +PRingPair : + (t : sort 0) -> + (ts : TypeList) -> + PRing t -> PRing (Tuple ts) -> PRing (Tuple (TypeCons t ts)); PRingPair a b pa pb = - { ringZero = (pa.ringZero, pb.ringZero) + { ringZero = consTuple a b pa.ringZero pb.ringZero , add = pairBinary a b pa.add pb.add , sub = pairBinary a b pa.sub pb.sub , mul = pairBinary a b pa.mul pb.mul , neg = pairUnary a b pa.neg pb.neg - , int = \ (i : Integer) -> (pa.int i, pb.int i) + , int = \ (i : Integer) -> consTuple a b (pa.int i) (pb.int i) }; -- Integral class @@ -1917,35 +1955,35 @@ processSHA2_512 n x = ec_double : (p : Num) -> - IntModNum p * IntModNum p * IntModNum p -> - IntModNum p * IntModNum p * IntModNum p; + #(IntModNum p, IntModNum p, IntModNum p) -> + #(IntModNum p, IntModNum p, IntModNum p); ec_double p x = - error (IntModNum p * IntModNum p * IntModNum p) "Unimplemented: ec_double"; + error #(IntModNum p, IntModNum p, IntModNum p) "Unimplemented: ec_double"; ec_add_nonzero : (p : Num) -> - IntModNum p * IntModNum p * IntModNum p -> - IntModNum p * IntModNum p * IntModNum p -> - IntModNum p * IntModNum p * IntModNum p; + #(IntModNum p, IntModNum p, IntModNum p) -> + #(IntModNum p, IntModNum p, IntModNum p) -> + #(IntModNum p, IntModNum p, IntModNum p); ec_add_nonzero p x y = - error (IntModNum p * IntModNum p * IntModNum p) "Unimplemented: ec_add_nonzero"; + error #(IntModNum p, IntModNum p, IntModNum p) "Unimplemented: ec_add_nonzero"; ec_mult : (p : Num) -> IntModNum p -> - IntModNum p * IntModNum p * IntModNum p -> - IntModNum p * IntModNum p * IntModNum p; + #(IntModNum p, IntModNum p, IntModNum p) -> + #(IntModNum p, IntModNum p, IntModNum p); ec_mult p x y = - error (IntModNum p * IntModNum p * IntModNum p) "Unimplemented: ec_mult"; + error #(IntModNum p, IntModNum p, IntModNum p) "Unimplemented: ec_mult"; ec_twin_mult : (p : Num) -> IntModNum p -> - IntModNum p * IntModNum p * IntModNum p -> - IntModNum p * IntModNum p * IntModNum p -> - IntModNum p * IntModNum p * IntModNum p; + #(IntModNum p, IntModNum p, IntModNum p) -> + #(IntModNum p, IntModNum p, IntModNum p) -> + #(IntModNum p, IntModNum p, IntModNum p); ec_twin_mult p x y z = - error (IntModNum p * IntModNum p * IntModNum p) "Unimplemented: ec_twin_mult"; + error #(IntModNum p, IntModNum p, IntModNum p) "Unimplemented: ec_twin_mult"; -------------------------------------------------------------------------------- -- Rewrite rules diff --git a/cryptol-saw-core/saw/CryptolM.sawcore b/cryptol-saw-core/saw/CryptolM.sawcore deleted file mode 100644 index 8a1c8ea252..0000000000 --- a/cryptol-saw-core/saw/CryptolM.sawcore +++ /dev/null @@ -1,823 +0,0 @@ -------------------------------------------------------------------------------- --- Cryptol primitives for SAWCore - -module CryptolM where - --- import Prelude; --- import Cryptol; -import SpecM; - - --------------------------------------------------------------------------------- --- Monadic assertions - -primitive proveEqNum : (n m:Num) -> Maybe (Eq Num n m); - --- A version of unsafeAssert specialized to the Num type -numAssertEqS : (E:EvType) -> (n m:Num) -> SpecM E (Eq Num n m); -numAssertEqS E n m = - maybe (Eq Num n m) (SpecM E (Eq Num n m)) - (errorS E (Eq Num n m) "numAssertEqS: assertion failed") - (retS E (Eq Num n m)) - (proveEqNum n m); - --- A proof that a Num is finite -isFinite : Num -> Prop; -isFinite = Num_rec (\ (_:Num) -> Prop) (\ (_:Nat) -> TrueProp) FalseProp; - --- Check whether a Num is finite -checkFinite : (n:Num) -> Maybe (isFinite n); -checkFinite = - Num_rec (\ (n:Num) -> Maybe (isFinite n)) - (\ (n:Nat) -> Just (isFinite (TCNum n)) (Refl Bool True)) - (Nothing (isFinite TCInf)); - --- Assert that a Num is finite, or fail -assertFiniteS : (E:EvType) -> (n:Num) -> SpecM E (isFinite n); -assertFiniteS E n = - maybe (isFinite n) (SpecM E (isFinite n)) - (errorS E (isFinite n) "assertFiniteM: Num not finite") - (retS E (isFinite n)) - (checkFinite n); - --- Recurse over a Num known to be finite -Num_rec_fin : (p: Num -> sort 1) -> ((n:Nat) -> p (TCNum n)) -> - (n:Num) -> isFinite n -> p n; -Num_rec_fin p f = - Num_rec (\ (n:Num) -> isFinite n -> p n) - (\ (n:Nat) (_:TrueProp) -> f n) - (efq1 (p TCInf)); - - --------------------------------------------------------------------------------- --- Monadic Sequences - -bvVecAtM : (E:EvType) -> (n : Nat) -> (len : Vec n Bool) -> (a : sort 0) -> - BVVec n len a -> Vec n Bool -> SpecM E a; -bvVecAtM E n len a xs i = - ifWithProof (SpecM E a) (bvult n i len) - (errorS E a "bvVecAtM: invalid sequence index") - (\ (pf:is_bvult n i len) -> retS E a (atBVVec n len a xs i pf)); - -atM : (E:EvType) -> (n : Nat) -> (a : sort 0) -> Vec n a -> Nat -> SpecM E a; -atM E n a xs i = - ite (SpecM E a) (ltNat i n) - (retS E a (at n a xs i)) - (errorS E a "atM: invalid sequence index"); - -bvVecUpdateM : (E:EvType) -> (n : Nat) -> (len : Vec n Bool) -> (a : sort 0) -> - BVVec n len a -> Vec n Bool -> a -> - SpecM E (BVVec n len a); -bvVecUpdateM E n len a xs i x = - ifWithProof (SpecM E (BVVec n len a)) (bvult n i len) - (errorS E (BVVec n len a) "bvVecUpdateM: invalid sequence index") - (\ (_:is_bvult n i len) -> retS E (BVVec n len a) - (updBVVec n len a xs i x)); - -fromBVVecUpdateM : (E:EvType) -> (n : Nat) -> (len : Vec n Bool) -> - (a : sort 0) -> BVVec n len a -> Vec n Bool -> a -> - a -> (m : Nat) -> SpecM E (Vec m a); -fromBVVecUpdateM E n len a xs i x def m = - ifWithProof (SpecM E (Vec m a)) (bvult n i len) - (errorS E (Vec m a) "bvVecUpdateM: invalid sequence index") - (\ (_:is_bvult n i len) -> retS E (Vec m a) - (genFromBVVec n len a - (updBVVec n len a xs i x) def m)); - -updateM : (E:EvType) -> (n : Nat) -> (a : sort 0) -> Vec n a -> Nat -> a -> - SpecM E (Vec n a); -updateM E n a xs i x = - ite (SpecM E (Vec n a)) (ltNat i n) - (retS E (Vec n a) (upd n a xs i x)) - (errorS E (Vec n a) "updateM: invalid sequence index"); - -eListSelM : (E:EvType) -> (a : sort 0) -> (n : Num) -> mseq E n a -> Nat -> - SpecM E a; -eListSelM E a = - Num_rec (\ (n:Num) -> mseq E n a -> Nat -> SpecM E a) - (\ (n:Nat) -> atM E n a) - (streamGet (SpecM E a)); - -streamJoinM : (E:EvType) -> (a : isort 0) -> (n : Nat) -> - Stream (SpecM E (Vec (Succ n) a)) -> - Stream (SpecM E a); -streamJoinM E a n s = - MkStream (SpecM E a) (\ (i:Nat) -> - fmapS E (Vec (Succ n) a) a - (\ (xs:Vec (Succ n) a) -> at (Succ n) a xs (modNat i (Succ n))) - (streamGet (SpecM E (Vec (Succ n) a)) s - (divNat i (Succ n))) ); - -{- -bvVecMapInvarBindM : (E:EvType) -> (stack:FunStack) -> - (a b c : isort 0) -> (n : Nat) -> (len : Vec n Bool) -> - (a -> SpecM E stack b) -> BVVec n len a -> - Bool -> (BVVec n len b -> SpecM E stack c) -> - SpecM E stack c; -bvVecMapInvarBindM E stack a b c n len f xs invar cont = - bindS E stack (BVVec n len b) c - (existsS E stack (BVVec n len b)) (\ (ys0:BVVec n len b) -> - multiArgFixS - E stack - (LRT_Fun (Vec n Bool) (\ (_:Vec n Bool) -> - LRT_Fun (BVVec n len b) (\ (_:BVVec n len b) -> - LRT_Ret c))) - (\ (rec : Vec n Bool -> BVVec n len b -> - SpecM E (pushFunStack - (singletonFrame - (LRT_Fun (Vec n Bool) (\ (_:Vec n Bool) -> - LRT_Fun (BVVec n len b) (\ (_:BVVec n len b) -> - LRT_Ret c)))) stack) c) - (i:Vec n Bool) (ys:BVVec n len b) -> - invariantHint - (SpecM E (pushFunStack - (singletonFrame - (LRT_Fun (Vec n Bool) (\ (_:Vec n Bool) -> - LRT_Fun (BVVec n len b) (\ (_:BVVec n len b) -> - LRT_Ret c)))) stack) c) - (and (bvule n i len) invar) - (ifWithProof - (SpecM E (pushFunStack - (singletonFrame - (LRT_Fun (Vec n Bool) (\ (_:Vec n Bool) -> - LRT_Fun (BVVec n len b) (\ (_:BVVec n len b) -> - LRT_Ret c)))) stack) c) - (bvult n i len) - (cont ys) - (\ (pf:is_bvult n i len) -> - bindS E stack b c - (f (atBVVec n len a xs i pf)) - (\ (y:b) -> rec (bvAdd n i (bvNat n 1)) - (updBVVec n len b ys i y))))) - (bvNat n 0) ys0); - -bvVecMapInvarM : (E:EvType) -> (stack:FunStack) -> - (a b : isort 0) -> (n : Nat) -> (len : Vec n Bool) -> - (a -> SpecM E stack b) -> BVVec n len a -> - Bool -> SpecM E stack (BVVec n len b); -bvVecMapInvarM E stack a b n len f xs invar = - bvVecMapInvarBindM E stack a b (BVVec n len b) n len f xs invar - (retS E stack (BVVec n len b)); - -bvVecMapM : (E:EvType) -> (stack:FunStack) -> - (a b : isort 0) -> (n : Nat) -> (len : Vec n Bool) -> - (a -> SpecM E stack b) -> BVVec n len a -> - SpecM E stack (BVVec n len b); -bvVecMapM E stack a b n len f xs = bvVecMapInvarM E stack a b n len f xs True; --} - --- Map a function f over a vector and pass the resulting mapped vector to a --- monadic continuation. Do this by starting with an arbitrary initial output --- vector and iteratively updating each index of that initial vector with the --- result of applying f to that index in the input vector, sort of like this: --- --- > existsS (Vec n b) >>= \ys0 -> --- > letrec loop ys i = --- > if i < n then loop (upd ys i (f i (ys@i))) (Succ i) else k ys in --- > loop ys0 0 -vecMapBindM : (E:EvType) -> (a : sort 0) -> (b : qsort 0) -> - (c : sort 0) -> (n : Nat) -> (Nat -> a -> SpecM E b) -> - Vec n a -> (Vec n b -> SpecM E c) -> - SpecM E c; -vecMapBindM E a b c n f xs cont = - bindS E (Vec n b) c - (existsS E (Vec n b)) (\ (ys0:Vec n b) -> - forNatLtThenS E (Vec n b) c n - (\ (i:Nat) (ys:Vec n b) -> - bindS E a (Vec n b) (atM E n a xs i) (\ (x:a) -> - bindS E b (Vec n b) (f i x) (\ (y:b) -> - updateM E n b ys i y))) - cont ys0); - -vecMapM : (E:EvType) -> (a : sort 0) -> (b : qsort 0) -> - (n : Nat) -> (Nat -> a -> SpecM E b) -> - Vec n a -> SpecM E (Vec n b); -vecMapM E a b n f xs = vecMapBindM E a b (Vec n b) n f xs (retS E (Vec n b)); - --- Computational version of seqMap -seqMapM : (E:EvType) -> (a : sort 0) -> (b : qsort 0) -> (n : Num) -> - (a -> SpecM E b) -> mseq E n a -> SpecM E (mseq E n b); -seqMapM E a b n_top f = - Num_rec (\ (n:Num) -> mseq E n a -> SpecM E (mseq E n b)) - (\ (n:Nat) -> vecMapM E a b n (\(i:Nat) -> f)) - (\ (s:Stream (SpecM E a)) -> - retS E (Stream (SpecM E b)) - (streamMap (SpecM E a) (SpecM E b) - (\ (m:SpecM E a) -> bindS E a b m f) s)) - n_top; - -mseq_cong1 : (E:EvType) -> (m : Num) -> (n : Num) -> (a : sort 0) -> - Eq Num m n -> Eq (sort 0) (mseq E m a) (mseq E n a); -mseq_cong1 E m n a eq_mn = - eq_cong Num m n eq_mn (sort 0) (\ (x:Num) -> mseq E x a); - --- Convert a seq to an mseq -seqToMseq : (E:EvType) -> (n:Num) -> (a:sort 0) -> seq n a -> mseq E n a; -seqToMseq E n_top a = - Num_rec (\ (n:Num) -> seq n a -> mseq E n a) - (\ (n:Nat) (v:Vec n a) -> v) - (streamMap a (SpecM E a) (retS E a)) - n_top; - -vecSequenceM : (E:EvType) -> (a : qsort 0) -> (n : Nat) -> - Vec n (SpecM E a) -> SpecM E (Vec n a); -vecSequenceM E a n = - vecMapM E (SpecM E a) a n (\(i:Nat) (x:SpecM E a) -> x); - - --------------------------------------------------------------------------------- --- List comprehensions - -fromM : (E:EvType) -> (a b : qisort 0) -> (m n : Num) -> mseq E m a -> - (a -> SpecM E (mseq E n b)) -> - SpecM E (mseq E (tcMul m n) (a * b)); -fromM E a b m n = - Num_rec - (\ (m:Num) -> mseq E m a -> - (a -> SpecM E (mseq E n b)) -> - SpecM E (mseq E (tcMul m n) (a * b))) - (\ (m:Nat) -> - Num_rec - (\ (n:Num) -> Vec m a -> - (a -> SpecM E (mseq E n b)) -> - SpecM E (mseq E (tcMul (TCNum m) n) (a * b))) - -- Case 1: (TCNum m, TCNum n) - (\ (n:Nat) -> - \ (xs : Vec m a) -> - \ (k : a -> SpecM E (Vec n b)) -> - vecMapBindM E a (Vec n (a * b)) - (Vec (mulNat m n) (a * b)) m - (\ (i:Nat) -> \ (x:a) -> - fmapS E (Vec n b) (Vec n (a * b)) - (map b (a * b) (\ (y : b) -> (x, y)) n) (k x)) - xs (\ (kxs:Vec m (Vec n (a * b))) -> - retS E (Vec (mulNat m n) (a * b)) - (join m n (a * b) kxs))) - -- Case 2: n = (TCNum m, TCInf) - (natCase - (\ (m':Nat) -> Vec m' a -> - (a -> SpecM E (Stream (SpecM E b))) -> - SpecM E (mseq E (if0Nat Num m' (TCNum 0) TCInf) (a * b))) - (\ (xs : Vec 0 a) -> - \ (k : a -> SpecM E (Stream (SpecM E b))) -> - retS E (Vec 0 (a * b)) (EmptyVec (a * b))) - (\ (m' : Nat) -> - \ (xs : Vec (Succ m') a) -> - \ (k : a -> SpecM E (Stream (SpecM E b))) -> - (\ (x:a) -> - fmapS E (Stream (SpecM E b)) (Stream (SpecM E (a * b))) - (streamMap (SpecM E b) (SpecM E (a * b)) - (fmapS E b (a * b) (\ (y:b) -> (x, y)))) - (k x)) - (head m' a xs)) - m) - n) - (Num_rec - (\ (n:Num) -> Stream (SpecM E a) -> - (a -> SpecM E (mseq E n b)) -> - SpecM E (mseq E (tcMul TCInf n) (a * b))) - -- Case 3: (TCInf, TCNum n) - (\ (n:Nat) -> - natCase - (\ (n':Nat) -> Stream (SpecM E a) -> - (a -> SpecM E (Vec n' b)) -> - SpecM E (mseq E (if0Nat Num n' (TCNum 0) TCInf) (a * b))) - (\ (xs : Stream (SpecM E a)) -> - \ (k : a -> SpecM E (Vec 0 b)) -> - retS E (Vec 0 (a * b)) (EmptyVec (a * b))) - (\ (n' : Nat) -> - \ (xs : Stream (SpecM E a)) -> - \ (k : a -> SpecM E (Vec (Succ n') b)) -> - retS E (Stream (SpecM E (a * b))) - (streamJoinM E (a * b) n' - (streamMap (SpecM E a) - (SpecM E (Vec (Succ n') (a * b))) - (\ (m:SpecM E a) -> - bindS E a (Vec (Succ n') (a * b)) m - (\ (x:a) -> - fmapS E (Vec (Succ n') b) (Vec (Succ n') (a * b)) - (map b (a * b) (\ (y:b) -> (x, y)) (Succ n')) - (k x))) - xs))) - n) - -- Case 4: (TCInf, TCInf) - (\ (xs : Stream (SpecM E a)) -> - \ (k : a -> SpecM E (Stream (SpecM E b))) -> - bindS E a (Stream (SpecM E (a * b))) - (streamGet (SpecM E a) xs 0) - (\ (x:a) -> - fmapS E (Stream (SpecM E b)) (Stream (SpecM E (a * b))) - (streamMap (SpecM E b) (SpecM E (a * b)) - (fmapS E b (a * b) (\ (y:b) -> (x, y)))) - (k x))) - n) - m; - -mletM : (E:EvType) -> (a : sort 0) -> (b : isort 0) -> (n : Num) -> a -> - (a -> SpecM E (mseq E n b)) -> - SpecM E (mseq E n (a * b)); -mletM E a b n = - Num_rec - (\ (n:Num) -> a -> - (a -> SpecM E (mseq E n b)) -> - SpecM E (mseq E n (a * b))) - (\ (n:Nat) -> \ (x:a) -> \ (f:a -> SpecM E (Vec n b)) -> - fmapS E (Vec n b) (Vec n (a * b)) - (map b (a * b) (\ (y : b) -> (x, y)) n) - (f x)) - (\ (x:a) -> \ (f:a -> SpecM E (Stream (SpecM E b))) -> - fmapS E (Stream (SpecM E b)) (Stream (SpecM E (a * b))) - (streamMap (SpecM E b) (SpecM E (a * b)) - (fmapS E b (a * b) (\ (y:b) -> (x, y)))) - (f x)) - n; - -seqZipM : (E:EvType) -> (a b : qisort 0) -> (m n : Num) -> - mseq E m a -> mseq E n b -> - SpecM E (mseq E (tcMin m n) (a * b)); -seqZipM E a b m n = - Num_rec - (\ (m:Num) -> mseq E m a -> mseq E n b - -> SpecM E (mseq E (tcMin m n) (a * b))) - (\ (m : Nat) -> - Num_rec - (\ (n:Num) -> Vec m a -> mseq E n b - -> SpecM E (mseq E (tcMin (TCNum m) n) (a * b))) - (\ (n:Nat) -> - \ (xs:Vec m a) -> \ (ys:Vec n b) -> - retS E (Vec (minNat m n) (a * b)) (zip a b m n xs ys)) - (\ (xs:Vec m a) -> \ (ys:Stream (SpecM E b)) -> - vecMapM E a (a * b) m - (\ (i : Nat) (x : a) -> - fmapS E b (a * b) (\ (y : b) -> (x,y)) - (streamGet (SpecM E b) ys i)) - xs) - n) - (Num_rec - (\ (n:Num) -> Stream (SpecM E a) -> mseq E n b - -> SpecM E (mseq E (tcMin TCInf n) (a * b))) - (\ (n:Nat) -> - \ (xs:Stream (SpecM E a)) -> \ (ys:Vec n b) -> - vecMapM E b (a * b) n - (\ (i : Nat) (y : b) -> - fmapS E a (a * b) (\ (x : a) -> (x,y)) - (streamGet (SpecM E a) xs i)) - ys) - (\ (xs:Stream (SpecM E a)) -> \ (ys:Stream (SpecM E b)) -> - retS E (Stream (SpecM E (a * b))) - (streamMap2 (SpecM E a) (SpecM E b) (SpecM E (a * b)) - (fmapS2 E a b (a * b) (\ (x:a) -> \ (y:b) -> (x, y))) - xs ys)) - n) - m; - -seqZipSameM : (E:EvType) -> (a b : isort 0) -> (n : Num) -> - mseq E n a -> mseq E n b -> - mseq E n (a * b); -seqZipSameM E a b n = - Num_rec - (\ (n : Num) -> mseq E n a -> mseq E n b -> mseq E n (a * b)) - (\ (n : Nat) -> zipSame a b n) - (streamMap2 (SpecM E a) (SpecM E b) (SpecM E (a * b)) - (fmapS2 E a b (a * b) (\ (x:a) -> \ (y:b) -> (x,y)))) - n; - - --------------------------------------------------------------------------------- --- Monadic versions of the Cryptol typeclass instances - --- PEq -PEqMSeq : (E:EvType) -> (n:Num) -> isFinite n -> (a:isort 0) -> PEq a -> - PEq (mseq E n a); -PEqMSeq E = - Num_rec_fin (\ (n:Num) -> (a:isort 0) -> PEq a -> PEq (mseq E n a)) - (\ (n:Nat) -> PEqVec n); - -PEqMSeqBool : (E:EvType) -> (n : Num) -> isFinite n -> PEq (mseq E n Bool); -PEqMSeqBool E = - Num_rec_fin (\ (n:Num) -> PEq (mseq E n Bool)) PEqWord; - --- PCmp -PCmpMSeq : (E:EvType) -> (n:Num) -> isFinite n -> (a:isort 0) -> PCmp a -> - PCmp (mseq E n a); -PCmpMSeq E = - Num_rec_fin (\ (n:Num) -> (a:isort 0) -> PCmp a -> PCmp (mseq E n a)) - (\ (n:Nat) -> PCmpVec n); - -PCmpMSeqBool : (E:EvType) -> (n : Num) -> isFinite n -> PCmp (mseq E n Bool); -PCmpMSeqBool E = - Num_rec_fin (\ (n:Num) -> PCmp (mseq E n Bool)) PCmpWord; - --- PSignedCmp -PSignedCmpMSeq : (E:EvType) -> (n:Num) -> isFinite n -> (a:isort 0) -> - PSignedCmp a -> PSignedCmp (mseq E n a); -PSignedCmpMSeq E = - Num_rec_fin (\ (n:Num) -> (a:isort 0) -> PSignedCmp a -> - PSignedCmp (mseq E n a)) - (\ (n:Nat) -> PSignedCmpVec n); - -PSignedCmpMSeqBool : (E:EvType) -> (n : Num) -> isFinite n -> - PSignedCmp (mseq E n Bool); -PSignedCmpMSeqBool E = - Num_rec_fin (\ (n:Num) -> PSignedCmp (mseq E n Bool)) PSignedCmpWord; - - --- PZero -PZeroSpecM : (E:EvType) -> (a : sort 0) -> PZero a -> PZero (SpecM E a); -PZeroSpecM E = retS E; - -PZeroMSeq : (E:EvType) -> (n : Num) -> (a : sort 0) -> PZero a -> - PZero (mseq E n a); -PZeroMSeq E n_top a pa = - Num_rec (\ (n:Num) -> PZero (mseq E n a)) - (\ (n:Nat) -> seqConst (TCNum n) a pa) - (seqConst TCInf (SpecM E a) (retS E a pa)) - n_top; - -PZeroMSeqBool : (E:EvType) -> (n : Num) -> isFinite n -> - PZero (mseq E n Bool); -PZeroMSeqBool E = - Num_rec_fin (\ (n:Num) -> PZero (mseq E n Bool)) - (\ (n:Nat) -> bvNat n 0); - --- PLogic -PLogicSpecM : (E:EvType) -> (a : sort 0) -> PLogic a -> PLogic (SpecM E a); -PLogicSpecM E a pa = - { logicZero = retS E a (pa.logicZero) - , and = fmapS2 E a a a (pa.and) - , or = fmapS2 E a a a (pa.or) - , xor = fmapS2 E a a a (pa.xor) - , not = fmapS E a a (pa.not) - }; - -PLogicMSeq : (E:EvType) -> (n : Num) -> (a : isort 0) -> PLogic a -> - PLogic (mseq E n a); -PLogicMSeq E n_top a pa = - Num_rec (\ (n:Num) -> PLogic (mseq E n a)) - (\ (n:Nat) -> PLogicVec n a pa) - (PLogicStream (SpecM E a) (PLogicSpecM E a pa)) - n_top; - -PLogicMSeqBool : (E:EvType) -> (n : Num) -> isFinite n -> - PLogic (mseq E n Bool); -PLogicMSeqBool E = - Num_rec_fin (\ (n:Num) -> PLogic (mseq E n Bool)) PLogicWord; - --- PRing -PRingSpecM : (E:EvType) -> (a : sort 0) -> PRing a -> PRing (SpecM E a); -PRingSpecM E a pa = - { ringZero = retS E a (pa.ringZero) - , add = fmapS2 E a a a (pa.add) - , sub = fmapS2 E a a a (pa.sub) - , mul = fmapS2 E a a a (pa.mul) - , neg = fmapS E a a (pa.neg) - , int = \ (i : Integer) -> retS E a (pa.int i) - }; - -PRingMSeq : (E:EvType) -> (n : Num) -> (a : isort 0) -> PRing a -> - PRing (mseq E n a); -PRingMSeq E n_top a pa = - Num_rec (\ (n:Num) -> PRing (mseq E n a)) - (\ (n:Nat) -> PRingVec n a pa) - (PRingStream (SpecM E a) (PRingSpecM E a pa)) - n_top; - -PRingMSeqBool : (E:EvType) -> (n : Num) -> isFinite n -> PRing (mseq E n Bool); -PRingMSeqBool E = - Num_rec_fin (\ (n:Num) -> PRing (mseq E n Bool)) PRingWord; - --- Integral -PIntegralMSeqBool : (E:EvType) -> (n : Num) -> isFinite n -> - PIntegral (mseq E n Bool); -PIntegralMSeqBool E = - Num_rec_fin (\ (n:Num) -> PIntegral (mseq E n Bool)) PIntegralWord; - --- PLiteral -PLiteralSeqBoolM : (E:EvType) -> (n : Num) -> isFinite n -> - PLiteral (mseq E n Bool); -PLiteralSeqBoolM E = - Num_rec_fin (\ (n:Num) -> PLiteral (mseq E n Bool)) bvNat; - - --------------------------------------------------------------------------------- --- Monadic versions of the Cryptol primitives - - --- Sequences - -ecShiftLM : (E:EvType) -> (m : Num) -> (ix a : sort 0) -> PIntegral ix -> - PZero a -> mseq E m a -> ix -> mseq E m a; -ecShiftLM E = - Num_rec (\ (m:Num) -> (ix a : sort 0) -> PIntegral ix -> PZero a -> - mseq E m a -> ix -> mseq E m a) - (\ (m:Nat) -> ecShiftL (TCNum m)) - (\ (ix a : sort 0) (pix:PIntegral ix) (pa:PZero a) -> - ecShiftL TCInf ix (SpecM E a) pix (PZeroSpecM E a pa)); - -ecShiftRM : (E:EvType) -> (m : Num) -> (ix a : sort 0) -> PIntegral ix -> - PZero a -> mseq E m a -> ix -> mseq E m a; -ecShiftRM E = - Num_rec (\ (m:Num) -> (ix a : sort 0) -> PIntegral ix -> PZero a -> - mseq E m a -> ix -> mseq E m a) - (\ (m:Nat) -> ecShiftR (TCNum m)) - (\ (ix a : sort 0) (pix:PIntegral ix) (pa:PZero a) -> - ecShiftR TCInf ix (SpecM E a) pix (PZeroSpecM E a pa)); - -ecSShiftRM : (E:EvType) -> (n : Num) -> isFinite n -> (ix : sort 0) -> - PIntegral ix -> mseq E n Bool -> ix -> mseq E n Bool; -ecSShiftRM E = - Num_rec_fin - (\ (n:Num) -> (ix : sort 0) -> PIntegral ix -> mseq E n Bool -> ix -> - mseq E n Bool) - (\ (n:Nat) -> ecSShiftR (TCNum n)); - -ecRotLM : (E:EvType) -> (m : Num) -> isFinite m -> (ix a : sort 0) -> - PIntegral ix -> mseq E m a -> ix -> mseq E m a; -ecRotLM E = - Num_rec_fin - (\ (m:Num) -> (ix a : sort 0) -> PIntegral ix -> mseq E m a -> ix -> - mseq E m a) - (\ (m:Nat) -> ecRotL (TCNum m)); - -ecRotRM : (E:EvType) -> (m : Num) -> isFinite m -> (ix a : sort 0) -> - PIntegral ix -> mseq E m a -> ix -> mseq E m a; -ecRotRM E = - Num_rec_fin - (\ (m:Num) -> (ix a : sort 0) -> PIntegral ix -> mseq E m a -> ix -> - mseq E m a) - (\ (m:Nat) -> ecRotR (TCNum m)); - -ecCatM : (E:EvType) -> (m : Num) -> isFinite m -> (n : Num) -> (a : isort 0) -> - mseq E m a -> mseq E n a -> mseq E (tcAdd m n) a; -ecCatM E = - Num_rec_fin - (\ (m:Num) -> (n:Num) -> (a:isort 0) -> mseq E m a -> mseq E n a -> - mseq E (tcAdd m n) a) - (\ (m:Nat) -> - Num_rec - (\ (n:Num) -> (a:isort 0) -> Vec m a -> mseq E n a -> - mseq E (tcAdd (TCNum m) n) a) - -- Case for (TCNum m, TCNum n) - (\ (n:Nat) -> \ (a:isort 0) -> append m n a) - -- Case for (TCNum m, TCInf) - (\ (a:isort 0) (v:Vec m a) -> - streamAppend (SpecM E a) m - (map a (SpecM E a) (retS E a) m v))); - -ecTakeM : (E:EvType) -> (m n : Num) -> (a : qisort 0) -> mseq E (tcAdd m n) a -> - SpecM E (mseq E m a); -ecTakeM E = - Num_rec - (\ (m:Num) -> (n:Num) -> (a:qisort 0) -> mseq E (tcAdd m n) a -> - SpecM E (mseq E m a)) - (\ (m:Nat) -> - Num_rec - (\ (n:Num) -> (a:qisort 0) -> mseq E (tcAdd (TCNum m) n) a -> - SpecM E (Vec m a)) - -- The case (TCNum m, TCNum n) - (\ (n:Nat) -> \ (a:qisort 0) -> \ (xs: Vec (addNat m n) a) -> - retS E (Vec m a) (take a m n xs)) - -- The case (TCNum m, infinity) - (\ (a:qisort 0) -> \ (xs: Stream (SpecM E a)) -> - vecSequenceM E a m (streamTake (SpecM E a) m xs))) - (Num_rec - (\ (n:Num) -> (a:qisort 0) -> mseq E (tcAdd TCInf n) a -> - SpecM E (Stream (SpecM E a))) - -- The case (TCInf, TCNum n) - (\ (n:Nat) -> \ (a:qisort 0) -> \ (xs:Stream (SpecM E a)) -> - retS E (Stream (SpecM E a)) xs) - -- The case (TCInf, TCInf) - (\ (a:qisort 0) -> \ (xs:Stream (SpecM E a)) -> - retS E (Stream (SpecM E a)) xs)); - -ecDropM : (E:EvType) -> (m : Num) -> isFinite m -> (n : Num) -> (a : isort 0) -> - mseq E (tcAdd m n) a -> mseq E n a; -ecDropM E = - Num_rec_fin - (\ (m:Num) -> (n:Num) -> (a:isort 0) -> mseq E (tcAdd m n) a -> mseq E n a) - (\ (m:Nat) -> - Num_rec - (\ (n:Num) -> (a:isort 0) -> mseq E (tcAdd (TCNum m) n) a -> mseq E n a) - -- The case (TCNum m, TCNum n) - (\ (n:Nat) -> \ (a:isort 0) -> drop a m n) - -- The case (TCNum m, infinity) - (\ (a:isort 0) -> streamDrop (SpecM E a) m)); - -ecJoinM : (E:EvType) -> (m n : Num) -> isFinite n -> (a : isort 0) -> - mseq E m (mseq E n a) -> mseq E (tcMul m n) a; -ecJoinM E = - Num_rec - (\ (m:Num) -> (n:Num) -> isFinite n -> (a:isort 0) -> - mseq E m (mseq E n a) -> mseq E (tcMul m n) a) - (\ (m:Nat) -> - Num_rec_fin - (\ (n:Num) -> (a:isort 0) -> Vec m (mseq E n a) -> - mseq E (tcMul (TCNum m) n) a) - -- Case for (TCNum m, TCNum n) - (\ (n:Nat) -> \ (a:isort 0) -> join m n a)) - -- No case for (TCNum m, TCInf), shoudn't happen - (Num_rec_fin - (\ (n:Num) -> (a:isort 0) -> Stream (SpecM E (mseq E n a)) -> - mseq E (tcMul TCInf n) a) - -- Case for (TCInf, TCNum n) - (\ (n:Nat) -> \ (a:isort 0) -> - natCase - (\ (n':Nat) -> Stream (SpecM E (Vec n' a)) -> - mseq E (if0Nat Num n' (TCNum 0) TCInf) a) - (\ (s:Stream (SpecM E (Vec 0 a))) -> EmptyVec a) - (\ (n':Nat) -> \ (s:Stream (SpecM E (Vec (Succ n') a))) -> - streamJoinM E a n' s) - n)); - -- No case for (TCInf, TCInf), shouldn't happen - -ecSplitM : (E:EvType) -> (m n : Num) -> isFinite n -> (a : qisort 0) -> - mseq E (tcMul m n) a -> mseq E m (mseq E n a); -ecSplitM E = - Num_rec - (\ (m:Num) -> (n:Num) -> isFinite n -> (a:qisort 0) -> - mseq E (tcMul m n) a -> mseq E m (mseq E n a)) - (\ (m:Nat) -> - Num_rec_fin - (\ (n:Num) -> (a:qisort 0) -> mseq E (tcMul (TCNum m) n) a -> - Vec m (mseq E n a)) - -- Case for (TCNum m, TCNum n) - (\ (n:Nat) -> \ (a:qisort 0) -> split m n a)) - -- No case for (TCNum m, TCInf), shouldn't happen - (Num_rec_fin - (\ (n:Num) -> (a:qisort 0) -> mseq E (tcMul TCInf n) a -> - Stream (SpecM E (mseq E n a))) - -- Case for (TCInf, TCNum n) - (\ (n:Nat) -> \ (a:qisort 0) -> - natCase - (\ (n':Nat) -> - mseq E (if0Nat Num n' (TCNum 0) TCInf) a -> - Stream (SpecM E (Vec n' a))) - (\ (xs : Vec 0 a) -> streamConst (SpecM E (Vec 0 a)) - (retS E (Vec 0 a) xs)) - (\ (n':Nat) (xs : Stream (SpecM E a)) -> - streamMap (Vec (Succ n') (SpecM E a)) - (SpecM E (Vec (Succ n') a)) - (vecSequenceM E a (Succ n')) - (streamSplit (SpecM E a) (Succ n') xs)) - n)); - -- No case for (TCInf, TCInf), shouldn't happen - -ecReverseM : (E:EvType) -> (n : Num) -> isFinite n -> (a : isort 0) -> - mseq E n a -> mseq E n a; -ecReverseM E = - Num_rec_fin (\ (n:Num) -> (a : isort 0) -> mseq E n a -> mseq E n a) - (\ (n:Nat) -> reverse n); - -ecTransposeM : (E:EvType) -> (m n : Num) -> (a : qisort 0) -> - mseq E m (mseq E n a) -> mseq E n (mseq E m a); -ecTransposeM E m n a = - Num_rec - (\ (m : Num) -> mseq E m (mseq E n a) -> - mseq E n (mseq E m a)) - (\ (m : Nat) -> - Num_rec - (\ (n : Num) -> Vec m (mseq E n a) -> - mseq E n (Vec m a)) - (\ (n : Nat) -> transpose m n a) - (\ (xss : Vec m (Stream (SpecM E a))) -> - MkStream (SpecM E (Vec m a)) (\ (i : Nat) -> - vecMapM E (Stream (SpecM E a)) a m - (\ (j:Nat) -> \ (xs:Stream (SpecM E a)) -> - streamGet (SpecM E a) xs i) - xss)) - n - ) - ( Num_rec - (\ (n : Num) -> Stream (SpecM E (mseq E n a)) -> - mseq E n (Stream (SpecM E a))) - (\ (n : Nat) -> \ (xss : Stream (SpecM E (Vec n a))) -> - gen n (Stream (SpecM E a)) (\ (i : Nat) -> - MkStream (SpecM E a) (\ (j : Nat) -> - fmapS E (Vec n a) a - (\ (xs:Vec n a) -> at n a xs i) - (streamGet (SpecM E (Vec n a)) xss j)))) - (\ (xss : Stream (SpecM E (Stream (SpecM E a)))) -> - MkStream (SpecM E (Stream (SpecM E a))) (\ (i : Nat) -> - retS E (Stream (SpecM E a)) - (MkStream (SpecM E a) (\ (j : Nat) -> - bindS E (Stream (SpecM E a)) a - (streamGet (SpecM E (Stream (SpecM E a))) xss j) - (\ (xs:Stream (SpecM E a)) -> streamGet (SpecM E a) xs i))))) - n - ) - m; - -ecAtM : (E:EvType) -> (n : Num) -> (a : sort 0) -> (ix : sort 0) -> - PIntegral ix -> mseq E n a -> ix -> SpecM E a; -ecAtM E n_top a ix pix = - Num_rec - (\ (n:Num) -> mseq E n a -> ix -> SpecM E a) - (\ (n:Nat) (v:Vec n a) -> - pix.posNegCases (SpecM E a) (atM E n a v) - (\ (_:Nat) -> - errorS E a "ecAtM: invalid sequence index")) - (\ (s:Stream (SpecM E a)) -> - pix.posNegCases (SpecM E a) (streamGet (SpecM E a) s) - (\ (_:Nat) -> - errorS E a "ecAtM: invalid sequence index")) - n_top; - -ecUpdateM : (E:EvType) -> (n : Num) -> (a : sort 0) -> (ix : sort 0) -> - PIntegral ix -> mseq E n a -> ix -> a -> SpecM E (mseq E n a); -ecUpdateM E n_top a ix pix = - Num_rec - (\ (n:Num) -> mseq E n a -> ix -> a -> - SpecM E (mseq E n a)) - (\ (n:Nat) (v:Vec n a) (i:ix) (x:a) -> - pix.posNegCases (SpecM E (Vec n a)) - (\ (i:Nat) -> updateM E n a v i x) - (\ (_:Nat) -> errorS E (Vec n a) - "ecUpdateM: invalid sequence index") i) - (\ (s:Stream (SpecM E a)) (i:ix) (x:a) -> - pix.posNegCases (SpecM E (Stream (SpecM E a))) - (\ (i:Nat) -> - retS E (Stream (SpecM E a)) - (streamUpd (SpecM E a) s i - (retS E a x))) - (\ (_:Nat) -> errorS E (Stream (SpecM E a)) - "ecUpdateM: invalid sequence index") i) - n_top; - -ecAtBackM : (E:EvType) -> (n : Num) -> isFinite n -> (a : isort 0) -> - (ix : sort 0) -> PIntegral ix -> - mseq E n a -> ix -> SpecM E a; -ecAtBackM E n pf a ix pix xs = - ecAtM E n a ix pix (ecReverseM E n pf a xs); - -ecFromToM : (E:EvType) -> (first : Num) -> isFinite first -> (last : Num) -> - isFinite last -> (a : sort 0) -> PLiteral a -> - mseq E (tcAdd (TCNum 1) (tcSub last first)) a; -ecFromToM E = - Num_rec_fin - (\ (first:Num) -> (last:Num) -> isFinite last -> - (a : sort 0) -> PLiteral a -> - mseq E (tcAdd (TCNum 1) (tcSub last first)) a) - (\ (first:Nat) -> - Num_rec_fin - (\ (last:Num) -> (a : sort 0) -> PLiteral a -> - mseq E (tcAdd (TCNum 1) (tcSub last (TCNum first))) a) - (\ (last:Nat) -> \ (a : sort 0) -> \ (pa : PLiteral a) -> - gen (addNat 1 (subNat last first)) a - (\ (i : Nat) -> pa (addNat i first)))); - -ecFromToLessThanM : (E:EvType) -> (first : Num) -> isFinite first -> - (bound : Num) -> (a : sort 0) -> PLiteralLessThan a -> - mseq E (tcSub bound first) a; -ecFromToLessThanM E first pf bound a = - Num_rec_fin - (\ (first:Num) -> PLiteralLessThan a -> - mseq E (tcSub bound first) a) - (\ (first:Nat) -> - Num_rec - (\ (bound:Num) -> PLiteralLessThan a -> - mseq E (tcSub bound (TCNum first)) a) - (\ (bound:Nat) -> \ (pa : PLiteralLessThan a) -> - gen (subNat bound first) a - (\ (i : Nat) -> pa (addNat i first))) - (\ (pa : PLiteralLessThan a) -> - MkStream (SpecM E a) - (\ (i : Nat) -> retS E a (pa (addNat i first)))) - bound) - first pf; - -ecFromThenToM : - (E:EvType) -> (first next last : Num) -> (a : sort 0) -> (len : Num) -> - isFinite len -> PLiteral a -> PLiteral a -> PLiteral a -> mseq E len a; -ecFromThenToM E first next _ a = - Num_rec_fin - (\ (len:Num) -> PLiteral a -> PLiteral a -> PLiteral a -> mseq E len a) - (\ (len:Nat) -> \ (pa : PLiteral a) -> \ (_ : PLiteral a) -> \ (_ : PLiteral a) -> - gen len a - (\ (i : Nat) -> - pa (subNat (addNat (getFinNat first) - (mulNat i (getFinNat next))) - (mulNat i (getFinNat first))))); - -ecInfFromM : (E:EvType) -> (a : sort 0) -> PIntegral a -> a -> mseq E TCInf a; -ecInfFromM E a pa x = - MkStream (SpecM E a) - (\ (i : Nat) -> - retS E a (pa.integralRing.add - x (pa.integralRing.int (natToInt i)))); - -ecInfFromThenM : (E:EvType) -> (a : sort 0) -> PIntegral a -> a -> a -> - mseq E TCInf a; -ecInfFromThenM E a pa x y = - MkStream (SpecM E a) - (\ (i : Nat) -> - retS E a (pa.integralRing.add x - (pa.integralRing.mul (pa.integralRing.sub y x) - (pa.integralRing.int (natToInt i))))); - -ecErrorM : (E:EvType) -> (a : sort 0) -> (len : Num) -> - mseq E len (Vec 8 Bool) -> SpecM E a; -ecErrorM E a len msg = - errorS E a "encountered call to the Cryptol 'error' function"; - - --------------------------------------------------------------------------------- diff --git a/cryptol-saw-core/saw/SpecM.sawcore b/cryptol-saw-core/saw/SpecM.sawcore deleted file mode 100644 index 39772495d0..0000000000 --- a/cryptol-saw-core/saw/SpecM.sawcore +++ /dev/null @@ -1,944 +0,0 @@ -------------------------------------------------------------------------------- --- The specification monad - -module SpecM where - --- import Prelude; -import Cryptol; - - --------------------------------------------------------------------------------- --- Type descriptions - --- Expression kinds -- - --- The kinds for objects that can be used in type-level expressions -data ExprKind : sort 0 where { - Kind_unit : ExprKind; - Kind_bool : ExprKind; - Kind_nat : ExprKind; - Kind_num : ExprKind; - Kind_bv : (w:Nat) -> ExprKind; -} - --- The type of an element of an ExprKind -exprKindElem : ExprKind -> sort 0; -exprKindElem EK = - ExprKind#rec (\ (_:ExprKind) -> sort 0) - #() Bool Nat Num (\ (w:Nat) -> Vec w Bool) EK; - --- The unary operations for type-level expressions -data TpExprUnOp : ExprKind -> ExprKind -> sort 0 where { - UnOp_BVToNat : (w:Nat) -> TpExprUnOp (Kind_bv w) Kind_nat; - UnOp_NatToBV : (w:Nat) -> TpExprUnOp Kind_nat (Kind_bv w); - UnOp_NatToNum : TpExprUnOp Kind_nat Kind_num; -} - --- Evaluate a unary operation to a function on elements of its ExprKinds -evalUnOp : (EK1 EK2:ExprKind) -> TpExprUnOp EK1 EK2 -> exprKindElem EK1 -> - exprKindElem EK2; -evalUnOp EK1 EK2 op = - TpExprUnOp#rec (\ (EK1 EK2:ExprKind) (_:TpExprUnOp EK1 EK2) -> - exprKindElem EK1 -> exprKindElem EK2) - (\ (w:Nat) -> bvToNat w) - (\ (w:Nat) -> bvNat w) - (\ (n:Nat) -> TCNum n) - EK1 EK2 op; - --- The binary operations for type-level expressions -data TpExprBinOp : ExprKind -> ExprKind -> ExprKind -> sort 0 where { - BinOp_AddNat : TpExprBinOp Kind_nat Kind_nat Kind_nat; - BinOp_MulNat : TpExprBinOp Kind_nat Kind_nat Kind_nat; - BinOp_AddBV : (w:Nat) -> TpExprBinOp (Kind_bv w) (Kind_bv w) (Kind_bv w); - BinOp_MulBV : (w:Nat) -> TpExprBinOp (Kind_bv w) (Kind_bv w) (Kind_bv w); - BinOp_AddNum : TpExprBinOp Kind_num Kind_num Kind_num; - BinOp_MulNum : TpExprBinOp Kind_num Kind_num Kind_num; -} - --- Evaluate a binary operation to a function on elements of its ExprKinds -evalBinOp : (EK1 EK2 EK3:ExprKind) -> TpExprBinOp EK1 EK2 EK3 -> - exprKindElem EK1 -> exprKindElem EK2 -> exprKindElem EK3; -evalBinOp EK1 EK2 EK3 op = - TpExprBinOp#rec (\ (EK1 EK2 EK3:ExprKind) (_:TpExprBinOp EK1 EK2 EK3) -> - exprKindElem EK1 -> exprKindElem EK2 -> exprKindElem EK3) - addNat mulNat bvAdd bvMul tcAdd tcMul - EK1 EK2 EK3 op; - - --- Kind and type descriptions -- - --- The kinds used for type descriptions, which can either be an expression kind --- or the kind of type descriptions themselves -data KindDesc : sort 0 where { - Kind_Expr : ExprKind -> KindDesc; - Kind_Tp : KindDesc; -} - --- Type-level expressions -data TpExpr : ExprKind -> sort 0 where { - TpExpr_Const : (EK:ExprKind) -> exprKindElem EK -> TpExpr EK; - TpExpr_Var : (EK:ExprKind) -> Nat -> TpExpr EK; - TpExpr_UnOp : (EK1 EK2:ExprKind) -> TpExprUnOp EK1 EK2 -> - TpExpr EK1 -> TpExpr EK2; - TpExpr_BinOp : (EK1 EK2 EK3:ExprKind) -> TpExprBinOp EK1 EK2 EK3 -> - TpExpr EK1 -> TpExpr EK2 -> TpExpr EK3; -} - --- The natural number N as a TpExpr -TpExprN : Nat -> TpExpr Kind_nat; -TpExprN n = TpExpr_Const Kind_nat n; - --- The natural number 0 as a TpExpr -TpExprZ : TpExpr Kind_nat; -TpExprZ = TpExpr_Const Kind_nat 0; - - --- Type descriptions, which form an inductive description of types. These types --- are higher-order in the sense that they include encodings for function --- index types that can be used in SpecM computations to perform corecursive --- function calls. -data TpDesc : sort 0 where { - -- The type of a function index for a nullary monadic function, i.e., a - -- function index with type SpecM R for type description R - Tp_M : TpDesc -> TpDesc; - - -- The type of a function index for a dependent monadic function that takes - -- in an element of the left-hand kind and substitutes that into the - -- right-hand type description - Tp_Pi : KindDesc -> TpDesc -> TpDesc; - - -- the type of a function index for a function from the left-hand type - -- description to the right-hand one - Tp_Arr : TpDesc -> TpDesc -> TpDesc; - - -- An element of a kind at the object level - Tp_Kind : KindDesc -> TpDesc; - - -- Pair and sum types - Tp_Pair : TpDesc -> TpDesc -> TpDesc; - Tp_Sum : TpDesc -> TpDesc -> TpDesc; - - -- Dependent pair types Tp_Sigma K B, whose first element is an element e of - -- kind K and whose second element is of substitution instance [e/x]B - Tp_Sigma : KindDesc -> TpDesc -> TpDesc; - - -- Sequence types - Tp_Seq : TpExpr Kind_num -> TpDesc -> TpDesc; - - -- The empty type - Tp_Void : TpDesc; - - -- Inductive types, where Tp_Ind A is equivalent to [Tp_Ind A/x]A - Tp_Ind : TpDesc -> TpDesc; - - -- Type variables, used for types bound by pis, sigmas, and inductive types - Tp_Var : Nat -> TpDesc; - - -- Explicit substitution of a type - Tp_TpSubst : TpDesc -> TpDesc -> TpDesc; - - -- Explicit substitution of a type-level expression - Tp_ExprSubst : TpDesc -> (EK:ExprKind) -> TpExpr EK -> TpDesc; - -} - --- The type description for the unit type -Tp_Unit : TpDesc; -Tp_Unit = Tp_Kind (Kind_Expr Kind_unit); - --- The type description for the natural number type -Tp_Nat : TpDesc; -Tp_Nat = Tp_Kind (Kind_Expr Kind_nat); - --- The type description for the Num type -Tp_Num : TpDesc; -Tp_Num = Tp_Kind (Kind_Expr Kind_num); - --- The type description for a bitvector type -Tp_bitvector : Nat -> TpDesc; -Tp_bitvector w = Tp_Kind (Kind_Expr (Kind_bv w)); - --- The type description for a vector type -Tp_Vec : TpExpr Kind_nat -> TpDesc -> TpDesc; -Tp_Vec n d = Tp_Seq (TpExpr_UnOp Kind_nat Kind_num UnOp_NatToNum n) d; - --- The type description for the type BVVec n len d -Tp_BVVec : (n:Nat) -> TpExpr (Kind_bv n) -> TpDesc -> TpDesc; -Tp_BVVec n len d = - Tp_Vec (TpExpr_UnOp (Kind_bv n) Kind_nat (UnOp_BVToNat n) len) d; - --- An expression (TpDesc or TpExpr) of a given kind -kindExpr : KindDesc -> sort 0; -kindExpr K = - KindDesc#rec (\ (_:KindDesc) -> sort 0) - (\ (EK:ExprKind) -> TpExpr EK) - TpDesc - K; - --- An expression (TpDesc or TpExpr) of a given kind for a variable -varKindExpr : (K:KindDesc) -> Nat -> kindExpr K; -varKindExpr K = - KindDesc#rec (\ (K:KindDesc) -> Nat -> kindExpr K) - (\ (EK:ExprKind) (ix:Nat) -> TpExpr_Var EK ix) - (\ (ix:Nat) -> Tp_Var ix) - K; - --- Build an explicit substitution type for an arbitrary kind, using either the --- Tp_TpSubst or Tp_ExprSubst constructor -Tp_Subst : TpDesc -> (K:KindDesc) -> kindExpr K -> TpDesc; -Tp_Subst T K = - KindDesc#rec (\ (K:KindDesc) -> kindExpr K -> TpDesc) - (\ (EK:ExprKind) (e:TpExpr EK) -> Tp_ExprSubst T EK e) - (\ (U:TpDesc) -> Tp_TpSubst T U) - K; - - --- Type-level environments -- - --- Decide equality for expression kinds -proveEqExprKind : (EK1 EK2 : ExprKind) -> Maybe (Eq ExprKind EK1 EK2); -proveEqExprKind EK1_top = - ExprKind#rec - (\ (EK1:ExprKind) -> (EK2:ExprKind) -> Maybe (Eq ExprKind EK1 EK2)) - (\ (EK2_top:ExprKind) -> - ExprKind#rec (\ (EK2:ExprKind) -> Maybe (Eq ExprKind Kind_unit EK2)) - (Just (Eq ExprKind Kind_unit Kind_unit) (Refl ExprKind Kind_unit)) - (Nothing (Eq ExprKind Kind_unit Kind_bool)) - (Nothing (Eq ExprKind Kind_unit Kind_nat)) - (Nothing (Eq ExprKind Kind_unit Kind_num)) - (\ (w:Nat) -> Nothing (Eq ExprKind Kind_unit (Kind_bv w))) - EK2_top) - (\ (EK2_top:ExprKind) -> - ExprKind#rec (\ (EK2:ExprKind) -> Maybe (Eq ExprKind Kind_bool EK2)) - (Nothing (Eq ExprKind Kind_bool Kind_unit)) - (Just (Eq ExprKind Kind_bool Kind_bool) (Refl ExprKind Kind_bool)) - (Nothing (Eq ExprKind Kind_bool Kind_nat)) - (Nothing (Eq ExprKind Kind_bool Kind_num)) - (\ (w:Nat) -> Nothing (Eq ExprKind Kind_bool (Kind_bv w))) - EK2_top) - (\ (EK2_top:ExprKind) -> - ExprKind#rec (\ (EK2:ExprKind) -> Maybe (Eq ExprKind Kind_nat EK2)) - (Nothing (Eq ExprKind Kind_nat Kind_unit)) - (Nothing (Eq ExprKind Kind_nat Kind_bool)) - (Just (Eq ExprKind Kind_nat Kind_nat) (Refl ExprKind Kind_nat)) - (Nothing (Eq ExprKind Kind_nat Kind_num)) - (\ (w:Nat) -> Nothing (Eq ExprKind Kind_nat (Kind_bv w))) - EK2_top) - (\ (EK2_top:ExprKind) -> - ExprKind#rec (\ (EK2:ExprKind) -> Maybe (Eq ExprKind Kind_num EK2)) - (Nothing (Eq ExprKind Kind_num Kind_unit)) - (Nothing (Eq ExprKind Kind_num Kind_bool)) - (Nothing (Eq ExprKind Kind_num Kind_nat)) - (Just (Eq ExprKind Kind_num Kind_num) (Refl ExprKind Kind_num)) - (\ (w:Nat) -> Nothing (Eq ExprKind Kind_num (Kind_bv w))) - EK2_top) - (\ (w1:Nat) (EK2_top:ExprKind) -> - ExprKind#rec (\ (EK2:ExprKind) -> Maybe (Eq ExprKind (Kind_bv w1) EK2)) - (Nothing (Eq ExprKind (Kind_bv w1) Kind_unit)) - (Nothing (Eq ExprKind (Kind_bv w1) Kind_bool)) - (Nothing (Eq ExprKind (Kind_bv w1) Kind_nat)) - (Nothing (Eq ExprKind (Kind_bv w1) Kind_num)) - (\ (w2:Nat) -> - Maybe__rec - (Eq Nat w1 w2) - (\ (_:Maybe (Eq Nat w1 w2)) -> - Maybe (Eq ExprKind (Kind_bv w1) (Kind_bv w2))) - (Nothing (Eq ExprKind (Kind_bv w1) (Kind_bv w2))) - (\ (e:Eq Nat w1 w2) -> - Just (Eq ExprKind (Kind_bv w1) (Kind_bv w2)) - (eq_cong Nat w1 w2 e ExprKind (\ (w:Nat) -> Kind_bv w))) - (proveEqNat w1 w2)) - EK2_top) - EK1_top; - --- Decide equality for kind descriptions -proveEqKindDesc : (K1 K2 : KindDesc) -> Maybe (Eq KindDesc K1 K2); -proveEqKindDesc K1_top = - KindDesc#rec - (\ (K1:KindDesc) -> (K2:KindDesc) -> Maybe (Eq KindDesc K1 K2)) - (\ (EK1:ExprKind) (K2_top:KindDesc) -> - KindDesc#rec - (\ (K2:KindDesc) -> Maybe (Eq KindDesc (Kind_Expr EK1) K2)) - (\ (EK2:ExprKind) -> - Maybe__rec - (Eq ExprKind EK1 EK2) - (\ (_:Maybe (Eq ExprKind EK1 EK2)) -> - Maybe (Eq KindDesc (Kind_Expr EK1) (Kind_Expr EK2))) - (Nothing (Eq KindDesc (Kind_Expr EK1) (Kind_Expr EK2))) - (\ (e:Eq ExprKind EK1 EK2) -> - Just (Eq KindDesc (Kind_Expr EK1) (Kind_Expr EK2)) - (eq_cong ExprKind EK1 EK2 e KindDesc - (\ (EK:ExprKind) -> Kind_Expr EK))) - (proveEqExprKind EK1 EK2)) - (Nothing (Eq KindDesc (Kind_Expr EK1) Kind_Tp)) - K2_top) - (\ (K2_top:KindDesc) -> - KindDesc#rec - (\ (K2:KindDesc) -> Maybe (Eq KindDesc Kind_Tp K2)) - (\ (EK2:ExprKind) -> Nothing (Eq KindDesc Kind_Tp (Kind_Expr EK2))) - (Just (Eq KindDesc Kind_Tp Kind_Tp) (Refl KindDesc Kind_Tp)) - K2_top) - K1_top; - --- An element of a kind -kindElem : KindDesc -> sort 0; -kindElem K = - KindDesc#rec (\ (_:KindDesc) -> sort 0) - (\ (EK:ExprKind) -> exprKindElem EK) - TpDesc - K; - --- The default element of an expression kind -defaultEKElem : (EK:ExprKind) -> exprKindElem EK; -defaultEKElem EK = - ExprKind#rec exprKindElem () False 0 (TCNum 0) (\ (w:Nat) -> bvNat w 0) EK; - --- The default element of a kind -defaultKindElem : (K:KindDesc) -> kindElem K; -defaultKindElem K = KindDesc#rec kindElem defaultEKElem Tp_Void K; - --- Build a kindExpr K from an element of kindElem K -constKindExpr : (K:KindDesc) -> kindElem K -> kindExpr K; -constKindExpr K = - KindDesc#rec (\ (K:KindDesc) -> kindElem K -> kindExpr K) - (\ (EK:ExprKind) (elem:exprKindElem EK) -> TpExpr_Const EK elem) - (\ (T:TpDesc) -> T) - K; - --- An element of an environment is a value, i.e., an element of some kind -TpEnvElem : sort 0; -TpEnvElem = Sigma KindDesc kindElem; - --- An environment is a substitution from variables to values -TpEnv : sort 0; -TpEnv = List TpEnvElem; - --- The empty environment -nilTpEnv : TpEnv; -nilTpEnv = Nil TpEnvElem; - --- Add a value to a type environment -envConsElem : (K:KindDesc) -> kindElem K -> TpEnv -> TpEnv; -envConsElem K elem env = - Cons TpEnvElem (exists KindDesc kindElem K elem) env; - --- Eliminate a TpEnvElem at a particular kind, returning the default element of --- that kind if the kind of the head does not match -elimTpEnvElem : (K:KindDesc) -> TpEnvElem -> kindElem K; -elimTpEnvElem K elem = - Maybe__rec - (Eq KindDesc (Sigma_proj1 KindDesc kindElem elem) K) - (\ (_ : Maybe (Eq KindDesc (Sigma_proj1 KindDesc kindElem elem) K)) -> - kindElem K) - (defaultKindElem K) - (\ (e : (Eq KindDesc (Sigma_proj1 KindDesc kindElem elem) K)) -> - Eq__rec - KindDesc (Sigma_proj1 KindDesc kindElem elem) - (\ (X : KindDesc) (_ : Eq KindDesc (Sigma_proj1 KindDesc kindElem elem) X) -> - kindElem X) - (Sigma_proj2 KindDesc kindElem elem) - K e) - (proveEqKindDesc (Sigma_proj1 KindDesc kindElem elem) K); - --- Get the head value of a TpEnv at a particular kind, returning the default --- element of that kind if the kind of the head does not match or env is empty -headTpEnv : (K:KindDesc) -> TpEnv -> kindElem K; -headTpEnv K env = - List__rec TpEnvElem (\ (_:TpEnv) -> kindElem K) - (defaultKindElem K) - (\ (elem:TpEnvElem) (_:TpEnv) (_:kindElem K) -> elimTpEnvElem K elem) - env; - --- Get the tail of an environment -tailTpEnv : TpEnv -> TpEnv; -tailTpEnv = - List__rec TpEnvElem (\ (_:TpEnv) -> TpEnv) nilTpEnv - (\ (_:TpEnvElem) (tl:TpEnv) (_:TpEnv) -> tl); - - --- Substitution and evaluation -- - --- Substitute an environment into a variable of a particular kind at lifting --- level n, meaning that the environment is a substitution for the variables --- starting at n. Return the new value of the variable if it was substituted for --- (meaning it has index n + i for some index i in the environment) or the new --- variable number if it was not. -substVar : Nat -> TpEnv -> (K:KindDesc) -> Nat -> Either (kindElem K) Nat; -substVar n_top env_top K var_top = - Nat__rec - (\ (_:Nat) -> Nat -> TpEnv -> Either (kindElem K) Nat) - - -- var = 0 case - (\ (n:Nat) (env:TpEnv) -> - Nat__rec (\ (_:Nat) -> Either (kindElem K) Nat) - - -- If the lifting level = 0, then substitute, returning the head of env - (Left (kindElem K) Nat (headTpEnv K env)) - - -- If not, return var unchanged, i.e., 0 - (\ (_:Nat) (_:Either (kindElem K) Nat) -> - Right (kindElem K) Nat 0) - - n) - - -- var = Succ var' case - (\ (var':Nat) (rec:Nat -> TpEnv -> Either (kindElem K) Nat) - (n:Nat) (env:TpEnv) -> - Nat__rec (\ (_:Nat) -> Either (kindElem K) Nat) - - -- If the lifting level = 0, recursively substitute the tail of env - -- into var'; this intuitively decrements var' and the size of env - (rec 0 (tailTpEnv env)) - - -- If the lifting level = S n', recursively substitute with the - -- decremented lifting level n', incrementing the result if it is still - -- a variable index - (\ (n':Nat) (_:Either (kindElem K) Nat) -> - Either__rec (kindElem K) Nat - (\ (_:Either (kindElem K) Nat) -> Either (kindElem K) Nat) - - -- Value return case: return the value unchanged - -- - -- NOTE: even though, for kind Kind_Tp, we are substituting type - -- descriptions that could have free variables, we are *not* - -- lifting them, because we are assuming that type descriptions - -- which are "values" in environments are closed. Thus, - -- techincally, this substitution can capture free variables. This - -- should not come up in practice, though, since all type - -- descriptions are expected to be machine-generated. - (\ (ret:kindElem K) -> Left (kindElem K) Nat ret) - - -- Variable return case: increment the returned variable index - (\ (ret_ix:Nat) -> Right (kindElem K) Nat (Succ ret_ix)) - - (rec n' env)) - n) - var_top n_top env_top; - --- Evaluate a variable to a value, using the default value for free variables -evalVar : Nat -> TpEnv -> (K:KindDesc) -> Nat -> kindElem K; -evalVar n env K var = - Either__rec (kindElem K) Nat (\ (_:Either (kindElem K) Nat) -> kindElem K) - (\ (v:kindElem K) -> v) - (\ (_:Nat) -> defaultKindElem K) - (substVar n env K var); - --- Substitute an environment at lifting level n into type-level expression e -substTpExpr : Nat -> TpEnv -> (EK:ExprKind) -> TpExpr EK -> TpExpr EK; -substTpExpr n env EK_top e = - TpExpr#rec (\ (EK:ExprKind) (_:TpExpr EK) -> TpExpr EK) - (\ (EK:ExprKind) (v:exprKindElem EK) -> TpExpr_Const EK v) - (\ (EK:ExprKind) (ix:Nat) -> - Either__rec (exprKindElem EK) Nat - (\ (_:Either (exprKindElem EK) Nat) -> TpExpr EK) - (\ (v:exprKindElem EK) -> TpExpr_Const EK v) - (\ (ix':Nat) -> TpExpr_Var EK ix') - (substVar n env (Kind_Expr EK) ix)) - (\ (EK1 EK2:ExprKind) (op:TpExprUnOp EK1 EK2) - (_:TpExpr EK1) (rec:TpExpr EK1) -> - TpExpr_UnOp EK1 EK2 op rec) - (\ (EK1 EK2 EK3:ExprKind) (op:TpExprBinOp EK1 EK2 EK3) - (_:TpExpr EK1) (rec1:TpExpr EK1) - (_:TpExpr EK2) (rec2:TpExpr EK2) -> - TpExpr_BinOp EK1 EK2 EK3 op rec1 rec2) - EK_top - e; - --- Evaluate a type-level expression to a value -evalTpExpr : TpEnv -> (EK:ExprKind) -> TpExpr EK -> exprKindElem EK; -evalTpExpr env EK_top e = - TpExpr#rec (\ (EK:ExprKind) (_:TpExpr EK) -> exprKindElem EK) - (\ (EK:ExprKind) (v:exprKindElem EK) -> v) - (\ (EK:ExprKind) (ix:Nat) -> evalVar 0 env (Kind_Expr EK) ix) - (\ (EK1 EK2:ExprKind) (op:TpExprUnOp EK1 EK2) - (_:TpExpr EK1) (rec:exprKindElem EK1) -> - evalUnOp EK1 EK2 op rec) - (\ (EK1 EK2 EK3:ExprKind) (op:TpExprBinOp EK1 EK2 EK3) - (_:TpExpr EK1) (rec1:exprKindElem EK1) - (_:TpExpr EK2) (rec2:exprKindElem EK2) -> - evalBinOp EK1 EK2 EK3 op rec1 rec2) - EK_top - e; - --- Substitute an environment at lifting level n into type description T -tpSubst : Nat -> TpEnv -> TpDesc -> TpDesc; -tpSubst n_top env_top T_top = - TpDesc#rec (\ (_:TpDesc) -> Nat -> TpEnv -> TpDesc) - (\ (_:TpDesc) (rec:Nat -> TpEnv -> TpDesc) (n:Nat) (env:TpEnv) -> - Tp_M (rec n env)) - (\ (K:KindDesc) (_:TpDesc) (rec:Nat -> TpEnv -> TpDesc) (n:Nat) (env:TpEnv) -> - Tp_Pi K (rec (Succ n) env)) - (\ (_:TpDesc) (recA:Nat -> TpEnv -> TpDesc) (_:TpDesc) - (recB:Nat -> TpEnv -> TpDesc) (n:Nat) (env:TpEnv) -> - Tp_Arr (recA n env) (recB n env)) - (\ (K:KindDesc) (_:Nat) (_:TpEnv) -> - Tp_Kind K) - (\ (_:TpDesc) (recA:Nat -> TpEnv -> TpDesc) (_:TpDesc) - (recB:Nat -> TpEnv -> TpDesc) (n:Nat) (env:TpEnv) -> - Tp_Pair (recA n env) (recB n env)) - (\ (_:TpDesc) (recA:Nat -> TpEnv -> TpDesc) (_:TpDesc) - (recB:Nat -> TpEnv -> TpDesc) (n:Nat) (env:TpEnv) -> - Tp_Sum (recA n env) (recB n env)) - (\ (K:KindDesc) (_:TpDesc) (rec:Nat -> TpEnv -> TpDesc) (n:Nat) (env:TpEnv) -> - Tp_Sigma K (rec (Succ n) env)) - (\ (len:TpExpr Kind_num) (_:TpDesc) (rec:Nat -> TpEnv -> TpDesc) - (n:Nat) (env:TpEnv) -> - Tp_Seq (substTpExpr n env Kind_num len) (rec n env)) - (\ (n:Nat) (env:TpEnv) -> Tp_Void) - (\ (_:TpDesc) (rec:Nat -> TpEnv -> TpDesc) (n:Nat) (env:TpEnv) -> - Tp_Ind (rec (Succ n) env)) - (\ (ix:Nat) (n:Nat) (env:TpEnv) -> - Either__rec (kindElem Kind_Tp) Nat - (\ (_:Either (kindElem Kind_Tp) Nat) -> TpDesc) - (\ (U:TpDesc) -> U) - (\ (ix':Nat) -> Tp_Var ix') - (substVar n env Kind_Tp ix)) - (\ (_:TpDesc) (rec_fun:Nat -> TpEnv -> TpDesc) - (_:TpDesc) (rec_arg:Nat -> TpEnv -> TpDesc) (n:Nat) (env:TpEnv) -> - rec_fun n (envConsElem Kind_Tp (rec_arg n env) env)) - (\ (_:TpDesc) (rec:Nat -> TpEnv -> TpDesc) - (EK:ExprKind) (e:TpExpr EK) (n:Nat) (env:TpEnv) -> - rec n (envConsElem (Kind_Expr EK) (evalTpExpr env EK e) env)) - T_top n_top env_top; - --- Unfold an inductive type description Tp_Ind A by substituting the current --- environment augmented with the mapping from deBruijn index 0 to Tp_Ind A -unfoldIndTpDesc : TpEnv -> TpDesc -> TpDesc; -unfoldIndTpDesc env T = - tpSubst 0 (envConsElem Kind_Tp (tpSubst 0 env (Tp_Ind T)) env) T; - - --- Elements of type descriptions -- - --- The elements of an inductive type with type description T. This is defined in --- the Coq model, but the only way we use them in SAW is to fold and unfold them --- using the functions indToTpElem and tpToIndElem, below, so we leave the --- actual definition of this type opaque in SAW. -primitive indElem : TpDesc -> sort 0; - - --------------------------------------------------------------------------------- --- ITree Specification monad - --- An event type is a type of events plus a mapping from events to their return --- types -data EvType : sort 1 where { - Build_EvType : (E:sort 0) -> (E -> sort 0) -> EvType; -} - --- Get the type for an EvType -evTypeType : EvType -> sort 0; -evTypeType e = - EvType#rec (\ (_:EvType) -> sort 0) (\ (E:sort 0) (_:E -> sort 0) -> E) e; - --- Get the return type for an event -evRetType : (E:EvType) -> evTypeType E -> sort 0; -evRetType e = - EvType#rec (\ (E:EvType) -> evTypeType E -> sort 0) - (\ (E:sort 0) (evTypeEnc:E -> sort 0) -> evTypeEnc) e; - --- The EvType with Void as the event type -VoidEv : EvType; -VoidEv = Build_EvType Void (elimVoid (sort 0)); - --- The monad for specifications of computations (FIXME: document this!) -primitive SpecM : (E:EvType) -> sort 0 -> sort 0; - --- Return for SpecM -primitive retS : (E:EvType) -> (a:sort 0) -> a -> SpecM E a; - --- Bind for SpecM -primitive bindS : (E:EvType) -> (a b:sort 0) -> SpecM E a -> - (a -> SpecM E b) -> SpecM E b; - --- Trigger an event in type E, returning its return type -primitive triggerS : (E:EvType) -> (e:evTypeType E) -> SpecM E (evRetType E e); - --- Signal an error in SpecM -primitive errorS : (E:EvType) -> (a:sort 0) -> String -> SpecM E a; - --- The spec that universally quantifies over all return values of type a -primitive forallS : (E:EvType) -> (a:qsort 0) -> SpecM E a; - --- The spec that existentially quantifies over all return values of type a -primitive existsS : (E:EvType) -> (a:qsort 0) -> SpecM E a; - --- Assume a proposition holds -primitive assumeS : (E:EvType) -> (p:Prop) -> SpecM E #(); - --- Assume a Boolean value is true -assumeBoolS : (E:EvType) -> Bool -> SpecM E #(); -assumeBoolS E b = assumeS E (EqTrue b); - --- The specification which assumes that the first argument is True and then --- runs the second argument -assumingS : (E:EvType) -> (a : sort 0) -> Bool -> SpecM E a -> SpecM E a; -assumingS E a cond m = bindS E #() a (assumeBoolS E cond) (\(_:#()) -> m); - --- The version of assumingS which appears in un-monadified Cryptol (this gets --- converted to assumingS during monadification, see assertingOrAssumingMacro) -assuming : (a : isort 0) -> Bool -> a -> a; -assuming a b x = ite a b x (error a "Assuming failed"); - --- Assert a proposition holds -primitive assertS : (E:EvType) -> (p:Prop) -> SpecM E #(); - --- Assert a Boolean value is true -assertBoolS : (E:EvType) -> Bool -> SpecM E #(); -assertBoolS E b = assertS E (EqTrue b); - --- The specification which asserts that the first argument is True and then --- runs the second argument -assertingS : (E:EvType) -> (a : sort 0) -> Bool -> SpecM E a -> SpecM E a; -assertingS E a cond m = bindS E #() a (assertBoolS E cond) (\(_:#()) -> m); - --- The version of assertingS which appears in un-monadified Cryptol (this gets --- converted to assertingS during monadification, see assertingOrAssumingMacro) -asserting : (a : isort 0) -> Bool -> a -> a; -asserting a b x = ite a b x (error a "Assertion failed"); - --- The computation that nondeterministically chooses one computation or another. --- As a specification, represents the disjunction of two specifications. -orS : (E:EvType) -> (a : sort 0) -> SpecM E a -> SpecM E a -> SpecM E a; -orS E a m1 m2 = - bindS E Bool a (existsS E Bool) (\ (b:Bool) -> ite (SpecM E a) b m1 m2); - - --------------------------------------------------------------------------------- --- Elements of type descriptions - --- The type of monadified sequences, which are vectors for finite length and --- infinite streams of computations, represented as functions from Nat to --- computations, for the infinite length -mseq : (E:EvType) -> Num -> sort 0 -> sort 0; -mseq E num a = - Num_rec (\ (_:Num) -> sort 0) (\ (n:Nat) -> Vec n a) (Stream (SpecM E a)) num; - - --- Specialized inductive type to indicate if a type description is to be treated --- as a monadic function or as a data type -data FunFlag : sort 0 where { - IsFun : FunFlag; - IsData : FunFlag; -} - --- An if-then-else on whether a FunFlag is IsFun -ifFun : (a : sort 1) -> FunFlag -> a -> a -> a; -ifFun a fflag t f = FunFlag#rec (\ (_:FunFlag) -> a) t f fflag; - --- Elements of a type description relative to an environment. The Boolean flag --- isf indicates that the type description should be treated like a function --- type: for the three monadic function type descriptions, Tp_M, Tp_Pi, and --- Tp_Arr, this flag has no effect, but for the other types (that do not --- describe function types) the isf flag turns them into the trivial unit type. -tpElemEnv : EvType -> TpEnv -> FunFlag -> TpDesc -> sort 0; -tpElemEnv E env_top isf_top T_top = - TpDesc#rec (\ (_:TpDesc) -> TpEnv -> FunFlag -> sort 0) - (\ (R:TpDesc) (rec:TpEnv -> FunFlag -> sort 0) (env:TpEnv) (_:FunFlag) -> - SpecM E (rec env IsData)) - (\ (K:KindDesc) (T:TpDesc) (rec:TpEnv -> FunFlag -> sort 0) - (env:TpEnv) (_:FunFlag) -> - (elem:kindElem K) -> rec (envConsElem K elem env) IsFun) - (\ (T:TpDesc) (recT:TpEnv -> FunFlag -> sort 0) - (U:TpDesc) (recU:TpEnv -> FunFlag -> sort 0) (env:TpEnv) (_:FunFlag) -> - recT env IsData -> recU env IsFun) - (\ (K:KindDesc) (_:TpEnv) (isf:FunFlag) -> - ifFun (sort 0) isf #() (kindElem K)) - (\ (T:TpDesc) (recT:TpEnv -> FunFlag -> sort 0) - (U:TpDesc) (recU:TpEnv -> FunFlag -> sort 0) (env:TpEnv) (isf:FunFlag) -> - ifFun (sort 0) isf #() (recT env IsData * recU env IsData)) - (\ (T:TpDesc) (recT:TpEnv -> FunFlag -> sort 0) - (U:TpDesc) (recU:TpEnv -> FunFlag -> sort 0) (env:TpEnv) (isf:FunFlag) -> - ifFun (sort 0) isf #() (Either (recT env IsData) (recU env IsData))) - (\ (K:KindDesc) (T:TpDesc) (rec:TpEnv -> FunFlag -> sort 0) - (env:TpEnv) (isf:FunFlag) -> - ifFun (sort 0) isf #() - (Sigma (kindElem K) (\ (v:kindElem K) -> - rec (envConsElem K v env) IsData))) - (\ (len:TpExpr Kind_num) (_:TpDesc) (rec:TpEnv -> FunFlag -> sort 0) - (env:TpEnv) (isf:FunFlag) -> - ifFun (sort 0) isf #() (mseq E (evalTpExpr env Kind_num len) (rec env IsData))) - (\ (_:TpEnv) (isf:FunFlag) -> ifFun (sort 0) isf #() Void) - (\ (T:TpDesc) (rec:TpEnv -> FunFlag -> sort 0) (env:TpEnv) (isf:FunFlag) -> - ifFun (sort 0) isf #() (indElem (unfoldIndTpDesc env T))) - (\ (var:Nat) (env:TpEnv) (isf:FunFlag) -> - -- Note: we have to use indElem here, rather than tpElem, because this - -- would not be an inductively smaller recursive call to take tpElem of - -- the substitution instance - indElem (tpSubst 0 env (Tp_Var var))) - (\ (_:TpDesc) (rec:TpEnv -> FunFlag -> sort 0) - (U:TpDesc) (_:TpEnv -> FunFlag -> sort 0) (env:TpEnv) (isf:FunFlag) -> - ifFun (sort 0) isf #() (rec (envConsElem Kind_Tp (tpSubst 0 env U) env) IsData)) - (\ (_:TpDesc) (rec:TpEnv -> FunFlag -> sort 0) (EK:ExprKind) (e:TpExpr EK) - (env:TpEnv) (isf:FunFlag) -> - ifFun (sort 0) isf #() - (rec (envConsElem (Kind_Expr EK) (evalTpExpr env EK e) env) IsData)) - T_top env_top isf_top; - --- Elements of a type description = elements relative to the empty environment -tpElem : EvType -> TpDesc -> sort 0; -tpElem E = tpElemEnv E nilTpEnv IsData; - --- Build the type of the pure type-level function from elements of a list of --- kind descriptions to the type described by a type description over deBruijn --- indices for those elements, i.e., return the type --- --- (x1:kindElem k1) ... (xn:kindElem k2) -> sort 0 -pureTpElemTypeFunType : List KindDesc -> sort 1; -pureTpElemTypeFunType ks_top = - List#rec KindDesc (\ (_:List KindDesc) -> sort 1) - (sort 0) - (\ (k:KindDesc) (ks:List KindDesc) (rec:sort 1) -> kindElem k -> rec) - ks_top; - --- Build the pure type-level function from elements of a list of kind --- descriptions to the type described by a type description over deBruijn --- indices for those elements, i.e., return the type --- --- \ (x1:kindElem k1) ... (xn:kindElem k2) -> tpElemEnv ev [x1,...,xn] d -pureTpElemTypeFun : (ev:EvType) -> (ks:List KindDesc) -> TpDesc -> - pureTpElemTypeFunType ks; -pureTpElemTypeFun ev ks_top d = - List__rec KindDesc - (\ (ks:List KindDesc) -> TpEnv -> pureTpElemTypeFunType ks) - (\ (env:TpEnv) -> tpElemEnv ev env IsData d) - (\ (k:KindDesc) (ks:List KindDesc) (rec:TpEnv -> pureTpElemTypeFunType ks) - (env:TpEnv) (elem:kindElem k) -> - rec (envConsElem k elem env)) - ks_top - nilTpEnv; - --- Specification functions of a type description -specFun : EvType -> TpDesc -> sort 0; -specFun E = tpElemEnv E nilTpEnv IsFun; - --- Fold an element of [Tp_Ind T/x]T to an element of Tp_Ind T; note that folding --- is monadic, a detail which is explained in the Coq model -primitive foldTpElem : (E:EvType) -> (T:TpDesc) -> - tpElem E (unfoldIndTpDesc nilTpEnv T) -> - SpecM E (tpElem E (Tp_Ind T)); - --- Unfold an element of Tp_Ind T to an element of [Tp_Ind T/x]T; unfolding does --- not need to be monadic, unlike folding -primitive unfoldTpElem : (E:EvType) -> (T:TpDesc) -> tpElem E (Tp_Ind T) -> - tpElem E (unfoldIndTpDesc nilTpEnv T); - - --- Create a lambda as a fixed-point that can call itself. Note that the type of --- f, specFun E T -> specFun E T, is the same as specFun E (Tp_Arr T T) when T --- is a monadic function type. -primitive FixS : (E:EvType) -> (T:TpDesc) -> - (specFun E T -> specFun E T) -> specFun E T; - --- A hint to Mr Solver that a recursive function has the given loop invariant -invariantHint : (a : sort 0) -> Bool -> a -> a; -invariantHint _ _ a = a; - --- The type of a tuple of spec functions of types Ts -specFuns : EvType -> List TpDesc -> sort 0; -specFuns E Ts = - List__rec TpDesc (\ (_:List TpDesc) -> sort 0) #() - (\ (T:TpDesc) (_:List TpDesc) (rec:sort 0) -> - specFun E T * rec) - Ts; - --- Build the multi-arity function type specFun E T1 -> ... specFun E Tn -> A -arrowSpecFuns : EvType -> List TpDesc -> sort 0 -> sort 0; -arrowSpecFuns E Ts_top a = - List__rec TpDesc (\ (_:List TpDesc) -> sort 0) a - (\ (T:TpDesc) (_:List TpDesc) (rec:sort 0) -> specFun E T -> rec) - Ts_top; - --- The type of a tuple of spec function bodies that take in function indexes to --- allow them to corecursively call themselves -MultiFixBodies : EvType -> List TpDesc -> sort 0; -MultiFixBodies E Ts = arrowSpecFuns E Ts (specFuns E Ts); - --- Create a collection of corecursive functions in a SpecM computation as a --- fixed-point where the functions can call themselves and each other -primitive MultiFixS : (E:EvType) -> (Ts:List TpDesc) -> - MultiFixBodies E Ts -> specFuns E Ts; - --- Perform a computation that can call a collection of corecursive functions -primitive LetRecS : (E:EvType) -> (Ts:List TpDesc) -> (a:sort 0) -> - MultiFixBodies E Ts -> arrowSpecFuns E Ts (SpecM E a) -> - SpecM E a; - --- --- Helper operations on SpecM --- - --- Perform a for loop from 0 through n-1, iterating a state value by applying --- the supplied one-step state update function f at indices 0 through n-1 and --- then calling the supplied continuation k. More formally, perform the --- following computation from some starting state value s0: --- --- f 0 s0 >>= \s1 -> f 1 s1 >>= \s2 -> ... f (n-1) s(n-1) >>= \sn -> k sn -forNatLtThenS : (E:EvType) -> (st ret : sort 0) -> Nat -> - (Nat -> st -> SpecM E st) -> (st -> SpecM E ret) -> - st -> SpecM E ret; -forNatLtThenS E st ret n f k = - Nat__rec (\ (_:Nat) -> st -> SpecM E ret) - k - (\ (i:Nat) (rec:st -> SpecM E ret) (s:st) -> - bindS E st ret (f (subNat n (Succ i)) s) rec) - n; - --- The type of the function returned by forNatLtThenSBody -forNatLtThenSBodyType : (E:EvType) -> (st ret : sort 0) -> sort 0; -forNatLtThenSBodyType E st ret = Nat -> st -> SpecM E ret; - --- Intuitively, forNatLtThenS behaves like a FixS computation, though it is --- defined inductively on the Nat argument rather than coinductively via FixS. --- The reason it is defined this way is that FixS requires type descriptions for --- its types, whereas forNatLtThenS can work on arbitrary st and ret types. MR --- solver likes things to look like FixS, however, so forNatLtThenSBody is what --- the body (i.e., function argument to FixS) would be if it were defined in --- terms of FixS. The Boolean value supplies an invariant for this recursive --- function over any variables currently in scope. -forNatLtThenSBody : (E:EvType) -> (st ret : sort 0) -> Nat -> - (Nat -> st -> SpecM E st) -> (st -> SpecM E ret) -> - Bool -> (Nat -> st -> SpecM E ret) -> - Nat -> st -> SpecM E ret; -forNatLtThenSBody E st ret n f k invar rec i s = - invariantHint (SpecM E ret) - (and (ltNat i (Succ n)) invar) - (ite (SpecM E ret) (ltNat i n) - (bindS E st ret (f i s) (rec (Succ i))) - (k s)); - --- Apply a pure function to the result of a computation -fmapS : (E:EvType) -> (a b:sort 0) -> (a -> b) -> SpecM E a -> SpecM E b; -fmapS E a b f m = bindS E a b m (\ (x:a) -> retS E b (f x)); - --- Apply a computation of a function to a computation of an argument -applyS : (E:EvType) -> (a b:sort 0) -> SpecM E (a -> b) -> SpecM E a -> SpecM E b; -applyS E a b fm m = - bindS E (a -> b) b fm (\ (f:a -> b) -> - bindS E a b m (\ (x:a) -> retS E b (f x))); - --- Apply a binary pure function to a computation -fmapS2 : (E:EvType) -> (a b c:sort 0) -> (a -> b -> c) -> - SpecM E a -> SpecM E b -> SpecM E c; -fmapS2 E a b c f m1 m2 = - applyS E b c (fmapS E a (b -> c) f m1) m2; - --- Apply a trinary pure function to a computation -fmapS3 : (E:EvType) -> (a b c d:sort 0) -> (a -> b -> c -> d) -> - SpecM E a -> SpecM E b -> SpecM E c -> SpecM E d; -fmapS3 E a b c d f m1 m2 m3 = - applyS E c d (fmapS2 E a b (c -> d) f m1 m2) m3; - --- Bind two values and pass them to a binary function -bindS2 : (E:EvType) -> (a b c:sort 0) -> SpecM E a -> - SpecM E b -> (a -> b -> SpecM E c) -> SpecM E c; -bindS2 E a b c m1 m2 k = - bindS E a c m1 (\ (x:a) -> bindS E b c m2 (\ (y:b) -> k x y)); - --- Bind three values and pass them to a trinary function -bindS3 : (E:EvType) -> (a b c d:sort 0) -> SpecM E a -> - SpecM E b -> SpecM E c -> - (a -> b -> c -> SpecM E d) -> SpecM E d; -bindS3 E a b c d m1 m2 m3 k = - bindS E a d m1 (\ (x:a) -> bindS2 E b c d m2 m3 (k x)); - --- A version of bind that takes the function first -bindApplyS : (E:EvType) -> (a b:sort 0) -> (a -> SpecM E b) -> - SpecM E a -> SpecM E b; -bindApplyS E a b k m = bindS E a b m k; - --- A version of bindS2 that takes the function first -bindApplyS2 : (E:EvType) -> (a b c:sort 0) -> (a -> b -> SpecM E c) -> - SpecM E a -> SpecM E b -> SpecM E c; -bindApplyS2 E a b c k m1 m2 = bindS2 E a b c m1 m2 k; - --- A version of bindS3 that takes the function first -bindApplyS3 : (E:EvType) -> (a b c d:sort 0) -> (a -> b -> c -> SpecM E d) -> - SpecM E a -> SpecM E b -> SpecM E c -> SpecM E d; -bindApplyS3 E a b c d k m1 m2 m3 = bindS3 E a b c d m1 m2 m3 k; - --- Compose two monadic functions -composeS : (E:EvType) -> (a b c:sort 0) -> - (a -> SpecM E b) -> (b -> SpecM E c) -> a -> SpecM E c; -composeS E a b c k1 k2 x = bindS E b c (k1 x) k2; - --- Tuple a type onto the input and output types of a monadic function -tupleSpecMFunBoth : (E:EvType) -> (a b c:sort 0) -> (a -> SpecM E b) -> - (c * a -> SpecM E (c * b)); -tupleSpecMFunBoth E a b c k = - \ (x: c * a) -> bindS E b (c * b) (k x.(2)) - (\ (y:b) -> retS E (c*b) (x.(1), y)); - --- Tuple a value onto the output of a monadic function -tupleSpecMFunOut : (E:EvType) -> (a b c:sort 0) -> c -> - (a -> SpecM E b) -> (a -> SpecM E (c*b)); -tupleSpecMFunOut E a b c x f = - \ (y:a) -> bindS E b (c*b) (f y) (\ (z:b) -> retS E (c*b) (x,z)); - --- Map a monadic function across a vector -mapS : (E:EvType) -> (a:sort 0) -> (b:isort 0) -> (a -> SpecM E b) -> - (n:Nat) -> Vec n a -> SpecM E (Vec n b); -mapS E a b f = - Nat__rec - (\ (n:Nat) -> Vec n a -> SpecM E (Vec n b)) - (\ (_:Vec 0 a) -> retS E (Vec 0 b) (EmptyVec b)) - (\ (n:Nat) (rec_f:Vec n a -> SpecM E (Vec n b)) - (v:Vec (Succ n) a) -> - fmapS2 E b (Vec n b) (Vec (Succ n) b) - (\ (hd:b) (tl:Vec n b) -> ConsVec b hd n tl) - (f (head n a v)) - (rec_f (tail n a v))); - --- Map a monadic function across a BVVec -mapBVVecS : (E:EvType) -> (a : sort 0) -> (b : isort 0) -> (a -> SpecM E b) -> - (n : Nat) -> (len : Vec n Bool) -> BVVec n len a -> - SpecM E (BVVec n len b); -mapBVVecS E a b f n len = mapS E a b f (bvToNat n len); - --- Cast a vector between lengths, testing that those lengths are equal -castVecS : (E:EvType) -> (a : sort 0) -> (n1 : Nat) -> (n2 : Nat) -> - Vec n1 a -> SpecM E (Vec n2 a); -castVecS E a n1 n2 v = - ifEqNatWithProof (SpecM E (Vec n2 a)) n1 n2 - (errorS E (Vec n2 a) "Could not cast Vec") - (\ (pf:Eq Nat n1 n2) -> - retS - E (Vec n2 a) - (coerce (Vec n1 a) (Vec n2 a) - (eq_cong Nat n1 n2 pf (sort 0) (\ (n:Nat) -> Vec n a)) - v)); - --- Append two BVVecs and cast the resulting size, if possible -appendCastBVVecS : (E:EvType) -> (n : Nat) -> - (len1 len2 len3 : Vec n Bool) -> (a : sort 0) -> - BVVec n len1 a -> BVVec n len2 a -> - SpecM E (BVVec n len3 a); -appendCastBVVecS E n len1 len2 len3 a v1 v2 = - ifBvEqWithProof (SpecM E (BVVec n len3 a)) n (bvAdd n len1 len2) len3 - (errorS E (BVVec n len3 a) "Could not cast BVVec") - (\ (pf:Eq (Vec n Bool) (bvAdd n len1 len2) len3) -> - retS - E (BVVec n len3 a) - (coerce (BVVec n (bvAdd n len1 len2) a) (BVVec n len3 a) - (eq_cong (Vec n Bool) (bvAdd n len1 len2) len3 pf - (sort 0) (\ (l:Vec n Bool) -> BVVec n l a)) - (appendBVVec n len1 len2 a v1 v2))); - - --- --- Defining refinement on SpecM computations --- - --- The return relation for refinesS that states that the output values of two --- SpecM computations are equal -eqRR : (R:sort 0) -> R -> R -> Prop; -eqRR R r1 r2 = Eq R r1 r2; - --- The proposition that one SpecM computation refines another, relative to a --- relation on their return values -primitive refinesS : (E:EvType) -> (R1:sort 0) -> (R2:sort 0) -> - (RR:R1 -> R2 -> Prop) -> SpecM E R1 -> SpecM E R2 -> Prop; - --- The specialization of refinesS to use eqRR -refinesS_eq : (E:EvType) -> (R:sort 0) -> SpecM E R -> SpecM E R -> Prop; -refinesS_eq E R m1 m2 = refinesS E R R (eqRR R) m1 m2; diff --git a/cryptol-saw-core/src/CryptolSAWCore/Cryptol.hs b/cryptol-saw-core/src/CryptolSAWCore/Cryptol.hs index 8298273032..44ffa61311 100644 --- a/cryptol-saw-core/src/CryptolSAWCore/Cryptol.hs +++ b/cryptol-saw-core/src/CryptolSAWCore/Cryptol.hs @@ -101,14 +101,12 @@ import SAWCore.Term.Pretty (showTerm) -- local modules: import CryptolSAWCore.Panic --- Type-check the Prelude, Cryptol, SpecM, and CryptolM modules at compile time +-- Type-check the Prelude and Cryptol modules at compile time import Language.Haskell.TH import CryptolSAWCore.Prelude -import CryptolSAWCore.PreludeM $(runIO (mkSharedContext >>= \sc -> - scLoadPreludeModule sc >> scLoadCryptolModule sc >> - scLoadSpecMModule sc >> scLoadCryptolMModule sc >> return [])) + scLoadPreludeModule sc >> scLoadCryptolModule sc >> pure [])) -------------------------------------------------------------------------------- @@ -354,6 +352,7 @@ importType sc env ty = where go = importType sc env + isErasedProp :: C.Prop -> Bool isErasedProp prop = case prop of @@ -527,11 +526,9 @@ provePropRec sc env prop0 prop = (C.pIsLogic -> Just (C.tIsTuple -> Just [])) -> do scGlobalApply sc "Cryptol.PLogicUnit" [] -- instance (Logic a, Logic b) => Logic (a, b) - (C.pIsLogic -> Just (C.tIsTuple -> Just [t])) - -> do provePropRec sc env prop0 (C.pLogic t) (C.pIsLogic -> Just (C.tIsTuple -> Just (t : ts))) -> do a <- importType sc env t - b <- importType sc env (C.tTuple ts) + b <- scTypeList sc =<< traverse (importType sc env) ts pa <- provePropRec sc env prop0 (C.pLogic t) pb <- provePropRec sc env prop0 (C.pLogic (C.tTuple ts)) scGlobalApply sc "Cryptol.PLogicPair" [a, b, pa, pb] @@ -574,11 +571,9 @@ provePropRec sc env prop0 prop = (C.pIsRing -> Just (C.tIsTuple -> Just [])) -> do scGlobalApply sc "Cryptol.PRingUnit" [] -- instance (Ring a, Ring b) => Ring (a, b) - (C.pIsRing -> Just (C.tIsTuple -> Just [t])) - -> do provePropRec sc env prop0 (C.pRing t) (C.pIsRing -> Just (C.tIsTuple -> Just (t : ts))) -> do a <- importType sc env t - b <- importType sc env (C.tTuple ts) + b <- scTypeList sc =<< traverse (importType sc env) ts pa <- provePropRec sc env prop0 (C.pRing t) pb <- provePropRec sc env prop0 (C.pRing (C.tTuple ts)) scGlobalApply sc "Cryptol.PRingPair" [a, b, pa, pb] @@ -648,11 +643,9 @@ provePropRec sc env prop0 prop = (C.pIsEq -> Just (C.tIsTuple -> Just [])) -> do scGlobalApply sc "Cryptol.PEqUnit" [] -- instance (Eq a, Eq b) => Eq (a, b) - (C.pIsEq -> Just (C.tIsTuple -> Just [t])) - -> do provePropRec sc env prop0 (C.pEq t) (C.pIsEq -> Just (C.tIsTuple -> Just (t : ts))) -> do a <- importType sc env t - b <- importType sc env (C.tTuple ts) + b <- scTypeList sc =<< traverse (importType sc env) ts pa <- provePropRec sc env prop0 (C.pEq t) pb <- provePropRec sc env prop0 (C.pEq (C.tTuple ts)) scGlobalApply sc "Cryptol.PEqPair" [a, b, pa, pb] @@ -688,11 +681,9 @@ provePropRec sc env prop0 prop = (C.pIsCmp -> Just (C.tIsTuple -> Just [])) -> do scGlobalApply sc "Cryptol.PCmpUnit" [] -- instance (Cmp a, Cmp b) => Cmp (a, b) - (C.pIsCmp -> Just (C.tIsTuple -> Just [t])) - -> do provePropRec sc env prop0 (C.pCmp t) (C.pIsCmp -> Just (C.tIsTuple -> Just (t : ts))) -> do a <- importType sc env t - b <- importType sc env (C.tTuple ts) + b <- scTypeList sc =<< traverse (importType sc env) ts pa <- provePropRec sc env prop0 (C.pCmp t) pb <- provePropRec sc env prop0 (C.pCmp (C.tTuple ts)) scGlobalApply sc "Cryptol.PCmpPair" [a, b, pa, pb] @@ -714,11 +705,9 @@ provePropRec sc env prop0 prop = (C.pIsSignedCmp -> Just (C.tIsTuple -> Just [])) -> do scGlobalApply sc "Cryptol.PSignedCmpUnit" [] -- instance (SignedCmp a, SignedCmp b) => SignedCmp (a, b) - (C.pIsSignedCmp -> Just (C.tIsTuple -> Just [t])) - -> do provePropRec sc env prop0 (C.pSignedCmp t) (C.pIsSignedCmp -> Just (C.tIsTuple -> Just (t : ts))) -> do a <- importType sc env t - b <- importType sc env (C.tTuple ts) + b <- scTypeList sc =<< traverse (importType sc env) ts pa <- provePropRec sc env prop0 (C.pSignedCmp t) pb <- provePropRec sc env prop0 (C.pSignedCmp (C.tTuple ts)) scGlobalApply sc "Cryptol.PSignedCmpPair" [a, b, pa, pb] @@ -1056,13 +1045,7 @@ importExpr sc env expr = case sel of C.TupleSel i _maybeLen -> do e' <- importExpr sc env e - let t = fastTypeOf (envC env) e - case C.tIsTuple t of - Just ts -> scTupleSelector sc e' (i+1) (length ts) - Nothing -> panic "importExpr" [ - "Invalid tuple selector: " <> Text.pack (show i), - "Type: " <> Text.pack (pretty t) - ] + scTupleSelector sc e' i C.RecordSel x _ -> do e' <- importExpr sc env e let t = fastTypeOf (envC env) e @@ -1071,7 +1054,7 @@ importExpr sc env expr = do i <- the ("Expected field " <> Text.pack (show x) <> " in normal RecordSel") (elemIndex x (map fst (C.canonicalFields fm))) - scTupleSelector sc e' (i+1) (length (C.canonicalFields fm)) + scTupleSelector sc e' i C.TNominal nt _args -> do let fs = case C.ntDef nt of C.Struct s -> C.ntFields s @@ -1087,7 +1070,7 @@ importExpr sc env expr = ] i <- the ("Expected field " <> Text.pack (show x) <> " in Newtype Record Sel") (elemIndex x (map fst (C.canonicalFields fs))) - scTupleSelector sc e' (i+1) (length (C.canonicalFields fs)) + scTupleSelector sc e' i _ -> panic "importExpr" [ "Invalid record selector: " <> Text.pack (pretty x), "Type: " <> Text.pack (pretty t) @@ -2009,13 +1992,10 @@ scCryptolType sc t = SC.VDataType _ _ _ -> Nothing - SC.VUnitType -> return (Right (C.tTuple [])) - SC.VPairType v1 v2 -> do - Right t1 <- asCryptolTypeValue v1 - Right t2 <- asCryptolTypeValue v2 - case C.tIsTuple t2 of - Just ts -> return (Right (C.tTuple (t1 : ts))) - Nothing -> return (Right (C.tTuple [t1, t2])) + SC.VTupleType vs -> + do es <- traverse asCryptolTypeValue vs + ts <- traverse asRight es + pure (Right (C.tTuple (Vector.toList ts))) SC.VPiType _nm v1 (SC.VNondependentPi v2) -> do Right t1 <- asCryptolTypeValue v1 @@ -2032,6 +2012,8 @@ scCryptolType sc t = SC.VRecordType{} -> Nothing SC.VRecursorType{} -> Nothing SC.VTyTerm{} -> Nothing + where + asRight = either (const Nothing) Just -------------------------------------------------------------------------------- -- exporting functions: @@ -2099,24 +2081,25 @@ exportValue ty v = case ty of exportTupleValue :: [TV.TValue] -> SC.CValue -> [V.Eval V.Value] exportTupleValue tys v = - case (tys, v) of - ([] , SC.VUnit ) -> [] - ([t] , _ ) -> [exportValue t v] - (t : ts, SC.VPair x y) -> (exportValue t (run x)) : exportTupleValue ts (run y) - _ -> error $ "exportValue: expected tuple" + case v of + SC.VTuple (Vector.toList -> xs) + | length xs == length tys -> + [ exportValue t (run x) | (t, x) <- zip tys xs ] + _ -> panic "Verifier.SAW.Cryptol.exportValue" ["expected tuple"] where run = SC.runIdentity . force exportRecordValue :: [(C.Ident, TV.TValue)] -> SC.CValue -> [(C.Ident, V.Eval V.Value)] exportRecordValue fields v = - case (fields, v) of - ([] , SC.VUnit ) -> [] - ([(n, t)] , _ ) -> [(n, exportValue t v)] - ((n, t) : ts, SC.VPair x y) -> (n, exportValue t (run x)) : exportRecordValue ts (run y) - (_, SC.VRecordValue (alistAllFields - (map (C.identText . fst) fields) -> Just ths)) -> + case v of + -- TODO: remove VTuple case when cryptol-saw-core importer switches record imports to use record types. + SC.VTuple (Vector.toList -> xs) + | length xs == length fields -> + [ (n, exportValue t (run x)) | ((n, t), x) <- zip (Map.assocs (Map.fromList fields)) xs ] + SC.VRecordValue (alistAllFields + (map (C.identText . fst) fields) -> Just ths) -> zipWith (\(n,t) x -> (n, exportValue t (run x))) fields ths - _ -> error $ "exportValue: expected record" + _ -> panic "Verifier.SAW.Cryptol.exportValue" ["expected record"] where run = SC.runIdentity . force @@ -2387,8 +2370,7 @@ genCodeForEnum sc env nt ctors = let n = length (C.ecFields ctor) scAbstractTerms sc [x] =<< scApplyAll sc funcVar - =<< forM [1..n] - (\i-> scTupleSelector sc x i n) + =<< forM [0 .. n-1] (scTupleSelector sc x) addTypeAbstractions =<< scAbstractTerms sc [b] diff --git a/cryptol-saw-core/src/CryptolSAWCore/Monadify.hs b/cryptol-saw-core/src/CryptolSAWCore/Monadify.hs deleted file mode 100644 index 6191beec44..0000000000 --- a/cryptol-saw-core/src/CryptolSAWCore/Monadify.hs +++ /dev/null @@ -1,1725 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE KindSignatures #-} - -{- | -Module : CryptolSAWCore.Monadify -Copyright : Galois, Inc. 2021 -License : BSD3 -Maintainer : westbrook@galois.com -Stability : experimental -Portability : non-portable (language extensions) - -This module implements a "monadification" transformation, which converts "pure" -SAW core terms that use inconsistent operations like @fix@ and convert them to -monadic SAW core terms that use monadic versions of these operations that are -consistent. The monad that is used is the @SpecM@ monad that is axiomatized in -the SAW core prelude. This is only a partial transformation, meaning that it -will fail on some SAW core terms. Specifically, it requires that all -applications @f arg@ in a term either have a non-dependent function type for @f@ -(i.e., a function with type @'Pi' x a b@ where @x@ does not occur in @b@) or a -pure argument @arg@ that does not use any of the inconsistent operations. - -Monadification is easiest to understand as a transformation on types that at a -high level replaces any function type of the form @a1 -> ... -> an -> b@ with -the monadic function type @a1' -> ... -> an' -> SpecM b'@, where @b'@ and each -@ai'@ are the result of monadifying @b@ and @ai@, respectively. Non-function -type constructors like pairs or vectors are monadified to themselves, though -their type arguments are also monadified. One slight complexity here is in -handling sequence types, which are either vectors for finite sequences or -functions from a natural number index to the element at that index for infinite -sequences. Since function types become monadic function types, infinite -sequences become monadic functions from a natural numbers to elements, i.e., -streams of computations. This is all handled by defining the type @mseq@ of -"monadified sequences" that use vectors for finite lengths and streams of -computations for the infinite length. - -In more detail, this transformation is defined with two type-level -transformations, @MT(a)@ and @CompMT(a)@, which define the "argument" and -"computational" monadification of @a@. The former is used to monadify arguments -in function types, and is also used to define _the_ monadification of a type. -The latter is used to monadify the return type of a function type, and adds a -@SpecM@ to that return type. These functions are defined as follows: - -> MT(Pi x (sort 0) b) = Pi x (sort 0) CompMT(b) -> MT(Pi x Num b) = Pi x Num CompMT(b) -> MT(Pi _ a b) = MT(a) -> CompMT(b) -> MT(#(a,b)) = #(MT(a),MT(b)) -> MT(seq n a) = mseq n MT(a) -> MT(f arg) = f MT(arg) -- For pure type function f -> MT(cnst) = cnst -> MT(dt args) = dt MT(args) -> MT(x) = x -> MT(_) = error - -> CompMT(tp = Pi _ _ _) = MT(tp) -> CompMT(n : Num) = n -> CompMT(tp) = SpecM MT(tp) - -The way monadification of types is implemented here is in two pieces. The first -is the 'monadifyType' function and its associated helpers, which converts a SAW -core type into an internal representation captured by the Haskell type -'MonType'. The second piece is the functions 'toArgType' and 'toCompType', which -map a 'MonType' generated from SAW type @a@ to the result of applying @MT(a)@ -and @CompMT(a)@, respectively. - - -FIXME: explain the term-level transformation below - -Term-level translation: - -MonArg(t : tp) ==> MT(tp) -MonArg(t) = - case Mon(t) of - m : SpecM MT(a) => shift \k -> m >>= \x -> k x - _ => t - -Mon(t : tp) ==> MT(tp) or CompMT(tp) (which are the same type for pis) -Mon((f : Pi x a b) arg) = Mon(f) MT(arg) -Mon((f : Pi _ a b) arg) = Mon(f) MonArg(arg) -Mon(Lambda x a t) = Lambda x MT(a) Mon(t) -Mon((t,u)) = (MonArg(t),MonArg(u)) -Mon(c args) = c MonArg(args) -Mon(x) = x -Mon(fix) = fixM (of some form...) -Mon(cnst) = cnstM if cnst is impure and monadifies to constM -Mon(cnst) = cnst otherwise --} - -module CryptolSAWCore.Monadify where - -import Numeric.Natural -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import Data.IntMap.Strict (IntMap) -import qualified Data.IntMap.Strict as IntMap -import qualified Data.Text as Text -import Control.Monad (forM_, unless) -import Control.Monad.Cont (Cont, cont, runCont) -import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.Reader (MonadReader(..), ReaderT(..)) -import Control.Monad.State (MonadState(..), StateT(..), evalStateT, modify) -import Control.Monad.Trans (MonadTrans(..)) -import qualified Control.Monad.Fail as Fail --- import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Maybe (isJust) -import qualified Data.Text as T -import qualified Text.URI as URI -import Data.Type.Equality - -import qualified SAWSupport.Pretty as PPS (defaultOpts) - -import SAWCore.Module (ModuleMap, Def(..), ResolvedName(..), requireNameInMap, resolvedNameType) -import SAWCore.Name -import SAWCore.Term.Functor -import SAWCore.SharedTerm -import SAWCore.OpenTerm -import SAWCore.Term.Pretty (scPrettyTermInCtx) - -import CryptolSAWCore.Panic -import CryptolSAWCore.TypedTerm -import CryptolSAWCore.Cryptol (Env) -import SAWCore.Recognizer --- import SAWCore.Position -import CryptolSAWCore.PreludeM - -import GHC.Stack --- import Debug.Trace - --- FIXME: move to OpenTerm.hs - --- | A global definition, which is either a primitive or a constant. -data GlobalDef = GlobalDef { globalDefName :: Name, - globalDefType :: Term, - globalDefTerm :: Term } - -instance Eq GlobalDef where - gd1 == gd2 = globalDefName gd1 == globalDefName gd2 - -instance Ord GlobalDef where - compare gd1 gd2 = compare (globalDefName gd1) (globalDefName gd2) - -instance Show GlobalDef where - show = show . globalDefName - --- | Get the 'String' name of a 'GlobalDef' -globalDefString :: GlobalDef -> String -globalDefString = T.unpack . toAbsoluteName . nameInfo . globalDefName - --- | Build an 'OpenTerm' from a 'GlobalDef' -globalDefOpenTerm :: GlobalDef -> OpenTerm -globalDefOpenTerm = closedOpenTerm . globalDefTerm - --- | Recognize a named global definition, including its type -asTypedGlobalDef :: (?mm :: ModuleMap) => Recognizer Term GlobalDef -asTypedGlobalDef t = - case unwrapTermF t of - Constant nm -> - let ty = resolvedNameType (requireNameInMap nm ?mm) - in Just $ GlobalDef nm ty t - Variable ec -> - Just $ GlobalDef (ecName ec) (ecType ec) t - _ -> Nothing - --- FIXME HERE NOW: remove these if no longer needed -{- - ----------------------------------------------------------------------- --- * Typing All Subterms ----------------------------------------------------------------------- - --- | A SAW core term where all of the subterms are typed -data TypedSubsTerm - = TypedSubsTerm { tpSubsIndex :: Maybe TermIndex, - tpSubsFreeVars :: BitSet, - tpSubsTermF :: TermF TypedSubsTerm, - tpSubsTypeF :: TermF TypedSubsTerm, - tpSubsSort :: Sort } - --- | Convert a 'Term' to a 'TypedSubsTerm' -typeAllSubterms :: SharedContext -> Term -> IO TypedSubsTerm -typeAllSubterms = error "FIXME HERE" - --- | Convert a 'TypedSubsTerm' back to a 'Term' -typedSubsTermTerm :: TypedSubsTerm -> Term -typedSubsTermTerm = error "FIXME HERE" - --- | Get the type of a 'TypedSubsTerm' as a 'TypedSubsTerm' -typedSubsTermType :: TypedSubsTerm -> TypedSubsTerm -typedSubsTermType tst = - TypedSubsTerm { tpSubsIndex = Nothing, tpSubsFreeVars = tpSubsFreeVars tst, - tpSubsTermF = tpSubsTypeF tst, - tpSubsTypeF = FTermF (Sort (tpSubsSort tst) noFlags), - tpSubsSort = sortOf (tpSubsSort tst) } - --- | Count the number of right-nested pi-abstractions of a 'TypedSubsTerm' -typedSubsTermArity :: TypedSubsTerm -> Int -typedSubsTermArity (TypedSubsTerm { tpSubsTermF = Pi _ _ tst }) = - 1 + typedSubsTermArity tst -typedSubsTermArity _ = 0 - --- | Count the number of right-nested pi abstractions in a term, which --- represents a type. This assumes that the type is in WHNF. -typeArity :: Term -> Int -typeArity tp = length $ fst $ asPiList tp - -class ToTerm a where - toTerm :: a -> Term - -instance ToTerm Term where - toTerm = id - -instance ToTerm TypedSubsTerm where - toTerm = typedSubsTermTerm - -unsharedApply :: Term -> Term -> Term -unsharedApply f arg = Unshared $ App f arg --} - - ----------------------------------------------------------------------- --- * Monadifying Types ----------------------------------------------------------------------- - --- | Test if a 'Term' is a first-order function type -isFirstOrderType :: Term -> Bool -isFirstOrderType (asPi -> Just (_, asPi -> Just _, _)) = False -isFirstOrderType (asPi -> Just (_, _, tp_out)) = isFirstOrderType tp_out -isFirstOrderType _ = True - --- | The implicit argument version of 'EventType' -type HasSpecMEvType = (?specMEvType :: EventType) - --- | The kinds used in monadification, i.e., the types of 'MonType's. These --- correspond to constructors of the SAW core type @KindDesc@, though we only --- use the subset that occur in Cryptol types here -data MonKind = MKType | MKNum deriving Eq - -type MKType = 'MKType -type MKNum = 'MKNum - --- | The @Num@ type as a SAW core term -numTypeOpenTerm :: OpenTerm -numTypeOpenTerm = dataTypeOpenTerm "Cryptol.Num" [] - --- | Representing type-level kinds at the data level -data KindRepr (k :: MonKind) where - MKTypeRepr :: KindRepr MKType - MKNumRepr :: KindRepr MKNum - --- | Convert a 'KindRepr' to the SAW core type it represents -kindReprOpenTerm :: KindRepr k -> OpenTerm -kindReprOpenTerm MKTypeRepr = sortOpenTerm $ mkSort 0 -kindReprOpenTerm MKNumRepr = numTypeOpenTerm - -instance TestEquality KindRepr where - -- NOTE: we write the patterns like this so that there are still 2*n cases for - -- n constructors but if we add a new constructor coverage checking will fail - testEquality MKTypeRepr MKTypeRepr = Just Refl - testEquality MKTypeRepr _ = Nothing - testEquality MKNumRepr MKNumRepr = Just Refl - testEquality MKNumRepr _ = Nothing - --- | A 'KindRepr' for a kind that is determined at runtime -data SomeKindRepr where SomeKindRepr :: KindRepr k -> SomeKindRepr - --- | A binary operation on @Num@ expressions -data NumBinOp = NBinOp_Add | NBinOp_Mul - --- | A representation of type-level @Num@ expressions, i.e., SAW core terms of --- type @TpExpr Kind_num@ -data NumTpExpr - -- | A type-level deBrujn level (not index; see docs on 'MTyVarLvl', below) - = NExpr_VarLvl Natural - -- | A @Num@ value as an expression - | NExpr_Const OpenTerm - -- | A binary operation on @Num@s - | NExpr_BinOp NumBinOp NumTpExpr NumTpExpr - --- | The internal (to monadification) representation of a SAW core type that is --- being monadified. Most of these constructors have corresponding constructors --- in the SAW core inductive type @TpDesc@ of type descriptions, other than --- 'MTyIndesc', which represents indescribable types -data MonType - = forall k. MTyForall LocalName (KindRepr k) (TpExpr k -> MonType) - | MTyArrow MonType MonType - | MTySeq NumTpExpr MonType - | MTyUnit - | MTyBool - | MTyBV Natural - | MTyPair MonType MonType - | MTySum MonType MonType - -- | A type with no type description, meaning it cannot be used in a - -- fixpoint - | MTyIndesc OpenTerm - -- | A type-level deBruijn level, where 0 refers to the outermost binding - -- (as opposed to deBruijn indices, where 0 refers to the innermost - -- binding); only used by 'toTpDesc' to convert a 'MonType' to a type - -- description, and should never be seen outside of that function - | MTyVarLvl Natural - --- | A type-level expression of the given kind; corresponds to the SAW core type --- @kindElem K@ -type family TpExpr (k::MonKind) where - TpExpr MKType = MonType - TpExpr MKNum = NumTpExpr - --- | A type-level expression whose kind is determined dynamically -data SomeTpExpr where SomeTpExpr :: KindRepr k -> TpExpr k -> SomeTpExpr - --- | Build a deBruijn level as a type-level expression of a given kind -kindVar :: KindRepr k -> Natural -> TpExpr k -kindVar MKTypeRepr = MTyVarLvl -kindVar MKNumRepr = NExpr_VarLvl - --- | Build a type-level expression from a value of kind @k@ -kindOfVal :: KindRepr k -> OpenTerm -> TpExpr k -kindOfVal MKTypeRepr = MTyIndesc -kindOfVal MKNumRepr = NExpr_Const - --- | Test if a monadification type @tp@ is considered a base type, meaning that --- @CompMT(tp) = CompM MT(tp)@ -isBaseType :: MonType -> Bool -isBaseType (MTyForall _ _ _) = False -isBaseType (MTyArrow _ _) = False -isBaseType _ = True - --- | Convert a SAW core 'Term' to a monadification kind, if possible -monadifyKind :: Term -> Maybe SomeKindRepr -monadifyKind (asGlobalApply "Cryptol.Num" -> Just []) = Just $ SomeKindRepr MKNumRepr -monadifyKind (asSort -> Just s) | s == mkSort 0 = Just $ SomeKindRepr MKTypeRepr -monadifyKind _ = Nothing - --- | Convert a numeric binary operation to a SAW core binary function on @Num@ -numBinOpOp :: NumBinOp -> OpenTerm -numBinOpOp NBinOp_Add = globalOpenTerm "Cryptol.tcAdd" -numBinOpOp NBinOp_Mul = globalOpenTerm "Cryptol.tcMul" - --- | Convert a numeric type expression to a SAW core @Num@ term; it is an error --- if it contains a deBruijn level -numExprVal :: NumTpExpr -> OpenTerm -numExprVal (NExpr_VarLvl _) = - panic "numExprVal" ["Unexpected deBruijn variable"] -numExprVal (NExpr_Const n) = n -numExprVal (NExpr_BinOp op e1 e2) = - applyOpenTermMulti (numBinOpOp op) [numExprVal e1, numExprVal e2] - --- | Convert a 'MonType' to the argument type @MT(tp)@ it represents; should --- only ever be applied to a 'MonType' that represents a valid SAW core type, --- i.e., one not containing 'MTyNum' or 'MTyVarLvl' -toArgType :: HasSpecMEvType => MonType -> OpenTerm -toArgType (MTyForall x k body) = - piOpenTerm x (kindReprOpenTerm k) (\e -> toCompType (body $ kindOfVal k e)) -toArgType (MTyArrow t1 t2) = - arrowOpenTerm "_" (toArgType t1) (toCompType t2) -toArgType (MTySeq n t) = - applyOpenTermMulti (globalOpenTerm "SpecM.mseq") - [evTypeTerm ?specMEvType, numExprVal n, toArgType t] -toArgType MTyUnit = unitTypeOpenTerm -toArgType MTyBool = boolTypeOpenTerm -toArgType (MTyBV n) = bitvectorTypeOpenTerm $ natOpenTerm n -toArgType (MTyPair mtp1 mtp2) = - pairTypeOpenTerm (toArgType mtp1) (toArgType mtp2) -toArgType (MTySum mtp1 mtp2) = - dataTypeOpenTerm "Prelude.Either" [toArgType mtp1, toArgType mtp2] -toArgType (MTyIndesc t) = t -toArgType (MTyVarLvl _) = panic "toArgType" ["Unexpected deBruijn index"] - --- | Convert a 'MonType' to the computation type @CompMT(tp)@ it represents -toCompType :: HasSpecMEvType => MonType -> OpenTerm -toCompType mtp@(MTyForall _ _ _) = toArgType mtp -toCompType mtp@(MTyArrow _ _) = toArgType mtp -toCompType mtp = specMTypeOpenTerm ?specMEvType $ toArgType mtp - --- | Convert a 'TpExpr' to either an argument type or a @Num@ term, depending on --- its kind -tpExprVal :: HasSpecMEvType => KindRepr k -> TpExpr k -> OpenTerm -tpExprVal MKTypeRepr = toArgType -tpExprVal MKNumRepr = numExprVal - --- | Convert a 'SomeTpExpr' to either an argument type or a @Num@ term, --- depending on its kind -someTpExprVal :: HasSpecMEvType => SomeTpExpr -> OpenTerm -someTpExprVal (SomeTpExpr k e) = tpExprVal k e - --- | Convert a 'MonKind' to the kind description it represents -toKindDesc :: KindRepr k -> OpenTerm -toKindDesc MKTypeRepr = tpKindDesc -toKindDesc MKNumRepr = numKindDesc - --- | Convert a numeric binary operation to a SAW core term of type @TpExprBinOp@ -numBinOpExpr :: NumBinOp -> OpenTerm -numBinOpExpr NBinOp_Add = ctorOpenTerm "SpecM.BinOp_AddNum" [] -numBinOpExpr NBinOp_Mul = ctorOpenTerm "SpecM.BinOp_MulNum" [] - --- | Convert a numeric type expression to a type-level expression, i.e., a SAW --- core term of type @TpExpr Kind_num@, assuming the supplied number of bound --- deBruijn levels -numExprExpr :: Natural -> NumTpExpr -> OpenTerm -numExprExpr lvl (NExpr_VarLvl l) = - -- Convert to a deBruijn index instead of a level (we use levels because they - -- are invariant under substitution): since there are lvl free variables, the - -- most recently bound is lvl - 1, so this has deBruijn index 0, while the - -- least recently bound is 0, so this has deBruijn index lvl - 1; lvl - l - 1 - -- thus gives us what we need - varTpExpr numExprKind (lvl - l - 1) -numExprExpr _ (NExpr_Const n) = constTpExpr numExprKind n -numExprExpr lvl (NExpr_BinOp op e1 e2) = - binOpTpExpr (numBinOpExpr op) numKindDesc numKindDesc numKindDesc - (numExprExpr lvl e1) (numExprExpr lvl e2) - --- | Main implementation of 'toTpDesc'. Convert a 'MonType' to the type --- description it represents, assuming the supplied number of bound deBruijn --- indices. The 'Bool' flag indicates whether the 'MonType' should be treated --- like a function type, meaning that the @Tp_M@ constructor should be added if --- the type is not already a function type. -toTpDescH :: Natural -> Bool -> MonType -> OpenTerm -toTpDescH lvl _ (MTyForall _ k body) = - piTpDesc (toKindDesc k) $ toTpDescH (lvl+1) True $ body $ kindVar k lvl -toTpDescH lvl _ (MTyArrow mtp1 mtp2) = - arrowTpDesc (toTpDescH lvl False mtp1) (toTpDescH lvl True mtp2) -toTpDescH lvl True mtp = - -- Convert a non-functional type to a functional one by making a nullary - -- monadic function, i.e., applying the @SpecM@ type constructor - mTpDesc $ toTpDescH lvl False mtp -toTpDescH lvl False (MTySeq n mtp) = - seqTpDesc (numExprExpr lvl n) (toTpDescH lvl False mtp) -toTpDescH _ False MTyUnit = unitTpDesc -toTpDescH _ False MTyBool = boolTpDesc -toTpDescH _ False (MTyBV w) = bvTpDesc w -toTpDescH lvl False (MTyPair mtp1 mtp2) = - pairTpDesc (toTpDescH lvl False mtp1) (toTpDescH lvl False mtp2) -toTpDescH lvl False (MTySum mtp1 mtp2) = - sumTpDesc (toTpDescH lvl False mtp1) (toTpDescH lvl False mtp2) -toTpDescH _ _ (MTyIndesc trm) = - bindPPOpenTerm trm $ \pp_trm -> - failOpenTerm ("toTpDescH: indescribable type:\n" ++ pp_trm) -toTpDescH lvl False (MTyVarLvl l) = - -- Convert a deBruijn level to a deBruijn index; see comments in numExprExpr - varTpDesc (lvl - l - 1) - --- | Convert a 'MonType' to the type description it represents -toTpDesc :: MonType -> OpenTerm -toTpDesc = toTpDescH 0 False - --- | The mapping for monadifying Cryptol typeclasses --- FIXME: this is no longer needed, as it is now the identity -typeclassMonMap :: [(Ident,Ident)] -typeclassMonMap = - [("Cryptol.PEq", "Cryptol.PEq"), - ("Cryptol.PCmp", "Cryptol.PCmp"), - ("Cryptol.PSignedCmp", "Cryptol.PSignedCmp"), - ("Cryptol.PZero", "Cryptol.PZero"), - ("Cryptol.PLogic", "Cryptol.PLogic"), - ("Cryptol.PRing", "Cryptol.PRing"), - ("Cryptol.PIntegral", "Cryptol.PIntegral"), - ("Cryptol.PLiteral", "Cryptol.PLiteral")] - --- | The mapping for monadifying type-level binary @Num@ operations -numBinOpMonMap :: [(Ident,NumBinOp)] -numBinOpMonMap = - [("Cryptol.tcAdd", NBinOp_Add), ("Cryptol.tcMul", NBinOp_Mul) - -- FIXME: handle the others: - -- "Cryptol.tcSub", "Cryptol.tcDiv", "Cryptol.tcMod", "Cryptol.tcExp", - -- "Cryptol.tcMin", "Cryptol.tcMax" - ] - --- | A context of local variables used for monadifying types, which includes the --- variable names, their original types (before monadification), and an optional --- 'MonType' bound to the variable if its type corresponds to a 'MonKind', --- meaning its binding site is being translated into an 'MTyForall'. --- --- NOTE: the reason this type is different from 'MonadifyCtx', the context type --- for monadifying terms, is that monadifying arrow types does not introduce a --- local 'MonTerm' argument, since they are not dependent functions and so do --- not use a HOAS encoding. -type MonadifyTypeCtx = [(LocalName, Term, Maybe SomeTpExpr)] - --- | Pretty-print a 'Term' relative to a 'MonadifyTypeCtx' -ppTermInTypeCtx :: MonadifyTypeCtx -> Term -> String -ppTermInTypeCtx ctx t = - scPrettyTermInCtx PPS.defaultOpts (map (\(x,_,_) -> x) ctx) t - --- | Extract the variables and their original types from a 'MonadifyTypeCtx' -typeCtxPureCtx :: MonadifyTypeCtx -> [(LocalName,Term)] -typeCtxPureCtx = map (\(x,tp,_) -> (x,tp)) - - --- | Monadify a type and convert it to its corresponding argument type -monadifyTypeArgType :: (HasCallStack, HasSpecMEvType) => MonadifyTypeCtx -> - Term -> OpenTerm -monadifyTypeArgType ctx t = toArgType $ monadifyType ctx t - --- | Check if a type-level operation, given by identifier, matching a 'NumBinOp' -monadifyNumBinOp :: Ident -> Maybe NumBinOp -monadifyNumBinOp i = lookup i numBinOpMonMap - - --- | Convert a SAW core 'Term' to a type-level expression of some kind, or panic --- if this is not possible -monadifyTpExpr :: (HasCallStack, HasSpecMEvType) => MonadifyTypeCtx -> Term -> - SomeTpExpr -{- -monadifyTpExpr ctx t - | trace ("\nmonadifyTpExpr:\n" ++ ppTermInTypeCtx ctx t) False = undefined --} - --- Type cases -monadifyTpExpr ctx (asPi -> Just (x, tp_in, tp_out)) - | Just (SomeKindRepr k) <- monadifyKind tp_in = - SomeTpExpr MKTypeRepr $ - MTyForall x k (\tp' -> - let ctx' = (x,tp_in,Just (SomeTpExpr k tp')):ctx in - monadifyType ctx' tp_out) -monadifyTpExpr ctx tp@(asPi -> Just (_, _, tp_out)) - | inBitSet 0 (looseVars tp_out) = - -- FIXME: make this a failure instead of an error - error ("monadifyType: " ++ - "dependent function type with non-kind argument type: " ++ - ppTermInTypeCtx ctx tp) -monadifyTpExpr ctx tp@(asPi -> Just (x, tp_in, tp_out)) = - SomeTpExpr MKTypeRepr $ - MTyArrow (monadifyType ctx tp_in) (monadifyType ((x,tp,Nothing):ctx) tp_out) -monadifyTpExpr _ (asTupleType -> Just []) = - SomeTpExpr MKTypeRepr $ MTyUnit -monadifyTpExpr ctx (asPairType -> Just (tp1, tp2)) = - SomeTpExpr MKTypeRepr $ - MTyPair (monadifyType ctx tp1) (monadifyType ctx tp2) -{- -monadifyType ctx (asRecordType -> Just tps) = - MTyRecord $ map (\(fld,tp) -> (fld, monadifyType ctx tp)) $ Map.toList tps --} -monadifyTpExpr ctx (asGlobalApply "Prelude.Eq" -> Just [k_trm, tp1, tp2]) - | isJust (monadifyKind k_trm) = - SomeTpExpr MKTypeRepr $ - -- NOTE: technically this is a Prop and not a sort 0, but it doesn't matter - MTyIndesc $ dataTypeOpenTerm "Prelude.Eq" [monadifyTypeArgType ctx tp1, - monadifyTypeArgType ctx tp2] -monadifyTpExpr _ (asBitvectorType -> Just w) = - SomeTpExpr MKTypeRepr $ MTyBV w -monadifyTpExpr ctx (asVectorType -> Just (asNat -> Just n, a)) = - let nM = NExpr_Const $ ctorOpenTerm "Cryptol.TCNum" [natOpenTerm n] - in SomeTpExpr MKTypeRepr $ MTySeq nM (monadifyType ctx a) -monadifyTpExpr ctx (asApplyAll -> ((asGlobalDef -> Just seq_id), [n, a])) - | seq_id == "Cryptol.seq" = - SomeTpExpr MKTypeRepr $ MTySeq (monadifyNum ctx n) (monadifyType ctx a) -monadifyTpExpr ctx (asApp -> Just ((asGlobalDef -> Just f), arg)) - | Just f_trans <- lookup f typeclassMonMap = - SomeTpExpr MKTypeRepr $ MTyIndesc $ - applyOpenTerm (globalOpenTerm f_trans) $ monadifyTypeArgType ctx arg -monadifyTpExpr _ (asGlobalDef -> Just bool_id) - | bool_id == "Prelude.Bool" = - SomeTpExpr MKTypeRepr $ MTyBool -monadifyTpExpr _ (asGlobalDef -> Just integer_id) - | integer_id == "Prelude.Integer" = - SomeTpExpr MKTypeRepr $ MTyIndesc $ globalOpenTerm "Prelude.Integer" -{- -monadifyType ctx (asApplyAll -> (f, args)) - | Just glob <- asTypedGlobalDef f - , Just ec_k <- monadifyKind $ globalDefType glob - , margs <- map (monadifyType ctx) args - , Just k_out <- applyKinds ec_k margs = - MTyBase k_out (applyOpenTermMulti (globalDefOpenTerm glob) $ - map toArgType margs) --} - --- Num cases -monadifyTpExpr _ (asGlobalApply "Cryptol.TCInf" -> Just []) - = SomeTpExpr MKNumRepr $ NExpr_Const $ ctorOpenTerm "Cryptol.TCInf" [] -monadifyTpExpr _ (asGlobalApply "Cryptol.TCNum" -> Just [asNat -> Just n]) - = SomeTpExpr MKNumRepr $ NExpr_Const $ ctorOpenTerm "Cryptol.TCNum" [natOpenTerm n] -monadifyTpExpr ctx (asApplyAll -> ((asGlobalDef -> Just f), [arg1, arg2])) - | Just op <- monadifyNumBinOp f - = SomeTpExpr MKNumRepr $ NExpr_BinOp op (monadifyNum ctx arg1) (monadifyNum ctx arg2) -monadifyTpExpr ctx (asLocalVar -> Just i) - | i < length ctx - , (_,_,Just (SomeTpExpr k e)) <- ctx!!i = SomeTpExpr k e -monadifyTpExpr ctx tp = - -- XXX this doesn't look like it should be a panic - panic "monadifyTpExpr" [ - "Not a valid type or numeric expression for monadification: " <> - T.pack (ppTermInTypeCtx ctx tp) - ] - --- | Convert a SAW core 'Term' to a monadification type, or panic if this is not --- possible -monadifyType :: (HasCallStack, HasSpecMEvType) => MonadifyTypeCtx -> Term -> - MonType -monadifyType ctx t - | SomeTpExpr MKTypeRepr tp <- monadifyTpExpr ctx t = tp -monadifyType ctx t = - panic "monadifyType" ["Not a type: " <> T.pack (ppTermInTypeCtx ctx t)] - --- | Convert a SAW core 'Term' to a type-level numeric expression, or panic if --- this is not possible -monadifyNum :: (HasCallStack, HasSpecMEvType) => MonadifyTypeCtx -> Term -> - NumTpExpr -monadifyNum ctx t - | SomeTpExpr MKNumRepr e <- monadifyTpExpr ctx t = e -monadifyNum ctx t = - panic "monadifyNum" ["Not a numeric expression: " <> T.pack (ppTermInTypeCtx ctx t)] - - ----------------------------------------------------------------------- --- * Monadified Terms ----------------------------------------------------------------------- - --- | A representation of a term that has been translated to argument type --- @MT(tp)@ -data ArgMonTerm - -- | A monadification term of a base type @MT(tp)@ - = BaseMonTerm MonType OpenTerm - -- | A monadification term of non-depedent function type - | FunMonTerm LocalName MonType MonType (ArgMonTerm -> MonTerm) - -- | A monadification term of polymorphic type - | forall k. ForallMonTerm LocalName (KindRepr k) (TpExpr k -> MonTerm) - --- | A representation of a term that has been translated to computational type --- @CompMT(tp)@ -data MonTerm - = ArgMonTerm ArgMonTerm - | CompMonTerm MonType OpenTerm - --- | An argument to a 'MonTerm' of functional type -data MonArg - -- | A type-level expression argument to a polymorphic function - = forall k. TpArg (KindRepr k) (TpExpr k) - -- | A term-level argument to a non-dependent function - | TrmArg ArgMonTerm - --- | Convert a 'SomeTpExpr' to a type-level 'MonArg' argument -tpExprToArg :: SomeTpExpr -> MonArg -tpExprToArg (SomeTpExpr k e) = TpArg k e - --- | Convert a numeric expression to a type-level 'MonArg' argument -numToArg :: NumTpExpr -> MonArg -numToArg = TpArg MKNumRepr - --- | Get the monadification type of a monadification term -class GetMonType a where - getMonType :: a -> MonType - -instance GetMonType ArgMonTerm where - getMonType (BaseMonTerm tp _) = tp - getMonType (ForallMonTerm x k body) = MTyForall x k (getMonType . body) - getMonType (FunMonTerm _ tp_in tp_out _) = MTyArrow tp_in tp_out - -instance GetMonType MonTerm where - getMonType (ArgMonTerm t) = getMonType t - getMonType (CompMonTerm tp _) = tp - - --- | Convert a monadification term to a SAW core term of type @CompMT(tp)@ -class ToCompTerm a where - toCompTerm :: HasSpecMEvType => a -> OpenTerm - -instance ToCompTerm ArgMonTerm where - toCompTerm (BaseMonTerm mtp t) = - retSOpenTerm ?specMEvType (toArgType mtp) t - toCompTerm (FunMonTerm x tp_in _ body) = - lambdaOpenTerm x (toArgType tp_in) (toCompTerm . body . fromArgTerm tp_in) - toCompTerm (ForallMonTerm x k body) = - lambdaOpenTerm x (kindReprOpenTerm k) (toCompTerm . body . kindOfVal k) - -instance ToCompTerm MonTerm where - toCompTerm (ArgMonTerm amtrm) = toCompTerm amtrm - toCompTerm (CompMonTerm _ trm) = trm - - --- | Convert an 'ArgMonTerm' to a SAW core term of type @MT(tp)@ -toArgTerm :: HasSpecMEvType => ArgMonTerm -> OpenTerm -toArgTerm (BaseMonTerm _ t) = t -toArgTerm t = toCompTerm t - - --- | Build a monadification term from a term of type @MT(tp)@ -class FromArgTerm a where - fromArgTerm :: HasSpecMEvType => MonType -> OpenTerm -> a - -instance FromArgTerm ArgMonTerm where - fromArgTerm (MTyForall x k body) t = - ForallMonTerm x k (\tp -> fromCompTerm (body tp) (applyOpenTerm t $ - tpExprVal k tp)) - fromArgTerm (MTyArrow t1 t2) t = - FunMonTerm "_" t1 t2 (\x -> fromCompTerm t2 (applyOpenTerm t $ toArgTerm x)) - fromArgTerm tp t = BaseMonTerm tp t - -instance FromArgTerm MonTerm where - fromArgTerm mtp t = ArgMonTerm $ fromArgTerm mtp t - --- | Build a monadification term from a computational term of type @CompMT(tp)@ -fromCompTerm :: HasSpecMEvType => MonType -> OpenTerm -> MonTerm -fromCompTerm mtp t | isBaseType mtp = CompMonTerm mtp t -fromCompTerm mtp t = ArgMonTerm $ fromArgTerm mtp t - --- | Test if a monadification type @tp@ is pure, meaning @MT(tp)=tp@ -monTypeIsPure :: MonType -> Bool -monTypeIsPure (MTyForall _ _ _) = False -monTypeIsPure (MTyArrow _ _) = False -monTypeIsPure (MTySeq _ _) = False -monTypeIsPure MTyUnit = True -monTypeIsPure MTyBool = True -monTypeIsPure (MTyBV _) = True -monTypeIsPure (MTyPair mtp1 mtp2) = monTypeIsPure mtp1 && monTypeIsPure mtp2 -monTypeIsPure (MTySum mtp1 mtp2) = monTypeIsPure mtp1 && monTypeIsPure mtp2 -monTypeIsPure (MTyIndesc _) = True -monTypeIsPure (MTyVarLvl _) = - panic "monTypeIsPure" ["Unexpected type variable"] - --- | Test if a monadification type @tp@ is semi-pure, meaning @SemiP(tp) = tp@, --- where @SemiP@ is defined in the documentation for 'fromSemiPureTermFun' below -monTypeIsSemiPure :: MonType -> Bool -monTypeIsSemiPure (MTyForall _ k tp_f) = - monTypeIsSemiPure $ tp_f $ kindOfVal k $ - -- This dummy OpenTerm should never be inspected by the recursive call - error "monTypeIsSemiPure" -monTypeIsSemiPure (MTyArrow tp_in tp_out) = - monTypeIsPure tp_in && monTypeIsSemiPure tp_out -monTypeIsSemiPure (MTySeq _ _) = False -monTypeIsSemiPure MTyUnit = True -monTypeIsSemiPure MTyBool = True -monTypeIsSemiPure (MTyBV _) = True -monTypeIsSemiPure (MTyPair mtp1 mtp2) = - -- NOTE: functions in pairs are not semi-pure; only pure types in pairs are - -- semi-pure - monTypeIsPure mtp1 && monTypeIsPure mtp2 -monTypeIsSemiPure (MTySum mtp1 mtp2) = - -- NOTE: same as pairs - monTypeIsPure mtp1 && monTypeIsPure mtp2 -monTypeIsSemiPure (MTyIndesc _) = True -monTypeIsSemiPure (MTyVarLvl _) = - panic "monTypeIsSemiPure" ["Unexpected type variable"] - --- | Build a monadification term from a function on terms which, when viewed as --- a lambda, is a "semi-pure" function of the given monadification type, meaning --- it maps terms of argument type @MT(tp)@ to an output value of argument type; --- i.e., it has type @SemiP(tp)@, defined as: --- --- > SemiP(Pi x (sort 0) b) = Pi x (sort 0) SemiP(b) --- > SemiP(Pi x Num b) = Pi x Num SemiP(b) --- > SemiP(Pi _ a b) = MT(a) -> SemiP(b) --- > SemiP(a) = MT(a) -fromSemiPureTermFun :: HasSpecMEvType => MonType -> ([OpenTerm] -> OpenTerm) -> - ArgMonTerm -fromSemiPureTermFun (MTyForall x k body) f = - ForallMonTerm x k $ \e -> - ArgMonTerm $ fromSemiPureTermFun (body e) (f . (tpExprVal k e:)) -fromSemiPureTermFun (MTyArrow t1 t2) f = - FunMonTerm "_" t1 t2 $ \x -> - ArgMonTerm $ fromSemiPureTermFun t2 (f . (toArgTerm x:)) -fromSemiPureTermFun tp f = BaseMonTerm tp (f []) - --- | Like 'fromSemiPureTermFun' but use a term rather than a term function -fromSemiPureTerm :: HasSpecMEvType => MonType -> OpenTerm -> ArgMonTerm -fromSemiPureTerm mtp t = fromSemiPureTermFun mtp (applyOpenTermMulti t) - --- | Build an 'ArgMonTerm' that 'fail's when converted to a term -failArgMonTerm :: HasSpecMEvType => MonType -> String -> ArgMonTerm -failArgMonTerm tp str = BaseMonTerm tp (failOpenTerm str) - --- | Build a 'MonTerm' that 'fail's when converted to a term -failMonTerm :: HasSpecMEvType => MonType -> String -> MonTerm -failMonTerm tp str = ArgMonTerm $ failArgMonTerm tp str - --- | Apply a monadified type to a type or term argument in the sense of --- 'applyPiOpenTerm', meaning give the type of applying @f@ of a type to a --- particular argument @arg@ -applyMonType :: HasCallStack => MonType -> MonArg -> MonType -applyMonType (MTyForall _ k1 f) (TpArg k2 t) - | Just Refl <- testEquality k1 k2 = f t -applyMonType (MTyArrow _ tp_ret) (TrmArg _) = tp_ret -applyMonType _ _ = error "applyMonType: application at incorrect type" - --- | Apply a monadified term to a type or term argument -applyMonTerm :: HasCallStack => MonTerm -> MonArg -> MonTerm -applyMonTerm (ArgMonTerm (ForallMonTerm _ k1 f)) (TpArg k2 e) - | Just Refl <- testEquality k1 k2 = f e -applyMonTerm (ArgMonTerm (FunMonTerm _ _ _ f)) (TrmArg arg) = f arg -applyMonTerm (ArgMonTerm (ForallMonTerm _ _ _)) _ = - panic "applyMonTerm" ["Application of term at incorrect type"] -applyMonTerm (ArgMonTerm (FunMonTerm _ _ _ _)) _ = - panic "applyMonTerm" ["Application of term at incorrect type"] -applyMonTerm (ArgMonTerm (BaseMonTerm _ _)) _ = - panic "applyMonTerm" ["Application of non-functional pure term"] -applyMonTerm (CompMonTerm _ _) _ = - panic "applyMonTerm" ["Application of non-functional computational term"] - --- | Apply a monadified term to 0 or more arguments -applyMonTermMulti :: HasCallStack => MonTerm -> [MonArg] -> MonTerm -applyMonTermMulti = foldl applyMonTerm - --- | Build a 'MonTerm' from a global of a given argument type, applying it to --- the current 'EventType' if the 'Bool' flag is 'True' -mkGlobalArgMonTerm :: HasSpecMEvType => MonType -> Ident -> Bool -> ArgMonTerm -mkGlobalArgMonTerm tp ident params_p = - fromArgTerm tp (if params_p - then applyGlobalOpenTerm ident [evTypeTerm ?specMEvType] - else globalOpenTerm ident) - --- | Build a 'MonTerm' from a 'GlobalDef' of semi-pure type, applying it to the --- current 'EventType' if the 'Bool' flag is 'True' -mkSemiPureGlobalDefTerm :: HasSpecMEvType => GlobalDef -> Bool -> ArgMonTerm -mkSemiPureGlobalDefTerm glob params_p = - fromSemiPureTerm (monadifyType [] $ globalDefType glob) - (if params_p - then applyOpenTermMulti (globalDefOpenTerm glob) [evTypeTerm ?specMEvType] - else globalDefOpenTerm glob) - --- | Build a 'MonTerm' from a constructor with the given 'ExtCns' -mkCtorArgMonTerm :: HasSpecMEvType => ExtCns Term -> ArgMonTerm -mkCtorArgMonTerm ec - | not (isFirstOrderType (ecType ec)) = - failArgMonTerm (monadifyType [] $ ecType ec) - ("monadification failed: cannot handle constructor " - ++ Text.unpack (toAbsoluteName (ecNameInfo ec)) ++ " with higher-order type") -mkCtorArgMonTerm ec = - case ecNameInfo ec of - ModuleIdentifier ident -> - fromSemiPureTermFun (monadifyType [] $ ecType ec) (ctorOpenTerm ident) - ImportedName{} -> - failArgMonTerm (monadifyType [] $ ecType ec) - ("monadification failed: cannot handle constructor " - ++ Text.unpack (toAbsoluteName (ecNameInfo ec)) ++ " with non-ident name") - - ----------------------------------------------------------------------- --- * Monadification Environments and Contexts ----------------------------------------------------------------------- - --- | A monadification macro is a function that inspects its first @N@ arguments --- before deciding how to monadify itself -data MonMacro = MonMacro { - macroNumArgs :: Int, - macroApply :: GlobalDef -> [Term] -> MonadifyM MonTerm } - --- | Make a simple 'MonMacro' that inspects 0 arguments and just returns a term -monMacro0 :: MonTerm -> MonMacro -monMacro0 mtrm = MonMacro 0 $ \_ _ -> usingEvType $ return mtrm - --- | Make a 'MonMacro' that maps a named global to a global of semi-pure type. --- (See 'fromSemiPureTermFun'.) Because we can't get access to the type of the --- global until we apply the macro, we monadify its type at macro application --- time. The 'Bool' flag indicates whether the current 'EventType' should also --- be passed as the first argument to the "to" global. -semiPureGlobalMacro :: Ident -> Ident -> Bool -> MonMacro -semiPureGlobalMacro from to params_p = - MonMacro 0 $ \glob args -> usingEvType $ - if nameInfo (globalDefName glob) == ModuleIdentifier from && args == [] then - return $ ArgMonTerm $ - fromSemiPureTerm (monadifyType [] $ globalDefType glob) - (if params_p then applyGlobalOpenTerm to [evTypeTerm ?specMEvType] - else globalOpenTerm to) - else - error ("Monadification macro for " ++ show from ++ " applied incorrectly") - --- | Make a 'MonMacro' that maps a named global to a global of argument type. --- Because we can't get access to the type of the global until we apply the --- macro, we monadify its type at macro application time. The 'Bool' flag --- indicates whether the "to" global is polymorphic in the event type, in which --- case the current 'EventType' is passed as its first argument. -argGlobalMacro :: NameInfo -> Ident -> Bool -> MonMacro -argGlobalMacro from to params_p = - MonMacro 0 $ \glob args -> usingEvType $ - if nameInfo (globalDefName glob) == from && args == [] then - return $ ArgMonTerm $ - mkGlobalArgMonTerm (monadifyType [] $ globalDefType glob) to params_p - else - error ("Monadification macro for " ++ show from ++ " applied incorrectly") - --- | An environment for monadification -data MonadifyEnv = MonadifyEnv { - -- | How to monadify named functions - monEnvMonTable :: Map NameInfo MonMacro, - -- | The @EvType@ used for monadification - monEnvEvType :: EventType - } - --- | Look up the monadification of a name in a 'MonadifyEnv' -monEnvLookup :: NameInfo -> MonadifyEnv -> Maybe MonMacro -monEnvLookup nmi env = Map.lookup nmi (monEnvMonTable env) - --- | Add a monadification for a name to a 'MonadifyEnv' -monEnvAdd :: NameInfo -> MonMacro -> MonadifyEnv -> MonadifyEnv -monEnvAdd nmi macro env = - env { monEnvMonTable = Map.insert nmi macro (monEnvMonTable env) } - --- | A context for monadifying 'Term's which maintains, for each deBruijn index --- in scope, both its original un-monadified type along with either a 'MonTerm' --- or 'MonType' for the translation of the variable to a local variable of --- monadified type or monadified kind -type MonadifyCtx = [(LocalName,Term,MonArg)] - --- | Convert a 'MonadifyCtx' to a 'MonadifyTypeCtx' -ctxToTypeCtx :: MonadifyCtx -> MonadifyTypeCtx -ctxToTypeCtx = map (\(x,tp,arg) -> - (x,tp,case arg of - TpArg k mtp -> Just (SomeTpExpr k mtp) - TrmArg _ -> Nothing)) - --- | Pretty-print a 'Term' relative to a 'MonadifyCtx' -ppTermInMonCtx :: MonadifyCtx -> Term -> String -ppTermInMonCtx ctx t = - scPrettyTermInCtx PPS.defaultOpts (map (\(x,_,_) -> x) ctx) t - --- | A memoization table for monadifying terms: a map from 'TermIndex'es to --- 'MonTerm's and, possibly, corresponding 'ArgMonTerm's. The latter are simply --- the result of calling 'argifyMonTerm' on the former, but are only added when --- needed (i.e. when 'memoArgMonTerm' is called, e.g. in 'monadifyArg'). -type MonadifyMemoTable = IntMap (MonTerm, Maybe ArgMonTerm) - --- | The empty memoization table -emptyMemoTable :: MonadifyMemoTable -emptyMemoTable = IntMap.empty - - ----------------------------------------------------------------------- --- * The Monadification Monad ----------------------------------------------------------------------- - --- | The read-only state of a monadification computation -data MonadifyROState = MonadifyROState { - -- | The monadification environment - monStEnv :: MonadifyEnv, - -- | The monadification context - monStCtx :: MonadifyCtx, - -- | The monadified return type of the top-level term being monadified; that - -- is, we are inside a call to 'monadifyTerm' applied to some function of SAW - -- core type @a1 -> ... -> an -> b@, and this is the type @b@ - monStTopRetType :: MonType -} - --- | Get the monadification table from a 'MonadifyROState' -monStMonTable :: MonadifyROState -> Map NameInfo MonMacro -monStMonTable = monEnvMonTable . monStEnv - --- | The monad for monadifying SAW core terms -newtype MonadifyM a = - MonadifyM { unMonadifyM :: - ReaderT MonadifyROState (StateT MonadifyMemoTable - (Cont MonTerm)) a } - deriving (Functor, Applicative, Monad, - MonadReader MonadifyROState, MonadState MonadifyMemoTable) - --- | Get the current 'EventType' in a 'MonadifyM' computation -askEvType :: MonadifyM EventType -askEvType = monEnvEvType <$> monStEnv <$> ask - --- | Run a 'MonadifyM' computation with the current 'EventType' -usingEvType :: (HasSpecMEvType => MonadifyM a) -> MonadifyM a -usingEvType m = - do ev <- askEvType - let ?specMEvType = ev in m - -instance Fail.MonadFail MonadifyM where - fail str = - usingEvType $ - do ret_tp <- topRetType - shiftMonadifyM $ \_ -> failMonTerm ret_tp str - --- | Capture the current continuation and pass it to a function, which must --- return the final computation result. Note that this is slightly differnet --- from normal shift, and I think corresponds to the C operator, but my quick --- googling couldn't find the right name... -shiftMonadifyM :: ((a -> MonTerm) -> MonTerm) -> MonadifyM a -shiftMonadifyM f = MonadifyM $ lift $ lift $ cont f - --- | Locally run a 'MonadifyM' computation with an empty memoization table, --- making all binds be local to that computation, and return the result -resetMonadifyM :: MonType -> MonadifyM MonTerm -> MonadifyM MonTerm -resetMonadifyM ret_tp m = - do ro_st <- ask - return $ runMonadifyM (monStEnv ro_st) (monStCtx ro_st) ret_tp m - --- | Get the monadified return type of the top-level term being monadified -topRetType :: MonadifyM MonType -topRetType = monStTopRetType <$> ask - --- | Run a monadification computation --- --- FIXME: document the arguments -runMonadifyM :: MonadifyEnv -> MonadifyCtx -> MonType -> - MonadifyM MonTerm -> MonTerm -runMonadifyM env ctx top_ret_tp m = - let ro_st = MonadifyROState env ctx top_ret_tp in - runCont (evalStateT (runReaderT (unMonadifyM m) ro_st) emptyMemoTable) id - --- | Run a monadification computation using a mapping for identifiers that have --- already been monadified and generate a SAW core term -runCompleteMonadifyM :: MonadIO m => SharedContext -> MonadifyEnv -> - Term -> MonadifyM MonTerm -> - m Term -runCompleteMonadifyM sc env top_ret_tp m = - let ?specMEvType = monEnvEvType env in - liftIO $ completeOpenTerm sc $ toCompTerm $ - runMonadifyM env [] (monadifyType [] top_ret_tp) m - --- | Memoize a computation of the monadified term associated with a 'TermIndex' -memoMonTerm :: TermIndex -> MonadifyM MonTerm -> MonadifyM MonTerm -memoMonTerm i m = - (IntMap.lookup i <$> get) >>= \case - Just (mtm, _) -> - return mtm - Nothing -> - do mtm <- m - modify (IntMap.insert i (mtm, Nothing)) - return mtm - --- | Memoize a computation of the monadified term of argument type associated --- with a 'TermIndex', using a memoized 'ArgTerm' directly if it exists or --- applying 'argifyMonTerm' to a memoized 'MonTerm' (and memoizing the result) --- if it exists -memoArgMonTerm :: TermIndex -> MonadifyM MonTerm -> MonadifyM ArgMonTerm -memoArgMonTerm i m = - (IntMap.lookup i <$> get) >>= \case - Just (_, Just argmtm) -> - return argmtm - Just (mtm, Nothing) -> - do argmtm <- argifyMonTerm mtm - modify (IntMap.insert i (mtm, Just argmtm)) - return argmtm - Nothing -> - do mtm <- m - argmtm <- argifyMonTerm mtm - modify (IntMap.insert i (mtm, Just argmtm)) - return argmtm - --- | Turn a 'MonTerm' of type @CompMT(tp)@ to a term of argument type @MT(tp)@ --- by inserting a monadic bind if the 'MonTerm' is computational -argifyMonTerm :: MonTerm -> MonadifyM ArgMonTerm -argifyMonTerm (ArgMonTerm mtrm) = return mtrm -argifyMonTerm (CompMonTerm mtp trm) = - usingEvType $ - do let tp = toArgType mtp - top_ret_tp <- topRetType - shiftMonadifyM $ \k -> - CompMonTerm top_ret_tp $ - bindSOpenTerm ?specMEvType tp (toArgType top_ret_tp) trm $ - lambdaOpenTerm "x" tp (toCompTerm . k . fromArgTerm mtp) - --- | Build a proof of @isFinite n@ by calling @assertFiniteS@ and binding the --- result to an 'ArgMonTerm' -assertIsFinite :: HasSpecMEvType => NumTpExpr -> MonadifyM ArgMonTerm -assertIsFinite e = - let n = numExprVal e in - argifyMonTerm (CompMonTerm - (MTyIndesc (applyOpenTerm - (globalOpenTerm "CryptolM.isFinite") n)) - (applyGlobalOpenTerm "CryptolM.assertFiniteS" - [evTypeTerm ?specMEvType, n])) - - ----------------------------------------------------------------------- --- * Monadification ----------------------------------------------------------------------- - --- | Apply a monadifying operation (like 'monadifyTpExpr') in a 'MonadifyM' -monadifyOpM :: HasCallStack => - (HasSpecMEvType => MonadifyTypeCtx -> Term -> a) -> - Term -> MonadifyM a -monadifyOpM f tm = - usingEvType $ - do ctx <- monStCtx <$> ask - return $ f (ctxToTypeCtx ctx) tm - --- | Monadify a type-level expression in the context of the 'MonadifyM' monad -monadifyTpExprM :: HasCallStack => Term -> MonadifyM SomeTpExpr -monadifyTpExprM = monadifyOpM monadifyTpExpr - --- | Monadify a type in the context of the 'MonadifyM' monad -monadifyTypeM :: HasCallStack => Term -> MonadifyM MonType -monadifyTypeM = monadifyOpM monadifyType - --- | Monadify a numeric expression in the context of the 'MonadifyM' monad -monadifyNumM :: HasCallStack => Term -> MonadifyM NumTpExpr -monadifyNumM = monadifyOpM monadifyNum - --- | Monadify a term to a monadified term of argument type -monadifyArg :: HasCallStack => (?mm :: ModuleMap) => Maybe MonType -> Term -> MonadifyM ArgMonTerm -{- -monadifyArg _ t - | trace ("Monadifying term of argument type: " ++ showTerm t) False - = undefined --} -monadifyArg mtp t@(STApp { stAppIndex = ix }) = - memoArgMonTerm ix $ usingEvType $ monadifyTerm' mtp t -monadifyArg mtp t = - usingEvType (monadifyTerm' mtp t) >>= argifyMonTerm - --- | Monadify a term to argument type and convert back to a term -monadifyArgTerm :: - HasCallStack => (?mm :: ModuleMap) => - Maybe MonType -> Term -> MonadifyM OpenTerm -monadifyArgTerm mtp t = usingEvType (toArgTerm <$> monadifyArg mtp t) - --- | Monadify a term -monadifyTerm :: (?mm :: ModuleMap) => Maybe MonType -> Term -> MonadifyM MonTerm -{- -monadifyTerm _ t - | trace ("Monadifying term: " ++ showTerm t) False - = undefined --} -monadifyTerm mtp t@(STApp { stAppIndex = ix }) = - memoMonTerm ix $ usingEvType $ monadifyTerm' mtp t -monadifyTerm mtp t = - usingEvType $ monadifyTerm' mtp t - --- | The main implementation of 'monadifyTerm', which monadifies a term given an --- optional monadification type. The type must be given for introduction forms --- (i.e.,, lambdas, pairs, and records), but is optional for elimination forms --- (i.e., applications, projections, and also in this case variables). Note that --- this means monadification will fail on terms with beta or tuple redexes. -monadifyTerm' :: HasCallStack => HasSpecMEvType => (?mm :: ModuleMap) => - Maybe MonType -> Term -> MonadifyM MonTerm -monadifyTerm' (Just mtp) t@(asLambda -> Just _) = - ask >>= \(MonadifyROState { monStEnv = env, monStCtx = ctx }) -> - return $ monadifyLambdas env ctx mtp t -{- -monadifyTerm' (Just mtp@(MTyForall _ _ _)) t = - ask >>= \ro_st -> - get >>= \table -> - return $ monadifyLambdas (monStEnv ro_st) table (monStCtx ro_st) mtp t -monadifyTerm' (Just mtp@(MTyArrow _ _)) t = - ask >>= \ro_st -> - get >>= \table -> - return $ monadifyLambdas (monStEnv ro_st) table (monStCtx ro_st) mtp t --} -monadifyTerm' (Just mtp@(MTyPair mtp1 mtp2)) (asPairValue -> - Just (trm1, trm2)) = - fromArgTerm mtp <$> (pairOpenTerm <$> - monadifyArgTerm (Just mtp1) trm1 <*> - monadifyArgTerm (Just mtp2) trm2) -{- -monadifyTerm' (Just mtp@(MTyRecord fs_mtps)) (asRecordValue -> Just trm_map) - | length fs_mtps == Map.size trm_map - , (fs,mtps) <- unzip fs_mtps - , Just trms <- mapM (\f -> Map.lookup f trm_map) fs = - fromArgTerm mtp <$> recordOpenTerm <$> zip fs <$> - zipWithM monadifyArgTerm (map Just mtps) trms --} -monadifyTerm' _ (asPairSelector -> Just (trm, False)) = - do mtrm <- monadifyArg Nothing trm - mtp <- case getMonType mtrm of - MTyPair t _ -> return t - _ -> fail "Monadification failed: projection on term of non-pair type" - return $ fromArgTerm mtp $ - pairLeftOpenTerm $ toArgTerm mtrm -monadifyTerm' (Just mtp@(MTySeq n mtp_elem)) (asFTermF -> - Just (ArrayValue _ trms)) = - do trms' <- traverse (monadifyArgTerm $ Just mtp_elem) trms - return $ fromArgTerm mtp $ - applyOpenTermMulti (globalOpenTerm "CryptolM.seqToMseq") - [evTypeTerm ?specMEvType, numExprVal n, toArgType mtp_elem, - flatOpenTerm $ ArrayValue (toArgType mtp_elem) trms'] -monadifyTerm' _ (asPairSelector -> Just (trm, True)) = - do mtrm <- monadifyArg Nothing trm - mtp <- case getMonType mtrm of - MTyPair _ t -> return t - _ -> fail "Monadification failed: projection on term of non-pair type" - return $ fromArgTerm mtp $ - pairRightOpenTerm $ toArgTerm mtrm -{- -monadifyTerm' _ (asRecordSelector -> Just (trm, fld)) = - do mtrm <- monadifyArg Nothing trm - mtp <- case getMonType mtrm of - MTyRecord mtps | Just mtp <- lookup fld mtps -> return mtp - _ -> fail ("Monadification failed: " ++ - "record projection on term of incorrect type") - return $ fromArgTerm mtp $ projRecordOpenTerm (toArgTerm mtrm) fld --} -monadifyTerm' _ (asLocalVar -> Just ix) = - (monStCtx <$> ask) >>= \case - ctx | ix >= length ctx -> fail "Monadification failed: vaiable out of scope!" - ctx | (_,_,TrmArg mtrm) <- ctx !! ix -> return $ ArgMonTerm mtrm - _ -> fail "Monadification failed: type variable used in term position!" -monadifyTerm' _ (asTupleValue -> Just []) = - return $ ArgMonTerm $ fromSemiPureTerm MTyUnit unitOpenTerm -{- -monadifyTerm' _ (asCtor -> Just (ec, args)) = - monadifyApply (ArgMonTerm $ mkCtorArgMonTerm ec) args --} -monadifyTerm' _ (asApplyAll -> (asTypedGlobalDef -> Just glob, args)) = - (Map.lookup (nameInfo (globalDefName glob)) <$> monStMonTable <$> ask) >>= \case - Just macro -> - do let (macro_args, reg_args) = splitAt (macroNumArgs macro) args - mtrm_f <- macroApply macro glob macro_args - monadifyApply mtrm_f reg_args - Nothing -> - monadifyTypeM (globalDefType glob) >>= \glob_mtp -> - if monTypeIsSemiPure glob_mtp then - monadifyApply (ArgMonTerm $ fromSemiPureTerm glob_mtp $ - globalDefOpenTerm glob) args - else error ("Monadification failed: unhandled constant: " - ++ globalDefString glob) -monadifyTerm' _ (asApp -> Just (f, arg)) = - do mtrm_f <- monadifyTerm Nothing f - monadifyApply mtrm_f [arg] -monadifyTerm' _ t = - (monStCtx <$> ask) >>= \ctx -> - fail ("Monadifiction failed: no case for term: " ++ ppTermInMonCtx ctx t) - - --- | Monadify the application of a monadified term to a list of terms, using the --- type of the already monadified to monadify the arguments -monadifyApply :: HasCallStack => (?mm :: ModuleMap) => MonTerm -> [Term] -> MonadifyM MonTerm -monadifyApply f (t : ts) - | MTyArrow tp_in _ <- getMonType f = - do mtrm <- monadifyArg (Just tp_in) t - monadifyApply (applyMonTerm f (TrmArg mtrm)) ts -monadifyApply f (t : ts) - | MTyForall _ _ _ <- getMonType f = - do arg <- tpExprToArg <$> monadifyTpExprM t - monadifyApply (applyMonTerm f arg) ts -monadifyApply _ (_:_) = fail "monadifyApply: application at incorrect type" -monadifyApply f [] = return f - - --- | Monadify a nested lambda abstraction by monadifying its body. This is done --- outside the 'MonadifyM' monad, since all of its state (including the eventual --- return type) will be reset when we monadify this body. -monadifyLambdas :: - HasCallStack => (?mm :: ModuleMap) => - MonadifyEnv -> MonadifyCtx -> - MonType -> Term -> MonTerm -monadifyLambdas env ctx (MTyForall _ k tp_f) (asLambda -> - Just (x, x_tp, body)) = - -- FIXME: check that monadifyKind x_tp == k - ArgMonTerm $ ForallMonTerm x k $ \mtp -> - monadifyLambdas env ((x,x_tp,TpArg k mtp) : ctx) (tp_f mtp) body -monadifyLambdas env ctx (MTyArrow tp_in tp_out) (asLambda -> - Just (x, x_tp, body)) = - -- FIXME: check that monadifyType x_tp == tp_in - ArgMonTerm $ FunMonTerm x tp_in tp_out $ \arg -> - monadifyLambdas env ((x,x_tp,TrmArg arg) : ctx) tp_out body -monadifyLambdas env ctx tp t = - monadifyEtaExpand env ctx tp tp t [] - --- | Monadify a term of functional type by lambda-abstracting its arguments, --- monadifying it, and applying the result to those lambda-abstracted arguments; --- i.e., by eta-expanding it. This ensures that the 'MonadifyM' computation is --- run in a context where the return type is not functional, which in turn --- ensures that any monadic binds inserted by 'argifyMonTerm' all happen inside --- the function. The first 'MonType' is the top-level functional type of the --- 'Term' being monadified, while the second 'MonType' is the type after the --- 'Term' is applied to the list of 'MonArg's, which represents all the --- variables generated by eta-expansion. -monadifyEtaExpand :: - HasCallStack => (?mm :: ModuleMap) => - MonadifyEnv -> MonadifyCtx -> - MonType -> MonType -> Term -> [MonArg] -> MonTerm -monadifyEtaExpand env ctx top_mtp (MTyForall x k tp_f) t args = - ArgMonTerm $ ForallMonTerm x k $ \mtp -> - monadifyEtaExpand env ctx top_mtp (tp_f mtp) t (args ++ [TpArg k mtp]) -monadifyEtaExpand env ctx top_mtp (MTyArrow tp_in tp_out) t args = - ArgMonTerm $ FunMonTerm "_" tp_in tp_out $ \arg -> - monadifyEtaExpand env ctx top_mtp tp_out t (args ++ [TrmArg arg]) -monadifyEtaExpand env ctx top_mtp mtp t args = - let ?specMEvType = monEnvEvType env in - applyMonTermMulti (runMonadifyM env ctx mtp - (monadifyTerm (Just top_mtp) t)) args - - ----------------------------------------------------------------------- --- * Handling the Primitives ----------------------------------------------------------------------- - --- | The macro for unsafeAssert, which checks the type of the objects being --- compared and dispatches to the proper comparison function -unsafeAssertMacro :: MonMacro -unsafeAssertMacro = MonMacro 1 $ \_ ts -> - usingEvType $ - let numFunType = - MTyForall "n" MKNumRepr $ \n -> MTyForall "m" MKNumRepr $ \m -> - MTyIndesc $ - dataTypeOpenTerm "Prelude.Eq" - [dataTypeOpenTerm "Cryptol.Num" [], - numExprVal n, numExprVal m] in - case ts of - [(asGlobalApply "Cryptol.Num" -> Just [])] -> - return $ ArgMonTerm $ - mkGlobalArgMonTerm numFunType "CryptolM.numAssertEqS" True - _ -> - fail "Monadification failed: unsafeAssert applied to non-Num type" - --- | The macro for if-then-else, which contains any binds in a branch to that --- branch -iteMacro :: (?mm :: ModuleMap) => MonMacro -iteMacro = MonMacro 4 $ \_ args -> usingEvType $ - do let (tp, cond, branch1, branch2) = - case args of - [t1, t2, t3, t4] -> (t1, t2, t3, t4) - _ -> error "iteMacro: wrong number of arguments!" - atrm_cond <- monadifyArg (Just MTyBool) cond - mtp <- monadifyTypeM tp - mtrm1 <- resetMonadifyM mtp $ monadifyTerm (Just mtp) branch1 - mtrm2 <- resetMonadifyM mtp $ monadifyTerm (Just mtp) branch2 - case (mtrm1, mtrm2) of - (ArgMonTerm atrm1, ArgMonTerm atrm2) -> - return $ fromArgTerm mtp $ - applyOpenTermMulti (globalOpenTerm "Prelude.ite") - [toArgType mtp, toArgTerm atrm_cond, toArgTerm atrm1, toArgTerm atrm2] - _ -> - return $ fromCompTerm mtp $ - applyOpenTermMulti (globalOpenTerm "Prelude.ite") - [toCompType mtp, toArgTerm atrm_cond, - toCompTerm mtrm1, toCompTerm mtrm2] - --- | The macro for the either elimination function, which converts the --- application @either a b c@ to @either a b (CompM c)@ -eitherMacro :: MonMacro -eitherMacro = MonMacro 3 $ \_ args -> - usingEvType $ - do let (tp_a, tp_b, tp_c) = - case args of - [t1, t2, t3] -> (t1, t2, t3) - _ -> error "eitherMacro: wrong number of arguments!" - mtp_a <- monadifyTypeM tp_a - mtp_b <- monadifyTypeM tp_b - mtp_c <- monadifyTypeM tp_c - let eith_app = applyGlobalOpenTerm "Prelude.either" [toArgType mtp_a, - toArgType mtp_b, - toCompType mtp_c] - return $ fromCompTerm (MTyArrow (MTyArrow mtp_a mtp_c) - (MTyArrow (MTyArrow mtp_b mtp_c) - (MTyArrow (MTySum mtp_a mtp_b) mtp_c))) eith_app - --- | The macro for uncurry, which converts the application @uncurry a b c@ --- to @uncurry a b (CompM c)@ -uncurryMacro :: MonMacro -uncurryMacro = MonMacro 3 $ \_ args -> - usingEvType $ - do let (tp_a, tp_b, tp_c) = - case args of - [t1, t2, t3] -> (t1, t2, t3) - _ -> error "uncurryMacro: wrong number of arguments!" - mtp_a <- monadifyTypeM tp_a - mtp_b <- monadifyTypeM tp_b - mtp_c <- monadifyTypeM tp_c - let unc_app = applyGlobalOpenTerm "Prelude.uncurry" [toArgType mtp_a, - toArgType mtp_b, - toCompType mtp_c] - return $ fromCompTerm (MTyArrow (MTyArrow mtp_a (MTyArrow mtp_b mtp_c)) - (MTyArrow (MTyPair mtp_a mtp_b) mtp_c)) unc_app - --- | The macro for invariantHint, which converts @invariantHint a cond m@ --- to @invariantHint (CompM a) cond m@ and which contains any binds in the body --- to the body -invariantHintMacro :: (?mm :: ModuleMap) => MonMacro -invariantHintMacro = MonMacro 3 $ \_ args -> usingEvType $ - do let (tp, cond, m) = - case args of - [t1, t2, t3] -> (t1, t2, t3) - _ -> error "invariantHintMacro: wrong number of arguments!" - atrm_cond <- monadifyArg (Just MTyBool) cond - mtp <- monadifyTypeM tp - mtrm <- resetMonadifyM mtp $ monadifyTerm (Just mtp) m - return $ fromCompTerm mtp $ - applyOpenTermMulti (globalOpenTerm "SpecM.invariantHint") - [toCompType mtp, toArgTerm atrm_cond, toCompTerm mtrm] - --- | The macro for @asserting@ or @assuming@, which converts @asserting@ to --- @assertingM@ or @assuming@ to @assumingM@ (depending on whether the given --- 'Bool' is true or false, respectively) and which contains any binds in the --- body to the body -assertingOrAssumingMacro :: (?mm :: ModuleMap) => Bool -> MonMacro -assertingOrAssumingMacro doAsserting = MonMacro 3 $ \_ args -> - usingEvType $ - do let (tp, cond, m) = - case args of - [t1, t2, t3] -> (t1, t2, t3) - _ -> error "assertingOrAssumingMacro: wrong number of arguments!" - atrm_cond <- monadifyArg (Just MTyBool) cond - mtp <- monadifyTypeM tp - mtrm <- resetMonadifyM mtp $ monadifyTerm (Just mtp) m - ev <- askEvType - let ident = if doAsserting then "SpecM.assertingS" - else "SpecM.assumingS" - return $ fromCompTerm mtp $ - applyOpenTermMulti (globalOpenTerm ident) - [evTypeTerm ev, toArgType mtp, toArgTerm atrm_cond, toCompTerm mtrm] - --- | @finMacro b i j from to params_p@ makes a 'MonMacro' that maps a named --- global @from@ whose @i@th through @(i+j-1)@th arguments are @Num@s, to a --- named global @to@, which is of semi-pure type if and only if @b@ is 'True', --- that takes an additional argument of type @isFinite n@ after each of the --- aforementioned @Num@ arguments. The @params_p@ flag indicates whether the --- current 'EventType' should be passed as the first argument to @to@. -finMacro :: Bool -> Int -> Int -> Ident -> Ident -> Bool -> MonMacro -finMacro isSemiPure i j from to params_p = - MonMacro (i+j) $ \glob args -> usingEvType $ - do if nameInfo (globalDefName glob) == ModuleIdentifier from && length args == i+j then - return () - else error ("Monadification macro for " ++ show from ++ - " applied incorrectly") - let (init_args_tms, fin_args_tms) = splitAt i args - -- Monadify the first @i@ args - init_args <- mapM monadifyTpExprM init_args_tms - -- Monadify the @i@th through @(i+j-1)@th args and build proofs that they are finite - fin_args <- mapM monadifyNumM fin_args_tms - fin_pfs <- mapM assertIsFinite fin_args - -- Apply the type of @glob@ to the monadified arguments and apply @to@ to the - -- monadified arguments along with the proofs that the latter arguments are finite - let glob_tp = monadifyType [] $ globalDefType glob - let glob_args = map tpExprToArg init_args ++ map numToArg fin_args - let glob_tp_app = foldl applyMonType glob_tp glob_args - let to_args = - map someTpExprVal init_args ++ - concatMap (\(n,pf) -> [numExprVal n, - toArgTerm pf]) (zip fin_args fin_pfs) - let to_app = - applyOpenTermMulti (globalOpenTerm to) - ((if params_p then (evTypeTerm ?specMEvType :) else id) to_args) - -- Finally, return the result as semi-pure dependent on @isSemiPure@ - return $ if isSemiPure - then ArgMonTerm $ fromSemiPureTerm glob_tp_app to_app - else ArgMonTerm $ fromArgTerm glob_tp_app to_app - --- FIXME HERE NOW: add a case for a fix of a record type of functions, which --- should translate to MultiFixS - --- | The macro for fix --- --- FIXME: does not yet handle mutual recursion -fixMacro :: (?mm :: ModuleMap) => MonMacro -fixMacro = MonMacro 2 $ \_ args -> case args of - [tp@(asPi -> Just _), f] -> - do ev <- askEvType - mtp <- monadifyTypeM tp - usingEvType $ do - amtrm_f <- monadifyArg (Just $ MTyArrow mtp mtp) f - return $ fromCompTerm mtp $ - applyOpenTermMulti (globalOpenTerm "SpecM.FixS") - [evTypeTerm ev, toTpDesc mtp, toCompTerm amtrm_f] - [(asRecordType -> Just _), _] -> - fail "Monadification failed: cannot yet handle mutual recursion" - _ -> error "fixMacro: malformed arguments!" - --- | A "macro mapping" maps a single pure identifier to a 'MonMacro' for it -type MacroMapping = (NameInfo, MonMacro) - --- | Build a 'MacroMapping' for an identifier to a semi-pure named function -mmSemiPure :: Ident -> Ident -> Bool -> MacroMapping -mmSemiPure from_id to_id params_p = - (ModuleIdentifier from_id, semiPureGlobalMacro from_id to_id params_p) - --- | Build a 'MacroMapping' for an identifier to a semi-pure named function --- whose @i@th through @(i+j-1)@th arguments are @Num@s that require --- @isFinite@ proofs -mmSemiPureFin :: Int -> Int -> Ident -> Ident -> Bool -> MacroMapping -mmSemiPureFin i j from_id to_id params_p = - (ModuleIdentifier from_id, finMacro True i j from_id to_id params_p) - --- | Build a 'MacroMapping' for an identifier to itself as a semi-pure function -mmSelf :: Ident -> MacroMapping -mmSelf self_id = - (ModuleIdentifier self_id, semiPureGlobalMacro self_id self_id False) - --- | Build a 'MacroMapping' from an identifier to a function of argument type, --- where the 'Bool' flag indicates whether the current 'SpecMArgs' should be --- passed as additional arguments to the "to" identifier -mmArg :: Ident -> Ident -> Bool -> MacroMapping -mmArg from_id to_id params_p = - (ModuleIdentifier from_id, - argGlobalMacro (ModuleIdentifier from_id) to_id params_p) - --- | Build a 'MacroMapping' for an identifier to a function of argument type, --- whose @i@th through @(i+j-1)@th arguments are @Num@s that require --- @isFinite@ proofs, where the 'Bool' flag indicates whether the current --- 'SpecMArgs' should be passed as additional arguments to the "to" identifier -mmArgFin :: Int -> Int -> Ident -> Ident -> Bool -> MacroMapping -mmArgFin i j from_id to_id params_p = - (ModuleIdentifier from_id, finMacro False i j from_id to_id params_p) - --- | Build a 'MacroMapping' from an identifier and a custom 'MonMacro' -mmCustom :: Ident -> MonMacro -> MacroMapping -mmCustom from_id macro = (ModuleIdentifier from_id, macro) - --- | The default monadification environment -defaultMonEnv :: (?mm :: ModuleMap) => MonadifyEnv -defaultMonEnv = MonadifyEnv { monEnvMonTable = defaultMonTable, - monEnvEvType = defaultSpecMEventType } - --- | The default primitive monadification table -defaultMonTable :: (?mm :: ModuleMap) => Map NameInfo MonMacro -defaultMonTable = - Map.fromList - [ - -- Prelude functions - mmCustom "Prelude.unsafeAssert" unsafeAssertMacro - , mmCustom "Prelude.ite" iteMacro - , mmCustom "Prelude.fix" fixMacro - , mmCustom "Prelude.either" eitherMacro - , mmCustom "Prelude.uncurry" uncurryMacro - , mmCustom "SpecM.invariantHint" invariantHintMacro - , mmCustom "SpecM.asserting" (assertingOrAssumingMacro True) - , mmCustom "SpecM.assuming" (assertingOrAssumingMacro False) - - -- Top-level sequence functions - , mmArg "Cryptol.seqMap" "CryptolM.seqMapM" True - , mmSemiPure "Cryptol.seq_cong1" "CryptolM.mseq_cong1" True - , mmArg "Cryptol.eListSel" "CryptolM.eListSelM" True - - -- List comprehensions - , mmArg "Cryptol.from" "CryptolM.fromM" True - , mmArg "Cryptol.mlet" "CryptolM.mletM" True - , mmArg "Cryptol.seqZip" "CryptolM.seqZipM" True - , mmSemiPure "Cryptol.seqZipSame" "CryptolM.seqZipSameM" True - - -- PEq constraints - , mmSemiPureFin 0 1 "Cryptol.PEqSeq" "CryptolM.PEqMSeq" True - , mmSemiPureFin 0 1 "Cryptol.PEqSeqBool" "CryptolM.PEqMSeqBool" True - - -- PCmp constraints - , mmSemiPureFin 0 1 "Cryptol.PCmpSeq" "CryptolM.PCmpMSeq" True - , mmSemiPureFin 0 1 "Cryptol.PCmpSeqBool" "CryptolM.PCmpMSeqBool" True - - -- PSignedCmp constraints - , mmSemiPureFin 0 1 "Cryptol.PSignedCmpSeq" "CryptolM.PSignedCmpMSeq" True - , mmSemiPureFin 0 1 "Cryptol.PSignedCmpSeqBool" "CryptolM.PSignedCmpMSeqBool" True - - -- PZero constraints - , mmSemiPure "Cryptol.PZeroSeq" "CryptolM.PZeroMSeq" True - , mmSemiPureFin 0 1 "Cryptol.PZeroSeqBool" "CryptolM.PZeroMSeqBool" True - - -- PLogic constraints - , mmSemiPure "Cryptol.PLogicSeq" "CryptolM.PLogicMSeq" True - , mmSemiPureFin 0 1 "Cryptol.PLogicSeqBool" "CryptolM.PLogicMSeqBool" True - - -- PRing constraints - , mmSemiPure "Cryptol.PRingSeq" "CryptolM.PRingMSeq" True - , mmSemiPureFin 0 1 "Cryptol.PRingSeqBool" "CryptolM.PRingMSeqBool" True - - -- PIntegral constraints - , mmSemiPureFin 0 1 "Cryptol.PIntegeralSeqBool" "CryptolM.PIntegeralMSeqBool" True - - -- PLiteral constraints - , mmSemiPureFin 0 1 "Cryptol.PLiteralSeqBool" "CryptolM.PLiteralSeqBoolM" True - - -- The Cryptol Literal primitives - , mmSelf "Cryptol.ecNumber" - , mmSelf "Cryptol.ecFromZ" - - -- The Ring primitives - , mmSelf "Cryptol.ecPlus" - , mmSelf "Cryptol.ecMinus" - , mmSelf "Cryptol.ecMul" - , mmSelf "Cryptol.ecNeg" - , mmSelf "Cryptol.ecToInteger" - - -- The comparison primitives - , mmSelf "Cryptol.ecEq" - , mmSelf "Cryptol.ecNotEq" - , mmSelf "Cryptol.ecLt" - , mmSelf "Cryptol.ecLtEq" - , mmSelf "Cryptol.ecGt" - , mmSelf "Cryptol.ecGtEq" - - -- Sequences - , mmSemiPure "Cryptol.ecShiftL" "CryptolM.ecShiftLM" True - , mmSemiPure "Cryptol.ecShiftR" "CryptolM.ecShiftRM" True - , mmSemiPure "Cryptol.ecSShiftR" "CryptolM.ecSShiftRM" True - , mmSemiPureFin 0 1 "Cryptol.ecRotL" "CryptolM.ecRotLM" True - , mmSemiPureFin 0 1 "Cryptol.ecRotR" "CryptolM.ecRotRM" True - , mmSemiPureFin 0 1 "Cryptol.ecCat" "CryptolM.ecCatM" True - , mmArg "Cryptol.ecTake" "CryptolM.ecTakeM" True - , mmSemiPureFin 0 1 "Cryptol.ecDrop" "CryptolM.ecDropM" True - , mmSemiPureFin 0 1 "Cryptol.ecDrop" "CryptolM.ecDropM" True - , mmSemiPureFin 1 1 "Cryptol.ecJoin" "CryptolM.ecJoinM" True - , mmSemiPureFin 1 1 "Cryptol.ecSplit" "CryptolM.ecSplitM" True - , mmSemiPureFin 0 1 "Cryptol.ecReverse" "CryptolM.ecReverseM" True - , mmSemiPure "Cryptol.ecTranspose" "CryptolM.ecTransposeM" True - , mmArg "Cryptol.ecAt" "CryptolM.ecAtM" True - , mmArg "Cryptol.ecUpdate" "CryptolM.ecUpdateM" True - , mmArgFin 0 1 "Cryptol.ecAtBack" "CryptolM.ecAtBackM" True - , mmSemiPureFin 0 2 "Cryptol.ecFromTo" "CryptolM.ecFromToM" True - , mmSemiPureFin 0 1 "Cryptol.ecFromToLessThan" "CryptolM.ecFromToLessThanM" True - , mmSemiPureFin 4 1 "Cryptol.ecFromThenTo" "CryptolM.ecFromThenToM" True - , mmSemiPure "Cryptol.ecInfFrom" "CryptolM.ecInfFromM" True - , mmSemiPure "Cryptol.ecInfFromThen" "CryptolM.ecInfFromThenM" True - , mmArg "Cryptol.ecError" "CryptolM.ecErrorM" True - ] - - ----------------------------------------------------------------------- --- * Top-Level Entrypoints ----------------------------------------------------------------------- - --- | Ensure that the @CryptolM@ module is loaded -ensureCryptolMLoaded :: SharedContext -> IO () -ensureCryptolMLoaded sc = - scModuleIsLoaded sc (mkModuleName ["CryptolM"]) >>= \is_loaded -> - if is_loaded then return () else - scLoadSpecMModule sc >> scLoadCryptolMModule sc - --- | Monadify a type to its argument type and complete it to a 'Term', --- additionally quantifying over the event type and function stack if the --- supplied 'Bool' is 'True' -monadifyCompleteArgType :: SharedContext -> MonadifyEnv -> Term -> Bool -> - IO Term -monadifyCompleteArgType sc env tp poly_p = - (ensureCryptolMLoaded sc >>) $ - completeOpenTerm sc $ - if poly_p then - -- Parameter polymorphism means pi-quantification over E - (piOpenTerm "E" (dataTypeOpenTerm "SpecM.EvType" []) $ \e -> - let ?specMEvType = EventType e in - -- NOTE: even though E is a free variable here, it can not be free in tp, - -- which is a closed term, so we do not list it in the MonadifyTypeCtx - -- argument of monadifyTypeArgType - monadifyTypeArgType [] tp) - else - let ?specMEvType = monEnvEvType env in monadifyTypeArgType [] tp - --- | Monadify a term of the specified type to a 'MonTerm' and then complete that --- 'MonTerm' to a SAW core 'Term', or 'fail' if this is not possible -monadifyCompleteTerm :: SharedContext -> MonadifyEnv -> Term -> Term -> IO Term -monadifyCompleteTerm sc env trm tp = - do ensureCryptolMLoaded sc - mm <- scGetModuleMap sc - let ?mm = mm - runCompleteMonadifyM sc env tp $ usingEvType $ - monadifyTerm (Just $ monadifyType [] tp) trm - --- | Convert a name of a definition to the name of its monadified version -monadifyName :: NameInfo -> IO NameInfo -monadifyName (ModuleIdentifier ident) = - return $ ModuleIdentifier $ mkIdent (identModule ident) $ - T.append (identBaseName ident) (T.pack "M") -monadifyName (ImportedName uri aliases) = - do frag <- URI.mkFragment (T.pack "M") - let aliases' = concatMap (\a -> [a, T.append a (T.pack "#M")]) aliases - return $ ImportedName (uri { URI.uriFragment = Just frag }) aliases' - --- | The implementation of 'monadifyNamedTerm' in the @StateT MonadifyEnv IO@ monad -monadifyNamedTermH :: SharedContext -> NameInfo -> Maybe Term -> Term -> - StateT MonadifyEnv IO MonTerm -monadifyNamedTermH sc nmi maybe_trm tp = - -- trace ("Monadifying " ++ T.unpack (toAbsoluteName nmi)) $ - get >>= \env -> let ?specMEvType = monEnvEvType env in - do let mtp = monadifyType [] tp - nmi' <- lift $ monadifyName nmi - comp_tp <- lift $ completeOpenTerm sc $ toCompType mtp - const_trm <- - case maybe_trm of - Just trm -> - -- trace ("" ++ ppTermInMonCtx env trm ++ "\n\n") $ - do trm' <- monadifyTermInEnvH sc trm tp - lift $ scConstant' sc nmi' trm' comp_tp - Nothing -> lift $ scOpaqueConstant sc nmi' comp_tp - return $ fromCompTerm mtp $ closedOpenTerm const_trm - --- | Monadify a 'Term' of the specified type with an optional body, bind the --- result to a fresh SAW core constant generated from the supplied name, and --- then convert that constant back to a 'MonTerm'. Like 'monadifyTermInEnv', --- this function also monadifies all constants the body contains, and adds --- the monadifications of those constants to the monadification environment. -monadifyNamedTerm :: SharedContext -> MonadifyEnv -> - NameInfo -> Maybe Term -> Term -> - IO (MonTerm, MonadifyEnv) -monadifyNamedTerm sc env nmi maybe_trm tp = - (ensureCryptolMLoaded sc >>) $ - flip runStateT env $ monadifyNamedTermH sc nmi maybe_trm tp - --- | The implementation of 'monadifyTermInEnv' in the @StateT MonadifyEnv IO@ monad -monadifyTermInEnvH :: SharedContext -> Term -> Term -> - StateT MonadifyEnv IO Term -monadifyTermInEnvH sc top_trm top_tp = - do lift $ ensureCryptolMLoaded sc - mm <- lift $ scGetModuleMap sc - let const_infos = Map.toAscList $ getConstantSet top_trm - forM_ const_infos $ \(vi, nmi) -> - do let r = requireNameInMap (Name vi nmi) mm - let tp = resolvedNameType r - let maybe_body = - case r of - ResolvedDef d -> defBody d - _ -> Nothing - env <- get - unless (isPreludeName nmi || Map.member nmi (monEnvMonTable env)) $ - do mtrm <- monadifyNamedTermH sc nmi maybe_body tp - modify $ monEnvAdd nmi (monMacro0 mtrm) - env <- get - lift $ monadifyCompleteTerm sc env top_trm top_tp - where preludeModules = mkModuleName <$> [["Prelude"], ["Cryptol"]] - isPreludeName = \case - ModuleIdentifier ident -> identModule ident `elem` preludeModules - _ -> False - --- | Monadify a term with the specified type along with all constants it --- contains, adding the monadifications of those constants to the monadification --- environment -monadifyTermInEnv :: SharedContext -> MonadifyEnv -> - Term -> Term -> IO (Term, MonadifyEnv) -monadifyTermInEnv sc top_env top_trm top_tp = - flip runStateT top_env $ monadifyTermInEnvH sc top_trm top_tp - --- | The implementation of 'monadifyCryptolModule' in the @StateT MonadifyEnv IO@ monad -monadifyCryptolModuleH :: SharedContext -> Env -> CryptolModule -> - StateT MonadifyEnv IO CryptolModule -monadifyCryptolModuleH sc cry_env (CryptolModule tysyns top_tts) = - fmap (CryptolModule tysyns) $ flip mapM top_tts $ \top_tt -> - do let top_tm = ttTerm top_tt - top_tp <- lift $ ttTypeAsTerm sc cry_env top_tt - tm <- monadifyTermInEnvH sc top_tm top_tp - tm' <- lift $ mkTypedTerm sc tm - return tm' - --- | Monadify each term in the given 'CryptolModule' along with all constants each --- contains, returning a new module which each term monadified, and adding the --- monadifications of all encountered constants to the monadification environment -monadifyCryptolModule :: SharedContext -> Env -> MonadifyEnv -> - CryptolModule -> IO (CryptolModule, MonadifyEnv) -monadifyCryptolModule sc cry_env top_env cry_mod = - flip runStateT top_env $ monadifyCryptolModuleH sc cry_env cry_mod diff --git a/cryptol-saw-core/src/CryptolSAWCore/PreludeM.hs b/cryptol-saw-core/src/CryptolSAWCore/PreludeM.hs deleted file mode 100644 index 918582a389..0000000000 --- a/cryptol-saw-core/src/CryptolSAWCore/PreludeM.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -{- | -Module : CryptolSAWCore.PreludeM -Copyright : Galois, Inc. 2012-2015 -License : BSD3 -Maintainer : huffman@galois.com -Stability : experimental -Portability : non-portable (language extensions) --} - -module CryptolSAWCore.PreludeM - ( module CryptolSAWCore.PreludeM - , scLoadPreludeModule - ) where - -import SAWCore.Prelude -import SAWCore.ParserUtils - -$(defineModuleFromFileWithFns - "specMModule" "scLoadSpecMModule" "cryptol-saw-core/saw/SpecM.sawcore") - -$(defineModuleFromFileWithFns - "cryptolMModule" "scLoadCryptolMModule" "cryptol-saw-core/saw/CryptolM.sawcore") diff --git a/cryptol-saw-core/src/CryptolSAWCore/TypedTerm.hs b/cryptol-saw-core/src/CryptolSAWCore/TypedTerm.hs index 8095b74a39..a91d456efd 100644 --- a/cryptol-saw-core/src/CryptolSAWCore/TypedTerm.hs +++ b/cryptol-saw-core/src/CryptolSAWCore/TypedTerm.hs @@ -156,8 +156,8 @@ destTupleTypedTerm sc (TypedTerm tp t) = Nothing -> fail "asTupleTypedTerm: not a tuple type" Just ctys -> do let len = length ctys - let idxs = take len [1 ..] - ts <- traverse (\i -> scTupleSelector sc t i len) idxs + let idxs = take len [0..] + ts <- traverse (scTupleSelector sc t) idxs pure $ zipWith TypedTerm (map (TypedTermSchema . C.tMono) ctys) ts -- First order types and values ------------------------------------------------ diff --git a/doc/developer/developer.md b/doc/developer/developer.md index 237a0973bd..c05dd20dd4 100644 --- a/doc/developer/developer.md +++ b/doc/developer/developer.md @@ -151,18 +151,16 @@ The following can be run with `cabal test`: - `saw-core-tests` - `cryptol-saw-core-tests` - `saw-core-coq-tests` -- `heapster-prover-tests` - `crux-mir-comp-tests` -There are three other sets of tests: +There are two other sets of tests: - `saw-remote-api tests` - `mr-solver-tests` -- `heapster-tests` The saw-remote-api tests can be run with the script `saw-remote-api/scripts/run_rpc_tests.sh`. -The other two are run by the CI but are not currently really intended +The other one is run by the CI but is not currently really intended to be run by hand. The s2n proofs that are also run by the CI are driven by scripts found diff --git a/doc/developer/issue-labels.md b/doc/developer/issue-labels.md index 82dedb7833..e60bde84a2 100644 --- a/doc/developer/issue-labels.md +++ b/doc/developer/issue-labels.md @@ -259,12 +259,6 @@ Cryptol-to-saw-core translation in the cryptol-saw-core package. * _subsystem: hardware_ - issues related to verification of hardware. -* _subsystem: heapster_ - issues related to memory verification using -Heapster. - -* _subsystem: MRSolver_ - issues related to the Mr. Solver -monadic-recursive solver in Heapster. - * _subsystem: saw-core_ - issues related to the saw-core representation or the saw-core subsystem. diff --git a/examples/mr_solver/SpecPrims.cry b/examples/mr_solver/SpecPrims.cry deleted file mode 100644 index 0a3b5d9ce4..0000000000 --- a/examples/mr_solver/SpecPrims.cry +++ /dev/null @@ -1,35 +0,0 @@ - -module SpecPrims where - -/* Specification primitives */ - -// The specification that holds for for some element of type a -exists : {a} a -exists = error "Cannot run exists" - -// The specification that holds for for all elements of type a -forall : {a} a -forall = error "Cannot run forall" - -// The specification that a computation has no errors -noErrors : {a} a -noErrors = exists - -// The specification that matches any computation. This calls exists at the -// function type () -> a, which is monadified to () -> SpecM a. This means that -// the exists does not just quantify over all values of type a like noErrors, -// but it quantifies over all computations of type a, including those that -// contain errors. -anySpec : {a} a -anySpec = exists () - -// The specification which asserts that the first argument is True and then -// returns the second argument -asserting : {a} Bit -> a -> a -asserting b x = - if b then x else error "Assertion failed" - -// The specification which assumes that the first argument is True and then -// returns the second argument -assuming : {a} Bit -> a -> a -assuming b x = if b then x else anySpec diff --git a/examples/mr_solver/monadify.cry b/examples/mr_solver/monadify.cry deleted file mode 100644 index 1d5659f5f7..0000000000 --- a/examples/mr_solver/monadify.cry +++ /dev/null @@ -1,25 +0,0 @@ - -module Monadify where - -import SpecPrims - -my_abs : [64] -> [64] -my_abs x = if x < 0 then -x else x - -err_if_lt0 : [64] -> [64] -err_if_lt0 x = - if x < 0 then error "x < 0" else x - -sha1 : ([8], [32], [32], [32]) -> [32] -sha1 (t, x, y, z) = - if (0 <= t) && (t <= 19) then (x && y) ^ (~x && z) - | (20 <= t) && (t <= 39) then x ^ y ^ z - | (40 <= t) && (t <= 59) then (x && y) ^ (x && z) ^ (y && z) - | (60 <= t) && (t <= 79) then x ^ y ^ z - else error "sha1: t out of range" - -fib : [64] -> [64] -fib x = if x == 0 then 1 else x * fib (x - 1) - -fibSpecNoErrors : [64] -> [64] -fibSpecNoErrors _ = noErrors diff --git a/examples/mr_solver/monadify.saw b/examples/mr_solver/monadify.saw deleted file mode 100644 index e174a18c45..0000000000 --- a/examples/mr_solver/monadify.saw +++ /dev/null @@ -1,126 +0,0 @@ - -enable_experimental; -import "SpecPrims.cry" as SpecPrims; -import "monadify.cry"; -// load_sawcore_from_file "../../cryptol-saw-core/saw/CryptolM.sawcore"; - -// Set the monadification of the Cryptol exists and forall functions -set_monadification "SpecPrims::exists" "SpecM.existsS" true; -set_monadification "SpecPrims::forall" "SpecM.forallS" true; - -let run_test name cry_term mon_term_expected = - do { print (str_concat "Test: " name); - print "Original term:"; - print_term cry_term; - mon_term <- monadify_term cry_term; - print "Monadified term:"; - print_term mon_term; - success <- is_convertible mon_term mon_term_expected; - if success then print "Success - monadified term matched expected\n" else - do { print "Test failed - did not match expected monadified term:"; - print_term mon_term_expected; - exit 1; }; }; - -let my_abs = unfold_term ["my_abs"] {{ my_abs }}; -let my_abs_M = parse_core_mod "CryptolM" "\ -\ \\(x : (mseq VoidEv (TCNum 64) Bool)) -> \ -\ bindS VoidEv (isFinite (TCNum 64)) \ -\ (mseq VoidEv (TCNum 64) Bool) \ -\ (assertFiniteS VoidEv (TCNum 64)) \ -\ (\\(x' : (isFinite (TCNum 64))) -> \ -\ bindS VoidEv (isFinite (TCNum 64)) \ -\ (mseq VoidEv (TCNum 64) Bool) \ -\ (assertFiniteS VoidEv (TCNum 64)) \ -\ (\\(x'' : (isFinite (TCNum 64))) -> \ -\ ite (SpecM VoidEv (mseq VoidEv (TCNum 64) Bool)) \ -\ (ecLt (mseq VoidEv (TCNum 64) Bool) (PCmpMSeqBool VoidEv (TCNum 64) x') x \ -\ (ecNumber (TCNum 0) (mseq VoidEv (TCNum 64) Bool) (PLiteralSeqBoolM VoidEv (TCNum 64) x''))) \ -\ (bindS VoidEv (isFinite (TCNum 64)) \ -\ (mseq VoidEv (TCNum 64) Bool) \ -\ (assertFiniteS VoidEv (TCNum 64)) \ -\ (\\(x''' : (isFinite (TCNum 64))) -> \ -\ retS VoidEv \ -\ (mseq VoidEv (TCNum 64) Bool) \ -\ (ecNeg (mseq VoidEv (TCNum 64) Bool) (PRingMSeqBool VoidEv (TCNum 64) x''') x))) \ -\ (retS VoidEv (mseq VoidEv (TCNum 64) Bool) x)))"; -run_test "my_abs" my_abs my_abs_M; - -let err_if_lt0 = unfold_term ["err_if_lt0"] {{ err_if_lt0 }}; -let err_if_lt0_M = parse_core_mod "CryptolM" "\ -\ \\(x : (mseq VoidEv (TCNum 64) Bool)) -> \ -\ bindS VoidEv (isFinite (TCNum 64)) (mseq VoidEv (TCNum 64) Bool) (assertFiniteS VoidEv (TCNum 64)) \ -\ (\\(x' : (isFinite (TCNum 64))) -> \ -\ bindS VoidEv (isFinite (TCNum 64)) (mseq VoidEv (TCNum 64) Bool) (assertFiniteS VoidEv (TCNum 64)) \ -\ (\\(x'' : (isFinite (TCNum 64))) -> \ -\ ite (SpecM VoidEv (mseq VoidEv (TCNum 64) Bool)) \ -\ (ecLt (mseq VoidEv (TCNum 64) Bool) (PCmpMSeqBool VoidEv (TCNum 64) x') x \ -\ (ecNumber (TCNum 0) (mseq VoidEv (TCNum 64) Bool) (PLiteralSeqBoolM VoidEv (TCNum 64) x''))) \ -\ (bindS VoidEv (isFinite (TCNum 8)) (mseq VoidEv (TCNum 64) Bool) (assertFiniteS VoidEv (TCNum 8)) \ -\ (\\(x''' : (isFinite (TCNum 8))) -> \ -\ ecErrorM VoidEv (mseq VoidEv (TCNum 64) Bool) (TCNum 5) \ -\ (seqToMseq VoidEv (TCNum 5) (mseq VoidEv (TCNum 8) Bool) \ -\ [ ecNumber (TCNum 120) (mseq VoidEv (TCNum 8) Bool) (PLiteralSeqBoolM VoidEv (TCNum 8) x''') \ -\ , (ecNumber (TCNum 32) (mseq VoidEv (TCNum 8) Bool) (PLiteralSeqBoolM VoidEv (TCNum 8) x''')) \ -\ , ecNumber (TCNum 60) (mseq VoidEv (TCNum 8) Bool) (PLiteralSeqBoolM VoidEv (TCNum 8) x''') \ -\ , (ecNumber (TCNum 32) (mseq VoidEv (TCNum 8) Bool) (PLiteralSeqBoolM VoidEv (TCNum 8) x''')) \ -\ , ecNumber (TCNum 48) (mseq VoidEv (TCNum 8) Bool) (PLiteralSeqBoolM VoidEv (TCNum 8) x''') ]))) \ -\ (retS VoidEv (mseq VoidEv (TCNum 64) Bool) x)))"; -run_test "err_if_lt0" err_if_lt0 err_if_lt0_M; - -/* -sha1 <- {{ sha1 }}; -print "Test: sha1"; -print "Original term:"; -print_term sha1; -sha1M <- monadify_term sha1; -print "Monadified term:"; -print_term sha1M; -*/ - -let fib = unfold_term ["fib"] {{ fib }}; -let fibM = parse_core_mod "CryptolM" "\ -\ \\(_x : Vec 64 Bool) -> \ -\ FixS VoidEv (Tp_Arr (Tp_bitvector 64) (Tp_M (Tp_bitvector 64))) \ -\ (\\(fib : (Vec 64 Bool -> SpecM VoidEv (Vec 64 Bool))) -> \ -\ \\(x : Vec 64 Bool) -> \ -\ bindS VoidEv (isFinite (TCNum 64)) (Vec 64 Bool) (assertFiniteS VoidEv (TCNum 64)) \ -\ (\\(x1 : isFinite (TCNum 64)) -> \ -\ bindS VoidEv (isFinite (TCNum 64)) (Vec 64 Bool) \ -\ (assertFiniteS VoidEv (TCNum 64)) \ -\ (\\(x2 : isFinite (TCNum 64)) -> \ -\ ite (SpecM VoidEv (Vec 64 Bool)) \ -\ (ecEq (Vec 64 Bool) (PEqMSeqBool VoidEv (TCNum 64) x1) x \ -\ (ecNumber (TCNum 0) (Vec 64 Bool) \ -\ (PLiteralSeqBoolM VoidEv (TCNum 64) x2))) \ -\ (bindS VoidEv (isFinite (TCNum 64)) (Vec 64 Bool) \ -\ (assertFiniteS VoidEv (TCNum 64)) \ -\ (\\(x3 : (isFinite (TCNum 64))) -> \ -\ retS VoidEv (Vec 64 Bool) \ -\ (ecNumber (TCNum 1) (Vec 64 Bool) \ -\ (PLiteralSeqBoolM VoidEv (TCNum 64) x3)))) \ -\ (bindS VoidEv (isFinite (TCNum 64)) (Vec 64 Bool) \ -\ (assertFiniteS VoidEv (TCNum 64)) \ -\ (\\(x3 : (isFinite (TCNum 64))) -> \ -\ bindS VoidEv (isFinite (TCNum 64)) (Vec 64 Bool) \ -\ (assertFiniteS VoidEv (TCNum 64)) \ -\ (\\(x4 : (isFinite (TCNum 64))) -> \ -\ bindS VoidEv (Vec 64 Bool) (Vec 64 Bool) \ -\ (fib \ -\ (ecMinus (Vec 64 Bool) (PRingMSeqBool VoidEv (TCNum 64) x3) x \ -\ (ecNumber (TCNum 1) (Vec 64 Bool) \ -\ (PLiteralSeqBoolM VoidEv (TCNum 64) x4)))) \ -\ (\\(x5 : Vec 64 Bool) -> \ -\ retS VoidEv (Vec 64 Bool) (ecMul (Vec 64 Bool) \ -\ (PRingMSeqBool VoidEv (TCNum 64) x3) x x5)))))))) \ -\ _x"; -run_test "fib" fib fibM; - -let noErrors = unfold_term ["noErrors"] {{ SpecPrims::noErrors }}; -let noErrorsM = parse_core_mod "CryptolM" "\\(a : sort 0) -> existsS VoidEv a"; -run_test "noErrors" noErrors noErrorsM; - -let fibSpecNoErrors = unfold_term ["fibSpecNoErrors"] {{ fibSpecNoErrors }}; -let fibSpecNoErrorsM = parse_core_mod "CryptolM" "\ -\ \\(__p1 : (mseq VoidEv (TCNum 64) Bool)) -> \ -\ existsS VoidEv (mseq VoidEv (TCNum 64) Bool)"; -run_test "fibSpecNoErrors" fibSpecNoErrors fibSpecNoErrorsM; diff --git a/examples/mr_solver/monadify_module.saw b/examples/mr_solver/monadify_module.saw deleted file mode 100644 index dcf3192acc..0000000000 --- a/examples/mr_solver/monadify_module.saw +++ /dev/null @@ -1,3 +0,0 @@ -enable_experimental; -// write_coq_cryptol_module "monadify.cry" "monadify_gen.v" [] ["fib"]; -write_coq_cryptol_module_monadic "monadify.cry" "monadify_gen_m.v" [] []; \ No newline at end of file diff --git a/examples/mr_solver/mr_solver_test_funs.sawcore b/examples/mr_solver/mr_solver_test_funs.sawcore deleted file mode 100644 index 718e6c9d91..0000000000 --- a/examples/mr_solver/mr_solver_test_funs.sawcore +++ /dev/null @@ -1,67 +0,0 @@ -module test_funs where - -import SpecM; - -test_fun0 : Vec 64 Bool -> SpecM VoidEv (Vec 64 Bool); -test_fun0 _ = retS VoidEv (Vec 64 Bool) (bvNat 64 0); - -test_fun1 : Vec 64 Bool -> SpecM VoidEv (Vec 64 Bool); -test_fun1 _ = retS VoidEv (Vec 64 Bool) (bvNat 64 1); - -test_fun2 : Vec 64 Bool -> SpecM VoidEv (Vec 64 Bool); -test_fun2 x = retS VoidEv (Vec 64 Bool) x; - --- If x == 0 then x else 0; should be equal to 0 -test_fun3 : Vec 64 Bool -> SpecM VoidEv (Vec 64 Bool); -test_fun3 x = - ite (SpecM VoidEv (Vec 64 Bool)) (bvEq 64 x (bvNat 64 0)) - (retS VoidEv (Vec 64 Bool) x) - (retS VoidEv (Vec 64 Bool) (bvNat 64 0)); - -{- --- let rec f x = 0 in f x -test_fun4 : Vec 64 Bool -> CompM (Vec 64 Bool); -test_fun4 x = - letRecM1 - (Vec 64 Bool) (Vec 64 Bool) (Vec 64 Bool) - (\ (f: Vec 64 Bool -> CompM (Vec 64 Bool)) (y:Vec 64 Bool) -> - returnM (Vec 64 Bool) (bvNat 64 0)) - (\ (f: Vec 64 Bool -> CompM (Vec 64 Bool)) -> - f x); - --- Alternate version of test_fun4 that uses letRecM directly -test_fun4_alt : Vec 64 Bool -> CompM (Vec 64 Bool); -test_fun4_alt x = - letRecM - (LRT_Cons (Vec 64 Bool) (\ (_:Vec 64 Bool) -> LRT_Ret (Vec 64 Bool)) - LRT_Nil) - (Vec 64 Bool) - (\ (f:(Vec 64 Bool -> CompM (Vec 64 Bool))) -> - ((\ (y:Vec 64 Bool) -> returnM (Vec 64 Bool) (bvNat 64 0)), ())) - (\ (f:(Vec 64 Bool -> CompM (Vec 64 Bool))) -> f x); - --- let rec f = f in f x -test_fun5 : Vec 64 Bool -> CompM (Vec 64 Bool); -test_fun5 x = - letRecM1 - (Vec 64 Bool) (Vec 64 Bool) (Vec 64 Bool) - (\ (f: Vec 64 Bool -> CompM (Vec 64 Bool)) -> f) - (\ (f: Vec 64 Bool -> CompM (Vec 64 Bool)) -> f x); - --- let rec f = g and g = f in f x -test_fun6 : Vec 64 Bool -> CompM (Vec 64 Bool); -test_fun6 x = - letRecM - (LRT_Cons - (LRT_Fun (Vec 64 Bool) (\ (_:Vec 64 Bool) -> LRT_Ret (Vec 64 Bool))) - (LRT_Cons - (LRT_Fun (Vec 64 Bool) (\ (_:Vec 64 Bool) -> LRT_Ret (Vec 64 Bool))) - LRT_Nil)) - (Vec 64 Bool) - (\ (f1:(Vec 64 Bool -> CompM (Vec 64 Bool))) - (f2:(Vec 64 Bool -> CompM (Vec 64 Bool))) -> - (f2, (f1, ()))) - (\ (f1:(Vec 64 Bool -> CompM (Vec 64 Bool))) - (f2:(Vec 64 Bool -> CompM (Vec 64 Bool))) -> - f1 x); --} diff --git a/examples/mr_solver/mr_solver_unit_tests.saw b/examples/mr_solver/mr_solver_unit_tests.saw deleted file mode 100644 index 870f50521b..0000000000 --- a/examples/mr_solver/mr_solver_unit_tests.saw +++ /dev/null @@ -1,155 +0,0 @@ -enable_experimental; - -load_sawcore_from_file "mr_solver_test_funs.sawcore"; - -let eq_bool b1 b2 = - if b1 then - if b2 then true else false - else - if b2 then false else true; - -let fail = do { print "Test failed"; exit 1; }; -let run_test name test expected = - do { if expected then print (str_concat "Test: " name) else - print (str_concat (str_concat "Test: " name) " (expecting failure)"); - actual <- test; - if eq_bool actual expected then print "Test passed\n" else - do { print "Test failed\n"; exit 1; }; }; - -// The constant 0 function const0 x = 0 -let ret0_core = "retS VoidEv (Vec 64 Bool) (bvNat 64 0)"; -let const0_core = str_concat "\\ (_:Vec 64 Bool) -> " ret0_core; -let const0 = parse_core_mod "SpecM" const0_core; - -// The constant 1 function const1 x = 1 -let const1_core = "\\ (_:Vec 64 Bool) -> retS VoidEv (Vec 64 Bool) (bvNat 64 1)"; -let const1 = parse_core_mod "SpecM" const1_core; - -// const0 <= const0 -prove_extcore mrsolver (refines [] const0 const0); -// (testing that "refines [] const0 const0" is actually "const0 <= const0") -let const0_refines = - str_concats ["(x:Vec 64 Bool) -> refinesS_eq VoidEv (Vec 64 Bool) ", - "((", const0_core, ") x) ", "((", const0_core, ") x)"]; -run_test "refines [] const0 const0" (is_convertible (parse_core_mod "SpecM" const0_refines) - (refines [] const0 const0)) true; -// (testing that "refines [x] ..." gives the same expression as "refines [] ...") -x <- fresh_symbolic "x" {| [64] |}; -run_test "refines [x] (const0 x) (const0 x)" - (is_convertible (refines [] const0 const0) - (refines [x] (term_apply const0 [x]) - (term_apply const0 [x]))) true; - -// The function test_fun0 <= const0 -let test_fun0 = parse_core_mod "test_funs" "test_fun0"; -prove_extcore mrsolver (refines [] const0 test_fun0); -// (testing that "refines [] const0 test_fun0" is actually "const0 <= test_fun0") -let const0_test_fun0_refines = - str_concats ["(x:Vec 64 Bool) -> refinesS_eq VoidEv (Vec 64 Bool) ", - "((", const0_core, ") x) ", "(test_fun0 x)"]; -run_test "refines [] const0 test_fun0" (is_convertible (parse_core_mod "test_funs" const0_test_fun0_refines) - (refines [] const0 test_fun0)) true; - -// not const0 <= const1 -fails (prove_extcore mrsolver (refines [] const0 const1)); -// (testing that "refines [] const0 const1" is actually "const0 <= const1") -let const0_const1_refines = - str_concats ["(x:Vec 64 Bool) -> refinesS_eq VoidEv (Vec 64 Bool) ", - "((", const0_core, ") x) ", "((", const1_core, ") x)"]; -run_test "refines [] const0 const1" (is_convertible (parse_core_mod "SpecM" const0_const1_refines) - (refines [] const0 const1)) true; - -// The function test_fun1 = const1 -let test_fun1 = parse_core_mod "test_funs" "test_fun1"; -prove_extcore mrsolver (refines [] const1 test_fun1); -fails (prove_extcore mrsolver (refines [] const0 test_fun1)); -// (testing that "refines [] const1 test_fun1" is actually "const1 <= test_fun1") -let const1_test_fun1_refines = - str_concats ["(x:Vec 64 Bool) -> refinesS_eq VoidEv (Vec 64 Bool) ", - "((", const1_core, ") x) ", "(test_fun1 x)"]; -run_test "refines [] const1 test_fun1" (is_convertible (parse_core_mod "test_funs" const1_test_fun1_refines) - (refines [] const1 test_fun1)) true; -// (testing that "refines [] const0 test_fun1" is actually "const0 <= test_fun1") -let const0_test_fun1_refines = - str_concats ["(x:Vec 64 Bool) -> refinesS_eq VoidEv (Vec 64 Bool) ", - "((", const0_core, ") x) ", "(test_fun1 x)"]; -run_test "refines [] const0 test_fun1" (is_convertible (parse_core_mod "test_funs" const0_test_fun1_refines) - (refines [] const0 test_fun1)) true; - -// ifxEq0 x = If x == 0 then x else 0; should be equal to 0 -let ifxEq0_core = "\\ (x:Vec 64 Bool) -> \ - \ ite (SpecM VoidEv (Vec 64 Bool)) \ - \ (bvEq 64 x (bvNat 64 0)) \ - \ (retS VoidEv (Vec 64 Bool) x) \ - \ (retS VoidEv (Vec 64 Bool) (bvNat 64 0))"; -let ifxEq0 = parse_core_mod "SpecM" ifxEq0_core; - -// ifxEq0 <= const0 -prove_extcore mrsolver (refines [] ifxEq0 const0); -// (testing that "refines [] ifxEq0 const0" is actually "ifxEq0 <= const0") -let ifxEq0_const0_refines = - str_concats ["(x:Vec 64 Bool) -> refinesS_eq VoidEv (Vec 64 Bool) ", - "((", ifxEq0_core, ") x) ", "((", const0_core, ") x)"]; -run_test "refines [] ifxEq0 const0" (is_convertible (parse_core_mod "SpecM" ifxEq0_const0_refines) - (refines [] ifxEq0 const0)) true; - - -// not ifxEq0 <= const1 -fails (prove_extcore mrsolver (refines [] ifxEq0 const1)); -// (testing that "refines [] ifxEq0 const1" is actually "ifxEq0 <= const1") -let ifxEq0_const1_refines = - str_concats ["(x:Vec 64 Bool) -> refinesS_eq VoidEv (Vec 64 Bool) ", - "((", ifxEq0_core, ") x) ", "((", const1_core, ") x)"]; -run_test "refines [] ifxEq0 const1" (is_convertible (parse_core_mod "SpecM" ifxEq0_const1_refines) - (refines [] ifxEq0 const1)) true; - -// noErrors1 x = existsS x. retS x -let noErrors1_core = - "\\ (_:Vec 64 Bool) -> existsS VoidEv (Vec 64 Bool)"; -let noErrors1 = parse_core_mod "SpecM" noErrors1_core; - -// const0 <= noErrors -prove_extcore mrsolver (refines [] noErrors1 noErrors1); -// (testing that "refines [] noErrors1 noErrors1" is actually "noErrors1 <= noErrors1") -let noErrors1_refines = - str_concats ["(x:Vec 64 Bool) -> refinesS_eq VoidEv (Vec 64 Bool) ", - "((", noErrors1_core, ") x) ", "((", noErrors1_core, ") x)"]; -run_test "refines [] noErrors1 noErrors1" (is_convertible (parse_core_mod "SpecM" noErrors1_refines) - (refines [] noErrors1 noErrors1)) true; - -// const1 <= noErrors -prove_extcore mrsolver (refines [] const1 noErrors1); -// (testing that "refines [] const1 noErrors1" is actually "const1 <= noErrors1") -let const1_noErrors1_refines = - str_concats ["(x:Vec 64 Bool) -> refinesS_eq VoidEv (Vec 64 Bool) ", - "((", const1_core, ") x) ", "((", noErrors1_core, ") x)"]; -run_test "refines [] const1 noErrors1" (is_convertible (parse_core_mod "SpecM" const1_noErrors1_refines) - (refines [] const1 noErrors1)) true; - -// noErrorsRec1 _ = orS (existsM x. returnM x) (noErrorsRec1 x) -// Intuitively, this specifies functions that either return a value or loop -let noErrorsRec1_core = - "FixS VoidEv (Tp_Arr (Tp_bitvector 64) (Tp_M (Tp_bitvector 64))) \ - \ (\\ (f: Vec 64 Bool -> SpecM VoidEv (Vec 64 Bool)) \ - \ (x: Vec 64 Bool) -> \ - \ orS VoidEv \ - \ (Vec 64 Bool) \ - \ (existsS VoidEv (Vec 64 Bool)) \ - \ (f x))"; -let noErrorsRec1 = parse_core_mod "SpecM" noErrorsRec1_core; - -// loop x = loop x -let loop1_core = - "FixS VoidEv (Tp_Arr (Tp_bitvector 64) (Tp_M (Tp_bitvector 64))) \ - \ (\\ (f: Vec 64 Bool -> SpecM VoidEv (Vec 64 Bool)) \ - \ (x:Vec 64 Bool) -> f x)"; -let loop1 = parse_core_mod "SpecM" loop1_core; - -// loop1 <= noErrorsRec1 -prove_extcore mrsolver (refines [] loop1 noErrorsRec1); -// (testing that "refines [] loop1 noErrorsRec1" is actually "loop1 <= noErrorsRec1") -let loop1_noErrorsRec1_refines = - str_concats ["(x:Vec 64 Bool) -> refinesS_eq VoidEv (Vec 64 Bool) ", - "((", loop1_core, ") x) ", "((", noErrorsRec1_core, ") x)"]; -run_test "refines [] loop1 noErrorsRec1" (is_convertible (parse_core_mod "SpecM" loop1_noErrorsRec1_refines) - (refines [] loop1 noErrorsRec1)) true; diff --git a/heapster.dockerfile b/heapster.dockerfile deleted file mode 100644 index 2da950e2a7..0000000000 --- a/heapster.dockerfile +++ /dev/null @@ -1,48 +0,0 @@ -FROM ubuntu:20.04 - -ARG heapster_commit=ca697c01ae9f3d2fbcae3169318d69f58e83efb2 - -ENV PATH="/home/heapster/.local/bin:/home/heapster/.cabal/bin:/home/heapster/.ghcup/bin:${PATH}" -ENV OPAMYES="true" - -# Dependencies for installing Haskell and Coq, mainly -RUN apt-get update && apt-get install -y \ - curl gcc git m4 make libtinfo5 libgmp-dev locales locales-all opam xz-utils z3 zlib1g-dev - -ENV LC_ALL en_US.UTF-8 -ENV LANG en_US.UTF-8 -ENV LANGUAGE en_US.UTF-8 - -# Running GHCUP and Opam don't like to run as root -RUN useradd -ms /bin/bash heapster -USER heapster - -# Install Coq and libraries -RUN opam init --disable-sandboxing -a && eval $(opam env) && \ - opam switch create with-coq 4.09.1 && \ - opam pin -y add coq 8.12.1 && eval $(opam env) && \ - opam repo add coq-released https://coq.inria.fr/opam/released && \ - opam update && opam install -y coq-bits - -# Install GHCUP, and use that to install GHC and Cabal -RUN mkdir -p ~/.ghcup/bin && \ - curl https://downloads.haskell.org/~ghcup/x86_64-linux-ghcup > /home/heapster/.ghcup/bin/ghcup && \ - chmod +x /home/heapster/.ghcup/bin/ghcup && \ - ghcup install 8.6.5 && ghcup set 8.6.5 && \ - ghcup install-cabal 3.2.0.0 && \ - cabal update - -# Build and install SAW -WORKDIR /home/heapster -# Necessary to deal with SSH URLs in some submodules -RUN git config --global url."https://github.com/".insteadOf git@github.com: -RUN git clone https://github.com/GaloisInc/saw-script.git && \ - cd saw-script && \ - git checkout ${heapster_commit} && \ - git submodule update --init --recursive && \ - ln -sf cabal.GHC-8.6.5.config cabal.project.freeze && \ - cabal build && \ - mkdir -p /home/heapster/.local/bin && \ - ln -sf `cabal exec which saw` /home/heapster/.local/bin/saw - -RUN eval $(opam env) && cd /home/heapster/saw-script/saw-core-coq/coq && make \ No newline at end of file diff --git a/heapster/.gitignore b/heapster/.gitignore deleted file mode 100644 index 7b980ef551..0000000000 --- a/heapster/.gitignore +++ /dev/null @@ -1,27 +0,0 @@ -dist -dist-* -cabal-dev -*.o -*.hi -*.hie -*.chi -*.chs.h -*.dyn_o -*.dyn_hi -.hpc -.hsenv -.cabal-sandbox/ -cabal.sandbox.config -*.prof -*.aux -*.hp -*.eventlog -.stack-work/ -cabal.project.local -cabal.project.local~ -.HTF/ -.ghc.environment.* -*.vo -*.vos -*.vok -*.glob diff --git a/heapster/README.md b/heapster/README.md deleted file mode 100644 index 44ff0853a1..0000000000 --- a/heapster/README.md +++ /dev/null @@ -1,306 +0,0 @@ -# Heapster - -Implementation of the Heapster type system of separation types inside SAW, -including a translation to SAWCore. - -The remainder of this README contains general information about using -Heapster about the `examples` directory contained here. - -## Building - -You will need to follow the instructions in the top-level README to download -or build a SAW binary, of which Heapster is a part. - -If you intend to interact with any of Heapster's Coq output, you will also need -to follow the instructions in the README in the `saw-core-coq` subdirectory. -Specifically, after installing the dependencies, you will need to run the -following (from this directory): -```bash -cd ../saw-core-coq/coq -make -``` - -## Using Heapster - -This section will walk through the process of using Heapster on some code in a -C file. This will involve generating LLVM bitcode from your file, writing a SAW -script to type-check your code with Heapster, and writing a Coq file to prove -things about the generated functional specification(s). - -### Generating LLVM bitcode - -The input to Heapster is an LLVM bitcode (`.bc`) file. To generate LLVM -bitcode from a C file, run the following: -```bash -clang -emit-llvm -g -c my_file.c -``` -Be aware that the resulting bitcode may depend on your `clang` version and your -operating system. In turn, this means the Heapster commands in your SAW script -and the proofs in your Coq file may also be dependent on how and where the -bitcode is generated. For this reason, we provide bitcode files for every -example in the `examples` directory. - -### Type-checking using a SAW script - -To use Heapster on your generated bitcode, you can either write a SAW script -(e.g. `my_file.saw`) or start a SAW interactive session. This document will -use writing a SAW script as an example, but the commands are the same in -either case. - -To see the documentation for any of the commands mentioned here, type `:help` -followed by the name of the command in a SAW interactive session. - -In order to use Heapster commands, you must begin with: -``` -enable_experimental; -``` -You can then load your example bitcode file into Heapster using the following: -``` -env <- heapster_init_env "my_file" "my_file.bc"; -``` -This file will not go into detail about the process of actually type-checking a -function with Heapster. Instead, we will briefly discuss a few of the main -commands used, as well as some examples. - -One of the simplest Heapster commands is `heapster_define_perm`, which defines -a new named permission which can then be used in Heapster types. As an -example, the following defines a permission which describes a 64-bit integer -value: -``` -heapster_define_perm - env - "int64" - " " - "llvmptr 64" - "exists x:bv 64.eq(llvmword(x))"; -``` -The first argument is the Heapster environment, the second is its name, the -third is its arguments (of which there are none), the fourth is the type of -value that the permission applies to, and the fifth is its definition. - -To define [permissions](doc/Permissions.md) which can describe unbounded data structures, you can use -the `heapster_define_recursive_perm` command. As an example, here is how to -describe a linked list of 64-bit words using this command: -``` -heapster_define_recursive_perm - env - "List64" - "rw:rwmodality" - "llvmptr 64" - ["eq(llvmword(0))", "ptr((rw,0) |-> int64<>) * ptr((rw,8) |-> List64)"] - "List (Vec 64 Bool)" - "foldList (Vec 64 Bool)" - "unfoldList (Vec 64 Bool)"; -``` -Its first four arguments are the same as for `heapster_define_perm`, its -fifth argument contains its different inductive cases (in this case, a `List64` -is either a null pointer, or a pointer to an `Int64` and another `List64`), -and its final three arguments are its translation into SAW core. Here the -SAW core definitions used are from the SAW core prelude, but if you need new -SAW core definitions, you will need to use the following command instead of -`heapster_init_env`: -``` -env <- heapster_init_env_from_file "my_file.sawcore" "my_file.bc"; -``` - -Finally, to actually type-check a function you can use -`heapster_typecheck_fun`. The following is an example using the `is_elem` -function from `examples/linked_list.c` and the permissions we defined above: -``` -heapster_typecheck_fun - env - "is_elem" - "().arg0:int64<>, arg1:List64 -o arg0:true, arg1:true, ret:int64<>"; -``` -The heapster type given has three parts, the context of ghost variables, the -input permissions, and the output permissions. Here there are no ghost -variables used, so the context is empty (the `()` at the start). The input -permissions state that the two arguments to `is_elem` are an `int64` and a -read-only `List64`, respectively. The output permissions state that the two -arguments are unconstrained after returning (the vacuous `true` permissions) -and that the returned value is an `int64`. - -Note that for more complicated examples, usually examples involving loops, -the `heapster_block_entry_hint` command will also need to be used in order for -the `heapster_typecheck_fun` command to succeed. In the case of functions with -loops, this hint corresponds to a loop invariant. Additionally, such examples -will also often require your unbounded data structure to be defined as a -reachability permission, using `heapster_define_reachability_perm`, instead of -just as a recursive permission. See `examples/iter_linked_list.saw` for some -examples of using the commands mentioned in this paragraph. - -Once you're finished, use the following command to export all the type-checked -functions in the current environment as functional specifications in Coq. By -convention, we add a `_gen` suffix to the filename. -``` -heapster_export_coq env "my_file_gen.v"; -``` - -### Heapster Permissions - -See this [additional documentation](doc/Permissions.md) for a reference on the syntax and meaning of heapster permissions. - -### Verifying in Coq - -To interact with the generated Coq code, you will first need to set up your Coq -environment. Make a file named `_CoqProject` with the following contents, -where `PATH_TO_SAW` is replaced by the path to the top-level `saw-script` -directory: -``` --Q PATH_TO_SAW/saw-core-coq/coq/generated/CryptolToCoq CryptolToCoq --Q PATH_TO_SAW/saw-core-coq/coq/handwritten/CryptolToCoq CryptolToCoq - -my_file_gen.v -``` -This file is already set up for the examples in the `examples` directory. - -By convention, the file which contains proofs about functions in your file -has the `_proofs` suffix added (e.g. `my_file_proofs.v`). This file should -also be added to your `_CoqProject`. - -In your `_proofs` file, you will want to import at least the following: -```coq -From CryptolToCoq Require Import SAWCorePrelude. -From CryptolToCoq Require Import CompMExtra. -``` - -You can then either load your file using `Load` (e.g. `Load "my_file_gen.v"`) -or make `-Q . Namespace`, where `Namespace` is whatever string you want, the -third line of your `_CoqProject` and use `Import` (e.g. -`Require Import Namespace.my_file_gen`). You will then need to import the -module from your generated file as well as the SAW core prelude module – all -together these lines should look like: -```coq -Load "my_file_gen.v". -Import my_file. -Import SAWCorePrelude. -``` - -Often the first thing you want to verify is that the generated specification -has no errors. Errors can appear because of errors in the LLVM bitcode or -because of errors in the type-checking process. Having errors of the first kind -in the generated specification is not an issue, but it must be proved that they -are never reached. Sometimes, a precondition and/or loop invariant must be -added in order for such a proof to be completed, see -`examples/arrays_proofs.v` for an example. In a generated spec, these errors -often look like the following: -``` -errorM "Failed Assert at arrays.c:19:14" -``` -Seeing an error of the second kind in your generated specification means you -need to revise the types you wrote in your SAW script. These errors are -usually quite distinctive in the generated Coq code, for example: -``` -errorM "At is_elem.c:26:12 ($10 = call $9($3, $7);) - Regs: $9 = fn @ , $3 = ptr @ , $7 = ptr4 @ - Input perms: top_ptr:eq(LLVMword ghost_bv), - top_ptr1:ptr((R,0) |-> int64<>)*ptr((R,8) |-> List64), - ghost_frm:llvmframe [C[&l]:8, C[&x]:8, local_ptr:8], - fn:(). - arg1:int64<>, arg:List64_nonnull - -o - arg1:true, arg:true, ret:int64<>, ptr:eq(LLVMword ghost_bv), - ptr4:eq(ptr3), local_ptr:ptr((W,0) |-> true), - C[&x]:ptr((W,0) |-> eq(ptr)), C[&l]:ptr((W,0) |-> eq(ptr1)), - ghost_bv:true, ptr3:List64, ptr1:eq(top_ptr1) - Could not prove (). ptr:int64<>, ptr4:List64_nonnull - - proveVarImplH: Could not prove - ptr3:eq(LLVMword 0) - -o - (). ptr((R,0) |-> int64<>)*ptr((R,8) |-> List64)" -``` - -To prove no-errors you will prove that your generated specification **refines** -the specification `noErrorsSpec`, which is defined as follows: -```coq -Definition noErrorsSpec : CompM A := existsM (fun x => returnM x). -``` - -For example, the statement of no-errors for `is_elem` is the following: -```coq -Lemma no_errors_is_elem : refinesFun is_elem (fun _ _ => noErrorsSpec). -``` - -You can think of specifications in the `CompM` monad (such as `noErrorsSpec` -and everything Heapster generates) as sets of possible executions, and the -refinement relation as the subset relation on these sets. In this way, -`noErrorsSpec` represents the set of all computations which return some pure -value (and thus cannot contain any calls to `errorM : string -> CompM A`), and -thus, proving that a specification refines `noErrorsSpec` represents proving -that it always returns some pure value. - -For the proof of `no_errors_is_elem`, we simply need to unfold both sides of -the refinement, then call the automated tactic `prove_refinement`, imported -from `CompMExtra`: -```coq -Proof. - unfold is_elem, is_elem__tuple_fun, noErrorsSpec. - prove_refinement. -Qed. -``` - -The `prove_refinement` tactic is not guaranteed to solve all goals. Sometimes, -the goals it leaves over can be completed with simple Coq tactics, and other -times the left over goals can help you discover that the lemma you're trying -to prove is false, and therefore you need to return to type-checking, or -add/revise your precondition and/or loop invariant. In this case, the tactic -was able to solve all goals. - -Note that when the generated specification has functions bound by a `letRecM`, -there must be a `letRecM` with matching shape on the right of a refinement. -To help set this up, you can use the `prove_refinement_match_letRecM_l` tactic, -which will generate as many goals as there are functions needed for the -`letRecM` on the right hand side. As an example, here is an excerpt from -`examples/iter_linked_list_proofs.v`, where a single matching `letRecM` -function is needed: -```coq -Lemma no_errors_is_elem : refinesFun is_elem (fun _ _ => noErrorsSpec). -Proof. - unfold is_elem, is_elem__tuple_fun. - prove_refinement_match_letRecM_l. - - exact (fun _ _ => noErrorsSpec). - unfold noErrorsSpec. - prove_refinement. -Qed. -``` -It is good practice to defer unfolding the right hand side until after -the `letRecM` functions have been added to avoid `prove_refinement` getting -ahead of itself. - -Check out the examples directory for more examples of what sort of things you -can prove about generated specifications. - -## Examples - -The `examples` directory contains lots of varied examples of the entire process -described above. To run all of the SAW scripts and Coq proofs, you can simply -run `make`, assuming that all `*_gen.v` files that may have been left from a -previous run have been deleted (alternately, you can first run `touch *.saw`). - -Here is a brief overview of the different examples. -- `linked_list` - This is a good set of examples to look at first. - `linked_list.saw` introduces the basics of Heapster type-checking, and - `linked_list_proofs.v` contains lots of varied proofs all of which are - relatively very easy to understand. -- `iter_linked_list` - This is a good set of examples to look at after the - above, as they are variants of the above, just written with loops instead of - recursion. These examples introduce reachability permissions, block entry - hints, and preconditions in Coq proofs. -- `loops` - Some more examples of functions with loops, but which do not - involve reachability permissions or preconditions. This set of examples - introduces functions which depend on other functions, see `loops_proofs.v`. -- `arrays` - This set of examples involves using multiple types of hints during - type-checking as well as preconditions, loop invariants, and lots of user - input post-`prove_refinement` on the Coq side. -- `mbox` - This is a set of examples based on "real-world" code, i.e. code - not written for the intent of testing Heapster. As such, not every function - is complete, and the most complicated examples can be found in this file. -- `iso_recursive` - This set of examples uses an experimental feature where - the SAW core definitions used when defining recursive permissions are - set automatically. - -Additionally, `clearbufs`, `xor_swap`, `memcpy`, and `string_set` contain some -minimal examples of type-checking various simple functions. - -Not included in this list are any of the rust examples. diff --git a/heapster/doc/Annotations.md b/heapster/doc/Annotations.md deleted file mode 100644 index ba958cccf5..0000000000 --- a/heapster/doc/Annotations.md +++ /dev/null @@ -1,31 +0,0 @@ -# LLVM Heapster Annotations - -To support type-preserving compilation, the user (or, more likely, a compiler) -can embed block entry hints _in_ the LLVM IR. - -This feature is *highly* experimental. - -This works by using a "dummy" function: - -``` -define void @heapster.require(...) { ret void } -``` - -To assign a hint to a basic block `B`, insert a call to this -function in `B`. The arguments are: - -- A ghost context to use, binding names to types -- A value permission context, binding: - 1. any ghost name in the context to a permission, - 2. any toplevel name (ranging over the names `top0 ... topN`) to a permission, - 3. any LLVM instruction dominating the basic block to a permission. In the spec, - the names `arg0 ... argN` can be used for these, and then ... -- ... the remaining arguments should be the instructions to _use_ for each `argi`. - -For example in [](../examples/bc-annot/foo.ll) the arguments to -`@heapster.require` in the last basic block of `@foo` are: - -- the string `@.ghosts` contains a ghost context string -- the string `@.spec` contains a spec assigning permissions not only to the ghosts and toplevels, but also `arg0` and `arg1`. -- the argument `%1`, meaning use `%1` for `arg0` -- the argument `%0`, meaning use `%0` for `arg1` diff --git a/heapster/doc/ImplProver.md b/heapster/doc/ImplProver.md deleted file mode 100644 index 6d4f5c13e4..0000000000 --- a/heapster/doc/ImplProver.md +++ /dev/null @@ -1,277 +0,0 @@ - -# The Heapster Implication Prover - -This document describes the Heapster implication prover. - -## The Implication Prover Monad - -The implication prover runs in the `ImplM` monad, whose type parameters are as follows: - -``` -ImplM vars s r ps_out ps_in a -``` - -An element of this type is an implication prover computation with return type `a`. The type variable `vars` lists the types of the existential variables, or _evars_, in scope. These represent "holes" in the permissions we are trying to prove. The type variables `s` and `r` describe the calling context of this implication computation at the top level: `s` describes the monadic state maintained by this calling context, while `r` describes the top-level result type required by this context. These types are left abstract in all of the implication prover. - -The type variables `ps_in` and `ps_out` describe the permission stack on the beginning and end of the computation. The existence of these two variables make `ImplM` a _generalized_ monad instead of just a standard monad, which means that these types can vary throughout an implication computation. The bind for `ImplM` is written `>>>=` instead of `>>=`, and has type - -``` -(>>>=) :: ImplM vars s r ps' ps_in a -> (a -> ImplM vars s r ps_out ps' b) -> - ImplM vars s r ps_out ps_in b -``` - -That is, the bind `m >>>= f` first runs `m`, which changes the permissions stack from `ps_in` to `ps'`, and then it passes the output of `m` to `f`, which changes the permissions stack from `ps'` to `s_out`, so the overall computation changes the permissions stack from `ps_in` to `ps_out`. As a more concrete example, the computation for pushing a permission onto the top of the stack is declared as - -``` -implPushM :: HasCallStack => NuMatchingAny1 r => ExprVar a -> ValuePerm a -> - ImplM vars s r (ps :> a) ps () -``` - -meaning that `implPushM` takes in a variable `x` and a permission `p` and returns a computation that starts in any permission stack `ps` and pushes permission `x:p` of type `a` onto the top of the stack. - -If the permission stack does not change, meaning that `ps_in` equals `ps_out`, then `ImplM` forms a monad. For instance, the function - -``` -partialSubstForceM :: (NuMatchingAny1 r, PermPretty a, - Substable PartialSubst a Maybe) => - Mb vars a -> String -> ImplM vars s r ps ps a -``` - -takes the current partial substitution for the evars and attempts to apply it to a value in a name-binding for those evars, raising an error if some evar that has not yet been instantiated is used in the value. (The "force" means to force the substitution to be defined or fail.) This function does not change the permission stack, and is in fact written in `do` notation in the code. - -The `ImplM` monad is defined as a generalized state-continuation monad. This construct is defined in `GenMonad.hs`, but we will not discuss it in too much detail here. The state that is maintained is given by the `ImplState` type, which contains information such as the current permission set, the types of all univeral and existential variables in scope, and the current instantiations of all the evars. The input and output types of the continuation portion of `ImplM` are both `PermImpl`, meaning each `ImplM` computation builds up an implication. The fact that `ImplM` is a continuation monad is only used in the `implApplyImpl1` function, which applies an `Impl1` rule by shifting the current continuation and re-applying it to build the sub-`PermImpl`s passed to that rule as an `MbPermImpls`. This means that rules with multiple disjunctive outputs, like or elimination and the catch rule, cause `ImplM` to fork its execution, running any subsequent computation once in each disjunctive branch. Thus, for performance reasons, it is helpful to reduce this forking as much as possible. - - -## Needed and Determined Variables - -One difficulty in doing proof search which must be addressed by the implication prover is that existential variables mean we do not have most general types. (There are other ways in which Heapster does not have most general types, but this is a more aggregious one.) For instance, there are two distinct ways to prove - -``` -x:ptr((R,0) |-> true) * x:ptr((R,8) |-> true) |- exists off:bv 64. x:ptr((R,off) |-> true) -``` - -by instantiating `off` to either 0 or 8. The difficulty is that if we choose the wrong value for `off` we might have to backtrack, potentially leading to an exponential search. The same problem occurs for function permissions with ghost variables, as ghost variables become existential variables that must be instantiated at call sites. Thus, for instance, Heapster cannot handle a function with permissions like - -``` -(off:bv 64). arg0:ptr((R,off) |-> true) -o empty -``` - -because it will not know how to instantiate `off` at the call site. Currently, this shows up as a type-checking error when such a function is called, but we could consider raising an error where such a function is defined. If you think about it, though, a function type like this does not really make any sense. How could a function take in a pointer to something where it doesn't know the offset of that pointer? - -If, however, there is some other permission that _determines_ the offset, then this problem is resolved. Consider, for instance, the following function type: - -``` -(off:bv 64). arg0:ptr((R,off) |-> true), arg1:eq(llvmword(off)) -o empty -``` - -This describes a function whose second argument says what the offset is for the first. Unlike the previous example, Heapster can handle this function type, because it will prove the equality permission on `arg1` first, and this proof will determine the value of `off` to be used for the permission on `arg0`. This function type also makes a lot more sense operationally, because now the function can know what the offset is. The more common version of this situation is passing the length of an array, using a type like this: - -``` -(len:bv 64). arg0:array(W,0,), arg1:eq(llvmword(len)) -o empty -``` - -A similar pattern can occur inside data structures. A common pattern in C is to have a `struct` with a variable-length array at the end, whose length is determined by one of the fields, like this: - -``` -struct foo { - ...; - int64_t len; - char data[]; -} -``` - -Rust slices are similar. A struct like this can be described by the Heapster shape - -``` -...; exsh len:bv 64.(fieldsh(eq(llvmword len));arraysh())) -``` - -This shape can be proved by the Heapster implication prover because the existential variable `len` in the shape is determined by the equality permission in the `len` field in the struct. If the struct did not have this field, Heapster would not be able to prove permissions with this shape. Again, such a shape does not really make sense, as the program would never know how long the `data` field is. - - -The Heapster implication prover addresses the problem of existential variables leading to non-unique types by requiring that all existential variables that could lead to this sort of problem in a permission `p` are assigned a uniquely determined value before it attempts to satisfy permission `p`. These variables are called the _needed_ variables of `p`, defined by the `neededVars` function in Permissions.hs. The needed variables include any free variables in the offsets and lengths of pointer, array, and block permissions, as well as any free variables of the more complicated permissions like lifetime ownership permissions. For equality permissions `eq(e)`, the free variables of `e` are not needed if `e` is a _determining_ expression, discussed below. In our example above, `off` is a needed variable on the right-hand side, so the implication prover will not prove this implication but will instead raise a type-checking error (with the `Impl1_Fail` rule described above). - -The only way to prove a permission with needed variables is if there is some other permission which is proved first that _determines_ the value of that variable. Intuitively, the idea is that a permission `p` determines an existential variable `x` if there is only one possible value of `x` for which `p` can possibly be proved. The canonical example of determination is the permission `eq(x)`: the only possible way to prove an `eq(x)` permission is to set `x` to the value that has this permission. If we are proving `y:eq(x)`, then `x` has to be set to `y`, while if we are proving a pointer permission `y:ptr((rw,off) |-> eq(x))`, `x` has to be set to the value pointed to by `y` at offset `off`. Note that, in this latter case, the implication prover will first prove some permission of the form `y:ptr((rw,off) |-> p)` and will then use the `Impl1_ElimLLVMFieldContents` rule to bind a local variable `z` for the value pointed to by `y` at offset `off`, so `x` will be set to this local variable `z`. In order to prove a pointer permission, however, the free variables in `off` (if there are any) must already be determined by some other permission, because these are needed variables of the pointer permission. Thus determined variables have a dependency structure, where some variables can only be determined if other variables are determined first. Further, a variable can not be determined by an equality inside an arbitrary permission. For instance, `eq(x) or p` does not determine `x`, because the proof may not take the left-hand branch of the disjunct. - -More generally, determined variables are defined by the `determinedVars` function. This function uses the helper function `isDeterminingExpr` to define whether an expression `e` used in an equality permission determines its variables. The following expression forms are determining: -* `x` -* `llvmword e` if `e` is determining -* `N*x + K` for constants `N` and `K` -* The permission `eq(e)` as an expression if `e` is determining -* `x &+ off` if `off` is determining -* Any expression with no free variables - -The `determinedVars` function is then defined as follows on permission `p`: - -| Permission `p` | Determined Variables | -|-------------|----------------------| -| `eq(e)` | The free variables of `e` if `e` is a determining expression, otherwise `[]` | -| `p1 * ... * pn` | The determined variables of the `pi` | -| `P` | The free variables of each determining expression in `args` | -| `[l]ptr((rw,off) \|-> p)` | The determined variables of `l`, `rw`, and `p`, if the variables in `off` are determined | -| `[l]array(rw,off, ImplM vars s r (ps_in :++: ps) ps_in () -``` - -This function attempts to prove `n` permisisons `x1:p1, ..., xn:pn`, adding those permissions to the top of the permissions stack. These permissions are inside of a binding for the existential variables specified by `vars`, which represent "holes" or unknown expressions that will be solved by building the proof. As an example, the type-checker for the pointer read instruction calls the implication prover with the existentially quantified permission - -``` -(rw,l,z). [l]ptr((rw,0) |-> eq(z)) -``` - -expressing that it requires a pointer permission at offset 0 with any lifetime `l`, any read/write modality `rw`, that points to any value `z`. - -There are a number of wrapper functions that call `proveVarsImplAppend`, including: - -* `proveVarsImpl`, which assumes the input permission stack is empty; -* `proveVarImpl`, which proves one permission; and -* `proveVarsImplVarEVars`, which is like `proveVarsImpl` but where all existential variables are instantiated with fresh variables. - -The top-level implication prover algorithm is then implemented as a descending sequence of "levels", each of is implemented as a function that performs some particular function and then calls the next level: - -| Function Name | Purpose | ---------------|----------| -| `proveVarsImplAppend` | Try to prove the required permissions, and, if that failos, non-deterministically end some lifetimes that could help in the proof | -| `proveVarsImplAppendInt` | Repeatedly call `findProvablePerm` to find the permission on the right that is most likely to be provable and then try to prove that permission | -| `proveExVarImpl` | Handle the case of a right-hand permission `x:p` where `x` itself is an evar by instantiating `x`, if possible | -| `proveVarImplInt` | Wrapper function that pushes the primary permissions for `x` onto the top of the stack, performs debug tracing, calls `proveVarImplH`, and then checks that the proved permission is correct | - - -## Proving a Permission - -The main logic for proving a permission is in the function `proveVarImplH`. (The implication prover uses the convention of using "`H`" as a suffix for helper functions.) As with many functions in the implication prover, this function takes in: a variable `x` that we are trying to prove a permission on; a permission `p` for `x` which is currently on top of the stack; and a permission `mb_p` inside a context of evars that we are trying to prove for `x`. (The prefix "`mb`" refers to "multi-binding", a binding of 0 or more evars.) The function then works by pattern-matching on `p` (the left-hand side) and `mb_p` (the right-hand side), using the following cases, some of which call out to helper functions described below: - -| Left-hand side | Right-hand side | Algorithmic steps taken | -|------------|--------------|--------------------| -| `p` | `true` | Pop `p` and Introduce a vacuous proof of `true` | -| `p` | `eq(e)` | Call `proveVarEq` to prove the equality | -| `p1 or p2` | `mb_p` | Eliminate the disjunction and recurse | -| `exists z. p` | `mb_p` | Eliminate the existential and recurse | -| `eq(y)` | `mb_p` | Prove `y:mb_p` and then cast the proof to `x:mb_p` | -| `eq(y &+ off)` | `mb_p` | Prove `y:(offsetPerm mb_p off)` and then case the proof to `x:mb_p` | -| `p` | `mb_p1 or mb_p2` | Nondeterminsitically try to prove either `mb_p1` or `mb_p2` | -| `p` | `exists z. mb_p` | Add a new evar for `z`, prove `x:mb_p`, and then use the value determined for `x` to introduce an existential permission | -| `P` | `mb_p` | Use the more specific rules below for named permissions | -| `p1 * ... * pi-1 * P * pi+1 * ... * pn` | `mb_p` | Use the more specific rules below for named permissions | -| `p` | `P` | Use the more specific rules below for named permissions | -| `eq(llvmword e)` | `p1 * ... * pn` | Fail, because we cannot prove any non-equality permissions for words, and the equality permissions were matched by an earlier case | -| `eq(struct(e1,...,en))` | `mb_p` | Eliminate `eq(struct(e1,...,en))` to a `struct(eq(e1),...,eq(en))` permission with equalities for each field | -| `eq(constant f)` | `(gs) ps_in -o ps_out` | Use an assumption on known function `f` | -| `p1 * ... * pn` | `mb_p1 * ... * mb_pn` | Call `proveVarConjImpl` to prove a conjunction implies a conjunction | -| `p` | `(X). X` | For existential permission variable `X`, set `X:=p` | -| `X` | `X` | For universal permission variable `X`, prove `X -o X` by reflexivity | -| `_` | `_` | In all other cases, fail | - - -## Proving Named Permissions - -Named permissions are of the form `P` for some permission name `P`. Each named permission represents some more complicated collection of permissions, that can depend on the argument expressions `args`. Permission names come in three sorts: - -* _Defined names_ are essentially abbreviations, where `P` unfolds to some permission `p` that does not contain `P` itself (unless `P` occurs `args`); - -* _Recursive names_ `P` are similar to defined names but where `P` unfolds to a permission that can contain `P`; and - -* _Opaque names_ are permissions which are too complicated to represent in Heapster, so Heapster just represents them with names. - -The "best" way to prove a named permission `P` is by reflexivity, i.e., to find an instance of `P` that is already in the current permissions set. The implication rules do allow some amount of weakening the arguments, so technically this is a search for `P` for some argument list `args'` that can be coerced to `args`. For opaque names, this is the only way to prove `P`. For defined names, the other option is to just unfold `P` to its definition, prove that permission, and then fold the result to `P`. Similarly, recursive names can also be unfolded to prove them. Dually, if there is a permission `P` with a defined or recursive name on the left, meaning it is already held in the current permission set, the implication prover will unfold this permission if it gets stuck trying to prove its goal any other way. This logic is implemented by the `implUnfoldOrFail` function, which is called in a number of places in the implication prover where it will otherwise fail. - -The one wrinkle is that unfolding recursive names can lead to non-termination. This can happen if we have an assumption `P1` on the left and we are trying to prove `P2` on the right where both `P1` and `P2` are recursive names. If we proceed by unfolding both `P1` and `P2`, then, because these unfoldings can each contain `P1` and `P2` again, we can end up back at the same proof goal, of having an assumption `P1` on the left and trying to prove `P2`. To prevent this infinite regress, the implication prover is restricted so that it will not unfold names on both the left and right sides in the same proof. This is done by maintainining a flag called `implStateRecRecurseFlag` that tracks whether there has been an unfolding of a recursive name on one side or the other. Whenever the implication prover has `P1` on the left and `P2` on the right for recursive names `P1` and `P2`, it then non-deterministically (using the `Impl1_Catch` rule to backtrack) chooses one side to unfold, and it proceeds from there. This handles the possibility that one of `P1` or `P2` contains the other as a sub-permission. - -In more detail, here are the cases of `proveVarImplH` that handle recursive permissions: - -| Left-hand side | Right-hand side | Algorithmic steps taken | -|------------|--------------|--------------------| -| `P` | `P` | For reachabilitiy permission `P`, nondeterministically prove the RHS by either reflexivity, meaning `x:eq(mb_e)`, or transitivity, meaning `e:P` | -| `P` | `P` | For non-reachabilitiy named permission `P`, prove `args` _weakens to_ `mb_args`, where write modalities weaken to read, bigger lifetimes weaken to smaller ones, and otherwise arguments weaken to themselves | -| `p1 * ... * pi-1 * P * pi+1 * ... pn` | `P` | Similar to above | -| `p` | `P` | If `P` is a _defined_ (i.e., non-recursive) name, unfold `P` to its definition and recurse | -| `P` | `mb_p` | If `P` is a defined name, unfold `P` to its definition and recurse | -| `p1 * ... * pi-1 * P * pi+1 * ... pn` | `mb_p` | If `P` is defined, unfold `P` to its definition and recurse | -| `P1` | `P2` | If `P1` and `P2` are both recursively-defined, nondeterminstically choose one side to unfold | -| `p1 * ... * pi-1 * P1 * pi+1 * ... pn` | `P2` | If `P1` and `P2` are both recursively-defined, nondeterminstically choose one side to unfold | -| `p` | `P` | If `P` is recursive, unfold `P` and recurse | -| `P` | `mb_p` | If `P1` and `P2` are both recursively-defined, nondeterminstically choose - - -## Proving Equalities and Equality Permissions - -Equality permissions are proved by `proveVarEq`, which takes a variable `x` and an expresson `mb_e` in a binding of the existential variables, and proves `x:eq(e)` for some instantiation `e` of the variables in `mb_e`. This function pushes a reflexive proof that `x:eq(x)`, calls `proveEq` to build an equality proof that `x=e`, and uses the equality proof with the `SImpl_CastPerm` rule to cast the proof of `x:eq(x)` on top of the stack to `x:eq(e)`. The meat of `proveVarEq` is thus in `proveEq`, which attempts to build equality proofs. The `proveEq` function is also called in other parts of the implication prover, e.g., to coerce the modalities of field, array, and block permissions. - -An equality proof in Heapster is a transitive sequence of equality proof steps `e=e',e'=e'',...`. Each step is a sequence of equality permissions `x1:eq(e1),...,xn:eq(en)`, where each equality `xi:eq(ei)` is oriented either left-to-right as `xi=ei` or right-to-left as `ei=xi`, along with a function `f` on `n` expressions. This represents the equality `f(left1,...,leftn)=f(right1,...,rightn)`, where `lefti` and `righti` are the left- and right-hand sides of the `i`th oriented version `xi=ei` or `ei=xi` of the permission `xi:eq(ei)`. Equality steps are represented by the Haskell type `EqProofStep ps a`, where `ps` is a list of the types of the variables `x1,...,xn` and `a` is the Haskell type of the objects being proved equal. (Equality proofs can be used not just on expressions, but at other types as well.) Entire equality proofs are represented by the type `EqProof ps a`, while the type `SomeEqProof a` is an equality proof where the permissions needed to prove it are existentially quantified. - -[comment]: <> (FIXME HERE: describe `proveEq` and `proveEqH`) - - -## Proving Conjuncts of Permissions - -Conjuncts `p1 * ... * pn` are proved by `proveVarConjImpl`, which repeatedly picks the "best" permission on the right to prove and calls `proveVarAtomicImpl` to prove it. Finding the "best" permission prioritizes defined permissions first, followed by recursive permissions, as this fits with the named permissions algorithm described above, followed by finding a permission whose needed variables have all been determined. - -The cases for `proveVarAtomicImpl` are as follows: - -| Permission to prove | Algorithmic steps taken | -|----------------|--------------------| -| `[l]ptr((rw,off) \|-> p)` | Call `proveVarLLVMField` | -| `[l]array(rw,off, p)`, the `proveVarLLVMField` function starts by first calling `implGetLLVMPermForOffset` to find a permission on the left that contains `off`. If this permission is a `memblock` permission, it is repeatedly eliminated, using the helper function `implElimLLVMBlock`, until an array or field permission is obtained. This permission is then passed to `proveVarLLVMFieldH`, which calls `proveVarLLVMFieldH2`, which dispatches based on the form of the permission. We call this the left-hand permission in this discussion, since `implGetLLVMPermForOffset` puts it on the top of the stack, i.e., the left of the implication. - -The main case `proveVarLLVMFieldH2` is when the left-hand permission is a field permission -`[l']ptr((rw',off) |-> p')` of the same size as the required one. In this case, `proveVarLLVMFieldH2` performs the following steps: -* Eliminate the contents of the field permission to get a permission of the form `[l']ptr((rw',off) |-> eq(y))` for some variable `y`; -* Prove `y:p` with a recursive call to `proveVarImplInt`; -* Use the `SImpl_IntroLLVMFieldContents` to combine the `y:p` permission into the left-hand permission to get `[l']ptr((rw',off) |-> p)`; -* Coerce the lifetime `l'` to `l` by calling `proveVarLifetimeFunctor`, which splits or ends lifetimes as needed; -* Coerce `rw'` to `rw` by calling `equalizeRWs`, which either proves the two are equal using `proveEq` and casting or weakens a write modality to a read modality; and -* Duplicate and recombine the pointer permission if it is copyable. - -If the left-hand permission is a pointer permission that is bigger than required, split the left-hand permission by calling `implLLVMFieldSplit`, recombine the part that is not required, and recursively call `proveVarLLVMFieldH` with the remaining left-hand permission. - -If the left-hand permission is a pointer permission that is smaller than required: -* Recursively call `proveVarLLVMFieldH` with the same left-hand permission to prove a pointer permission `[l]ptr((rw,off) |-> eq(y))` of the same size, i.e., with existential variable `y:llvmptr (8*sz)` where `sz` is the size of the left-hand permission in bytes; -* Prove `[l]ptr((rw,off+sz) |-> eq(z))` for existential variables `z` of the remaining size; -* Call `implLLVMFieldConcat` to concatenate these two field permissions; and -* Call `proveVarLLVMFieldH` with the resulting permission of the correct size as the left-hand permission. - -If the left-hand permission is an array permission where the required permission lines up with one of the cells of the array, borrow or copy (depending on whether the array is copyable) the corresponding array cell and recursively call `proveVarLLVMFieldH` with the cell permission that was borrowed. - -If the left-hand permission is an array permission where the required permission covers multiple cells of the array, borrow or copy those cells (depending on whether the array is copyable) as a single array permission, coerce the resulting cells to a field using the `SImpl_LLVMArrayToField` rule, and pass the resulting permission as the left-hand permission of a recursive call to `proveVarLLVMFieldH`. - -In all other cases, `proveVarLLVMFieldH2` fails. - - -## Proving Array Permissions - - - -## Proving Block Permissions - diff --git a/heapster/doc/Permissions.md b/heapster/doc/Permissions.md deleted file mode 100644 index 03853781bd..0000000000 --- a/heapster/doc/Permissions.md +++ /dev/null @@ -1,127 +0,0 @@ -Summary of Metavariables -======================== - -In this document, we use the following metavariables to refer to different sorts of data. - - **Metavariable** | **Description** - ------------------ | -------------------------------- - `a` | Permission type - `e` | Permission expression - `b`, `w` | Bitvector expression - `x` | Permission expression variable - `rw` | ReadWrite modality expression - `sh` | Shape expression - `l` | Lifetime expression - `p` | Value permission - - - -Value Types -================ - -The Heapster value types include the regular crucible types as well as heapster-specific types: - -| **Permission Types `a`** | **Description** | -| :---: | :--- | -| `unit` | Crucible unit type | -| `bool` | Crucible boolean type | -| `nat` | Crucible type of natural numbers | -| `bv w` | Crucible bitvector type of width `w` | -| `struct(a1,..,an)` | Crucible struct type \[equivalent to a tuple, not to be used for C structs\] | -| `llvmptr w` | llvm-specific crucible type of pointers of width `w` | -| `rwmodality` | type of modality for read or write permissions | -| `permlist` | type of a list of permissions - outdated | -| `llvmframe w` | type of ghost objects that represent the current stack frame with respect to bitvectors of width `w` | -| `perm(a)` | type of permissions describing how to use an object of type `a`. That is, the proposition `x:p` for a permission `p` of type `perm(a)` means "`a` value `x` of type `a` has permission `p`". | -| `llvmshape w` | type of shapes with respect to bitvectors of width `w` | -| `llvmblock w` | type of blocks of memory with respect to bitvectors of width `w` | - -Permission expressions -====================== - -Expressions that are considered \"pure\" for use in permissions. - -A llvm-pointer (aka an llvm value) is either an llvmword or a variable+an offset - -Any crucible type can have a variable of that type, and that thing is an expression - -| Permission Expressions `e` | Type | Description | -| :---: | :---: | :--- | -| `x` | any | Any expression variable | -| `unit` | `unit` | A unit literal | -| `b` | `bool` | A literal boolean value | -| `n` | `nat` | A literal natural number | -| `n` | `bv w` | A literal bitvector | -| `b1 + b2` | `bv w` | Sum of two bitvectors | -| `-b` | `bv w` | 2's complement negation of a bitvector | -| `b1 * b2` | `bv w` | Linear multiplication of two bitvectors, meaning that one of the operands must be a constant | -| `struct(e1,..,en)` | `struct(a1,..,an)` | A (crucible) struct is a tuple of expressions for each argument of the struct type. Crucible structs are different from C structs, and we only use crucible structs when we need to, otherwise C structs are described manually as pointers into chunks of memory | -| `llvmword(e)` | `llvmptr(w)` | An LLVM value that represents a word, i.e. whose region identifier is 0, given a bitvector expression `e:bv w` | -| `x &+ o` | `llvmptr(w)` | An LLVM pointer built by adding an offset `o` (a bitvector expression) to an LLVM pointer variable `x` | -| `R` | `rwmodality` | The read modality | -| `W` | `rwmodality` | The write modality | -| `p` | `perm(a)` | A permission as an expression | - -In addition to the above expressions, we also have shape expressions, which we separated out only for the sake of readability. - -| Shape Permission Expressions `sh` | Type | Description | -| :---: | :---: | :--- | -| `emptysh` | `llvmshape w` | The empty shape | -| `name` | `llvmshape w` | A named shape along with arguments for it, with optional read/write and lifetime modalities that are applied to the body of the shape. Named shapes can either be (1) defined shapes (alias) (2) recursive shapes, or (3) opaque shapes (axioms-all you know is their length). | -| `eqsh(e)` | `llvmshape w` | A shape equal to the llvmblock `e`, where `e` is an expression of type `llvmblock w`. Used to type memcpy. | -| `sh1 orsh sh2` | `llvmshape w` | A disjunctive shape. `sh1` and `sh2` need not have the same size. | -| `sh1 ; sh2` | `llvmshape w` | A sequence of two shapes | -| `[l]ptrsh(rw,sh)` | `llvmshape w` | A shape for a pointer to another memory block, i.e. a memblock permission, with a given shape. This memblock permission will have the same read/write and lifetime modalities as the memblock permission containing this pointer shape, unless they are specifically overridden by the pointer shape; i.e., we have that `[l]memblock(rw,off,len,[l']ptrsh(rw',sh)) = [l]memblock(rw,off,len, fieldsh([l']memblock(rw',0,len(sh),sh)))`, where `rw'` and/or `l'` can be `Nothing`, in which case they default to `rw` and `l`, respectively. | -| `fieldsh(sz,p)` | `llvmshape w` | A shape for a single pointer field, given a permission `p` that acts on a pointer of size `sz`. | -| `fieldsh(p)` | `llvmshape w` | Equivalent to `fieldsh(w,p)`. | -| `arraysh(s,len,sh)` | `llvmshape w` | A shape for an array with the given stride, length (in number of elements = total length / stride), and fields `sh` | -| `exsh x:a.sh` | `llvmshape w` | An existential shape | -| `falsesh` | `llvmshape w` | The unsatisfiable or contradictory shape | - - -Value permissions -================= - -A value permission is a permission to do something with a value, such as use it as a pointer. This also includes a limited set of predicates on values (you can think about this as \"permission to assume the value satisfies this predicate\" if you like). - -The type of permissions, `perm(a)`, can be thought of as a function from values of type a to a pair of a proposition and a rely-guarantee permission. - -``` -[| perm(a) |] = a -> (prop * rely-guarantee permission) -``` - -For example, informally: - -``` -[| ptr((W,0) ⊢> true) |] = \x -> - (x is allocated, you can read/write to *x in - the current memory and no one else can) - -[| ptr((R,0) ⊢> true) |] = \x -> - (x is allocated, you can read from *x in the current memory - and no one else can write to it) -``` - -For a variable `x:a`, the proposition `x:p` means "`x` has permission `p`": this takes `[|p|]:a -> (prop * RG perm)` and applies it to `x:a` to get a `(prop * rg perm)` - -| Permissions `p` | Type | Description | -| :---: | :---: | :--- | -| `true` | `perm(a)` | trivial permission that always holds | -| `p1 or p2` | `perm(a)` | disjunction; both `p1` and `p2` must satisfy `perm(a)` | -| `p1 * p2` | `perm(a)` | separating conjunction; `p1` and `p2` (both satisfying `perm(a)`) must be atomic permissions (not a disjunction, existential, or equality permission) | -| `eq(e)` | `perm(a)` | a value equal to the expression `e:a` | -| `exists x:a. p` | `perm(b)` | there exists some expression `e:a` such that `p[e/x]:perm(b)` holds | -| `false` | `perm(a)` | The unsatisfiable or contradictory permission | -| `x@o` | `perm(a)` | A named permission with expression arguments, with optional offset expression `o`. Named permissions can either be (1) defined permissions (aliases) (2) recursive permissions, or (3) opaque permissions (axioms). | -| `[l]array(rw, off,
  • `l` is the lifetime during which this permission is active;
  • `off` is a permission expression representing the offset of this array from the pointer in bytes;
  • `len` is a permission expression representing the number of cells in the array;
  • `stride` is a permission expression representing the number of bytes in a cell;
  • `sh` is a shape expression representing the shape of elements in the array
    • | -| `[l]memblock(rw,o,len,sh)` | `perm(llvmptr w)` | gives read or write access to a memory block, whose contents also give some permissions, where:
    • `rw` indicates whether this is a read or write block permission
    • `l` is the lifetime during which this block permission is active
    • `o` is the offset of the block from the pointer in bytes
    • `len` is the length of the block in bytes
    • `sh` is the shape of the block
    | -| `free(e)` | `perm(llvmptr w)` | Says that we have permission to free the memory pointed at by this pointer if we have write permission to `e` words of size `w`, where `e` is a permission expression for a bitvector of width `w`. Superseded by opaque permissions. | -| `[l]ptr((rw,o) \|-> p)` | `perm(llvmptr w)` | pointer permission where
    • `l` is a lifetime during which the permission can be used
    • `rw` is a read or write token
    • `o` is the offset from the variable the permission applies to where the read or write is being allowed
    • `p` is the permission held by the value being pointed to at the offset, of type `perm(llvmptr w)`.
    This is similar to `exists y. [l]ptr((rw,o) ⊢> eq(y)) * y:p` but we can't actually write this in Heapster because we can't write `y:p` on locally-bound variables. | -| `[l]ptr((rw,o,sz) \|-> p)` | `perm(llvmptr w)` | Similar to `[l]ptr((rw,o) ⊢> p)` but where the value pointed to has `sz` bits, i.e., `p:llvmptr sz`. So, for `x : llvmptr w` (`w` = number of bits), the permission `[l]ptr((rw,o) ⊢> p)` is equivalent to `[l]ptr((rw,o,w) ⊢> p)` | -| `shape(sh)` | `perm(llvmblock w)` | Says that a memory block has shape expression `sh` | -| `lowned [ls](x1:P1,... -o x1':P1',...)` | `perm(l)` | Permission `l:lowned (...)` says that the current task/process/function/code *owns* lifetime `l`. A lifetime intuitively represents a period of time, during which it is "current" and after which it is "finished". Ownership of `l` is the permission to end `l` whenever you want, assuming certain conditions (described below) are met, along with the knowledge that `l` has not yet been ended, i.e., that `l` is current. This latter knowledge allows the owner of `l` to use permissions like `[l]ptr(...)` that depend on `l` being current.
    Most of the structure of the lowned permission describes the conditions under which `l` can be ended. The list `ls` contains lifetimes that are contained in `l`, meaning they must end before `l` ends. Once all lifetimes in ls are finished, the act of ending `l` can be performed, and has permission type given by the implication `∏in -o ∏out`, where each `∏` is a list of the form `x1:P1, ..., xn:Pn`. That is, ending `l` requires permissions `∏in` to be "given back" to `l`, and in exchange the ender gets permissions `∏out`, which are intuitively being held by `l` until it is finished. | -| `[l']lcurrent` | `perm(l)` | Assertion that a lifetime `l` is current during another lifetime expression `l'` | -| `lfinished` | `perm(l)` | Assertion that a lifetime has finished | -| `llvmfunptr{n,w}((x0:p_g,...) arg0:p0,... -o arg0:p0',...,ret:p_ret)` | `perm(llvmptr w)` | Says an LLVM value is a pointer to a function with `n` arguments, each of which have type `llvmptr w` (i.e., have bit width `w`), and with output type `llvmptr w`. This function takes in ghost arguments `x0:p_g,...`, as well as input permissions given by permission `p0` on the first argument, `p1` on the second, etc.. The function returns permissions `p0'` on the first argument, `p1'` on the second, etc., along with permission pret on the return value.
    Note that `arg0`, `arg1`, etc, and `ret`, are not variables: they must have those names, though the argument variables may occur in any order. | -| `llvmframe[e1:m1,..,en:mn]` | `perm(llvmframe w)` | Permission to allocate (via `alloca`) on an LLVM stack frame, and permission to delete that stack frame if we have exclusive permissions to all the given LLVM pointer objects. The frame permission is a list of permission expressions (`e_i`) for pointers that have been allocated in the frame and their corresponding allocation sizes (`m_i`) in words of size `n`. | -| `struct(p1,..,pn)` | `perm (struct(a1,..,an))` | A struct permission is a sequence of permissions for each argument of the crucible struct type | diff --git a/heapster/doc/Rules.md b/heapster/doc/Rules.md deleted file mode 100644 index 21d3e58e1b..0000000000 --- a/heapster/doc/Rules.md +++ /dev/null @@ -1,115 +0,0 @@ -# Heapster Permission Implication - -Heapster permission implication is a form of _affine logic_, which in turn is a form of the better-known concept of linear logic. Linear logic is a logic where each proposition assumed by a proof must be used exactly once in that proof. Propositions in linear logic can thus be viewed as a form of "resource" that gets used up in building a proof. For example, consider the rule - -``` -dollar * dollar * dollar |- candy_bar -``` - -to represent the concept that a particular candy bar costs $3. Intuitively, the `dollar` proposition represents possession of a dollar, `candy_bar` represents possession of a (reasonably fancy) candy bar, and `*` represents the conjunction of two propositions. A "proof" using this rule consumes three `dollar` propositions and generates one `candy_bar` proposition, intuitively representing the purchase of this candy bar. Importantly, unlike standard classical or even intuitionistic logic, where `p and p` is equivalent to `p`, the conjunction `p * p` in linear logic represents two copies of the proposition `p`, which in general is different than `p` by itself; e.g., if we could prove `dollar |- dollar * dollar` then we could generate all the money we wanted. This is not to say that `p |- p * p` is never true, just that it is only true for some `p`, which correspond to resources that can be duplicated. See any introduction to linear logic for more details. - -Affine logic is a version of linear logic where propositions can be "thrown away", that is, where the rule `p * q |- p` holds for all `p` and `q`. The reason we use affine logic here is that it is useful for describing a notion of _permissions_, where each `p` intuitively corresponds to permission to perform a particular action. It is always justified to forget some permission if you are not going to use it, but you can't in general give yourself more permissions. One of the central permissions used in Heapster is the permission to access memory through a particular pointer. The simplest form of this is the pointer permission `x:ptr((rw,off) |-> p)`, that represents a permission to read — and possibly write, depending on `rw` — memory at offset `off` from `x`, along with permission `y:p` to whatever value `y` is currently stored there. The `array` and `memblock` permissions also represent different forms of permission to read and possibly write memory, with different stipulations on the permissions held for the values currently stored there. Read-only permissions are copyable, meaning that `x:ptr((R,off) |-> p) |- x:ptr((R,off) |-> p) * x:ptr((R,off) |-> p)` can be proved in Heapster, as long as `p` does not contain any write permissions, while write permissions `x:ptr((W,off) |-> p)` are not. This corresponds to the one-writer or multiple readers paradigm of, e.g., Rust. - -The remainder of this section explains Heapster implication. - - -## Permission Implication Rules - -At any given point during type-checking and/or implication proving, Heapster maintains a _permission set_ that describes the current permissions to various objects that are currently held by the program. Permission sets are defined by the `PermSet` type in Permissions.hs, and have two components: the _permissions map_, which maps each variable `x` in scope to what is called the _primary_ permission held on `x`; and the _permissions stack_, which represents the permissions that are actively being used or manipulated. We write a permission set as: - -``` -x1 -> px1 * ... * xm -> pxm; y1:p1 * ... * yn:pn -``` - -The portion before the semicolon represents the permissions map, which maps each `xi` to its primary permission `pxi`, while the portion after the semicolon represents the permissions stack, containing permissions `y1:p1` through `yn:pn` in sequence. The final permissions `yn:pn` is the top of the stack. We often write `PS` for a permission set. - -The general form of permission implication is the judgment - -``` -PS |- (z1_1, ..., z1_k1 . PS1) \/ ... \/ (zn_1, ..., zn_kn . PSn) -``` - -which says that, starting with permission set `PS` on the left-hand side of the turnstyle `|-`, we can prove one of the permission sets `PSi` on the right-hand side. Each disjunctive case could introduce 0 or more existential variables `zi_1, ..., zi_ki`, which can be used in the corresponding permission set `PSi`. We often omit the permissions map and/or the existential variables when they are not necessary; e.g., we write `PS1 |- PS2` instead of `PS1 |- ( [] . PS2)`. We also tend to omit the permissions map from implications, as permissions maps almost never change; thus, e.g., we might write `x:p |- y:q` instead of `x1 -> px1 * ... * xm -> pxm; x:p |- x1 -> px1 * ... * xm -> pxm; y:q`. - -Permission implication in Heapster is actually a sort of "partial implication". The above-displayed implicaiton judgment in fact says that, if we hvae permission set `PS`, we can _try_ to get one of the permission sets `PSi`, though we can't control which one we get, and we might fail. What this failure means exactly is a little hard to define without going into the details of the translation to SAW core / Coq and relationship between the resulting term and the original program. As one way to understand what failure means here, consider that each permission set `PS` actually describes a set of possible states, one for each substitution of values for all the free variables in `PS`. For some of these states, we can exchange the permissions in `PS` for the permissions in one of the `PSi`, though in some of those states, trying to do this leads to undefined behavior, or at least behavior we are not going to reason about. Another way to think about Heapster implication is to always add an extra disjunction `\/ dunno` to each right-hand side, so an implication `PS |- PS1 \/ ... \/ PSn` becomes `PS |- PS1 \/ ... \/ PSn \/ dunno`, meaning that from permissions `PS` we either can get one of the `PSi` or we get a result that says that we have to give up on modeling the current execution of the program. At a slightly more technical level, failure means means that the translation of a failure is just the `errorM` computation, which, again, doesn't mean that the original computation actually has an error, just that we don't know how to reason about it. Either way, we will simply say "prove" or "implies" below instead of something like "partially prove in some states". - -Permission implications are built up from two rules, the identity rule and the step rule. The identity rule is just a proof that `PS |- PS`. The step rule looks like this: - -``` -PS |-(1) (zs1.PS1) \/ ... \/ (zsn.PSn) -PS1 |- (zs1_1.PS1_1) \/ ... \/ (zs1_k1.PS1_k1) -... -PSm |- (zsm_1.PSm_1) \/ ... \/ (zsm_km.PSm_km) ------------------------------------------------------ -PS |- (zs1_1.PS1_1) \/ ... \/ (zs1_k1.PS1_k1) \/ ... \/ (zsm_1.PSm_1) \/ ... \/ (zsm_km.PSm_km) -``` - -Intuitively, this says that we can start with an implication and then apply further implications to each of the output permission sets of the original implication, yielding a bigger implication of all of the disjuncts returned by all of the further implications. The notation `|-(1)` denotes a single step of implication, which is built using one of the single-step rules that we describe below. Intuitively, this means that a permission implication can be viewed as a tree, whose leaves are identity rules and whose internal nodes are step rules whose shapes are defined by the single step `|-(1)` implication. - -Permission implications are represented in Haskell by the type `PermImpl r ps`. The type variable `ps` is a Haskell datakind that specifies a sequence of Crucible types for the variables and permissions on the stack at the beginning of the proof. For example, the representation of an implication `x1:p1 * ... * xn:pn |- PS1 \/ ... \/ PSn` will have type `PermImpl r (RNil :> t1 :> ... :> tn)` in Haskell, where each `xi` has Crucible type `ti` and each `pi` has the corresponding Crucible type `ValuePermType ti` (which is the type of a permission that applies to an element of type `ti`). The datakind `RNil` is the empty sequence. (The "R" stands for "right-associated list", because the cons operator `:>` adds new list elements on the right instead of the left; this datakind is defined in the Hobbits library, but is identical to the one defined in Data.Parameterized.Ctx.) - -In addition to describing the form of an implication, the `PermImpl` representation in Haskell also contains a "result" for each output permission set. That is, permission implications are a form of tree, as described above, and the `PermImpl` type stores results `r1, ..., rn` at each leaf `PS1, ..., PSn` in an implication of `PS |- PS1 \/ ... \/ PSn`. The result type is given by the `r` argument to `PermImpl`, and this type is parameterized by the datakind corresponding to the types of the permissions on the stack at that point. That is, a permission implication `PS |- PS1 \/ ... \/ PSn` will contain elements of type `r ps1` through `r psn`, assuming that each `psi` is the Haskell datakind that represents the stack for each `PSi`. Intuitively, the result does something with the permissions `PSi`. The most common example of this is in the typed representation of functions used in TypedCrucible.hs, where a function can contain a permission implication, using the `TypedImplStmt` constructor, to coerce the permissions it currently holds to some form that is needed to perform an operation. For instance, a `load` instruction requires the permissions currently held by a program to be coerced to a `ptr` permission. Whenever an implication `PS |- PS1 \/ ... \/ PSn` occurs in a typed Crucible representation, the remaining instructions must be type-checked relative to each of the permission sets `PSi`. This is represented by having the `PermImpl` representation contain one copy of the remaining instructions for each output `PSi`, type-checked relative to that permission set. - -The one-step implication rules defined by the `|-(1)` judgment are defined by the `PermImpl1 ps_in ps_outs` type, which represents a rule with input stack described by datakind `ps_in` and 0 or more disjunctive output stacks given by `ps_outs`, which is a list of 0 or more disjuncts that bind 0 or more existential variables and leave 0 or more types on the stack. (See the documentation of `PermImpl1` for more details.) These include the following rules (along with a few more that we do not discuss here): - -| Rule name | Rule description | Rule implication | -----------|-------------|-----------------| -| `Impl1_Fail` | Failure of implication | `ps \|-(1) empty` (where `empty` is 0 disjuncts) | -| `Impl1_Catch` | Try one implication and then a second if the first fails | `ps \|-(1) ps \/ ps` | -| `Impl1_Push` | Push the primary permission for `x` onto the stack | `..., x -> p; ps \|-(1) ..., x -> true; ps * x:p` | -| `Impl1_Pop` | Pop the top of the stack back to the primary permission for `x` | `..., x -> true; ps * x:p \|-(1) ..., x -> p; ps` | -| `Impl1_ElimOr` | Eliminate a disjunction on the top of the stack | `ps * x:(p1 or p2) \|-(1) (ps * x:p1) \/ (ps * x:p2)` | -| `Impl1_ElimExists` | Eliminate an existential on the top of the stack | `ps * x:(exists z.p) \|-(1) (z. ps * x:p)` | -| `Impl1_Simpl` | Apply a simple implication of the form `ps1 \|- ps2` | `ps * ps1 \|-(1) ps * ps2` | -| `Impl1_ElimLLVMFieldContents` | Extract the contents of an LLVM pointer permission | `ps * x:ptr((rw,off) -> p) \|-(1) y. ps * x:ptr((rw,off) -> eq(y)) * y:p` | - -[comment]: <> (FIXME: explain the above rules!) - -The most common implication rule is `Impl1_Simpl`, which applies a "simple" implication rule that exactly only one disjunctive output permission and binds no variables. The simple implication rules are described by the type `SimplImpl ps_in ps_out`. A rule of this type assumes that permissions `ps_in` are on the top of the stack, though there can be more permissions below these on the stack. It then consumes `ps_in`, replacing them with permissions `ps_out`. (As above, the `ps_in` and `ps_out` type arguments in Haskell are actually datakinds capturing the types of the input and output permissions of the rule.) These include too many rules to list here, so we only describe enough of them to give a flavor of what they do. - -Some of the simple implication rules are structural. These include the following: - -| Rule name | Rule description | Rule implication | -----------|-------------|-----------------| -| `SImpl_Drop` | Drop a permission | `x:p \|- .` | -| `SImpl_Copy` | Copy any permission that is copyable, i.e., satisfies `permIsCopyable` | `x:p \|- x:p * x:p` | -| `SImpl_Swap` | Swap the top two permissions on the stack | `x:p1 * y:p2 \|- y:p2 * x:p1` | -| `SImpl_MoveUp` | Move a permission towards the top of the stack | `x:p * ps1 * ps2 \|- ps1 * x:p * ps2` | -| `SImpl_MoveDown` | Move a permission away from the top of the stack | `ps1 * x:p * ps2 \|- x:p * ps1 * ps2` | -| `SImpl_IntroConj` | Prove an empty conjunction (which is the same as `true`) | `. \|- x:true` | -| `SImpl_ExtractConj` | Extract the `i`th conjunct of a conjunction | `x:(p0 * ... * p(n-1)) \|- x:pi * x:(p0 * ... p(i-1) * p(i+1) ... * p(n-1))` | -| `SImpl_CopyConj` | Copy the `i`th conjunct of a conjunction, assuming it is copyable | `x:(p0 * ... * p (n-1)) \|- x:pi * x:(p0 * ... * p(n-1))` | -| `SImpl_InsertConj` | Insert a permission into a conjunction | `x:p * x:(p0 * ... * p(n-1)) \|- x:(p0 * ... * p(i-1) * p * pi * ... * p(n-1))` | -| `SImpl_AppendConjs` | Combine the top two conjunctions on the stack | `x:(p1 * ... * pi) * x:(pi+1 * ... * pn) \|- x:(p1 * ... * pn)` | -| `SImpl_SplitConjs` | Split the conjunctive permissions on the top of the stack in two | `x:(p1 * ... * pn) \|- x:(p1 * ... * pi) * x:(pi+1 * ... * pn)` | - - -The elimination rules for disjunctions and existentials are `PermImpl1`s, because the former has multiple disjuncts and the latter introduces local variables, but their introduction rules are simple implications, as are both the introduction and elimination rules for named permissions: - -| Rule name | Rule description | Rule implication | -----------|-------------|-----------------| -| `SImpl_IntroOrL` | Prove a disjunctive permission from its left disjunct | `x:p1 \|- x:(p1 or p2)` | -| `SImpl_IntroOrR` | Prove a disjunctive permission from its right disjunct | `x:p2 \|- x:(p1 or p2)` | -| `SImpl_IntroExists` | Prove an existential permission from a substitution instance | `x:[e/z]p \|- x:(exists z.p)` | -| `SImpl_FoldNamed` | Prove a named permission from its unfolding | `x:(unfold P args) \|- x:P` | -| `SImpl_UnfoldNamed` | Eliminate a named permission by unfolding it | `x:P \|- x:(unfold P args)` | - - -Equality permissions are manipulated with the following simple implication rules: - -| Rule name | Rule description | Rule implication | -----------|-------------|-----------------| -| `SImpl_IntroEqRefl` | Prove any `x` equals itself | `. \|- x:eq(x)` | -| `SImpl_InvertEq` | Prove if `x` equals `y` then `y` equals `x` | `x:eq(y) \|- y:eq(x)` | -| `SImpl_InvTransEq` | Prove that if `x` and `y` equal the same `e` then they equal each other | `x:eq(e) * y:eq(e) \|- x:eq(y)` | -| `SImpl_LLVMWordEq` | If `y` equals `e` then `llvmword(y)` equals `llvmword(e)` | `x:eq(llvmword(y)) * y:eq(e) \|- x:eq(llvmword(e))` | -| `SImpl_LLVMOffsetZeroEq` | Offsetting an LLVM value by `0` preserves equality | `. \|- x:eq(x &+ 0)` | -| `SImpl_InvertLLVMOffsetEq` | Subtract an offset from both sides of an LLVM value equality | `x:eq(y+off) \|- y:eq(x-off)` | -| `SImpl_Cast` | Cast the variable of a permission using an equality | `x:eq(y) * y:p \|- x:p` | -| `SImpl_CastPerm` | Cast a permission `p` to `p'`, assuming that `x1=e1`, ..., `xn=en` imply that `p=p'` | `x1:eq(e1) * ... * xn:eq(en) * x:p \|- x:p'` | - - -[comment]: <> (FIXME: Implementation of the rules: `simplImplIn` and `simplImplOut`, `applyImpl1`: these all check for correct perms) - -[comment]: <> (FIXME: Explain overall pattern of the simplimpl rules: intro vs elim rules for most constructs) - diff --git a/heapster/doc/Rust.md b/heapster/doc/Rust.md deleted file mode 100644 index d1cfc1a667..0000000000 --- a/heapster/doc/Rust.md +++ /dev/null @@ -1,11 +0,0 @@ - -# Type-checking Rust with Heapster - -FIXME: write a simple tutorial -- Defining types -- Symbols and name-mangling -- Assuming standard library functions -- Assuming low-level primitives like `memcpy`; refer to the - [Rust Translation](RustTrans.md) for more detail about the relationship between - Rust and Heapster types -- Type-checking diff --git a/heapster/doc/RustTrans.md b/heapster/doc/RustTrans.md deleted file mode 100644 index 838e8a5e53..0000000000 --- a/heapster/doc/RustTrans.md +++ /dev/null @@ -1,649 +0,0 @@ - -# Rust-to-Heapster Translation - -In this document, we describe the automated translation from Rust types to -Heapster permissions. Because some of the details of how Rust types are laid out -in memory are not explicitly defined by the Rust specification, some of this -translation has been informed by experimentation with how Rust compiles various -functions and types, so may not be entirely complete or accurate, but it so far -seems to work in most cases. - - -## Translating Expression Types - -Unlike in many languages where types describe program values, Rust types in fact -describe the shape and structure of blocks of memory. Each Rust variable -designates a block of memory where the value of the variable is stored. The type -of the variable then describes the shape of that memory. Thus, Rust types are -translated to Heapster shape expressions, which Heapster uses to describe -memory. Heapster shapes are documented [here](Permissions.md). - -The basic conversion from Rust is described in the following table, though Rust -implements a number of layout optimizations, described below, that alter this -translation. In this table, we write `[| T |]` for the translation of Rust type -`T` to a Heapster shape, and we write `len(sh)` for the Heapster expression -giving the length of Heapster shape `sh`, when this is defined. The notation -`[\| Name \|]` denotes the translation of the type definition associated with -type name `Name`, as defined in the next section. - - -| Rust Type | Translation to a Heapster Shape | -|--------|--------------------| -| `Box` | `ptr((W,0) \|-> [\| T \|])` | -| `&mut 'a [T]` | see below | -| `&mut 'a T` | `[a]ptrsh(W,[\| T \|])` if `T` is not a DST | -| `&'a [T]` | see below | -| `&'a T` | `[a]ptrsh(R,[\| T \|])` if `T` is not a DST | -| `[T;N]` | `arraysh(N, [\| T \|])` | -| `(T1,...,Tn)` | `[\| T1 \|] ; ... ; [\| Tn \|]` | -| `Name<'a1,...,'am,T1,...,Tn>` | `[\| Name \|] (a1, ..., am, [\| T1 \|], ..., [\| Tn \|])` | -| `!` | `falsesh` | - - -Types of the form `&mut 'a [T]` and `&'a [T]` are treated specially in Rust, -because these are references to a slice type `[T]` of unknown size. In Rust, -types with unknown size are called _dynamically sized types_ or DSTs. These -require special treatment in order to ensure that dereferences are always -bounds-checked to be in the bounds of the slice. To make this possible, -references to DSTs are always "fat pointers" that are a pointer value along with -an integer value that says how many elements are in the slice pointed to by the -pointer. Thus, the type `&mut 'a [T]` is translated as follows: - -``` -exsh n:bv 64.[a]ptrsh(W,arraysh(n,[| T |]));eq(llvmword(n)) -``` - -This shape says there exists an `n` such that the first field in a memory block -of this shape points to an array of `n` elements, each of which have shape -`[| T |]`, while the second field is an LLVM word value equal to `n`. Read -references `&'a [T]` to slices are translated similarly, but with read instead -of write pointer shapes. - - - -## Translating Type Definitions - -Rust includes type definitions for structure and enumeration types, which allow -the user to define a type name `Name` as either a sequence of Rust types or a -tagged disjunction of sequences of Rust types, respectively. These type -definitions can be polymorphic, meaning that the can quantify over Rust -lifetimes and types. They can also be recursive, meaning the definition of -`Name` can include `Name` itself. - -Both structure and enumeration types are translated to Heapster by using the SAW -command - -``` -heapster_define_rust_type env "...Rust type definition..." -``` - -This command adds a Heapster named shape to the current Heapster environment -`env` with the same name as the Rust type definition. - - -Rust structure types are written - -``` -pub struct Name<'a1,...,'am,X1,...,Xn> { fld1 : T1, ..., fldn : Tn } -``` - -This type is essentially a sequence type, and is translated to a Heapster named -shape defined as follows: -``` -Name = [\| T1 \|] ; ... ; [\| Tn \|] -``` -As with the translation of Rust tuple types, this translates a Rust structure -type to the sequence shape built from sequencing the translations of the -structure fields. Note that Heapster named shapes can be recursive, which is the -case is the original definition of `Name` is recursive. - - -Rust enumeration types are written - -``` -enum Name<'a1,...,'am,X1,...,Xn> { - Ctor1 (T1_1,...,T1_k1), - Ctor2 (T2_1,...,T2_k2), - ... - Ctorl (Tl_1,...,Tl_kl) -} -``` - -This defines `Name` as a disjunctive type, whose elements are sequences of one -of the lists `Ti_1, ..., Ti_ki` of types. To identify which of these disjunctive -cases holds for a particular block of memory, the block always starts with a -tag, also called a _discriminant_, that is an integer in the range `0,...,l-1`. -An enumeration type like the above is translated to Heapster as follows: - -``` -Name = - (fieldsh(eq(llvmword(0))) ; [| T1_1 |] ; ... ; [| T1_k1 |]) orsh - (fieldsh(eq(llvmword(1))) ; [| T2_1 |] ; ... ; [| T2_k2 |]) orsh - ... - (fieldsh(eq(llvmword(l-1))) ; [| Tl_1 |] ; ... ; [| Tl_kl |]) -``` - -(NOTE: Technically speaking, this translation assumes the enum has been -flagged with the `#[repr(C,u64)]` pragma to indicate that the discriminant is a -64-bit integer and that the type is laid out in a C-compatible manner.) - - -## Niche Optimization - -As an optimization, Rust has one exception to the rules given above for enums -that is called _niche optimization_. To define niche optimization, we first -define the notion of an _option-like_ enum, which is an enum type that has one -constructor with a field of some type `T` and one constructor with no fields. -The type `T` is called the _payload_ of the option-like enum type. The primary -example is the type `Option`, defined (in the Rust standard library) as -follows: - -``` -enum Option { None, Some (X) } -``` - -A _niche_ in a type `T` is any bit pattern with the same size as `T` but that is -disallowed by the shape requirements of `T`. For instance, the `Box` and -reference pointer types in Rust are required to be non-null, so the null value -is a niche for these types. Similarly, an enum type with `N` fields, numbered -`0` through `N-1`, has a niche where the discriminant is set to the value `N`. - -The high-level idea of niche optimization is that the fieldless constructor of -an option-like type can be represented by a niche value in its payload type. -This reduces the size of the elements of this type by eliminating the need for -its discriminant. Thus, for example, the `Option` Rust type is translated to the -following cases: - -``` -Option<[a]ptr((rw,off) |-> p)> = eq(llvmword(0)) or [a]ptr((rw,off) |-> p) -Option<(fieldsh(eq(llvmword(0)));sh0) orsh ... orsh (fieldsh(eq(llvmword(n)));shn)> = - (fieldsh(eq(llvmword(0)));sh0) orsh ... orsh (fieldsh(eq(llvmword(n)));shn) - orsh fieldsh(eq(llvmword(n+1))) -Option = - fieldsh(eq(llvmword(0))) orsh (fieldsh(eq(llvmword(1)));X) -``` - - -## Translating Function Types - -Rust function definitions are written like this: - -``` -fn foo <'a1,...,'am> (x1 : T1, ..., xn : Tn) -> T { ... } -``` - -This defines `foo` as a function that is polymorphic over `m` lifetimes that -takes `n` input arguments of types `T1` through `Tn` to an output value of type -`T`. Note that Rust function types can in general be polymorphic over type -variables as well, but Rust compilation to LLVM always monomorphizes these -polymorphic function types, so Heapster, which runs on LLVM code, never sees -these polymorphic types. In Heapster, we write the type of this function as: - -``` -<'a1,...,'am> fn (x1 : T1, ..., xk : Tk) -> T -``` - -where the variable names are optional. For technical reasons, Rust does not -actually allow polymorphic function types, but only supports non-polymorphic -functions types, starting with the `fn` keyword, so this is a syntactic -extension supported by Heapster. - -Rust function types are translated to Heapster function types in two steps. The -first step is argument layout. Argument layout takes the translations of the -Rust argument types to Heapster shapes, which describe the shape of memory -blocks, and lays out those memory block shapes onto register values. At a high -level, this step can be seen as bridging the gap between Rust types, which -describe blocks of memory, and LLVM types, which describe values. The second -step is to add lifetime permissions. This step generates lifetime ownership -permissions for each of the lifetime variables `'ai` in the Rust function type. -The remainder of this section illustrates this translation process through some -examples, and then defines each of the two function type translation steps in -detail. - - -### How Function Types are Translated - -For function types with no lifetimes whose arguments and return values all fit -into a single register (which we assume is 64-bits), the translation is -straightforward. For example, consider the following `box_read` function, that -reads a 64-bit unsigned value from a `Box` pointer: - -``` -fn box_read (p:Box) -> u64 { *p } -``` - -The type of `box_read` is `(Box) -> u64`, which translates to the Heapster -function type - -``` -arg0:ptr((W,0) |-> exists z. eq(llvmword(z))) -o arg0:true, ret:exists z. eq(llvmword(z)) -``` - -This type says that the first and only argument, `arg0`, is a pointer to an LLVM -word value when the function is called. More specifically, the permission -`exists z.eq(llvmword(z))` describes an LLVM value that is a word, or numeric, -value, as opposed to a pointer value. Because it is so common, Heapster scripts -often define the abbreviation `int64<>` for this permission, and we shall use -this abbreviation in the remaining examples here. The return value `ret` for our -example is also an LLVM word value. On return, no permissions are held on the -`arg0` value, reflecting the fact that the `Box` pointer passed into `box_read` -is deallocated by that function. - -If an argument type does not fit into a single register but does fit into two -registers, Rust will lay it out across two argument values at the LLVM level. -For example, let us define a struct type `Pair64` of pairs of 64-bit integers -and a function `pair_proj1` to project out the first element of such a struct as -follows: - -``` -struct Pair64 { proj1 : u64, proj2 : u64 } - -fn pair_proj1 (p:Pair64) -> u64 { p.1 } -``` - -The `Pair64` structure fits into two 64-bit registers, so the type of -`pair_proj1` is translated to the Heapster type - -``` -arg0:int64<>, arg1:int64<> -o ret:int64<> -``` - -Note that, if the input or output permission on an argument is the vacuous -permission `true`, it can be omitted, so the above permission states that no -permissions are returned with the argument values `arg0` and `arg1`. - -If the return value fits into two registers, Rust returns it as a two-element -structure, so, for instance, the Rust function type `fn (Pair64) -> Pair64` -translates to the Heapster type - -``` -arg0:int64<>, arg1:int64<> -o struct(int64<>,int64<>) -``` - -Fieldless enums, which is the Rust name for enum types where none of the -constructors has any fields, can be laid out in a single register for the -discriminant. For enum types with fields, if all the fields of each constructor -of an enum fit into a single register, then the entire enum is laid out as two -registers, one for the discriminant and one for the field(s) of the -corresponding constructor. This type is a little more complicated to represent -in Heapster, because the disjunction for the enum must apply to multiple values -at the same time. This is accomplished using a ghost variable of struct type, -and stating the the individual arguments equal its projections. For example, if -we define the enum - -``` -#[repr(C,u64)] pub enum Sum { Left (X), Right (Y) } -``` - -then the type `fn (Sum<(),u64>) -> u64` is translated as follows: - -``` -ghost:(struct(eq(llvmword(0)),true) or struct(eq(llvmword(1)),int64<>)), -arg0:eq_proj(ghost,0), arg1:eq_proj(ghost,1) --o -ret:int64<> -``` - -This type says that, on input, the first and second arguments are the first and -second projections, respectively, of some struct given by a ghost variable -`ghost`. The permissions on `ghost` say that either its first field equals `0` -and its second field is unconstrained, corresponding to the `Left` constructor -of the `Sum` type, or its first field equals `1` and its second field is a -64-bit integer, corresponding to the `Right` constructor. As before, the output -permissions are `int64<>` for the return value and no permissions for the input -arguments. - -If the type of an argument does not fit into two registers, Rust passes it by -pointer. That is, if an argument has a type `T` that does not fit into two -registers, then it is treated as if it had type `Box`. For example, if we -define the struct type - -``` -struct Triple64 { triple1:u64, triple2:u64, triple3:u64 } -``` - -then the type `fn (Triple64) -> u64` is translated to - -``` -arg0:memblock(W,0,24,Triple64<>) -o ret:int64<> -``` - -where the named shape `Triple64<>` is defined as the sequence - -``` -fieldsh(int64<>);fieldsh(int64<>);fieldsh(int64<>) -``` - -of three field shapes containing 64-bit integers. The `memblock` input -permission has size `24` because `Triple64<>` has three 8-byte fields, for a -total size of 24 bytes. - -If the return value does not fit into two registers, its value is written to a -pointer that is passed as the first argument. So, for instance, the function -type `fn (Triple64) -> Triple64` is translated to - -``` -arg0:memblock(W,0,24,true), arg1:(W,0,24,Triple64<>) -o arg0:(W,0,24,Triple64<>) -``` - -This indicates that, on input, `arg0` points to a 24-byte memory block. The -`true` shape indicates that this block can be uninitialized, i.e., that no -constraints are made on its shape. The actual input argument of type `Triple64` -is passed as `arg1`. On output, permissions to `arg1` are dropped, but -permissions to `arg0` are changed to have the shape `Triple64<>` of the return -type. - -The remaining complexity in translating function types to Heapster is in -handling lifetimes. This works by adding lifetime ownership permissions to both -the input and output permissions for each lifetime `'a` in the Rust function -type, indicating that lifetime `'a` is active at the start of the function and -when it returns. The input lifetime ownership permission for `'a` says that each -of the permissions mentioning lifetime `'a` has been borrowed from some other, -larger lifetime that is outside of `'a`. The output lifetime ownership -permission for `'a` says that these same permissions are still borrowed by `'a` -from the same outer lifetimes, but that all of those permissions have been -"given back" to `'a` except for those permissions in the output permissions that -still mention `'a`. - -In more detail, recall that a lifetime ownership permission has the form -`a:lowned (ps_in -o ps_out)`. This permission indicates that lifetime `a` -"holds" or "contains" permissions `ps_out`, and is current "leasing out" or -"lending" permissions `ps_in`. Once all of the lent permissions `ps_in` are -returned to lifetime `a`, that lifetime can be ended, and the permissions -`ps_out` that it holds can be recovered. The input lifetime ownership permission -used for `a` has the form `a:lowned (ps_a_in -o ps_a_abs)`, where `ps_a_in` is -the list of all permissions containing `a` in the input of the translated Rust -function type, and `ps_a_abs` is the result of replacing each occurrence of `a` -and its accompanying read/write modality with fresh variables. (NOTE: the actual -input lifetime ownership permission computed by Heapster is the simplified -lifetime ownership permission `a:lowned(ps_a_abs)`, which is logically -equivalent to the above but has a simpler translation.) The output -lifetime ownership permission is `a:lowned (ps_a_out -o ps_a_abs)`, where -`ps_a_out` is the list of all permissions containing `a` in the output of the -translated Rust function type. - -For example, consider the accessor function - -``` -fn <'a> pair_proj1_ref (p:&mut 'a Pair64) -> &mut 'a u64 { &mut p.1 } -``` - -that takes a mutable reference to a `Pair64` and returns a mutable reference to -its first element. The translation of the type of `pair_proj1_ref`, which is the -function type `<'a> fn (&mut 'a Pair64) -> &mut 'a u64`, is the Heapster type - -``` -a:lowned(arg0:[a]ptr((W,0) |-> Pair64<>) -o arg0:[l]ptr((rw,0) |-> Pair64<>)), -arg0:[a]ptr((W,0) |-> Pair64<>) --o -a:lowned(ret:[a]ptr((W,0) |-> int64<>) -o arg0:[l]ptr((rw,0) |-> Pair64<>)), -ret:[a]ptr((W,0) |-> int64<>) -``` - -The input permissions say that `arg0` is a writeable pointer to a `Pair64` -structure, that is only valid while lifetime `a` is active. Further, the input -lifetime ownership permission for `a` says that, when the function is called, -`a` holds pointer permissions to `arg0` relative to some other lifetime `l`, and -is currently lending pointer permissions to `arg0` relative to `a`. The output -permissions say that the return value `ret` is a writeable pointer to a 64-bit -integer that is relative to lifetime `a`. The output lifetime permission for `a` -says that `a` holds the same pointer permission relative to lifetime `l` as on -input, but is only lending out the pointer held by `ret`. - -If a permission containing lifetime `a` is inside another permission, it is -lifted to the top level by creating a ghost variable that holds that permission. -For instance, the type `<'a> fn (Box<&'a u64>) -> u64` is translated to the -Heapster type - -``` -a:lowned(z:[a]ptr((R,0) |-> int64<>) -o z:[l]ptr((rw,0) |-> int64<>)), -arg0:ptr((W,0) |-> eq(z)), z:[a]ptr((R,0) |-> int64<>) --o -a:lowned(empty -o z:[l]ptr((rw,0) |-> int64<>)), -ret:int64<> -``` - -In this case, `z` is a ghost variable used to represent the pointer value -pointed to by `arg0` for which a pointer permission in lifetime `a` is held. As -before, the input lifetime ownership permission for `a` specifies that pointer -permissions for `z` relative to some outer lifetime `l` are held by lifetime -`a`, which is currently lending out a copy of those permissions relative to -lifetime `a`. Since there are no occurrences of `a` in the output Rust type, the -output lifetime ownership permission for `a` indicates that `a` is not lending -any permissions on return from the function, indicated with the `empty` -permissions list. - - -### Argument Layout - -Argument layout converts a shape, which describes the layout and associated -permissions of a memory block, to a permission on a sequence of register values, -if this is possible. Note that this concept is different from the Rust concept -of "type layout", though the two are related. In fact, the notion of argument -layout described here is very undocumented in Rust, and has in fact been -determined by consulting a number of blog posts and by much experimentation. - -In Heapster (as in the underlying Crucible type system), sequences of values are -called structs and a permission on a sequence of values is called a struct -permission. Argument layout is thus defined as a partial function `Lyt(sh)` that -maps a Heapster shape `sh` for a particular function argument to a permission of -type `perm(struct(tp1,...,tpn))` for some value types (i.e., Crucible types) -`tp1` through `tpn`. When the layout of the type `T` of an argument is not -defined --- e.g., if `T` is too big to fit in registers or it is a slice or -other dynamically-sized type that has no well-defined size --- then the -corresponding argument is represented as a pointer to a block of memory with the -shape defined by `T`. - -In order to define `Lyt(sh)`, we first define two helper operations on structure -permissions. Both of these are partial functions that take in two structure -permissions, possibly of different types, and return a structure permission with -some potentially different type. The first of these is the struct permission -append operator `p1 ++ p2`, which combines a struct permission `p1` of type -`perm(struct(tp1,...,tpm))` and `p2` of type `perm(struct(tp1',...,tpn'))` into -a permission of type `perm(struct(tp1,...,tpm,tp1',...,tpn'))` on the append of -structs with permissions `p1` and `p2`. This operation is defined as follows: - -| Permissions `p1` and `p2` to Append | Resulting Permission `p1++p2` | -| ------------------------ | --------------------- | -| `struct(p1,...,pn) ++ struct(q1,...,qm)` = | `struct(p1,...,pn,q1,...,qm)` | -| `(p1 or p2) ++ q` = | `(p1 ++ q) or (p2 ++ q)` | -| `p ++ (q1 or q2)` = | `(p ++ q1) or (p ++ q2)` | -| `(exists z. p) ++ q` = | `exists z. (p ++ q)` | -| `_ ++ _` = | Undefined otherwise | - -The second operation on structure permissions needed here is the disjucntion -operation `p1 \/ p2`. Intuitively, this operation takes the disjunction of the -two struct permissions `p1` and `p2` after first equalizing the number of -registers they refer to. More formally, this `p1 \/ p2` is defined as follows: - -* If `p1=struct(p1')` and `p2=struct(p2')` where `p1'` and `p2'` have the same - type, then `p1 \/ p2=struct(p1' or p2')`; - -* If there is a permission `p1' = p1 ++ struct(true,true,...,true)` of the same - type as `p2`, then `p1 \/ p2` is defined as the disjunction `p1' or p2`; - -* If there is a permission `p2' = p2 ++ struct(true,true,...,true)` of the same - type as `p1`, then `p1 \/ p2` is defined as the disjunction `p1 or p2'`; - -* Otherwise, `p1 \/ p2` is undefined. - -Using these operations, the layout function `Lyt(sh)` is defined as follows: - -| Heapster shape | Its layout as a struct permission | -|--------------|--------------------------| -| `Lyt(emptysh)` = | `struct()` | -| `Lyt(Name)` = | `Lyt(unfold(Name,args))` | -| `Lyt(fieldsh(p))` = | `struct(p)` | -| `Lyt(arraysh(k,stride,sh))` = | `Lyt(sh;...;sh)` for `k` copies of `sh`, if `8*len(sh)=stride` | -| `Lyt(arraysh(_,_,_))` = | undefined otherwise | -| `Lyt(sh1 ; sh2)` = | `Lyt(sh1) ++ Lyt(sh2)` | -| `Lyt(sh1 orsh sh2)` = | `Lyt(sh1) \/ Lyt(sh2)` | -| `Lyt(exsh z. sh)` = | `exists z. Lyt(sh)` | -| `Lyt(falsesh)` = | `false` | - -The empty shape is laid out as a struct permission on an empty list of fields. -Named shapes are laid out by laying out their unfolding. Field shapes are laid -out as a struct permission with a single field whose permission is given by the -permission in the field shape. Array shapes with a known, fixed size `k` are -laid out as `k` copies of their shape. Otherwise, array shapes with a -dynamically-determined length are not laid out as arguments. Sequence and -disjunctive shapes are laid out using the `++` and `\/` operations defined -above, respectively, while existential shapes are laid out as existential -permissions and the false shape is laid out as the false permission. - -Using the `Lyt(sh)` function, we define the argument layout function `Arg(sh)` -that maps `sh` to a sequence of arguments and their corresponding permissions. -The Rust compiler uses the convention that any type that fits in no more than -two argument values is laid out into argument values, and otherwise is passed by -pointer. To handle this convention, `Arg(sh)` returns permissions for up to two -argument values if `Lyt(sh)` returns a struct permission with at most two -fields, and otherwise returns a `memblock` permission describing a pointer to a -memory block of shape `sh`. More formally, `Arg(sh)` is a function from shape -`sh` to a sequence of normal and ghost arguments with permissions, defined as -follows: - -* If `Lyt(sh)=struct(p1,...,pn)` for a sequence `p1,...,pn` of 0, 1, or 2 - permissions, then `Arg(sh)=arg1:p1,...,argn:pn`; - -* If `Lyt(sh)=p` for `p` of type `perm(struct(tp1,...,tpn))` for a sequence - `tp1,...,tpn` of 0, 1, or 2 types, then - `Arg(sh)=ghost:p,arg1:eq_proj(ghost,1),...,argn:eq_proj(ghost,n)`; - -* If `Lyt(sh)` is undefined but `len(sh)=ln`, then `Arg(sh)=arg:memblock(W,0,ln,sh)`; - -* Otherwise, `Arg(sh)` is undefined. - -The complexity of the second case comes from the case where `Lyt(sh)` returns a -struct permission where the permissions on the individual fields are cannot be -separated from each other. In this case, `Arg(sh)` returns a ghost variable -`ghost` to specify the tuple of the arguments, each of which are required to -equal their corresponding projection of `ghost` using `eq_proj` permissions. - -The argument layout function `Arg(sh)` is extended to multiple arguments with -the argument sequence layout function `Args(sh1,...,shn)`. For any sequence -`sh1,...,shn` of shapes for `n` input arguments, we define the -`Args(sh1,...,shn)` as the sequence of permissions on regular and ghost -arguments given by `Arg(sh1),...,Arg(shn)`, if all of these are defined. - -We define the return value layout function `Ret(sh)` as a partial function from -a shape `sh` to a permission on the return value `ret` of a funciton as follows: - -* If `Lyt(sh)=struct(p)` for a single permission `p`, then `Ret(sh)=ret:p`; - -* If `Lyt(sh)=p` for `p` of type `perm(struct(tp1,...,tpn))` for a sequence - `tp1,...,tpn` of 0, 1, or 2 types, then `Ret(sh)=ret:p`; - -* Otherwise, `Ret(sh)` is undefined. - -We can then define the function type layout `FnLyt(sh1,...,shn,sh)` of a -sequence of `n` shapes for input arguments and a shape `sh` for the return value -as follows: - -* If `Ret(sh)=ret:p` and `Args(sh1,...,shn)` is defined, then - `FnLyt(sh1,...,shn,sh)` is defined as the Heapster function permission - `Args(sh1,...,shn) -o ret:p` that takes in the regular and ghost arguments - specificed by `Args(sh1,...,shn)` and returns a value `ret` with permission - `p`; - -* If `Ret(sh)` is undefined but `Args(sh1,...,shn)` is defined and `len(sh)=ln`, then - `FnLyt(sh1,...,shn,sh)` is defined as the Heapster function permission - ``` - arg0:memblock(W,0,ln,emptysh),Args(sh1,...,shn) -o arg0:memblock(W,0,ln,emptysh) - ``` - -* Otherwise, `FnLyt(sh1,...,shn,sh)` is undefined. - - -### Adding Lifetime Permissions - -Adding lifetime permissions to the translation of a Rust function type is done -in two steps. The first step, lifetime lifting, lifts permissions containing a -lifetime to the top level. The second step constructs the required lifetime -ownership permissions. - -For the first step, the lifetime lifting function `LtLift(p)` maps a permission -`p` to a lifted permission along with 0 or more fresh ghost variables with -permissions on them. Intuitively, this operation finds permissions contained -inside `p` that use any of the lifetime variables of a function type, and lift -those permissions to permissions on fresh ghost variables. This allows the -permission type for a function to refer to just those values inside a more -complicated type that depend on a particular lifetime. - -To define the lifetime lifting function, we first define the lifetime lifting -contexts as follows: - -``` -L ::= _ | [l]ptr((rw,off) |-> L) * p1 * ... * pn | [l]memblock(rw,off,len,Lsh) * p1 * ... * pn -Lsh ::= sh1;Lsh | Lsh;sh2 | fieldsh(L) | ptrsh(rw,l,Lsh) -``` - -Each lifetime lifting context `L` is a permission with a single occurrence of a -"hole" of the form `_`. Similarly, a lifetime lifting shape context `Lsh` is a -shape containing a single occurrence of a hole inside one of its field -permissions. We write `L[p]` and `Lsh[p]` for the result of replacing the hole -`_` with `p` in `L` or `Lsh`, respectively. Intuitively, a hole describes an -occurrence of a permission inside a larger permission or shape that can be -lifted to a top-level ghost variable. Holes are only allowed inside a pointer -permission or the shape of a block permission; specifically, they are not -allowed inside disjunctive or array permissions, because there could be zero or -multiple values corresponding to that permission, and lifetime lifting is only -supposed to lift a single value. - -If any permission `p` can be written as `L[p']` for some `L` that is not the -trivial context `_` and some `p'` containing a free lifetime variable, then we -say that the permission `L[eq(z)]` along with the permission assignment `z:p'` -for fresh ghost variable `z` is a _lifetime lifting_ of `p`. We then define the -lifetime lifting function `LtLift(p)` from permission `p` to a permission plus -a sequence of zero or more ghost variables with permissions as follows: - -* If `p` has a lifetime lifting `L[eq(z)]` and `z:p'` such that `p'` itself has - no lifetime lifting, then `LtLift(p)` returns `LtLift(L[eq(z)])` along with - `z:p'`; - -* Otherwise, `LtLift(p)` just returns `p` itself. - -The `LtLift()` function is then extended to lists of permissions -`x1:p1,...,xn:pn` by applying it pointwise to the individual permissions `p1` -through `pn`. - - -For the second step of adding lifetime permissions to the translation of a Rust -function type, we first define the operation `LtPerms(a)(x:p)` that finds all -permissions containing lifetime `a` in the permission assignment `x:p`. This is -defined as follows: - -* For conjunctions, the operation returns only those conjuncts that contain - lifetime `a`, meaning that `LtPerms(a)(x:p1*...*pn)=x:p(i1)*...*p(ik)` where - `i1,...,ik` is the sequence of indices `i` such that `pi` contains lifetime - variable `a` free; - -* If `p` is not a conjunction but contains `a` free, then `LtPerms(a)(x:p)=x:p`; - -* Othersise, `LtPerms(a)(x:p)` is the empty sequence `()`. - -To add a lifetime permission to a function type `ps_in -o ps_out`, we define the -function - -``` -AddLt(a)(ps_in -o ps_out) = - let ps_a_in = LtPerms(a)(ps_in) in - let ps_a_abs = absMods(a)(ps_a_in) in - a:lowned(ps_a_in -o ps_a_abs), ps_in -o a:lowned(LtPerms(a)(ps_out) -o a_ps_in) -``` - -The function `absMods(a)(ps)` abstracts each occurrence of lifetime `a` and its -associated read/write modality by instantiating them with fresh ghost variables. -To add multiple lifetime permissions to a function type, we define - -``` -AddLts(a1,...,an)(ps_in -o ps_out) = - AddLt(a1)(AddLt(a2)(... AddLt(an)(ps_in -o ps_out))) -``` - -Putting all the pieces together, we define the translation of a Rust function -type as follows: - -``` -[| <'a1,...,'am> fn (x1 : T1, ..., xk : Tk) -> T |] = - AddLts(a1,...,an)(LtLift(FnLyt([| T1 |], ..., [| Tn |], [| T |]))) -``` diff --git a/heapster/doc/tutorial/tutorial.md b/heapster/doc/tutorial/tutorial.md deleted file mode 100644 index d86ada4e43..0000000000 --- a/heapster/doc/tutorial/tutorial.md +++ /dev/null @@ -1,1257 +0,0 @@ -# Tutorial to learn the basics of Heapster - -This tutorial extends the current README with enough details and -examples to get anyone up to speed with using and hacking on Heapster. - - -**Table of Contents** - -- [Tutorial to learn the basics of Heapster](#tutorial-to-learn-the-basics-of-heapster) - - [Building](#building) - - [Build Saw](#build-saw) - - [Build the Coq backend for Saw](#build-the-coq-backend-for-saw) - - [Build all the examples](#build-all-the-examples) - - [A quick tour of SAW](#a-quick-tour-of-saw) - - [Overview](#overview) - - [Running an example](#running-an-example) - - [1. Compile the code.](#1-compile-the-code) - - [2. Run the saw interpreter](#2-run-the-saw-interpreter) - - [3. Load the file and extract the two function specifications.](#3-load-the-file-and-extract-the-two-function-specifications) - - [4. Define the equality theorem.](#4-define-the-equality-theorem) - - [5. Call the SAT/SMT solver to prove the theorem.](#5-call-the-satsmt-solver-to-prove-the-theorem) - - [Batch scripts](#batch-scripts) - - [Using Heapster](#using-heapster) - - [Heapster type-checking overview](#heapster-type-checking-overview) - - [First example](#first-example) - - [Pointers](#pointers) - - [Structs](#structs) - - [Batch scripts](#batch-scripts-1) - - [Arrays](#arrays) - - [Recursive data structures](#recursive-data-structures) - - [1. Generating LLVM bitcode](#1-generating-llvm-bitcode-1) - - [2. Run the SAW interpreter with Heapster](#2-run-the-saw-interpreter-with-heapster-1) - - [3. Load the file and extract the function types.](#3-load-the-file-and-extract-the-function-types) - - [4. Writing heapster types for your functions](#4-writing-heapster-types-for-your-functions-1) - - [Defining list permissions](#defining-list-permissions) - - [5. Type-check your program](#5-type-check-your-program-1) - - - - -## Building - -We'll start by building everything you need to use Heapster. All the -commands here are with respect to the top-level `saw-script` directory. - -### Build Saw - -You will need to follow the instructions in the top-level [README](../../README.md) to -download or build a SAW binary, of which Heapster is a part. In -particular, make sure you follow the instructions to install Z3. Once `./build.sh` -succeeds it should report - -```bash -COPIED EXECUTABLES TO /Path/To/Saw/saw-script/bin. -``` - -If everything is installed correctly you should be able to run saw - -```bash -cabal run saw -``` - -This should open the saw interactive session. It should show you a -pretty SAW logo with the version number. We will learn more about the -interactive session later. For now you can quit the session with `:quit` or -`:q` like so: - -```bash -sawscript> :quit -``` - -### Build the Coq backend for Saw - -In this tutorial we will also interact with Heapster's Coq output. So -you'll need to follow the instructions in the -[README](../../../saw-core-coq/README.md) in the `saw-core-coq` -subdirectory. Specifically, after installing the dependencies, you -will need to run the following (from the top level directory): - -```bash -cd saw-core-coq/coq -make -``` - -It is expected that you will see a large number of warnings, but the -build should complete without any errors. - -**TODO: How do we check if this is properly installed before continuing?** - -For the sake of this tutorial, it will also be useful to install a -[user interface](https://coq.inria.fr/user-interfaces.html) to -interact with extracted Coq code. I recomment installing [Proof -General](https://proofgeneral.github.io/). - -Before continuing, return to the top-level directory with `cd ../..`. - -### Build all the examples - -The easiest way to verify that everything has been set up correctly is -to build all the heapser examples. Simply go to the examples folder -and build, like so - -```bash -cd /heapster/examples -make -``` - -If this is the first time you run make in this folder, you will see `cabal run saw` called multiple times like so - -``` -/Path/To/Saw/ -[16:59:41.084] Loading file "/Path/To/Saw/saw-script/heapster/examples/linked_list.saw" -cabal run saw xor_swap.saw -Up to date - - - -[16:59:42.974] Loading file "/Path/To/Saw/saw-script/heapster/examples/xor_swap.saw" -cabal run saw xor_swap_rust.saw -Up to date -``` - -Eventually it should start making the coq files - -```bash -COQC global_var_gen.v -COQC global_var_proofs.v -COQC sha512_gen.v -``` - -It might take several minutes but it should complete without any -errors. Once it's done, you know you are ready to use Heapster! - -Before continuing, return to the top-level directory with `cd ../..`. - -## A quick tour of SAW - -You don't need to be an expert in SAW to handle Heapster, but a little -familiarity is useful. If you want to dig deeper into SAW, there is a -dedicated [tutorial](https://saw.galois.com/tutorial.html) for -that. Here we just present the general ideas of SAW. - -### Overview - -SAWScript is a special-purpose programming language developed by -Galois to help orchestrate and track the results of the large -collection of proof tools necessary for analysis and verification of -complex software artifacts. - -In this tutorial we will overview how to use SAW to prove the functional -equality of different implementations. The steps are as follows: - -- [1. Compile the code.](#1-compile-the-code) -- [2. Run the saw interpreter](#2-run-the-saw-interpreter) -- [3. Load the file and extract the two function specifications.](#3-load-the-file-and-extract-the-two-function-specifications) -- [4. Define the equality theorem.](#4-define-the-equality-theorem) -- [5. Call the SAT/SMT solver to prove the theorem.](#5-call-the-satsmt-solver-to-prove-the-theorem) - -Steps 3-5 can all be written in a single `.saw` file, and batch processed by SAW. - -### Running an example - -We will use the same `ffs` example used in the [SAW -tutorial](https://saw.galois.com/tutorial.html). Head over to the -`saw-script/doc/tutorial/code` directory to find the file. - -Our aim is to prove functional equivalence of two implementations of -`ffs` (there are more implementations in that file). The function -should return the index of the first non-zero bit of its input and -can be implemented in the following two ways. - -```C -uint32_t ffs_ref(uint32_t word) { - int i = 0; - if(!word) - return 0; - for(int cnt = 0; cnt < 32; cnt++) - if(((1 << i++) & word) != 0) - return i; - return 0; // notreached -} - -uint32_t ffs_imp(uint32_t i) { - char n = 1; - if (!(i & 0xffff)) { n += 16; i >>= 16; } - if (!(i & 0x00ff)) { n += 8; i >>= 8; } - if (!(i & 0x000f)) { n += 4; i >>= 4; } - if (!(i & 0x0003)) { n += 2; i >>= 2; } - return (i) ? (n+((i+1) & 0x01)) : 0; -} -``` - -The former loops over all the bits in the input until it finds the -first 1. The later does a binary search over the input by using masks -where there is a 1. - -#### 1. Compile the code. - - We can use clang to compile our C code down - to LLVM like so: - - ```bash - clang -g -c -emit-llvm -o ffs.bc ffs.c - ``` - - Where the options mean: - * The `-g` flag instructs clang to include debugging information, which is useful in SAW to refer to variables and struct fields using the same names as in C. - * The `-c` flag asks clang to only run the preprocess, compile, and assemble steps. - * `-emit-llvm` requests LLVM bitcode as output. - * `-o ffs.bc` tells clang to write the output into `ffs.bc` - -Luckily, SAW has some code to do all of this for you in the `Makefile`. You can simply run -```bash -> make ffs.bc -``` -to get the same effect. - -#### 2. Run the saw interpreter - -Run `cabal run saw` to start the interpreter. You should see the SAW -logo and version number. Then you can run your first saw command: - - ```bash - sawscript> print "Hello World" - [14:49:30.413] Hello World - ``` - -#### 3. Load the file and extract the two function specifications. - To load the file, we will use `llvm_load_module`. We can check what the function does with - - ``` - sawscript> :? llvm_load_module - Description - ----------- - - llvm_load_module : String -> TopLevel LLVMModule - - Load an LLVM bitcode file and return a handle to it. - ``` - - Also, if you ever forget the name of a function, you can find it by - running `:env` which will display the current sawscript - environment. Finally you can always type `:help` to remember these - commands. - - Run `l <- llvm_load_module "ffs.bc"` to load the file and store it - in the variable `l`. If you print the environment with `:env` you - will now see a new variable `l : LLVMModule`. - - Now from `l`, we want to extract the two functions - - ``` - sawscript> ffs_ref <- llvm_extract l "ffs_ref" - sawscript> ffs_imp <- llvm_extract l "ffs_imp" - ``` - - That's it! If you want, you can check again `:env` to confirm the - variables of type `Term` have been created. - -#### 4. Define the equality theorem. - - Our theorem can now refer to the two recently created terms. Since - we want to prove functional equivalence, we just state that the - functions are equal for all inputs. - - ``` - sawscript> let thm1 = {{ \x -> ffs_ref x == ffs_imp x }}; - ``` - - If you check the environment (`:env`) you will see that theorems are also of type `Term`. - -#### 5. Call the SAT/SMT solver to prove the theorem. - -Let's start by checking the command we will use `prove`: - -```bash -sawscript> :? prove -Description ------------ - - prove : ProofScript () -> Term -> TopLevel ProofResult - -Use the given proof script to attempt to prove that a term is valid -(true for all inputs). Returns a proof result that can be analyzed -with 'caseProofResult' to determine whether it represents a successful -proof or a counter-example. -``` - -Notice that it takes a `ProofScript`. You can look at the -environment (`:env`) and look at all the proof scripts (searching -for `ProofScript`), such as `abc`, `cvc4`, `mathsat`, and `z3`. If -you want to play with different solvers you would have to install -them. For now, since we have `z3` installed we can use it: - -```bash -sawscript> result <- prove z3 thm1 -sawscript> print result -[16:39:47.506] Valid -``` - -Which tells us that `z3` managed to prove the functional equality! - -### Batch scripts - -To make things easier, you can write all the code above into a single -`.saw` file and process it in a batch. The file `ffs.saw` would look like this: - -```bash -print "Loading module ffs.bc"; -l <- llvm_load_module "ffs.bc"; - -print "Extracting reference term: ffs_ref"; -ffs_ref <- llvm_extract l "ffs_ref"; - -print "Extracting implementation term: ffs_imp"; -ffs_imp <- llvm_extract l "ffs_imp"; - -print "Proving equivalence: ffs_ref == ffs_imp"; -let thm1 = {{ \x -> ffs_ref x == ffs_imp x }}; -result <- prove z3 thm1; -print result; - -print "Done." -``` - -If you save the file in the same directory you can run: -```bash -% cabal run saw -- ffs.saw -Up to date - -[16:49:13.646] Loading file "/PATH/TO/SAW/saw-script/doc/tutorial/code/my_ffs.saw" -[16:49:13.647] Loading module ffs.bc -[16:49:13.651] Extracting reference term: ffs_ref -[16:49:13.663] Extracting implementation term: ffs_imp -[16:49:13.666] Proving equivalence: ffs_ref == ffs_imp -[16:49:13.716] Valid -[16:49:13.716] Done. -``` - -That's it! You know the basics of SAW. - -## Using Heapster - -Heapster is, fundamentally, a type system for extracting functional -specifications from memory-safe imperative programs. The type system, -defined inside SAW, uses separation types to reason about memory -safety. Once a program is type-checked as memory-safe, it can be then -extracted as a functional program to be verified in Coq. - -**TODO: Double check this description of Heapster** - -This section assumes you are in the `/heapster/examples` -directory. If you are not, make sure to go there - -```bash -cd /heapster/examples -make -``` - -### Heapster type-checking overview - -Heapster allows us to (1) type check programs with respect to -types that can express separation loigc and (2) extract -the resulting functional program to Coq for further verification. - -The process will generally involve - - -- [1. Generating LLVM bitcode](#1-generating-llvm-bitcode) -- [2. Run the SAW interpreter with Heapster](#2-run-the-saw-interpreter-with-heapster) -- [3. Load the file.](#3-load-the-file) -- [4. Writing heapster types for your functions](#4-writing-heapster-types-for-your-functions) -- [5. Type-check your program](#5-type-check-your-program) -- [6. Extract Coq specifications and write proofs](#6-writing-a-coq-file-to-prove-things-about-the-generated-functional-specifications) - -Just like with SAW, Heapster can be processed in batch. To do so, you -can combine steps 2-6 in a `.saw` file and use SAW's batch processing. - -### First example - -This section will walk through the process of using Heapster to write, -typecheck and verify some C code. We will start by type-checking the -simple `add` function, wich you can find in `tutorial_c.c` in the -examples directory. - -```C -uint64_t add (uint64_t x, uint64_t y) { return x + y; } -``` - -We will type-check the rest of the functions in that file, plus some -recursive functions later in the tutorial. - - -#### 1. Generating LLVM bitcode - -Just like with SAW, we want to work with the LLVM bitcode -(`.bc`). - -```bash -clang -g -c -emit-llvm -o tutorial_c.bc tutorial_c.c -``` - -Alternatively, as long as you are in the `heapster/examples` directory, you can also run - -```bash -make tutorial_c.bc -``` - -Be aware that the resulting bitcode may depend on your `clang` version -and your operating system. In turn, this means the Heapster commands -in your SAW script and the proofs in your Coq file may also be -dependent on how and where the bitcode is generated. If you find an -incompatibility, please report it. For all other examples beyond this -simple tutorial file, the binary code has been provided already to -avoid incompatibilities. - -#### 2. Run the SAW interpreter with Heapster - -We start by running saw with `cabal run saw`. Once SAW is loaded, you -can load all the Heapster commands with - -``` -sawscript> enable_experimental -``` - -If you print the environment now (with `:env`) you will notice a new -set of commands, all starting with `heapster_*`. You can also start -typing the name and press tab to see all the functions. These are all -the Heapster commands. - -``` -sawscript> heapster_ [TAB] -heapster_assume_fun heapster_find_symbols -heapster_assume_fun_multi heapster_find_symbols_with_type -heapster_assume_fun_rename heapster_find_trait_method_symbol -heapster_assume_fun_rename_prim heapster_gen_block_perms_hint -heapster_block_entry_hint heapster_get_cfg -heapster_define_irt_recursive_perm heapster_init_env -heapster_define_irt_recursive_shape heapster_init_env_debug -heapster_define_llvmshape heapster_init_env_for_files -heapster_define_opaque_llvmshape heapster_init_env_for_files_debug -heapster_define_opaque_perm heapster_init_env_from_file -heapster_define_perm heapster_init_env_from_file_debug -heapster_define_reachability_perm heapster_join_point_hint -heapster_define_recursive_perm heapster_parse_test -heapster_define_rust_type heapster_print_fun_trans -heapster_define_rust_type_qual heapster_set_debug_level -heapster_export_coq heapster_set_translation_checks -heapster_find_symbol heapster_typecheck_fun -heapster_find_symbol_commands heapster_typecheck_fun_rename -heapster_find_symbol_with_type heapster_typecheck_mut_funs -``` - -You can then use `:?` to see further information for each of them. - -#### 3. Load the file. - -To load a file into heapster you can use `heapster_init_env`. Let's -check its documentation first - -``` -sawscript> :? heapster_init_env -Description ------------ - -EXPERIMENTAL - - heapster_init_env : String -> String -> TopLevel HeapsterEnv - -Create a new Heapster environment with the given SAW module name - from the named LLVM bitcode file. -sawscript> -``` - -As you see it takes two names. The second name refers to the bitcode -file containing the code we are verifying. The first is the name we -want to give our SAW core module. That is the place where Heapster -will store all our type checked functions and their extracted -functional specification. By convention we use the same name as the -LLVM file. - -The function returns a Heapster environment that contains all the -definitions of the module (not to be confused with the SAW environment -that can be printed wiht `:env`). - -``` -env <- heapster_init_env "tutorial_c" "tutorial_c.bc" -``` - -we have created a new Heapster environment that we can explore. - -``` -sawscript> env -[20:07:14.272] Module: tutorial_c.bc -Types: - %struct.vector3d = type { i64, i64, i64 } - -Globals: - -External references: - declare default void @llvm.dbg.declare(metadata, metadata, - metadata) - -Definitions: - i64 @add(i64 %0, i64 %1) - i64 @add_mistyped(i64 %0, i64 %1) - void @incr_ptr(i64* %0) - i64 @norm_vector(%struct.vector3d* %0) -``` - -The Heapster environment contains all the types, global definitions, -external references and functions from the loaded module. In our first -example we will focus on the `add` function. - - -#### 4. Writing heapster types for your functions - -The Heapster type for the `add` function is rather simple: - -``` -"().arg0:int64<>, arg1:int64<> -o arg0:true, arg1:true, ret:int64<>" -``` - -It starts with an empty parenthesis `().` that contains the local -ghost environment. Since this function doesn't require ghost -variables, it is empty. - -The rest of the type is composed of two parts separated by the linear -implication operator `-o`, sometimes known as "lollipop". The left hand -side of the operator, refers to the state of memory before the -function executes. And it says that the two arguments passed to `add`, -`arg0` and `arg1`, are 64-bit integers. The predicate `int64`, which -we will define in a moment, takes no arguments as represented by the -empty angled brackets `<>`. - -The right hand side describes the memory after the function -executes. It says nothing about about the arguments (other than they -exist), with `true`, the predicate that is always satisfied. It also -says that the return value `ret` is another 64-bit integer. - -Notice, in particular, that the type does not assert that the return -value is the sum of the inputs. That's because Hepaster is not a -correctness logic. It is a memory safety type system. However, as you -will shortly see, after checking for memory safety, we can extract -`add` as a functional program and verify its correctness in Coq. - -##### Defining permission predicates - -Before we tell Heapster the type of `add`, as described above, we -need to define the predicate `int64` with the following type - -``` -exists x:bv 64.eq(llvmword(x)) -``` - -It says that there exist some bit-vector of length 64 (`bv 64`) which -is equal, as an LLVM word, to the "current variable". In other words, -it says that the current variable is equal to some number that can be -described as a bit-vector of size 64. - -To notify Heapster of this predicate we use the command -`heapster_define_perm`, which defines a new named permission which can -then be used in Heapster types. - -``` -heapster_define_perm env "int64" " " "llvmptr 64" "exists x:bv 64.eq(llvmword(x))" -``` - -The first argument is the Heapster environment, the second is its -name, the third is its arguments (of which there are none), the fourth -is the type of value that the permission applies to, and the fifth is -its permision type. Notice how in Heapster, most of the arguments are -passed as strings. - -With this, the new permission is created and added to the -environment. Uses of this named permission are written `int64<>` where -the `<>` is the empty list of arguments, as seen in the type of `add` -above. Unfortunately, there is currently no way to print the newly defined -permissions. If you try to print the environment (`print env`) at this -point, you will only see the `llvm` definitions. We might add -functionality for showing permissions in the future. - -#### 5. Type-check your program - -Armed with the `int64` predicate, we can write the type for `add` and -ask Heapster to type check it. - -``` -heapster_typecheck_fun env "add" "().arg0:int64<>, arg1:int64<> -o arg0:true, arg1:true, ret:int64<>" -``` - -The `heapster_typecheck_fun` command takes the environment, the name -of the function to typecheck and its permission type. The command then -attempts to typecheck the function and extracts its functional -specification. The functional specification is then added to the SAW -core module `tutorial_c` with the sufix `__tuple_fun`, in this case -`add__tuple_fun`. - -The function `add_mistyped`, in the same `tutorial_bc` and already -loaded in the Heapster environment, is identical to `add` so we can -experiment with mistyping. Try running the following command - -``` -heapster_typecheck_fun env "add_mistyped" "().arg0:true, arg1:int64<> -o arg0:true, arg1:true, ret:int64<>" -``` - -The first argument is typed as `true`, but we know it is an `i64` -which can't be proven from the trivial `true`. So this type check -should fail, but it silently terminates! What gives? - -Heapster allows for the typechecker to fail in parts of -the function and the extraction will translate those parts into the -error specification. The user could then, for example, prove that -those locations are not reachable in the program, for full -correctness. Unfortunately, this means that the typechecking will fail -silently and an error won't be caught until we check the Coq -extraction, as we show in the next section. - -#### 6. Writing a Coq file to prove things about the generated functional specification(s) - -Once you're finished, use the following command to export all the -type-checked functions in the current environment as functional -specifications in Coq. By convention, we add a `_gen` suffix to the -filename. - -``` -heapster_export_coq env "tutorial_c_gen.v"; -``` - -Open up the new `tutorial_c_gen.v` file in your examples -directory. You should see a handful of auto-generated imports and four -definitions. - -The first two definitions `add__tuple_fun` and `add` might have a -scary looking types, but they simplify to - -``` -add__tuple_fun : (bitvector 64 -> bitvector 64 -> CompM (bitvector 64)) * unit -add : bitvector 64 -> bitvector 64 -> CompM (bitvector 64) -``` - -That is, `add__tuple_fun` if a list of definitions, encoded as a -tuple. Saw uses these heterogeneous lists to encode functions, or -parts of them, that depend on each other. In this case, there is only -the `add` function and a unit `()`, representing the end of -the list (similar to `nil`). The `add` function takes two integers -(as 64-bit vectors) and returns another one (under the `CompM` monoid -that accepts failure). - -The other two definitions are the equivalent definitions for the -`add_mistyped` function. However, in `add_mistyped__tuple_fun` you -will find a call to `errorM` with an error message - -``` -implUnfoldOrFail: Could not prove - top_ptr1:true -o (). is_llvmptr -``` - -explaining that, for the first pointer (that is `arg0`) it couldn't -prove that `true -o (). is_llvmptr`, as we expected. The function -couldn't be typechecked with the given type. The lack of calls to -`errorM` in `add__tuple_fun` confirms that it was correctly -typechecked. - -Notice that the converse is not true: there are some well-typed -functions that will still use `errorM` in their extracted function to, -for example, dynamically check for memory bounds. We will see those -examples in later sections. **TODO: Make sure we do this. Perhaps add -an array example?** - -Before we continue, make sure to build the `.vo` file, so we can -import the definitions in `tutorial_c_gen.v` from other files. Do so with - -``` -make tutorial_c_gen.vo -``` - -This should produce a new file `tutorial_c_gen.vo`. - - -##### Writting your own proofs - -Open a new coq file `tutorial_c_proofs.v` in the same folder -(i.e. `heapster/examples/`) and the following preamble - -``` -From CryptolToCoq Require Import SAWCoreScaffolding. -From CryptolToCoq Require Import SAWCoreScaffolding. -From CryptolToCoq Require Import SAWCoreVectorsAsCoqVectors. -From CryptolToCoq Require Import SAWCoreBitvectors. -From CryptolToCoq Require Import SAWCorePrelude. - -(* The following 2 lines allows better automation *) -Require Import Examples.common. -Require Import Coq.Program.Tactics. - -(* Import our function definitions*) -Require Import Examples.tutorial_c_gen. -Import tutorial_c. -``` - -It first imports all the SAW functionality we need and some useful -tactics. Then it imports our new definitions (e.g. `add`). - -Our first proof will claim that the function `add` produces no -errors. More specifically, it says that for all inputs (that's what -`spec_refines_eq` quantifies) `add` always refines to `safety_spec`. That -is, it returns a pure value without errors. - -``` - -Lemma no_errors_add (x y: bitvector 64) : - spec_refines_eq (add x y) (safety_spec (x,y)). -Proof. -``` - -We will use our automation to quickly prove the lemma, - -``` -solve_trivial_spec 0 0. Qed. -``` - -You can also attempt the same proof with `add_mistyped`, which -obviously will fail, since `add_mistyped` has an error. First, you -will note that `add_mistyped` only takes one argument (since only one -was defined in its signature) - -``` -Lemma no_errors_add_mistyped (x: bitvector 64) : - spec_refines_eq (add_mistyped x) (safety_spec (x)). -Proof. solve_trivial_spec 0 0. - - clarify_goal_tutorial. -``` - -After rewriting the terms for clarity, you can see the -remaining goal says that an `ErrorS` is a refinement of -`RetS`. In other words, it's trying to prove that a trivially -pure function has an error. That's obviously false. - -``` -Abort. -``` - -Congratulations you have written your first Coq proofs with Heapster! - -### Pointers - -The next function we will type-check is a simple function that -increments the value in a pointer - -```C -void incr_ptr (uint64_t *x) { *x += 1; } -``` - -Assuming you completed the last section, you should have interactive -saw open, the `tutorial_c.bc` loaded in the environment `env`, so -`incr_ptr` should already be in your environment, but you can double -check by printing `env`. We can then skip the steps 1-3 and go -directly to writing heapster types for the function. - -The type for this function should be - -``` -(). arg0:ptr((W,0) |-> int64<>) -o arg0:ptr((W,0) |-> int64<>) -``` - -As before, the ghost environment is omitted and both sides of the -implication are identical, since the function doesn't change the shape -of memory. The return value is `void`, so we can omit it or add a -trivial `ret:true`. - -The permission for pointers `ptr` takes three arguments. First, it -describes the read-write modality. In this case the -pointer is writable `W`, since it will be modified. The second -argument describes the pointer offset, here `0`. Finally, the third -argument describes the content of the pointer, in this case a 64-bit -integer `int64<>`. - -Then we can type-check the function with - -``` -heapster_typecheck_fun env "incr_ptr" "(). arg0:ptr((W,0) |-> int64<>) -o arg0:ptr((W,0) |-> int64<>)" -``` - -Finally we can generate the functional specification in Coq with - -``` -heapster_export_coq env "tutorial_c_gen.v"; -``` - -The old file should be overwritten and now contains the functional -specification of `add`, `add_mistyped` and `incr_ptr`. As you can see -the definition of `incr_ptr__tuple_fun` has no references to `errorM`, -so we know it was correctly type checked. - -You will have to generate the `.vo` again to write proofs about -`incr_ptr`. After you do so, we can easily prove that `incr_ptr` -produces no errors. - -``` -Lemma no_errors_incr_ptr (x: bitvector 64) : - spec_refines_eq (incr_ptr x) (safety_spec x). -Proof. solve_trivial_spec 0 0. Qed. -``` - -### Structs - -The next function we will type-check deals with structs. In our -example, we defined a function that can compute the norm of a 3D -vector - -``` C -// Struct that represents the three coordinates for a 3D vector -typedef struct { uint64_t x; uint64_t y; uint64_t z; } vector3d; - -// function that computes the norm of a 3D vector -// || (x,y,z) || = x^2+y^2+z^2 -uint64_t norm_vector (vector3d *v) { return (v->x * v->x + v->y * v->y + v->z * v->z); } -``` - -Again, we assume that you still have the definitions from the previous -sections so we can start defining the type for the function. - -Let's start by defining a predicate for `vector3d` like so - -``` -heapster_define_perm env "vec3d" "rw:rwmodality" "llvmptr 64" "ptr((rw,0) |-> int64<>) * ptr((rw,8) |-> int64<>) * ptr((rw,16) |-> int64<>)" -``` - -First, notice that we added an arguments `rw` of type -`rwmodality`. This is such that we can control if the vector is -readable or writable. Second, notice that the predicate still applies -to 64-bit pointers. Finally, the type describes three integers, all -with the read-write modality given by the argument `rw`, at offsets -`0`, `8` and `16` and each with an `int64`. - -Then we can define the type of `norm_vector` as - -``` -(). arg0:vec3d -o arg0:vec3d, ret:int64<> -``` - -which says that the function takes a readable 3D vector, and returns -an integer. Notice that the `arg0` on the right hand side could also -be written as `arg0:true`. However, we still want to express that the -function does change that memory so we make it explicit. - -Then we can type-check the function with - -``` -heapster_typecheck_fun env "norm_vector" "(). arg0:vec3d -o arg0:vec3d, ret:int64<>" -``` - -Finally we can generate the functional specification in Coq with - -``` -heapster_export_coq env "tutorial_c_gen.v"; -``` - -The functional specification of `norm_vector` should have been added -to the `tutorial_c_gen.v` file. You will have to generate the `.vo` -again to write proofs about `norm_vector`. After you do so, we can -easily prove that `norm_vector` produces no errors. The statement and -the proof, follow exactly the last two lemmas. - -### Batch scripts - -Notice that, just like in saw, Heapster scripts can be processed in -batch. You can create a file `tutorial_c.saw` with all the commands so -far. It should look something like this - -``` -enable_experimental -env <- heapster_init_env "tutorial_c" "tutorial_c.bc" -print "File loaded" - -heapster_define_perm env "int64" " " "llvmptr 64" "exists x:bv 64.eq(llvmword(x))" -print "Defined an 64-bit integer." - -heapster_typecheck_fun env "add" "().arg0:int64<>, arg1:int64<> -o arg0:true, arg1:true, ret:int64<>" -print "Type checked add." - -heapster_typecheck_fun env "add_mistyped" "().arg0:true, arg1:int64<> -o arg0:true, arg1:true, ret:int64<>" -print "Type checked add_mistyped. This will produce an error in the output." - -heapster_typecheck_fun env "incr_ptr" "(). arg0:ptr((W,0) |-> int64<>) -o arg0:ptr((W,0) |-> int64<>)" -print "Type checked incr_ptr." - - -heapster_define_perm env "vec3d" "rw:rwmodality" "llvmptr 64" "ptr((rw,0) |-> int64<>) * ptr((rw,8) |-> int64<>) * ptr((rw,16) |-> int64<>)" -heapster_typecheck_fun env "norm_vector" "(). arg0:vec3d -o arg0:vec3d, ret:int64<>" -print "Type checked incr_ptr." - -heapster_export_coq env "tutorial_c_gen.v"; -print "Export to Coq." - -print "Done." -``` - -then you can process it with just - -``` -% cabal run saw -- tutorial_c.saw -Up to date - - - -[16:41:49.222] Loading file "/Users/Santiago/Projects/saw-script/heapster/examples/tutorial_c.saw" -[16:41:49.230] File loaded -[16:41:49.245] Type checked add. -[16:41:49.249] Type checked add_mistyped. This will produce an error in the output. -[16:41:49.257] Type checked incr_ptr. -[16:41:49.312] Type checked norm_vector. -[16:41:49.329] Export to Coq. -[16:41:49.329] Done. -``` - - -### Arrays - -We will briefly explore arrays, which have slightly more interesting -memory restrictions. Namely, array access must be in bounds. The code -in this section are already generated for you and you can find them, -together with more examples in the files `arrays.c`, `arrays.saw`, -`arrays_gen.v` and `arrays_proofs.v`. - -We will consider the function `zero_array` which zeroes out all the -values in an array (see code in `arrays.c`). - -```C -void zero_array (int64_t *arr, uint64_t len) { - for (uint64_t i = 0; i < len; ++i) { - arr[i] = 0; - } -} -``` - -The type for this function is relatively simple, it only assumes that -`len` is actually the length for the given array `arr`. This is -achieved by used a shared or ghost variable `len` which is both the -length of the array and equal to the second argument (see the code in `arrays.saw`) - -``` -heapster_typecheck_fun env "zero_array" - "(len:bv 64). arg0:int64array, arg1:eq(llvmword(len)) -o \ - \ arg0:int64array, arg1:true, ret:true"; -``` - -Heapster also expects a loop invariant hint for every loop. Loop -invariants look just like function types, taking the loop variables as -arguments. In this case the loop introduces a new variable `i` which -is the offset into the array. We represent that with a new ghost -variable - -``` -heapster_typecheck_fun env "zero_array_from" - "(len:bv 64, off:bv 64). arg0:int64array, arg1:eq(llvmword(len)), arg2:eq(llvmword(off)) -o \ - \ arg0:int64array, arg1:true, arg2:true, ret:true"; -``` - -Certainly function correctness must ensure that all the writes to the -array (i.e. `arr[i] = 0`) happen within bounds. However this is a -dynamic property which is not part of type-checking. Instead, Heapster -adds dynamic checks on the extracted code which we will see in the Coq -code. - -Let's go to `arrays_gen.v` (which has already been generated for you) -and look for the definition of `zero_array__bodies`. You will -notice that it calls `errorS` twice, but in this case, that's not a -sign of a typing error! Heapster includes these errors to catch -out-of-bounds array accesses and unrepresentable indices (i.e. index -that can't be written as a machine integer). The code below is a -simplification of the `zero_array__bodies` with some notation for -readability (see below for how to enable such pritty printing). - -``` -(fun (e0 : int64) (p0 : Vector int64 e0) => - CallS VoidEv emptyFunStack zero_array__frame - (mkFrameCall zero_array__frame 1 e0 (0)[64] p0 tt tt tt), - (fun (e0 e1 : int64) (p0 : Vector int64 e0) (_ _ _ : unit) => - if negb ((if e1 < e0 then (-1)[1] else (0)[1]) == (0)[1]) - then - if ((17293822569102704640)[64] <= e1) && (e1 <= (1152921504606846975)[64]) - then - If e1

    zero_array_precond len) (fun _ _ => True) (x,y, bvAdd _ x (intToBv _ 1))). -Proof. -``` - -It claims that, assuming the precondition `zero_array_precond` is -satisfied, then the function `zero_array` produces no errors. The -precondition simply says that the length of the array is within -computable integers. - -``` -Definition zero_array_precond x - := 64 <= x /\ x <= bvMem_hi. -``` - - -We will not go into detail about the proof, but notice that the -important steps are handled by custom automation. - - -### Recursive data structures - -We will now typecheck a function over lists, a recursive data -structure. You can start a fresh SAW session with `cabal run saw` -(quit any current session with `:q` if you are in one), but make sure -you do so from the `heapster/examples` directory. - -Specifically, we want to verify the function `is_elem`, -which tests if a specific value is in a list. The function, together -with others, can be found in `linked_list.c`, in the examples -directory. - -```C -typedef struct list64_t { - int64_t data; - struct list64_t *next; -} list64_t; - -int64_t is_elem (int64_t x, list64_t *l) { - if (l == NULL) { - return 0; - } else if (l->data == x) { - return 1; - } else { - return is_elem (x, l->next); - } -} -``` - -#### 1. Generating LLVM bitcode - -We have already included the binary for all the examples, but if you -want to generate it yourself, you can run - -```bash -make linked_list.bc -``` - -#### 2. Run the SAW interpreter with Heapster - -Load the Heapster commands - -```bash -sawscript> enable_experimental -``` - -#### 3. Load the file and extract the function types. - -To work with lists, we need add the SAW core definition of lists to -our SAW core module. The definition is - -``` -List_def : (a:sort 0) -> sort 0; -List_def a = List a; -``` - -**TODO: what is this definition? Why can't we just use `List a`** - -We can add such definitions to a SAW core file. One has already been -created for you at `linked_list.sawcore`. Every SAW core file starts -with the declaration of the module name and, most files, import the -Prelude. - -``` -module linked_list where - -import Prelude; -``` - -With this file created, we start our environment with - -``` -env <- heapster_init_env_from_file "linked_list.sawcore" "linked_list.bc"; -``` - -which, much like `heapster_init_env`, creates a new environment but, -instead of creating a fresh SAW core module, it initialises the module -with the given file, here `linked_list.sawcore`. Just as before, this -creates a new Heapster environment that we can explore. - -``` -sawscript> print env -[20:19:48.436] Module: linked_list.bc -Types: - %struct.list64_t = type { i64, %struct.list64_t* } - -Globals: - -External references: - declare default void @llvm.dbg.declare(metadata, metadata, - metadata) - declare default i8* @malloc(i64) - -Definitions: - i64 @is_head(i64 %0, %struct.list64_t* %1) - i64 @is_elem(i64 %0, %struct.list64_t* %1) - i64 @any(i64(i64)* %0, %struct.list64_t* %1) - %struct.list64_t* @find_elem(i64 %0, %struct.list64_t* %1) - %struct.list64_t* @sorted_insert(i64 %0, %struct.list64_t* %1) - %struct.list64_t* @sorted_insert_no_malloc(%struct.list64_t* %0, - %struct.list64_t* %1) -``` - -#### 4. Writing heapster types for your functions - -We can check in the environment `env` for the LLVM type of the function we -are type checking. - -```LLVM -i64 @is_elem(i64 %0, %struct.list64_t* %1) -``` - -The function `is_elem` takes a 64-bit integer and a list of 64-bit -integers, and returns another 64-bit integer. After the return, we -don't care about the inputs, so we can write the type like this - -``` -().arg0:int64<>, arg1:List64 -o arg0:true, arg1:true, ret:int64<> -``` - -But we will need to define the predicates for `int64` and `List64` - -##### Defining list permissions - -We know how to define `int64`, as we did before, - -``` -sawscript> heapster_define_perm env "int64" " " "llvmptr 64" "exists x:bv 64.eq(llvmword(x))" -``` - -but we need a new predicate for lists. Before we look at the -definition of a `List64` lets focus on its permission type. First -of all, `List64` takes a single argument `rw:rwmodality` which -determines if the list is readable or writable, just like 3D -vectors. It's type should look something like this - -``` -["eq(llvmword(0))", "ptr((rw,0) |-> int64<>) * ptr((rw,8) |-> List64)"] -``` - -The definition shows the diferent cases for a list, separated by a -comma. In the first case, a `List64` can be a null pointer, expressed -with the type `eq(llvmword(0))`. In the second case, a list is a -pointer where offset `0` is the head, an `Int64`, and offset `8` is -the tail, is recursively a `List64`. In the later case, -both elements are tagged with `rw`, describing if they are readable or -writable, as determined by the argument to `List64`. - -To define [permissions](doc/Permissions.md) which can describe -unbounded data structures, you can use the -`heapster_define_recursive_perm` command. Here is how to use the -command to define lists. - -``` -heapster_define_recursive_perm - env - "List64" - "rw:rwmodality" - "llvmptr 64" - ["eq(llvmword(0))", "ptr((rw,0) |-> int64<>) * ptr((rw,8) |-> List64)"] - "List_def" "foldList" "unfoldList"; -``` - -Its first four arguments are the same as for `heapster_define_perm`, -namely the environment, the name, the arguments and the type of value -that the permission applies to. The fifth argument is its permission -type. The final three arguments are its translation into SAW core. As -you might remember, this is the `List_def` we defined in our SAW core -file which is now loaded in the module. The other two `foldList` and -`unfoldList` are **TODO: What are these???** - -See this [additional documentation](../Permissions.md) for a -reference on the syntax and meaning of heapster permissions. - -#### 5. Type-check your program - -Just as before you only need to run - -``` -heapster_typecheck_fun env "is_elem" -"().arg0:int64<>, arg1:List64 -o arg0:true, arg1:true, -ret:int64<>"; -``` - -Note that for more complicated examples, usually examples involving loops, -the `heapster_block_entry_hint` command will also need to be used in order for -the `heapster_typecheck_fun` command to succeed. In the case of functions with -loops, this hint corresponds to a loop invariant. Additionally, such examples -will also often require your unbounded data structure to be defined as a -reachability permission, using `heapster_define_reachability_perm`, instead of -just as a recursive permission. See `iter_linked_list.saw` for some -examples of using the commands mentioned in this paragraph. - -Once you're finished, use the following command to export all the type-checked -functions in the current environment as functional specifications in Coq. By -convention, we add a `_gen` suffix to the filename. -``` -heapster_export_coq env "my_file_gen.v"; -``` diff --git a/heapster/examples/.gitignore b/heapster/examples/.gitignore deleted file mode 100644 index ff04e5b9e6..0000000000 --- a/heapster/examples/.gitignore +++ /dev/null @@ -1,4 +0,0 @@ -Makefile.coq* -.Makefile.coq* -*_gen.v -dilithium diff --git a/heapster/examples/Dilithium2.cry b/heapster/examples/Dilithium2.cry deleted file mode 100644 index 6d9d52a777..0000000000 --- a/heapster/examples/Dilithium2.cry +++ /dev/null @@ -1,333 +0,0 @@ - -module Dilithium2 where - -infixr 1 & - -(&) : {a, b} a -> (a -> b) -> b -x & f = f x - -// params.h - -type SEEDBYTES = 32 -type CRHBYTES = 64 -type TRBYTES = 64 -type RNDBYTES = 32 -type N = 256 -type Q = 8380417 -type D = 13 -type ROOT_OF_UNITY = 1753 -type K = 4 -type L = 4 -type ETA = 2 -type TAU = 39 -type BETA = 78 -type GAMMA1 = (2 ^^ 17) // (1 << 17) -type GAMMA2 = ((Q-1)/88) -type OMEGA = 80 -type CTILDEBYTES = 32 -type POLYT1_PACKEDBYTES = 320 -type POLYT0_PACKEDBYTES = 416 -type POLYVECH_PACKEDBYTES = (OMEGA + K) -type POLYZ_PACKEDBYTES = 576 -type POLYW1_PACKEDBYTES = 192 -type POLYETA_PACKEDBYTES = 96 -type CRYPTO_PUBLICKEYBYTES = (SEEDBYTES + K*POLYT1_PACKEDBYTES) -type CRYPTO_SECRETKEYBYTES = (2*SEEDBYTES - + TRBYTES - + L*POLYETA_PACKEDBYTES - + K*POLYETA_PACKEDBYTES - + K*POLYT0_PACKEDBYTES) -type CRYPTO_BYTES = (CTILDEBYTES + L*POLYZ_PACKEDBYTES + POLYVECH_PACKEDBYTES) - - -// randombytes.c - -primitive randombytes : {n} [n][8] - - -// fips202.c - -type keccak_state = ([25][64], [32]) - -primitive shake256_init : keccak_state -primitive shake256_absorb : {n} keccak_state -> [n][8] -> (keccak_state, [n][8]) -primitive shake256_finalize : keccak_state -> keccak_state -primitive shake256_squeeze : {n} keccak_state -> ([n][8], keccak_state) -primitive shake256 : {m, n} [n][8] -> ([m][8], [n][8]) - -// poly.c - -type poly = [N][32] - -primitive poly_challenge : [SEEDBYTES][8] -> (poly, [SEEDBYTES][8]) -primitive poly_ntt : poly -> poly - - -// polyvec.c - -type polyvecl = [L]poly -type polyveck = [K]poly - -primitive polyvec_matrix_expand : [SEEDBYTES][8] -> ([K]polyvecl, [SEEDBYTES][8]) -primitive polyvec_matrix_pointwise_montgomery : [K]polyvecl -> polyvecl -> (polyveck, [K]polyvecl, polyvecl) -primitive polyvecl_uniform_eta : [CRHBYTES][8] -> [16] -> (polyvecl, [CRHBYTES][8]) -primitive polyvecl_uniform_gamma1 : [CRHBYTES][8] -> [16] -> (polyvecl, [CRHBYTES][8]) -primitive polyvecl_reduce : polyvecl -> polyvecl -primitive polyvecl_add : polyvecl -> polyvecl -> (polyvecl, polyvecl) -primitive polyvecl_ntt : polyvecl -> polyvecl -primitive polyvecl_invntt_tomont : polyvecl -> polyvecl -primitive polyvecl_pointwise_poly_montgomery : poly -> polyvecl -> (polyvecl, poly, polyvecl) -primitive polyvecl_chknorm : polyvecl -> [32] -> (polyvecl, [32]) -primitive polyveck_uniform_eta : [CRHBYTES][8] -> [16] -> (polyveck, [CRHBYTES][8]) -primitive polyveck_reduce : polyveck -> polyveck -primitive polyveck_caddq : polyveck -> polyveck -primitive polyveck_add : polyveck -> polyveck -> (polyveck, polyveck) -primitive polyveck_sub : polyveck -> polyveck -> (polyveck, polyveck) -primitive polyveck_shiftl : polyveck -> polyveck -primitive polyveck_ntt : polyveck -> polyveck -primitive polyveck_invntt_tomont : polyveck -> polyveck -primitive polyveck_pointwise_poly_montgomery : poly -> polyveck -> (polyveck, poly, polyveck) -primitive polyveck_chknorm : polyveck -> [32] -> (polyveck, [32]) -primitive polyveck_power2round : polyveck -> (polyveck, polyveck) -primitive polyveck_decompose : polyveck -> (polyveck, polyveck) -primitive polyveck_make_hint : polyveck -> polyveck -> (polyveck, polyveck, polyveck, [32]) -primitive polyveck_use_hint : polyveck -> polyveck -> (polyveck, polyveck) -primitive polyveck_pack_w1 : polyveck -> ([K*POLYW1_PACKEDBYTES][8], polyveck) - -// packing.c - -primitive pack_pk : [SEEDBYTES][8] -> polyveck -> - ([CRYPTO_PUBLICKEYBYTES][8], [SEEDBYTES][8], polyveck) -primitive unpack_pk : [CRYPTO_PUBLICKEYBYTES][8] -> - ([SEEDBYTES][8], polyveck, [CRYPTO_PUBLICKEYBYTES][8]) -primitive pack_sk : [SEEDBYTES][8] -> [TRBYTES][8] -> [SEEDBYTES][8] -> - polyveck -> polyvecl -> polyveck -> - ([CRYPTO_SECRETKEYBYTES][8], - [SEEDBYTES][8], [TRBYTES][8], [SEEDBYTES][8], - polyveck, polyvecl, polyveck) -primitive unpack_sk : [CRYPTO_SECRETKEYBYTES][8] -> - ([SEEDBYTES][8], [TRBYTES][8], [SEEDBYTES][8], - polyveck, polyvecl, polyveck, [CRYPTO_SECRETKEYBYTES][8]) -primitive pack_sig : [CTILDEBYTES][8] -> polyvecl -> polyveck -> - ([CRYPTO_BYTES][8], [CTILDEBYTES][8], polyvecl, polyveck) -primitive unpack_sig : [CRYPTO_BYTES][8] -> - ([CTILDEBYTES][8], polyvecl, polyveck, [CRYPTO_BYTES][8], - [32]) - - -// sign.c - crypto_sign_keypair - -crypto_sign_keypair : - ([CRYPTO_PUBLICKEYBYTES][8], [CRYPTO_SECRETKEYBYTES][8], [32]) -crypto_sign_keypair = - /* Get randomness for rho, rhoprime and key */ - randombytes`{SEEDBYTES} & \seedbuf_rand_0 -> - shake256 seedbuf_rand_0 & \(seedbuf_0, seedbuf_rand_1) -> - take seedbuf_0 & \rho_0 -> - take (drop`{SEEDBYTES} seedbuf_0) & \rhoprime_0 -> - take (drop`{SEEDBYTES + CRHBYTES} seedbuf_0) & \key_0 -> - - /* Expand matrix */ - polyvec_matrix_expand rho_0 & \(mat_0, rho_1) -> - - /* Sample short vectors s1 and s2 */ - polyvecl_uniform_eta rhoprime_0 0 & \(s1_0, rhoprime_1) -> - polyveck_uniform_eta rhoprime_1 `L & \(s2_0, rhoprime_2) -> - - /* Matrix-vector multiplication */ - s1_0 & \s1hat_0 -> - polyvecl_ntt s1hat_0 & \s1hat_1 -> - polyvec_matrix_pointwise_montgomery mat_0 s1hat_1 & \(t1_0, mat_1, s1hat_2) -> - polyveck_reduce t1_0 & \t1_1 -> - polyveck_invntt_tomont t1_1 & \t1_2 -> - - /* Add error vector s2 */ - polyveck_add t1_2 s2_0 & \(t1_3, s2_1) -> - - /* Extract t1 and write public key */ - polyveck_caddq t1_3 & \t1_4 -> - polyveck_power2round t1_4 & \(t1_5, t0_0) -> - pack_pk rho_1 t1_5 & \(pk_0, rho_2, t1_6) -> - - /* Compute H(rho, t1) and write secret key */ - shake256 pk_0 & \(tr_0, pk_1) -> - pack_sk rho_2 tr_0 key_0 t0_0 s1_0 s2_1 & \(sk_0, rho_3, tr_1, key_1, t0_1, s1_1, s2_2) -> - - (pk_1, sk_0, 0) - - -// sign.c - crypto_sign_signature - -crypto_sign_signature : {mlen} - [mlen][8] -> [CRYPTO_SECRETKEYBYTES][8] -> - ([CRYPTO_BYTES][8], [64], [mlen][8], [CRYPTO_SECRETKEYBYTES][8], [32]) -crypto_sign_signature m_0 sk_0 = - zero & \nonce_0 -> - - unpack_sk sk_0 & \(rho_0, tr_0, key_0, t0_0, s1_0, s2_0, sk_1) -> - - /* Compute mu = CRH(tr, msg) */ - shake256_init & \state_0 -> - shake256_absorb`{TRBYTES} state_0 tr_0 & \(state_1, tr_1) -> - shake256_absorb`{mlen} state_1 m_0 & \(state_2, m_1) -> - shake256_finalize state_2 & \state_3 -> - shake256_squeeze`{CRHBYTES} state_3 & \(mu_0, state_4) -> - - zero & \rnd_0 -> - shake256_init & \state_5 -> - shake256_absorb`{SEEDBYTES} state_5 key_0 & \(state_6, key_1) -> - shake256_absorb`{RNDBYTES} state_6 rnd_0 & \(state_7, rnd_1) -> - shake256_absorb`{CRHBYTES} state_7 mu_0 & \(state_8, mu_1) -> - shake256_finalize state_8 & \state_9 -> - shake256_squeeze`{CRHBYTES} state_9 & \(rhoprime_0, state_10) -> - - /* Expand matrix and transform vectors */ - polyvec_matrix_expand rho_0 & \(mat_0, rho_1) -> - polyvecl_ntt s1_0 & \s1_1 -> - polyveck_ntt s2_0 & \s2_1 -> - polyveck_ntt t0_0 & \t0_1 -> - - crypto_sign_signature_rej rhoprime_0 nonce_0 mat_0 mu_1 s1_1 s2_1 t0_1 m_1 sk_1 - -crypto_sign_signature_rej : {mlen} - [CRHBYTES][8] -> [16] -> [K]polyvecl -> [CRHBYTES][8] -> polyvecl -> - polyveck -> polyveck -> [mlen][8] -> [CRYPTO_SECRETKEYBYTES][8] -> - ([CRYPTO_BYTES][8], [64], [mlen][8], [CRYPTO_SECRETKEYBYTES][8], [32]) -crypto_sign_signature_rej rhoprime_0 nonce_0 mat_0 mu_1 s1_1 s2_1 t0_1 m_1 sk_1 = - /* Sample intermediate vector y */ - polyvecl_uniform_gamma1 rhoprime_0 nonce_0 & \(y_0, rhoprime_1) -> - (nonce_0 + 1) & \nonce_1 -> - - /* Matrix-vector multiplication */ - y_0 & \z_0 -> - polyvecl_ntt z_0 & \z_1 -> - polyvec_matrix_pointwise_montgomery mat_0 z_1 & \(w1_0, mat_1, z_2) -> - polyveck_reduce w1_0 & \w1_1 -> - polyveck_invntt_tomont w1_1 & \w1_2 -> - - /* Decompose w and call the random oracle */ - polyveck_caddq w1_2 & \w1_3 -> - polyveck_decompose w1_3 & \(w1_4, w0_0) -> - polyveck_pack_w1 w1_4 & \(sig_w1_packedbytes_0, w1_5) -> - - shake256_init & \state_11 -> - shake256_absorb state_11 mu_1 & \(state_12, mu_2) -> - shake256_absorb state_12 sig_w1_packedbytes_0 & \(state_13, sig_w1_packedbytes_1) -> - shake256_finalize state_13 & \state_14 -> - shake256_squeeze`{CTILDEBYTES} state_14 & \(sig_ctildebytes_0, state_15) -> - poly_challenge sig_ctildebytes_0 & \(cp_0, sig_ctildebytes_1) -> - poly_ntt cp_0 & \cp_1 -> - - /* Compute z, reject if it reveals secret */ - polyvecl_pointwise_poly_montgomery cp_1 s1_1 & \(z_3, cp_2, s1_2) -> - polyvecl_invntt_tomont z_3 & \z_4 -> - polyvecl_add z_4 y_0 & \(z_5, y_1) -> - polyvecl_reduce z_5 & \z_6 -> - polyvecl_chknorm z_6 (`GAMMA1 - `BETA) & \(z_7, polyvecl_chknorm_z_res) -> - if polyvecl_chknorm_z_res != 0 then - crypto_sign_signature_rej rhoprime_1 nonce_1 mat_1 mu_2 s1_2 s2_1 t0_1 m_1 sk_1 else - - /* Check that subtracting cs2 does not change high bits of w and low bits - * do not reveal secret information */ - polyveck_pointwise_poly_montgomery cp_2 s2_1 & \(h_0, cp_3, s2_2) -> - polyveck_invntt_tomont h_0 & \h_1 -> - polyveck_sub w0_0 h_1 & \(w0_1, h_2) -> - polyveck_reduce w0_1 & \w0_2 -> - polyveck_chknorm w0_2 (`GAMMA2 - `BETA) & \(w0_3, polyveck_chknorm_w0_res) -> - if polyveck_chknorm_w0_res != 0 then - crypto_sign_signature_rej rhoprime_1 nonce_1 mat_1 mu_2 s1_2 s2_2 t0_1 m_1 sk_1 else - - /* Compute hints for w1 */ - polyveck_pointwise_poly_montgomery cp_3 t0_1 & \(h_3, cp_4, t0_2) -> - polyveck_invntt_tomont h_3 & \h_4 -> - polyveck_reduce h_4 & \h_5 -> - polyveck_chknorm h_5 (`GAMMA2) & \(h_6, polyveck_chknorm_h_res) -> - if polyveck_chknorm_h_res != 0 then - crypto_sign_signature_rej rhoprime_1 nonce_1 mat_1 mu_2 s1_2 s2_2 t0_2 m_1 sk_1 else - - polyveck_add w0_3 h_6 & \(w0_4, h_7) -> - polyveck_make_hint w0_4 w1_5 & \(h_8, w0_5, w1_6, n_0) -> - if n_0 > `OMEGA then - crypto_sign_signature_rej rhoprime_1 nonce_1 mat_1 mu_2 s1_2 s2_2 t0_2 m_1 sk_1 else - - /* Write signature */ - pack_sig sig_ctildebytes_1 z_7 h_8 & \(sig_0, sig_ctildebytes_2, z_8, h_9) -> - (`CRYPTO_BYTES) & \siglen_0 -> - (sig_0, siglen_0, m_1, sk_1, 0) - - -// sign.c - crypto_sign - -crypto_sign : {mlen} Literal mlen [64] => - [mlen][8] -> [CRYPTO_SECRETKEYBYTES][8] -> - ([CRYPTO_BYTES][8], [mlen][8], [64], [mlen][8], [CRYPTO_SECRETKEYBYTES][8], [32]) -crypto_sign m_0 sk_0 = - m_0 & \sm_plus_CRYPTO_BYTES_0 -> - crypto_sign_signature sm_plus_CRYPTO_BYTES_0 sk_0 - & \(sm_up_to_CRYPTOBYTES_0, smlen_0, sm_plus_CRYPTO_BYTES_1, sk_1, _) -> - (smlen_0 + `mlen) & \smlen_1 -> - (sm_up_to_CRYPTOBYTES_0, sm_plus_CRYPTO_BYTES_1, smlen_1, m_0, sk_0, 0) - - -// sign.c - crypto_sign_verify - -crypto_sign_verify : {slen, mlen} Literal slen [64] => - [CRYPTO_BYTES][8] -> [mlen][8] -> [CRYPTO_PUBLICKEYBYTES][8] -> - ([CRYPTO_BYTES][8], [mlen][8], [CRYPTO_PUBLICKEYBYTES][8], [32]) -crypto_sign_verify sig_0 m_0 pk_0 = - if (`slen : [64]) != `CRYPTO_BYTES then - (sig_0, m_0, pk_0, 0xffffffff) else - - unpack_pk pk_0 & \(rho_0, t1_0, pk_1) -> - unpack_sig sig_0 & \(c_0, z_0, h_0, sig_1, unpack_sig_res) -> - if unpack_sig_res != 0 then - (sig_1, m_0, pk_1, 0xffffffff) else - polyvecl_chknorm z_0 (`GAMMA1 - `BETA) & \(z_1, polyvecl_chknorm_res) -> - if polyvecl_chknorm_res != 0 then - (sig_1, m_0, pk_1, 0xffffffff) else - - /* Compute CRH(H(rho, t1), msg) */ - shake256 pk_1 & \(mu_0, pk_2) -> - shake256_init & \state_0 -> - shake256_absorb`{CRHBYTES} state_0 mu_0 & \(state_1, mu_1) -> - shake256_absorb`{mlen} state_1 m_0 & \(state_2, m_1) -> - shake256_finalize state_2 & \state_3 -> - shake256_squeeze`{CRHBYTES} state_3 & \(mu_2, state_4) -> - - /* Matrix-vector multiplication; compute Az - c2^dt1 */ - poly_challenge c_0 & \(cp_0, c_1) -> - polyvec_matrix_expand rho_0 & \(mat_0, rho_1) -> - - polyvecl_ntt z_1 & \z_2 -> - polyvec_matrix_pointwise_montgomery mat_0 z_2 & \(w1_0, mat_1, z_3) -> - - poly_ntt cp_0 & \cp_1 -> - polyveck_shiftl t1_0 & \t1_1 -> - polyveck_ntt t1_1 & \t1_2 -> - polyveck_pointwise_poly_montgomery cp_1 t1_2 & \(t1_prime_0, cp_2, t1_3) -> - - polyveck_sub w1_0 t1_prime_0 & \(w1_1, t1_prime_1) -> - polyveck_reduce w1_1 & \w1_2 -> - polyveck_invntt_tomont w1_2 & \w1_3 -> - - /* Reconstruct w1 */ - polyveck_caddq w1_3 & \w1_4 -> - polyveck_use_hint w1_4 h_0 & \(w1_5, h_1) -> - polyveck_pack_w1 w1_5 & \(buf_0, w1_6) -> - - /* Call random oracle and verify challenge */ - shake256_init & \state_5 -> - shake256_absorb`{CRHBYTES} state_5 mu_2 & \(state_6, mu_3) -> - shake256_absorb`{K*POLYW1_PACKEDBYTES} state_6 buf_0 & \(state_7, buf_1) -> - shake256_finalize state_7 & \state_8 -> - shake256_squeeze`{CTILDEBYTES} state_8 & \(c2_0, state_9) -> - loop sig_1 m_1 pk_2 c_1 c2_0 0 - where loop : [CRYPTO_BYTES][8] -> [mlen][8] -> [CRYPTO_PUBLICKEYBYTES][8] -> - [CTILDEBYTES][8] -> [CTILDEBYTES][8] -> [32] -> - ([CRYPTO_BYTES][8], [mlen][8], [CRYPTO_PUBLICKEYBYTES][8], [32]) - loop sig_1 m_1 pk_2 c_1 c2_0 i = - if i < `CTILDEBYTES - then if c_1 @ i != c2_0 @ i - then (sig_1, m_1, pk_2, -1) - else loop sig_1 m_1 pk_2 c_1 c2_0 (i+1) - else (sig_1, m_1, pk_2, 0) diff --git a/heapster/examples/Dilithium2.saw b/heapster/examples/Dilithium2.saw deleted file mode 100644 index 563df40e77..0000000000 --- a/heapster/examples/Dilithium2.saw +++ /dev/null @@ -1,440 +0,0 @@ -enable_experimental; - -import "Dilithium2.cry"; - -// The required `dilithium2.bc` file is to be built by: -// 1. Cloning the `standard` branch of the official Dilithium reference -// implementation (https://github.com/pq-crystals/dilithium) - specifially, -// the commit `918af1a6eaedcedf9fdd8aaaca6c1fccd5a7a51f` is the latest that -// has been confirmed to work (NB: if you update this commit hash be sure to -// also update the commit hash in the `heapster/examples/Makefile`) -// 2. Applying the `dilithium.patch` file provided in this directory -// 3. Running `LLVM_COMPILER=clang make bitcode` in the `ref` directory of the -// patched `dilithium` repo -// 4. Copying the `libpqcrystals_dilithium2_ref.so.bc` file generated in the -// `ref` directory of the patched `dilithium` repo into -// `heapster/examples` as `dilithium2.bc` -// Run `make Dilithium2.bc` to perform these steps automatically, or see the -// `Makefile` in this directory for more detail. -env <- heapster_init_env "Dilithium2" "dilithium2.bc"; - - -//////////////////////////////// -// Basic Heapster permissions // -//////////////////////////////// - -include "specPrims.saw"; - -heapster_define_perm env "int64" " " "llvmptr 64" "exists x:bv 64.eq(llvmword(x))"; -heapster_define_perm env "int32" " " "llvmptr 32" "exists x:bv 32.eq(llvmword(x))"; -heapster_define_perm env "int16" " " "llvmptr 16" "exists x:bv 16.eq(llvmword(x))"; -heapster_define_perm env "int8" " " "llvmptr 8" "exists x:bv 8.eq(llvmword(x))"; - -heapster_assume_fun_rename env "llvm.memcpy.p0i8.p0i8.i64" "memcpy" - "(rw:rwmodality, l1:lifetime, l2:lifetime, \ - \ b:llvmblock 64, len:bv 64). \ - \ arg0:[l1]memblock(W,0,len,emptysh), arg1:[l2]memblock(rw,0,len,eqsh(len,b)), \ - \ arg2:eq(llvmword(len)) -o \ - \ arg0:[l1]memblock(W,0,len,eqsh(len,b)), arg1:[l2]memblock(rw,0,len,eqsh(len,b))" - "\\ (len:Vec 64 Bool) -> retS VoidEv #() ()"; - -heapster_assume_fun_rename env "llvm.memmove.p0i8.p0i8.i64" "memmove" - "(rw:rwmodality, l1:lifetime, l2:lifetime, len:bv 64). \ - \ arg0:[l1]memblock(W,0,len,emptysh), arg1:[l2]array(rw,0,)), \ - \ arg2:eq(llvmword(len)) -o \ - \ arg0:[l1]array(W,0,)), arg1:[l2]array(rw,0,))" - "\\ (len:Vec 64 Bool) (v:BVVec 64 len (Vec 8 Bool)) -> \ - \ retS VoidEv (BVVec 64 len (Vec 8 Bool) * BVVec 64 len (Vec 8 Bool)) (v, v)"; - -heapster_assume_fun_rename env "llvm.memset.p0i8.i64" "memset" - "(l1:lifetime, len:bv 64). \ - \ arg0:[l1]memblock(W,0,len,emptysh), arg1:int8<>, arg2:eq(llvmword(len)) -o \ - \ arg0:[l1]array(W,0,))" - "\\ (len:Vec 64 Bool) (x:Vec 8 Bool) -> \ - \ retS VoidEv (BVVec 64 len (Vec 8 Bool)) (repeatBVVec 64 len (Vec 8 Bool) x)"; - - -////////////////////////////////////// -// Heapster permissions for C types // -////////////////////////////////////// - -heapster_define_llvmshape env "keccak_state_sh" 64 "" "arraysh(<25, *8, fieldsh(64, int64<>)); fieldsh(32, int32<>)"; -heapster_define_perm env "keccak_state" "rw:rwmodality" "llvmptr 64" "memblock(rw, 0, 208, keccak_state_sh<>)"; -heapster_define_perm env "uninit_keccak_state" "rw:rwmodality" "llvmptr 64" "memblock(rw, 0, 208, emptysh)"; - -heapster_define_llvmshape env "poly_sh" 64 "" "arraysh(<256, *4, fieldsh(32, int32<>))"; -heapster_define_llvmshape env "polyvecl_sh" 64 "" "arraysh(<4, *1024, poly_sh<>)"; -heapster_define_llvmshape env "polyveck_sh" 64 "" "arraysh(<4, *1024, poly_sh<>)"; -heapster_define_llvmshape env "polymatlk_sh" 64 "" "arraysh(<4, *4096, polyvecl_sh<>)"; - -heapster_define_perm env "poly" "rw:rwmodality" "llvmptr 64" "memblock(rw, 0, 1024, poly_sh<>)"; -heapster_define_perm env "polyvecl" "rw:rwmodality" "llvmptr 64" "memblock(rw, 0, 4096, polyvecl_sh<>)"; -heapster_define_perm env "polyveck" "rw:rwmodality" "llvmptr 64" "memblock(rw, 0, 4096, polyveck_sh<>)"; -heapster_define_perm env "polymatlk" "rw:rwmodality" "llvmptr 64" "memblock(rw, 0, 16384, polymatlk_sh<>)"; - -heapster_define_perm env "uninit_poly" "rw:rwmodality" "llvmptr 64" "memblock(rw, 0, 1024, emptysh)"; -heapster_define_perm env "uninit_polyvecl" "rw:rwmodality" "llvmptr 64" "memblock(rw, 0, 4096, emptysh)"; -heapster_define_perm env "uninit_polyveck" "rw:rwmodality" "llvmptr 64" "memblock(rw, 0, 4096, emptysh)"; -heapster_define_perm env "uninit_polymatlk" "rw:rwmodality" "llvmptr 64" "memblock(rw, 0, 16384, emptysh)"; - - -////////////////////////////////////////////////// -// Heapster assumptions of auxilliary functions // -////////////////////////////////////////////////// - -// randombytes.c - -heapster_assume_fun_rename_prim env "randombytes" "randombytes" - "(len:bv 64). arg0:memblock(W,0,len,emptysh), arg1:eq(llvmword(len)) \ - \ -o arg0:array(W,0,))"; - -// fips202.c - -heapster_assume_fun_rename_prim env "pqcrystals_dilithium_fips202_ref_shake256_init" "shake256_init" - "(). arg0:uninit_keccak_state -o arg0:keccak_state"; - -heapster_assume_fun_rename_prim env "pqcrystals_dilithium_fips202_ref_shake256_absorb" "shake256_absorb" - "(len:bv 64). arg0:keccak_state, arg1:array(W,0,)), arg2:eq(llvmword(len)) \ - \ -o arg0:keccak_state, arg1:array(W,0,))"; - -heapster_assume_fun_rename_prim env "pqcrystals_dilithium_fips202_ref_shake256_finalize" "shake256_finalize" - "(). arg0:keccak_state -o arg0:keccak_state"; - -heapster_assume_fun_rename_prim env "pqcrystals_dilithium_fips202_ref_shake256_squeeze" "shake256_squeeze" - "(len:bv 64). arg0:memblock(W,0,len,emptysh), arg1:eq(llvmword(len)), arg2:keccak_state \ - \ -o arg0:array(W,0,)), arg2:keccak_state"; - -heapster_assume_fun_rename_prim env "pqcrystals_dilithium_fips202_ref_shake256" "shake256" - "(outlen:bv 64, inlen:bv 64). arg0:memblock(W,0,outlen,emptysh), arg1:eq(llvmword(outlen)), \ - \ arg2:array(W,0,)), arg3:eq(llvmword(inlen)) \ - \ -o arg0:array(W,0,)), \ - \ arg2:array(W,0,))"; - -// poly.c - -heapster_assume_fun_rename_prim env "pqcrystals_dilithium2_ref_poly_challenge" "poly_challenge" - "(). arg0:uninit_poly, arg1:array(W,0,<32,*1,fieldsh(8,int8<>)) \ - \ -o arg0:poly, arg1:array(W,0,<32,*1,fieldsh(8,int8<>))"; - -heapster_assume_fun_rename_prim env "pqcrystals_dilithium2_ref_poly_ntt" "poly_ntt" - "(). arg0:poly -o arg0:poly"; - -// polyvec.c - -heapster_assume_fun_rename_prim env "pqcrystals_dilithium2_ref_polyvec_matrix_expand" "polyvec_matrix_expand" - "(). arg0:uninit_polymatlk, arg1:array(W,0,<32,*1,fieldsh(8,int8<>)) \ - \ -o arg0:polymatlk, arg1:array(W,0,<32,*1,fieldsh(8,int8<>))"; - -heapster_assume_fun_rename_prim env "pqcrystals_dilithium2_ref_polyvec_matrix_pointwise_montgomery" "polyvec_matrix_pointwise_montgomery" - "(). arg0:uninit_polyveck, arg1:polymatlk, arg2:polyvecl \ - \ -o arg0:polyveck, arg1:polymatlk, arg2:polyvecl"; - -heapster_assume_fun_rename_prim env "pqcrystals_dilithium2_ref_polyvecl_uniform_eta" "polyvecl_uniform_eta" - "(). arg0:uninit_polyvecl, arg1:array(W,0,<64,*1,fieldsh(8,int8<>)), arg2:int16<> \ - \ -o arg0:polyvecl, arg1:array(W,0,<64,*1,fieldsh(8,int8<>))"; - -heapster_assume_fun_rename_prim env "pqcrystals_dilithium2_ref_polyvecl_uniform_gamma1" "polyvecl_uniform_gamma1" - "(). arg0:uninit_polyvecl, arg1:array(W,0,<64,*1,fieldsh(8,int8<>)), arg2:int16<> \ - \ -o arg0:polyvecl, arg1:array(W,0,<64,*1,fieldsh(8,int8<>))"; - -heapster_assume_fun_rename_prim env "pqcrystals_dilithium2_ref_polyvecl_reduce" "polyvecl_reduce" - "(). arg0:polyvecl -o arg0:polyvecl"; - -heapster_assume_fun_rename_prim env "pqcrystals_dilithium2_ref_polyvecl_add" "polyvecl_add" - "(). arg0:polyvecl, arg1:eq(arg0), arg2:polyvecl \ - \ -o arg0:polyvecl, arg1:eq(arg0), arg2:polyvecl"; - -heapster_assume_fun_rename_prim env "pqcrystals_dilithium2_ref_polyvecl_ntt" "polyvecl_ntt" - "(). arg0:polyvecl -o arg0:polyvecl"; - -heapster_assume_fun_rename_prim env "pqcrystals_dilithium2_ref_polyvecl_invntt_tomont" "polyvecl_invntt_tomont" - "(). arg0:polyvecl -o arg0:polyvecl"; - -heapster_assume_fun_rename_prim env "pqcrystals_dilithium2_ref_polyvecl_pointwise_poly_montgomery" "polyvecl_pointwise_poly_montgomery" - "(). arg0:uninit_polyvecl, arg1:poly, arg2:polyvecl \ - \ -o arg0:polyvecl, arg1:poly, arg2:polyvecl"; - -heapster_assume_fun_rename_prim env "pqcrystals_dilithium2_ref_polyvecl_chknorm" "polyvecl_chknorm" - "(). arg0:polyvecl, arg1:int32<> -o arg0:polyvecl, ret:int32<>"; - -heapster_assume_fun_rename_prim env "pqcrystals_dilithium2_ref_polyveck_uniform_eta" "polyveck_uniform_eta" - "(). arg0:uninit_polyveck, arg1:array(W,0,<64,*1,fieldsh(8,int8<>)), arg2:int16<> \ - \ -o arg0:polyveck, arg1:array(W,0,<64,*1,fieldsh(8,int8<>))"; - -heapster_assume_fun_rename_prim env "pqcrystals_dilithium2_ref_polyveck_reduce" "polyveck_reduce" - "(). arg0:polyveck -o arg0:polyveck"; - -heapster_assume_fun_rename_prim env "pqcrystals_dilithium2_ref_polyveck_caddq" "polyveck_caddq" - "(). arg0:polyveck -o arg0:polyveck"; - -heapster_assume_fun_rename_prim env "pqcrystals_dilithium2_ref_polyveck_add" "polyveck_add" - "(). arg0:polyveck, arg1:eq(arg0), arg2:polyveck \ - \ -o arg0:polyveck, arg1:eq(arg0), arg2:polyveck"; - -heapster_assume_fun_rename_prim env "pqcrystals_dilithium2_ref_polyveck_sub" "polyveck_sub" - "(). arg0:polyveck, arg1:eq(arg0), arg2:polyveck \ - \ -o arg0:polyveck, arg1:eq(arg0), arg2:polyveck"; - -heapster_assume_fun_rename_prim env "pqcrystals_dilithium2_ref_polyveck_shiftl" "polyveck_shiftl" - "(). arg0:polyveck -o arg0:polyveck"; - -heapster_assume_fun_rename_prim env "pqcrystals_dilithium2_ref_polyveck_ntt" "polyveck_ntt" - "(). arg0:polyveck -o arg0:polyveck"; - -heapster_assume_fun_rename_prim env "pqcrystals_dilithium2_ref_polyveck_invntt_tomont" "polyveck_invntt_tomont" - "(). arg0:polyveck -o arg0:polyveck"; - -heapster_assume_fun_rename_prim env "pqcrystals_dilithium2_ref_polyveck_pointwise_poly_montgomery" "polyveck_pointwise_poly_montgomery" - "(). arg0:uninit_polyveck, arg1:poly, arg2:polyveck \ - \ -o arg0:polyveck, arg1:poly, arg2:polyveck"; - -heapster_assume_fun_rename_prim env "pqcrystals_dilithium2_ref_polyveck_chknorm" "polyveck_chknorm" - "(). arg0:polyveck, arg1:int32<> -o arg0:polyveck, ret:int32<>"; - -heapster_assume_fun_rename_prim env "pqcrystals_dilithium2_ref_polyveck_power2round" "polyveck_power2round" - "(). arg0:polyveck, arg1:uninit_polyveck, arg2:eq(arg0) \ - \ -o arg0:polyveck, arg1:polyveck, arg2:eq(arg0)"; - -heapster_assume_fun_rename_prim env "pqcrystals_dilithium2_ref_polyveck_decompose" "polyveck_decompose" - "(). arg0:polyveck, arg1:uninit_polyveck, arg2:eq(arg0) \ - \ -o arg0:polyveck, arg1:polyveck, arg2:eq(arg0)"; - -heapster_assume_fun_rename_prim env "pqcrystals_dilithium2_ref_polyveck_make_hint" "polyveck_make_hint" - "(). arg0:uninit_polyveck, arg1:polyveck, arg2:polyveck \ - \ -o arg0:polyveck, arg1:polyveck, arg2:polyveck, ret:int32<>"; - -heapster_assume_fun_rename_prim env "pqcrystals_dilithium2_ref_polyveck_use_hint" "polyveck_use_hint" - "(). arg0:polyveck, arg1:eq(arg0), arg2:polyveck \ - \ -o arg0:polyveck, arg1:eq(arg0), arg2:polyveck"; - -heapster_assume_fun_rename_prim env "pqcrystals_dilithium2_ref_polyveck_pack_w1" "polyveck_pack_w1" - "(). arg0:memblock(W,0,768,emptysh), arg1:polyveck \ - \ -o arg0:array(W,0,<768,*1,fieldsh(8,int8<>)), arg1:polyveck"; - -// packing.c - -heapster_assume_fun_rename_prim env "pqcrystals_dilithium2_ref_pack_pk" "pack_pk" - "(). arg0:memblock(W,0,1312,emptysh), arg1:array(W,0,<32,*1,fieldsh(8,int8<>)), arg2:polyveck \ - \ -o arg0:array(W,0,<1312,*1,fieldsh(8,int8<>)), arg1:array(W,0,<32,*1,fieldsh(8,int8<>)), arg2:polyveck"; - -heapster_assume_fun_rename_prim env "pqcrystals_dilithium2_ref_unpack_pk" "unpack_pk" - "(). arg0:memblock(W,0,32,emptysh), arg1:uninit_polyveck, arg2:array(W,0,<1312,*1,fieldsh(8,int8<>)) \ - \ -o arg0:array(W,0,<32,*1,fieldsh(8,int8<>)), arg1:polyveck, arg2:array(W,0,<1312,*1,fieldsh(8,int8<>))"; - -heapster_assume_fun_rename_prim env "pqcrystals_dilithium2_ref_pack_sk" "pack_sk" - "(). arg0:memblock(W,0,2560,emptysh), arg1:array(W,0,<32,*1,fieldsh(8,int8<>)), \ - \ arg2:array(W,0,<64,*1,fieldsh(8,int8<>)), arg3:array(W,0,<32,*1,fieldsh(8,int8<>)), \ - \ arg4:polyveck, arg5:polyvecl, arg6:polyveck \ - \ -o arg0:array(W,0,<2560,*1,fieldsh(8,int8<>)), arg1:array(W,0,<32,*1,fieldsh(8,int8<>)), \ - \ arg2:array(W,0,<64,*1,fieldsh(8,int8<>)), arg3:array(W,0,<32,*1,fieldsh(8,int8<>)), \ - \ arg4:polyveck, arg5:polyvecl, arg6:polyveck"; - -heapster_assume_fun_rename_prim env "pqcrystals_dilithium2_ref_unpack_sk" "unpack_sk" - "(). arg0:memblock(W,0,32,emptysh), arg1:memblock(W,0,64,emptysh), \ - \ arg2:memblock(W,0,32,emptysh), arg3:uninit_polyvecl, arg4:uninit_polyvecl, \ - \ arg5:uninit_polyvecl, arg6:array(W,0,<2560,*1,fieldsh(8,int8<>)) \ - \ -o arg0:array(W,0,<32,*1,fieldsh(8,int8<>)), arg1:array(W,0,<64,*1,fieldsh(8,int8<>)), \ - \ arg2:array(W,0,<32,*1,fieldsh(8,int8<>)), arg3:polyvecl, arg4:polyvecl, \ - \ arg5:polyvecl, arg6:array(W,0,<2560,*1,fieldsh(8,int8<>))"; - -heapster_assume_fun_rename_prim env "pqcrystals_dilithium2_ref_pack_sig" "pack_sig" - "(). arg0:memblock(W,0,2420,emptysh), arg1:array(W,0,<32,*1,fieldsh(8,int8<>)), \ - \ arg2:polyvecl, arg3:polyveck \ - \ -o arg0:array(W,0,<2420,*1,fieldsh(8,int8<>)), arg1:array(W,0,<32,*1,fieldsh(8,int8<>)), \ - \ arg2:polyvecl, arg3:polyveck"; - -heapster_assume_fun_rename_prim env "pqcrystals_dilithium2_ref_unpack_sig" "unpack_sig" - "(). arg0:memblock(W,0,32,emptysh), arg1:uninit_polyvecl, arg2:uninit_polyveck, \ - \ arg3:array(W,0,<2420,*1,fieldsh(8,int8<>)) \ - \ -o arg0:array(W,0,<32,*1,fieldsh(8,int8<>)), arg1:polyvecl, arg2:polyveck, \ - \ arg3:array(W,0,<2420,*1,fieldsh(8,int8<>)), ret:int32<>"; - - -///////////////////////////////////// -// Heapster typechecking of sign.c // -///////////////////////////////////// - -heapster_typecheck_fun_rename env "pqcrystals_dilithium2_ref_keypair" "crypto_sign_keypair" - "(). arg0:memblock(W,0,1312,emptysh), arg1:memblock(W,0,2560,emptysh) \ - \ -o arg0:array(W,0,<1312,*1,fieldsh(8,int8<>)), arg1:array(W,0,<2560,*1,fieldsh(8,int8<>)), ret:int32<>"; - -heapster_typecheck_fun_rename env "pqcrystals_dilithium2_ref_signature" "crypto_sign_signature" - "(mlen:bv 64). arg0:memblock(W,0,2420,emptysh), arg1:ptr((W,0) |-> true), \ - \ arg2:array(W,0,)), arg3:eq(llvmword(mlen)), \ - \ arg4:array(W,0,<2560,*1,fieldsh(8,int8<>)) \ - \ -o arg0:array(W,0,<2420,*1,fieldsh(8,int8<>)), arg1:ptr((W,0) |-> int64<>), \ - \ arg2:array(W,0,)), \ - \ arg4:array(W,0,<2560,*1,fieldsh(8,int8<>)), ret:int32<>"; - -heapster_typecheck_fun_rename env "pqcrystals_dilithium2_ref" "crypto_sign" - "(mlen:bv 64). arg0:memblock(W,0,2420,emptysh) * memblock(W,2420,mlen,emptysh), \ - \ arg1:ptr((W,0) |-> true), \ - \ arg2:array(W,0,)), arg3:eq(llvmword(mlen)), \ - \ arg4:array(W,0,<2560,*1,fieldsh(8,int8<>)) \ - \ -o arg0:array(W,0,<2420,*1,fieldsh(8,int8<>)) * array(W,2420,)), \ - \ arg1:ptr((W,0) |-> int64<>), \ - \ arg2:array(W,0,)), arg3:eq(llvmword(mlen)), \ - \ arg4:array(W,0,<2560,*1,fieldsh(8,int8<>)), ret:int32<>"; - -heapster_typecheck_fun_rename env "pqcrystals_dilithium2_ref_verify" "crypto_sign_verify" - "(slen:bv 64, mlen: bv 64). \ - \ arg0:array(W,0,<2420,*1,fieldsh(8,int8<>)), arg1:eq(llvmword(slen)), \ - \ arg2:array(W,0,)), arg3:eq(llvmword(mlen)), \ - \ arg4:array(W,0,<1312,*1,fieldsh(8,int8<>)) \ - \ -o arg0:array(W,0,<2420,*1,fieldsh(8,int8<>)), \ - \ arg2:array(W,0,)), \ - \ arg4:array(W,0,<1312,*1,fieldsh(8,int8<>)), ret:int32<>"; - -// heapster_set_debug_level env 1; - -// heapster_typecheck_fun_rename env "pqcrystals_dilithium2_ref_open" "crypto_sign_open" -// "(smlen: bv 64). \ -// \ arg0:memblock(W,0,smlen,emptysh), arg1:ptr((W,0) |-> true), \ -// \ arg2:array(W,0,)), arg3:eq(llvmword(smlen)), \ -// \ arg4:array(W,0,<1312,*1,fieldsh(8,int8<>)) \ -// \ -o arg0:array(W,0,)), arg1:ptr((W,0) |-> int64<>), \ -// \ arg2:array(W,0,)), \ -// \ arg4:array(W,0,<1312,*1,fieldsh(8,int8<>)), ret:int32<>"; - - -////////////////////////////////////////////// -// The saw-core terms generated by Heapster // -////////////////////////////////////////////// - -let randombytes = parse_core_mod "Dilithium2" "randombytes"; -let shake256_init = parse_core_mod "Dilithium2" "shake256_init"; -let shake256_absorb = parse_core_mod "Dilithium2" "shake256_absorb"; -let shake256_finalize = parse_core_mod "Dilithium2" "shake256_finalize"; -let shake256_squeeze = parse_core_mod "Dilithium2" "shake256_squeeze"; -let shake256 = parse_core_mod "Dilithium2" "shake256"; -let poly_challenge = parse_core_mod "Dilithium2" "poly_challenge"; -let poly_ntt = parse_core_mod "Dilithium2" "poly_ntt"; -let polyvec_matrix_expand = parse_core_mod "Dilithium2" "polyvec_matrix_expand"; -let polyvec_matrix_pointwise_montgomery = parse_core_mod "Dilithium2" "polyvec_matrix_pointwise_montgomery"; -let polyvecl_uniform_eta = parse_core_mod "Dilithium2" "polyvecl_uniform_eta"; -let polyvecl_uniform_gamma1 = parse_core_mod "Dilithium2" "polyvecl_uniform_gamma1"; -let polyvecl_reduce = parse_core_mod "Dilithium2" "polyvecl_reduce"; -let polyvecl_add = parse_core_mod "Dilithium2" "polyvecl_add"; -let polyvecl_ntt = parse_core_mod "Dilithium2" "polyvecl_ntt"; -let polyvecl_invntt_tomont = parse_core_mod "Dilithium2" "polyvecl_invntt_tomont"; -let polyvecl_pointwise_poly_montgomery = parse_core_mod "Dilithium2" "polyvecl_pointwise_poly_montgomery"; -let polyvecl_chknorm = parse_core_mod "Dilithium2" "polyvecl_chknorm"; -let polyveck_uniform_eta = parse_core_mod "Dilithium2" "polyveck_uniform_eta"; -let polyveck_reduce = parse_core_mod "Dilithium2" "polyveck_reduce"; -let polyveck_caddq = parse_core_mod "Dilithium2" "polyveck_caddq"; -let polyveck_add = parse_core_mod "Dilithium2" "polyveck_add"; -let polyveck_sub = parse_core_mod "Dilithium2" "polyveck_sub"; -let polyveck_shiftl = parse_core_mod "Dilithium2" "polyveck_shiftl"; -let polyveck_ntt = parse_core_mod "Dilithium2" "polyveck_ntt"; -let polyveck_invntt_tomont = parse_core_mod "Dilithium2" "polyveck_invntt_tomont"; -let polyveck_pointwise_poly_montgomery = parse_core_mod "Dilithium2" "polyveck_pointwise_poly_montgomery"; -let polyveck_chknorm = parse_core_mod "Dilithium2" "polyveck_chknorm"; -let polyveck_power2round = parse_core_mod "Dilithium2" "polyveck_power2round"; -let polyveck_decompose = parse_core_mod "Dilithium2" "polyveck_decompose"; -let polyveck_make_hint = parse_core_mod "Dilithium2" "polyveck_make_hint"; -let polyveck_use_hint = parse_core_mod "Dilithium2" "polyveck_use_hint"; -let polyveck_pack_w1 = parse_core_mod "Dilithium2" "polyveck_pack_w1"; -let pack_pk = parse_core_mod "Dilithium2" "pack_pk"; -let unpack_pk = parse_core_mod "Dilithium2" "unpack_pk"; -let pack_sk = parse_core_mod "Dilithium2" "pack_sk"; -let unpack_sk = parse_core_mod "Dilithium2" "unpack_sk"; -let pack_sig = parse_core_mod "Dilithium2" "pack_sig"; -let unpack_sig = parse_core_mod "Dilithium2" "unpack_sig"; -let crypto_sign_keypair = parse_core_mod "Dilithium2" "crypto_sign_keypair"; -let crypto_sign_signature = parse_core_mod "Dilithium2" "crypto_sign_signature"; -let crypto_sign = parse_core_mod "Dilithium2" "crypto_sign"; -let crypto_sign_verify = parse_core_mod "Dilithium2" "crypto_sign_verify"; - - -//////////////////////////////////////////////////// -// Mr. Solver assumptions of auxilliary functions // -//////////////////////////////////////////////////// - -print "Admitting refinements of auxiliary functions:"; -thm_randombytes <- prove_extcore (admit "randombytes") (refines [] randombytes {{ randombytes }}); -thm_shake256_init <- prove_extcore (admit "shake256_init") (refines [] shake256_init {{ shake256_init }}); -thm_shake256_absorb <- prove_extcore (admit "shake256_absorb") (refines [] shake256_absorb {{ shake256_absorb }}); -thm_shake256_finalize <- prove_extcore (admit "shake256_finalize") (refines [] shake256_finalize {{ shake256_finalize }}); -thm_shake256_squeeze <- prove_extcore (admit "shake256_squeeze") (refines [] shake256_squeeze {{ shake256_squeeze }}); -thm_shake256 <- prove_extcore (admit "shake256") (refines [] shake256 {{ shake256 }}); -thm_poly_challenge <- prove_extcore (admit "poly_challenge") (refines [] poly_challenge {{ poly_challenge }}); -thm_poly_ntt <- prove_extcore (admit "poly_ntt") (refines [] poly_ntt {{ poly_ntt }}); -thm_polyvec_matrix_expand <- prove_extcore (admit "polyvec_matrix_expand") (refines [] polyvec_matrix_expand {{ polyvec_matrix_expand }}); -thm_polyvec_matrix_pointwise_montgomery <- prove_extcore (admit "polyvec_matrix_pointwise_montgomery") (refines [] polyvec_matrix_pointwise_montgomery {{ polyvec_matrix_pointwise_montgomery }}); -thm_polyvecl_uniform_eta <- prove_extcore (admit "polyvecl_uniform_eta") (refines [] polyvecl_uniform_eta {{ polyvecl_uniform_eta }}); -thm_polyvecl_uniform_gamma1 <- prove_extcore (admit "polyvecl_uniform_gamma1") (refines [] polyvecl_uniform_gamma1 {{ polyvecl_uniform_gamma1 }}); -thm_polyvecl_reduce <- prove_extcore (admit "polyvecl_reduce") (refines [] polyvecl_reduce {{ polyvecl_reduce }}); -thm_polyvecl_add <- prove_extcore (admit "polyvecl_add") (refines [] polyvecl_add {{ polyvecl_add }}); -thm_polyvecl_ntt <- prove_extcore (admit "polyvecl_ntt") (refines [] polyvecl_ntt {{ polyvecl_ntt }}); -thm_polyvecl_invntt_tomont <- prove_extcore (admit "polyvecl_invntt_tomont") (refines [] polyvecl_invntt_tomont {{ polyvecl_invntt_tomont }}); -thm_polyvecl_pointwise_poly_montgomery <- prove_extcore (admit "polyvecl_pointwise_poly_montgomery") (refines [] polyvecl_pointwise_poly_montgomery {{ polyvecl_pointwise_poly_montgomery }}); -thm_polyvecl_chknorm <- prove_extcore (admit "polyvecl_chknorm") (refines [] polyvecl_chknorm {{ polyvecl_chknorm }}); -thm_polyveck_uniform_eta <- prove_extcore (admit "polyveck_uniform_eta") (refines [] polyveck_uniform_eta {{ polyveck_uniform_eta }}); -thm_polyveck_reduce <- prove_extcore (admit "polyveck_reduce") (refines [] polyveck_reduce {{ polyveck_reduce }}); -thm_polyveck_caddq <- prove_extcore (admit "polyveck_caddq") (refines [] polyveck_caddq {{ polyveck_caddq }}); -thm_polyveck_add <- prove_extcore (admit "polyveck_add") (refines [] polyveck_add {{ polyveck_add }}); -thm_polyveck_sub <- prove_extcore (admit "polyveck_sub") (refines [] polyveck_sub {{ polyveck_sub }}); -thm_polyveck_shiftl <- prove_extcore (admit "polyveck_shiftl") (refines [] polyveck_shiftl {{ polyveck_shiftl }}); -thm_polyveck_ntt <- prove_extcore (admit "polyveck_ntt") (refines [] polyveck_ntt {{ polyveck_ntt }}); -thm_polyveck_invntt_tomont <- prove_extcore (admit "polyveck_invntt_tomont") (refines [] polyveck_invntt_tomont {{ polyveck_invntt_tomont }}); -thm_polyveck_pointwise_poly_montgomery <- prove_extcore (admit "polyveck_pointwise_poly_montgomery") (refines [] polyveck_pointwise_poly_montgomery {{ polyveck_pointwise_poly_montgomery }}); -thm_polyveck_chknorm <- prove_extcore (admit "polyveck_chknorm") (refines [] polyveck_chknorm {{ polyveck_chknorm }}); -thm_polyveck_power2round <- prove_extcore (admit "polyveck_power2round") (refines [] polyveck_power2round {{ polyveck_power2round }}); -thm_polyveck_decompose <- prove_extcore (admit "polyveck_decompose") (refines [] polyveck_decompose {{ polyveck_decompose }}); -thm_polyveck_make_hint <- prove_extcore (admit "polyveck_make_hint") (refines [] polyveck_make_hint {{ polyveck_make_hint }}); -thm_polyveck_use_hint <- prove_extcore (admit "polyveck_use_hint") (refines [] polyveck_use_hint {{ polyveck_use_hint }}); -thm_polyveck_pack_w1 <- prove_extcore (admit "polyveck_pack_w1") (refines [] polyveck_pack_w1 {{ polyveck_pack_w1 }}); -thm_pack_pk <- prove_extcore (admit "pack_pk") (refines [] pack_pk {{ pack_pk }}); -thm_unpack_pk <- prove_extcore (admit "unpack_pk") (refines [] unpack_pk {{ unpack_pk }}); -thm_pack_sk <- prove_extcore (admit "pack_sk") (refines [] pack_sk {{ pack_sk }}); -thm_unpack_sk <- prove_extcore (admit "unpack_sk") (refines [] unpack_sk {{ unpack_sk }}); -thm_pack_sig <- prove_extcore (admit "pack_sig") (refines [] pack_sig {{ pack_sig }}); -thm_unpack_sig <- prove_extcore (admit "unpack_sig") (refines [] unpack_sig {{ unpack_sig }}); -print "(Done admitting refinements of auxiliary functions)\n"; - -let assumed_fns = addrefns [ - thm_randombytes, thm_shake256_init, thm_shake256_absorb, thm_shake256_finalize, - thm_shake256_squeeze, thm_shake256, thm_poly_challenge, thm_poly_ntt, - thm_polyvec_matrix_expand, thm_polyvec_matrix_pointwise_montgomery, - thm_polyvecl_uniform_eta, thm_polyvecl_uniform_gamma1, thm_polyvecl_reduce, - thm_polyvecl_add, thm_polyvecl_ntt, thm_polyvecl_invntt_tomont, - thm_polyvecl_pointwise_poly_montgomery, thm_polyvecl_chknorm, - thm_polyveck_uniform_eta, thm_polyveck_reduce, thm_polyveck_caddq, - thm_polyveck_add, thm_polyveck_sub, thm_polyveck_shiftl, thm_polyveck_ntt, - thm_polyveck_invntt_tomont, thm_polyveck_pointwise_poly_montgomery, - thm_polyveck_chknorm, thm_polyveck_power2round, thm_polyveck_decompose, - thm_polyveck_make_hint, thm_polyveck_use_hint, thm_polyveck_pack_w1, - thm_pack_pk, thm_unpack_pk, thm_pack_sk, thm_unpack_sk, thm_pack_sig, - thm_unpack_sig ] empty_rs; - - -//////////////////////// -// Mr. Solver: sign.c // -//////////////////////// - -thm_crypto_sign_keypair <- - prove_extcore - (mrsolver_with assumed_fns) - (refines [] crypto_sign_keypair {{ crypto_sign_keypair }}); - -thm_crypto_sign_signature <- - prove_extcore - (mrsolver_with assumed_fns) - (refines [] crypto_sign_signature {{ crypto_sign_signature }}); - -let {{ - crypto_sign_spec : {mlen} Literal mlen [64] => - [mlen][8] -> [CRYPTO_SECRETKEYBYTES][8] -> - ([CRYPTO_BYTES][8], [mlen][8], [64], [mlen][8], [CRYPTO_SECRETKEYBYTES][8], [32]) - crypto_sign_spec m sk = assuming (`mlen < (-2420)) (crypto_sign m sk) -}}; - -thm_crypto_sign <- - prove_extcore - (mrsolver_with (addrefns [thm_crypto_sign_signature] assumed_fns)) - (refines [] crypto_sign {{ crypto_sign_spec }}); - -thm_crypto_sign_verify <- - prove_extcore - (mrsolver_with assumed_fns) - (refines [] crypto_sign_verify {{ crypto_sign_verify }}); diff --git a/heapster/examples/Either.cry b/heapster/examples/Either.cry deleted file mode 100644 index 6adf0f39e0..0000000000 --- a/heapster/examples/Either.cry +++ /dev/null @@ -1,10 +0,0 @@ - -/* The definition of the Either type as an abstract type in Cryptol */ - -module Either where - -primitive type Either : * -> * -> * - -primitive Left : {a, b} a -> Either a b -primitive Right : {a, b} b -> Either a b -primitive either : {a, b, c} (a -> c) -> (b -> c) -> Either a b -> c diff --git a/heapster/examples/Makefile b/heapster/examples/Makefile deleted file mode 100644 index e7e8f4102f..0000000000 --- a/heapster/examples/Makefile +++ /dev/null @@ -1,70 +0,0 @@ -all: Makefile.coq mr-solver-tests - -Makefile.coq: _CoqProject - coq_makefile -f _CoqProject -o Makefile.coq - -include Makefile.coq - -# If running in CI, always set $SAW=`which saw`. Otherwise, if saw is not in the -# current path, fall back on cabal run saw -SAW=$(shell which saw) -ifeq ($(SAW),) - ifeq ($(CI),) - SAW=cabal run saw - else - $(error Could not find SAW executable; PATH = $(PATH)) - endif -endif - -# If running in GitHub Actions, the $CI environment variable will be defined -# (see https://docs.github.com/en/actions/learn-github-actions/variables#default-environment-variables) -# and these Makefile rules will not be defined. As a consequence, Make will -# /never/ rebuild .bc files. This ensures that the CI will always test the .bc -# files that were checked into version control. (See #1801 for an example of -# what can go wrong if CI rebuilds .bc files with different compilers from what -# were used to originally produce them.) -ifeq ($(CI),) - %.bc: %.c - clang -emit-llvm -g -c $< - - xor_swap_rust.bc: xor_swap_rust.rs - rustc --crate-type=lib --emit=llvm-bc xor_swap_rust.rs - - rust_data.bc: rust_data.rs - rustc --crate-type=lib --emit=llvm-bc rust_data.rs - - rust_lifetimes.bc: rust_lifetimes.rs - rustc --crate-type=lib --emit=llvm-bc rust_lifetimes.rs - - dilithium: dilithium.patch - rm -rf dilithium - git clone https://github.com/pq-crystals/dilithium.git - # NB: If you update this commit hash be sure to also update the commit hash - # in the top-level comment in `heapster/examples/Dilithium2.saw` - cd dilithium && git checkout 918af1a6eaedcedf9fdd8aaaca6c1fccd5a7a51f - patch -p0 < dilithium.patch - - # NB: So far we've only been able to get this step to work on a Ubuntu VM, - # so building dilithium2.bc, etc. locally on a non-Ubuntu machine is likely - # not possible without significant effort to configure clang appropriately - dilithium%.bc: dilithium - cd dilithium/ref && LLVM_COMPILER=clang make bitcode - cp dilithium/ref/libpqcrystals_dilithium$*_ref.so.bc dilithium$*.bc -endif - -%_gen.v: %.saw %.bc - $(SAW) $< - -# Lists all the Mr Solver tests without their ".saw" suffix, except Dilithium2 -# FIXME: Get linked_list and sha512 working with type descriptions -MR_SOLVER_TESTS = higher_order_mr_solver exp_explosion_mr_solver \ - arrays_mr_solver # linked_list_mr_solver sha512_mr_solver - -.PHONY: mr-solver-tests $(MR_SOLVER_TESTS) Dilithium2 -mr-solver-tests: $(MR_SOLVER_TESTS) Dilithium2 - -$(MR_SOLVER_TESTS): - $(SAW) $@.saw - -Dilithium2: dilithium2.bc - $(SAW) Dilithium2.saw diff --git a/heapster/examples/SpecPrims.cry b/heapster/examples/SpecPrims.cry deleted file mode 100644 index 5a64cf7754..0000000000 --- a/heapster/examples/SpecPrims.cry +++ /dev/null @@ -1,29 +0,0 @@ -module SpecPrims where - -/* Specification primitives */ - -// The specification that holds for some element of type a -exists : {a} a -exists = error "Cannot run exists" - -// The specification that holds for all elements of type a -forall : {a} a -forall = error "Cannot run forall" - -// The specification that a computation has no errors -noErrors : {a} a -noErrors = exists - -// The specification which asserts that the first argument is True and then -// returns the second argument -asserting : {a} Bit -> a -> a -asserting b x = if b then x else error "Assertion failed" - -// The specification which assumes that the first argument is True and then -// returns the second argument -assuming : {a} Bit -> a -> a -assuming _ x = x - -// A hint to Mr Solver that a recursive function has the given loop invariant -invariantHint : {a} Bit -> a -> a -invariantHint b x = x diff --git a/heapster/examples/_CoqProject b/heapster/examples/_CoqProject deleted file mode 100644 index 17ff80627c..0000000000 --- a/heapster/examples/_CoqProject +++ /dev/null @@ -1,40 +0,0 @@ --Q ../../saw-core-coq/coq/generated/CryptolToCoq CryptolToCoq --Q ../../saw-core-coq/coq/handwritten/CryptolToCoq CryptolToCoq --Q . Examples - -# FIXME: Uncomment _proofs files when they're updated with the latest automation -linked_list_gen.v -#linked_list_proofs.v -xor_swap_gen.v -#xor_swap_proofs.v -xor_swap_rust_gen.v -#xor_swap_rust_proofs.v -c_data_gen.v -#c_data_proofs.v -string_set_gen.v -#string_set_proofs.v -loops_gen.v -#loops_proofs.v -iter_linked_list_gen.v -#iter_linked_list_proofs.v -memcpy_gen.v -#memcpy_proofs.v -rust_data_gen.v -#rust_data_proofs.v -rust_lifetimes_gen.v -#rust_lifetimes_proofs.v -arrays_gen.v -#arrays_proofs.v -clearbufs_gen.v -#clearbufs_proofs.v -exp_explosion_gen.v -#exp_explosion_proofs.v -mbox_gen.v -#mbox_proofs.v -global_var_gen.v -#global_var_proofs.v -sha512_gen.v -#sha512_proofs.v -io_gen.v -#io_proofs.v -#common.v diff --git a/heapster/examples/arrays.bc b/heapster/examples/arrays.bc deleted file mode 100644 index c24694e418..0000000000 Binary files a/heapster/examples/arrays.bc and /dev/null differ diff --git a/heapster/examples/arrays.c b/heapster/examples/arrays.c deleted file mode 100644 index 9ab31a74a5..0000000000 --- a/heapster/examples/arrays.c +++ /dev/null @@ -1,155 +0,0 @@ -#include -#include - -/* Test if an array contains 0 recursively */ -int64_t contains0_rec (int64_t *arr, int64_t len, int64_t i) { - if (i >= len) { - return 0; - } else if (arr[i] == 0) { - return 1; - } else { - return contains0_rec (arr, len, i+1); - } -} - -/* Like contains0_rec but with len first */ -int64_t contains0_rec_ (uint64_t len, int64_t *arr, uint64_t i) { - if (i >= len) { - return 0; - } else if (arr[i] == 0) { - return 1; - } else { - return contains0_rec_ (len, arr, i+1); - } -} - -/* Test if an array contains 0 */ -int64_t contains0 (int64_t *arr, uint64_t len) { - for (uint64_t i = 0; i < len; ++i) { - if (arr[i] == 0) { return 1; } - } - return 0; -} - -/* Test if an array contains 0 */ -int64_t contains0_after (int64_t *arr, uint64_t len, uint64_t i) { - for (; i < len; ++i) { - if (arr[i] == 0) { return 1; } - } - return 0; -} - -/* Test if a sorted array contains 0 by divide-and-conquer */ -int64_t contains0_sorted_rec (int64_t *arr, uint64_t len) { - if (len == 0) { - return 0; - } else if (len == 1) { - return arr[0] == 0 ? 1 : 0; - } else { - uint64_t halfway = len / 2; - if (arr[halfway] > 0) { - return contains0_sorted_rec (arr, halfway); - } else { - return contains0_sorted_rec (arr+halfway, len - halfway); - } - } -} - -/* Zero out an array */ -void zero_array (int64_t *arr, uint64_t len) { - for (uint64_t i = 0; i < len; ++i) { - arr[i] = 0; - } -} - -/* Zero out an array starting at a given offset */ -void zero_array_from (int64_t *arr, uint64_t len, uint64_t off) { - for (; off < len; ++off) { - arr[off] = 0; - } -} - -/* Zeroes every negative element of an array and returns the - sum of the results */ -uint64_t filter_and_sum_pos (int64_t * arr, uint64_t len) { - uint64_t sum = 0; - for (uint64_t i = 0; i < len; ++i) { - if (arr[i] < 0) { - arr[i] = 0; - } - sum += arr[i]; - } - return sum; -} - -uint64_t sum_2d (int64_t **arr, uint64_t l1, uint64_t l2) { - uint64_t sum = 0; - for (uint64_t i = 0; i < l1; ++i) { - for (uint64_t j = 0; j < l2; ++j) { - sum += arr[i][j]; - } - } - return sum; -} - -/* Finds the sum of the elements of an array by incrementing the given pointer - instead of using a for loop over an index */ -uint64_t sum_inc_ptr(const uint8_t *arr, size_t len) { - uint64_t sum = 0; - while (len--) { - sum += arr[0]; - arr += 1; - } - return sum; -} - -/* Like the above, but uses an array of int64_t */ -uint64_t sum_inc_ptr_64(const uint64_t *arr, size_t len) { - uint64_t sum = 0; - while (len--) { - sum += arr[0]; - arr += 8; - } - return sum; -} - -/* For an array of even length, returns the sum of the even components of the - array minus the sum of the odd components of an array */ -uint64_t even_odd_sums_diff(const uint64_t *arr, size_t len) { - uint64_t sum = 0; - for (uint64_t i = 1; i < len; i += 2) { - sum += arr[i-1] - arr[i]; - } - return sum; -} - -uint64_t alloc_sum_array_test (void) { - uint64_t X[8]; - X[0] = 0; X[1] = 1; X[2] = 2; X[3] = 3; - X[4] = 4; X[5] = 5; X[6] = 6; X[7] = 7; - /* - for (uint64_t i = 0; i < 16; ++i) { - X[i] = i; - } - */ - return sum_inc_ptr_64 (X, 8); -} - -/* A dummy function used as a hint for Heapster that arr is initialized up - through index i */ -void array_init_hint (uint64_t len, uint64_t i, uint64_t *arr) { return; } - -/* Test out an initialization loop for a locally-allocated array, using a - function that initializes an array X to X[i]=i for each i and then sums the - resulting array by calling sum_inc_ptr_64. This is similar to - alloc_sum_array_test, except that it initializes the array in a loop. */ -uint64_t array_init_loop_test (void) { - uint64_t X[8]; - uint64_t i = 0; - - array_init_hint (8, i, X); - for (; i < 8; ++i) { - X[i] = i; - } - return sum_inc_ptr_64 (X, 8); -} diff --git a/heapster/examples/arrays.cry b/heapster/examples/arrays.cry deleted file mode 100644 index 4b7ce92922..0000000000 --- a/heapster/examples/arrays.cry +++ /dev/null @@ -1,15 +0,0 @@ - -module Arrays where - -import SpecPrims - -zero_array_loop_spec : {n} Literal n [64] => [n][64] -> [n][64] -zero_array_loop_spec ys = loop 0 ys - where loop : [64] -> [n][64] -> [n][64] - loop i xs = invariantHint (i <= 0x0fffffffffffffff) - (if i < `n then loop (i+1) (update xs i 0) - else xs) - -zero_array_spec : {n} Literal n [64] => [n][64] -> [n][64] -zero_array_spec xs = assuming (`n <= 0x0fffffffffffffff) - [ 0 | _ <- xs ] diff --git a/heapster/examples/arrays.saw b/heapster/examples/arrays.saw deleted file mode 100644 index 3c2d204627..0000000000 --- a/heapster/examples/arrays.saw +++ /dev/null @@ -1,81 +0,0 @@ -enable_experimental; -env <- heapster_init_env_from_file "arrays.sawcore" "arrays.bc"; - -// Integer types -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(W,0,))"; - - -heapster_typecheck_fun env "contains0_rec_" - "(len:bv 64). arg0:eq(llvmword(len)), arg1:int64array, arg2:int64<> -o \ - \ arg0:true, arg1:int64array, arg2:true, ret:int64<>"; - -// the old way using a block entry hint -// heapster_block_entry_hint env "contains0" 9 -// "top0:bv 64, top1:llvmptr 64, top2:llvmptr 64" -// "frm:llvmframe 64, x0:llvmptr 64, x1:llvmptr 64" -// "top0:true, top1:array(0, int64<>]), -// \ top2:eq(llvmword(top0)), arg0:ptr((W,0) |-> true), \ -// \ arg1:ptr((W,0) |-> eq(x1)), arg2:ptr((W,0) |-> eq(x0)), arg3:ptr((W,0) |-> int64<>), \ -// \ frm:llvmframe [arg3:8, arg2:8, arg1:8, arg0:8], x0:eq(top2), x1:eq(top1)"; -// heapster_typecheck_fun env "contains0" -// "(len:bv 64). arg0:array(0, int64<>]), arg1:eq(llvmword(len)) -o \ -// \ arg0:array(0, int64<>]), arg1:true, ret:int64<>"; - -heapster_typecheck_fun env "contains0" - "(len:bv 64). arg0:int64array, arg1:eq(llvmword(len)) -o \ - \ arg0:int64array, arg1:true, ret:int64<>"; - -heapster_typecheck_fun env "zero_array" - "(len:bv 64). arg0:int64array, arg1:eq(llvmword(len)) -o \ - \ arg0:int64array, arg1:true, ret:true"; - -heapster_typecheck_fun env "zero_array_from" - "(len:bv 64, off:bv 64). arg0:int64array, arg1:eq(llvmword(len)), arg2:eq(llvmword(off)) -o \ - \ arg0:int64array, arg1:true, arg2:true, ret:true"; - -heapster_join_point_hint env "filter_and_sum_pos" []; -heapster_typecheck_fun env "filter_and_sum_pos" - "(len:bv 64). arg0:int64array, arg1:eq(llvmword(len)) -o \ - \ arg0:int64array, arg1:true, ret:int64<>"; - -heapster_typecheck_fun env "sum_2d" - "(l1:bv 64,l2:bv 64). arg0:array(W,0,)))), \ - \ arg1:eq(llvmword(l1)), arg2:eq(llvmword(l2)) -o \ - \ arg0:array(W,0,)))), \ - \ arg1:true, arg2:true, ret:int64<>"; - -heapster_typecheck_fun env "sum_inc_ptr" - "(len:bv 64). arg0:array(W,0,)), arg1:eq(llvmword(len)) -o \ - \ arg0:array(W,0,)), arg1:true, ret:int64<>"; - -heapster_typecheck_fun env "sum_inc_ptr_64" - "(len:bv 64). arg0:array(W,0,)), arg1:eq(llvmword(len)) -o \ - \ arg0:array(W,0,)), arg1:true, ret:int64<>"; - -// Notably, this works even without heapster widening the permissions of `i` to -// `eq(2*x+1)` for some ghost `x` (currently, it sees `eq(1)` and `eq(3)` and -// widens them to just `eq(x)` for some ghost `x`) -heapster_typecheck_fun env "even_odd_sums_diff" - "(l:bv 64). arg0:array(W,0,<2*l,*8,fieldsh(int64<>)), arg1:eq(llvmword(2*l)) -o \ - \ arg0:array(W,0,<2*l,*8,fieldsh(int64<>)), arg1:true, ret:int64<>"; - -heapster_typecheck_fun env "alloc_sum_array_test" "(). empty -o ret:int64<>"; - -// This is a dummy function, used as a hint to Heapster that the second argument -// is initialized up through the index given by the first -heapster_typecheck_fun env "array_init_hint" - "(len:bv 64, i: bv 64). \ - \ arg0:eq(llvmword(len)), arg1:eq(llvmword(i)), \ - \ arg2:array(W,0,)) * memblock(W, 8*i, len + (-8)*i, emptysh) \ - \ -o \ - \ arg2:array(W,0,)) * memblock(W, 8*i, len + (-8)*i, emptysh)"; - -//heapster_set_debug_level env 1; -/* -heapster_typecheck_fun env "array_init_loop_test" "(). empty -o ret:int64<>"; -*/ - -heapster_export_coq env "arrays_gen.v"; diff --git a/heapster/examples/arrays.sawcore b/heapster/examples/arrays.sawcore deleted file mode 100644 index 750a4ae7f9..0000000000 --- a/heapster/examples/arrays.sawcore +++ /dev/null @@ -1,44 +0,0 @@ - -module arrays where - -import SpecM; - -noErrorsHDesc : TpDesc; -noErrorsHDesc = - Tp_Pi - (Kind_Expr (Kind_bv 64)) - (Tp_Arr - (Tp_Kind (Kind_Expr (Kind_bv 64))) - (Tp_Arr - (Tp_BVVec 64 (TpExpr_Var (Kind_bv 64) 0) - (Tp_Kind (Kind_Expr (Kind_bv 64)))) - (Tp_M (Tp_Pair - (Tp_BVVec 64 (TpExpr_Var (Kind_bv 64) 0) - (Tp_Kind (Kind_Expr (Kind_bv 64)))) - (Tp_Kind (Kind_Expr (Kind_bv 64))))))); - - --- The helper function for noErrorsContains0 --- --- noErrorsContains0H len i v = --- orS existsS (noErrorsContains0H len (i+1) v) -noErrorsContains0H : (len i:Vec 64 Bool) -> BVVec 64 len (Vec 64 Bool) -> - SpecM VoidEv (BVVec 64 len (Vec 64 Bool) * Vec 64 Bool); -noErrorsContains0H len_top i_top v_top = - (FixS VoidEv noErrorsHDesc - (\ (rec : specFun VoidEv noErrorsHDesc) (len:Vec 64 Bool) (i:Vec 64 Bool) - (v:BVVec 64 len (Vec 64 Bool)) -> - invariantHint - (SpecM VoidEv (BVVec 64 len (Vec 64 Bool) * Vec 64 Bool)) - (and (bvsle 64 0x0000000000000000 i) - (bvsle 64 i 0x0fffffffffffffff)) - (orS VoidEv (BVVec 64 len (Vec 64 Bool) * Vec 64 Bool) - (existsS VoidEv (BVVec 64 len (Vec 64 Bool) * Vec 64 Bool)) - (rec len (bvAdd 64 i 0x0000000000000001) v)))) - len_top i_top v_top; - --- The specification that contains0 has no errors -noErrorsContains0 : (len:Vec 64 Bool) -> BVVec 64 len (Vec 64 Bool) -> - SpecM VoidEv (BVVec 64 len (Vec 64 Bool) * Vec 64 Bool); -noErrorsContains0 len v = - noErrorsContains0H len 0x0000000000000000 v; diff --git a/heapster/examples/arrays_mr_solver.saw b/heapster/examples/arrays_mr_solver.saw deleted file mode 100644 index 21c9f2f453..0000000000 --- a/heapster/examples/arrays_mr_solver.saw +++ /dev/null @@ -1,18 +0,0 @@ -include "arrays.saw"; - -// Test that contains0 |= contains0 -let contains0 = parse_core_mod "arrays" "contains0"; -prove_extcore mrsolver (refines [] contains0 contains0); - -let noErrorsContains0 = parse_core_mod "arrays" "noErrorsContains0"; -prove_extcore mrsolver (refines [] contains0 noErrorsContains0); - -include "specPrims.saw"; -import "arrays.cry"; - -monadify_term {{ zero_array_spec }}; - -// FIXME: Uncomment once FunStacks are removed -let zero_array = parse_core_mod "arrays" "zero_array"; -prove_extcore mrsolver (refines [] zero_array {{ zero_array_loop_spec }}); -prove_extcore mrsolver (refines [] zero_array {{ zero_array_spec }}); diff --git a/heapster/examples/arrays_proofs.v b/heapster/examples/arrays_proofs.v deleted file mode 100644 index 1c69ae0032..0000000000 --- a/heapster/examples/arrays_proofs.v +++ /dev/null @@ -1,435 +0,0 @@ -From Coq Require Import Lists.List. -From Coq Require Import String. -From Coq Require Import Vectors.Vector. -From CryptolToCoq Require Import SAWCoreScaffolding. -From CryptolToCoq Require Import SAWCoreVectorsAsCoqVectors. -From CryptolToCoq Require Import SAWCoreBitvectors. - -From CryptolToCoq Require Import SAWCorePrelude. -From EnTree Require Import Automation. -Require Import Lia. -From CryptolToCoq Require Import SAWCoreBitvectorsZifyU64. - -Require Import Examples.common. -Require Import Examples.arrays_gen. -Import arrays. - -Import SAWCorePrelude. - -Import VectorNotations. - -Set Nested Proofs Allowed. -Lemma UIP_bv : - forall {n} (x y : bitvector n) (p1 p2 : x = y), p1 = p2. -Proof. - intros. - apply UIP_dec. - clear. intros. - refine (eq_dec _ boolEq _ n x y). - clear. intros. - split; intros H. - - destruct x; destruct y; auto. - - subst x. destruct y; reflexivity. -Qed. -Require Import Coq.Program.Tactics. - -Declare Scope bv_64. -Local Open Scope bv_64. -Bind Scope bv_64 with bitvector. - -Infix "+":= (bvAdd 64) (at level 50, left associativity): bv_64. -Infix "-":= (bvSub 64) (at level 50, left associativity): bv_64. -Infix "<":= (isBvslt 64) (at level 70): bv_64. -Infix "<=":= (isBvsle 64) (at level 70): bv_64. - -(*This is a prototype of a tactic to solve all signed inequalities for -Boolean vectors, as long as there is no overflow. Ideally, if the -tactic fails, it will show you the bounds you need to prove that thre -is no overflow. You probably missed them in your invariants. - -The idea is pretty simple: convert everything to to `Int` and, becasue -there is no overflow, we can remove the module quantifiers and crush -it with standard lia. - -TO DO: - -- Support all arith relations eq[ ], lt[ ], gt[ ], le[✓], ge[ ] - -- Don't directly apply rewrites to all subgoals for efficiency - -- Recognize when there is a terminal "node" to apply `lia`. Right now - we attempt lia at every step, whcih is wasteful. - - *) - -Lemma eq_bvToInt: - forall n a b, - (BinInt.Z.lt (bvToInt n a) (bvToInt n b)) -> - isBvslt n a b. -Proof. -Admitted. -Lemma lt_bvToInt: - forall n a b, - (BinInt.Z.lt (bvToInt n a) (bvToInt n b)) -> - isBvslt n a b. -Proof. -Admitted. -Lemma le_bvToInt: - forall n a b, - (BinInt.Z.le (bvToInt n a) (bvToInt n b)) -> - isBvsle n a b. -Proof. -Admitted. - - -Ltac bvToInt_ineq:= - first [apply eq_bvToInt | - apply lt_bvToInt | - apply le_bvToInt]. - -Ltac remove_mods:= - (*TODO: Add other operations*) - try rewrite bvAdd_Zadd_mod_64; - try rewrite bvSub_Zsub_mod_64; - try rewrite bvMul_Zmul_mod_64; - repeat rewrite bvToInt_intToBv_64; - repeat rewrite BinInt.Z.mod_small. - -Ltac solve_bv_no_overflow:= - try lia; - match goal with - | |- isBvsle _ ?LHA ?RHS => - apply le_bvToInt - | |- isBvslt _ ?LHA ?RHS => - apply lt_bvToInt - end; remove_mods; - try solve_bv_no_overflow. - - - -Definition bvMem_lo := intToBv 64 0xf000000000000000. -Definition bvMem_hi := intToBv 64 0x0fffffffffffffff. - - -Definition zero_array_precond x - := isBvsle 64 (intToBv 64 0) x /\ isBvsle 64 x bvMem_hi. - -Definition zero_array_invariant x x' i - := isBvsle 64 (intToBv 64 0) i /\ isBvsle 64 i x /\ x = x'. - -Record HeVector T := - someVector { - hvLen1 : nat - ; hvLen2 : _ - ; theVector : BVVec hvLen1 hvLen2 T - }. -Arguments someVector {T hvLen1 hvLen2} theVector. - - -(* Simpler version of `inversion_sigma` where the inversion is only applied if the hyp has the same *) -Ltac simple_inv_sigma:= - match goal with - | H: (_; ?x) = (_; ?y) |- _ => eapply inj_pair2 in H; try subst x - end. -Ltac inv_with_sigma H:= inversion H; repeat simple_inv_sigma. -Tactic Notation "inv_someVector" "in" "*" := - match goal with H: someVector _ = someVector _ |- _ => inv_with_sigma H end. - - -Lemma HeVectorToSigma: - forall len len' vec vec', - (exists (Plen : len = len'), - eq_rect len (fun x => BVVec 64 x (bitvector 64)) vec len' Plen = vec') -> - someVector vec = someVector vec'. -Proof. intros * [Plen Heq]. subst len'. - rewrite <- eq_rect_eq in Heq; subst; auto. -Qed. - -Hint Extern 101 (IntroArg ?n (someVector ?a = someVector ?b) _) => - let e1 := argName n in IntroArg_intro e1; -(eapply HeVectorToSigma in e1); -revert e1; apply (IntroArg_fold n _ _) : refines prepostcond. - -Polymorphic Lemma IntroArg_someVector T n m a1 a2 b1 b2 (eq : a1 = a2) goal : - IntroArg n (eq_rect _ (fun x => BVVec m x T) b1 _ eq = b2) (fun _ => goal) -> - IntroArg n (@someVector T m a1 b1 = @someVector T m a2 b2) (fun _ => goal). -Proof. - destruct eq. - intros HH a. - inv_with_sigma a. - eapply HH; reflexivity. -Qed. - -Hint Extern 101 (IntroArg ?n ?A ?g) => - simple apply IntroArg_someVector; idtac "Done it" - : refines prepostcond. - -Lemma no_errors_zero_array x y: - spec_refines_eq (zero_array x y) - (total_spec (fun '(len, vec, dec) => zero_array_precond len) (fun _ _ => True) (x,y, bvAdd _ x (intToBv _ 1))). -Proof. - intros; unfold_function. - prove_refinement. - - wellfounded_decreasing_nat. - exact (bvToNat _ x1). - - prepost_case 0 0. - + exact (someVector a = someVector a0 /\ - x = x1 /\ - bvAdd _ x (intToBv _ 1) = x2). - + exact (someVector r = someVector r0). - + prepost_case 1 0. - * exact (someVector a = someVector a0 /\ - x = x2 /\ - x3 = bvSub _ x0 x1 /\ - zero_array_invariant x0 x x1). - * exact ( (someVector r = someVector r0)). - * prepost_exclude_remaining. - - prove_refinement_continue; - (* Need to add `inv_someVector` to the automation to reduce better*) - try inv_someVector in *. - (* with NoRewrite NoSolve *) - + reflexivity. - + assert (HH: isBvule _ x0 (bvsmax _)). - { clear - e_assume. - destruct e_assume. - eapply isBvule_to_isBvsle_pos; auto. - vm_compute; auto. - rewrite H0. vm_compute. reflexivity. - } - clear - HH. lia. - + reflexivity. - + repeat split. - eapply e_assume. - + reflexivity. - + destruct_conjs; subst. - clear HPrePost HWf. lia. - + destruct_conjs; subst. auto. - + unfold zero_array_precond in *; destruct_conjs; subst; hnf; split. - * solve_bv_no_overflow. - * split; auto. - solve_bv_no_overflow. - + reflexivity. - + unfold zero_array_precond, zero_array_invariant in *. - destruct_conjs; subst. - subst. - hnf. - rewrite and_bool_eq_false in *. - exfalso. - destruct e_if0 as [e_if0 | e_if0]. - * eapply isBvslt_def_opp in e_if0. - rewrite <- i1 in e_if0. - vm_compute in e_if0; congruence. - * eapply isBvslt_def_opp in e_if0. - rewrite -> i2 in e_if0. - rewrite -> i0 in e_if0. - vm_compute in e_if0. congruence. - + reflexivity. - - Unshelve. - all: auto. - -Qed. - - -Definition contains0_precond l - := isBvsle 64 (intToBv 64 0) l /\ isBvsle 64 l bvMem_hi. - -Definition contains0_invariant l l' i - := isBvsle 64 (intToBv 64 0) i /\ isBvsle 64 i l /\ l = l'. - -(* This proof is *identical* to no_errors_zero_array except for in the one noted spot *) -Lemma no_errors_contains0 - : refinesFun contains0 (fun x _ => assumingM (contains0_precond x) noErrorsSpec). -Proof. - unfold contains0, contains0__tuple_fun, contains0_precond. - prove_refinement_match_letRecM_l. - - exact (fun a' i _ _ _ _ _ => assumingM (contains0_invariant a a' i) noErrorsSpec). - unfold contains0_invariant, noErrorsSpec. - fold bvMem_lo; fold bvMem_hi. - time "no_errors_contains0" prove_refinement. - all: try assumption. - (* Different from no_errors_zero_array - this used to be taken care of by `prove_refinement`! - (FIXME Figure out why this fails to be automated here but not above.) *) - - rewrite e_if in e_maybe. - discriminate e_maybe. - - transitivity a2. - + assumption. - + apply isBvsle_suc_r; eauto. - rewrite e_assuming2, e_assuming0. - reflexivity. - - apply isBvslt_to_isBvsle_suc. - apply isBvult_to_isBvslt_pos; assumption. - - rewrite <- e_assuming1 in e_if0. - discriminate e_if0. - - rewrite e_assuming2, e_assuming0 in e_if0. - apply isBvslt_antirefl in e_if0; contradiction e_if0. -Qed. - - -Definition sum_2d_precond l1 l2 - := isBvsle 64 (intToBv 64 0) l1 /\ isBvsle 64 l1 bvMem_hi /\ - isBvsle 64 (intToBv 64 0) l2 /\ isBvsle 64 l2 bvMem_hi. - -Definition sum_2d_invariant1 (l1 l1' l2 l2' i j : bitvector 64) - := isBvsle 64 (intToBv 64 0) i /\ isBvslt 64 i l1 /\ l1 = l1' /\ - isBvsle 64 (intToBv 64 0) j /\ isBvsle 64 j l2 /\ l2 = l2'. - -Definition sum_2d_invariant2 (l1 l1' l2 l2' i : bitvector 64) - := isBvsle 64 (intToBv 64 0) i /\ isBvsle 64 i l1 /\ l1 = l1' /\ l2 = l2'. - -Lemma no_errors_sum_2d - : refinesFun sum_2d (fun l1 l2 _ => assumingM (sum_2d_precond l1 l2) noErrorsSpec). -Proof. - unfold sum_2d, sum_2d__tuple_fun, sum_2d_precond. - time "no_errors_sum_2d (1/2)" prove_refinement_match_letRecM_l. - - exact (fun a' a0' i j _ _ _ _ _ _ _ => assumingM (sum_2d_invariant1 a a' a0 a0' i j) noErrorsSpec). -Admitted. -(* - exact (fun a' a0' i => assumingM (sum_2d_invariant2 a a' a0 a0' i) noErrorsSpec). *) -(* unfold sum_2d_invariant1, sum_2d_invariant2, noErrorsSpec. *) -(* fold bvMem_lo; fold bvMem_hi. *) -(* time "no_errors_sum_2d (2/2)" prove_refinement. *) -(* all: try assumption. *) -(* * rewrite <- isBvult_to_isBvslt_pos in e_assuming4; try assumption. *) -(* rewrite e_assuming4 in e_maybe. *) -(* discriminate e_maybe. *) -(* * rewrite <- isBvsle_suc_r; try assumption. *) -(* rewrite e_assuming6, e_assuming2. *) -(* reflexivity. *) -(* * apply isBvslt_to_isBvsle_suc, isBvult_to_isBvslt_pos; assumption. *) -(* * rewrite <- e_assuming5 in e_if2. *) -(* vm_compute in e_if2; inversion e_if2. *) -(* * rewrite e_assuming6, e_assuming2 in e_if2. *) -(* apply isBvslt_antirefl in e_if2; inversion e_if2. *) -(* * rewrite <- e_assuming3 in e_if0. *) -(* vm_compute in e_if0; inversion e_if0. *) -(* * rewrite e_assuming4, e_assuming0 in e_if0. *) -(* apply isBvslt_antirefl in e_if0; inversion e_if0. *) -(* * rewrite e_assuming3. *) -(* apply isBvsle_suc_r, isBvslt_to_isBvsle. *) -(* rewrite e_assuming4, e_assuming0. *) -(* reflexivity. *) -(* * apply isBvslt_to_isBvsle_suc; assumption. *) -(* * apply isBvult_to_isBvslt_pos; assumption. *) -(* Qed. *) - - -Definition sum_inc_ptr_invar (len0 idx len : bitvector 64) := - isBvule 64 idx len0 /\ len = bvSub 64 len0 idx. - -Lemma no_errors_sum_inc_ptr : refinesFun sum_inc_ptr (fun len arr => noErrorsSpec). -Proof. - unfold sum_inc_ptr, sum_inc_ptr__tuple_fun. - prove_refinement_match_letRecM_l. - - exact (fun len0 idx len sum arr _ _ _ => assumingM (sum_inc_ptr_invar len0 idx len) noErrorsSpec). - 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. *) admit. - + rewrite H in e_maybe; discriminate e_maybe. - - apply isBvult_to_isBvule_suc; assumption. - - repeat rewrite bvSub_eq_bvAdd_neg. - rewrite bvAdd_assoc; f_equal. - rewrite bvNeg_bvAdd_distrib; reflexivity. - - apply isBvule_zero_n. - - symmetry; apply bvSub_n_zero. - *) -Admitted. -(* Qed. *) - - -Definition sum_inc_ptr_spec len : BVVec 64 len (bitvector 8) -> bitvector 64 := - foldr _ _ _ (fun a b => bvAdd 64 b (bvUExt 56 8 a)) (intToBv 64 0). - -Definition sum_inc_ptr_letRec_spec len0 idx len (sum : bitvector 64) arr (_ _ _ : unit) := - forallM (fun (pf : isBvule 64 idx len0) => - assumingM (len = bvSub 64 len0 idx) - (returnM (arr, bvAdd 64 sum (sum_inc_ptr_spec (bvSub 64 len0 idx) - (dropBVVec _ _ _ idx pf arr))))). - -Lemma sum_inc_ptr_spec_ref : - refinesFun sum_inc_ptr (fun len arr => returnM (arr, sum_inc_ptr_spec len arr)). -Proof. - unfold sum_inc_ptr, sum_inc_ptr__tuple_fun. - prove_refinement_match_letRecM_l. - - exact sum_inc_ptr_letRec_spec. - unfold noErrorsSpec, sum_inc_ptr_letRec_spec, sum_inc_ptr_spec. - time "sum_inc_ptr_spec_ref" prove_refinement. - (* Why didn't prove_refinement do this? *) - 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 |]. - apply bvEq_bvSub_r in H. - symmetry in H; contradiction. - + rewrite H in e_maybe; discriminate e_maybe. - - apply isBvult_to_isBvule_suc; assumption. - - repeat rewrite bvSub_eq_bvAdd_neg. - rewrite bvAdd_assoc; f_equal. - rewrite bvNeg_bvAdd_distrib; reflexivity. - (* unique to this proof *) - - admit. - - repeat f_equal. - admit. - (* same as no_errors_sum_inc_ptr *) - - apply isBvule_zero_n. - - symmetry; apply bvSub_n_zero. - (* unique to this proof *) - - rewrite bvAdd_id_l. - repeat f_equal. - admit. *) -Admitted. - -(* We *really* need a better bitvector library, the lemmas we need are getting pretty ad-hoc *) - -Axiom isBvsle_bvSub_inj_pos : forall w a b c, isBvsle w (intToBv w 0) a -> - isBvsle w (intToBv w 0) b -> - isBvsle w (intToBv w 0) c -> - isBvsle w (bvSub w a c) (bvSub w b c) <-> - isBvsle w a b. - -Definition even_odd_sums_diff_invar half_len len i := - len = bvMul 64 (intToBv 64 2) half_len /\ - isBvslt 64 (intToBv 64 0) i. - -Lemma no_errors_even_odd_sums_diff : - refinesFun even_odd_sums_diff (fun half_len arr => noErrorsSpec). -Proof. - unfold even_odd_sums_diff, even_odd_sums_diff__tuple_fun. - Set Printing Depth 1000. - prove_refinement_match_letRecM_l. - - exact (fun half_len len sum i arr _ _ _ _ => - assumingM (even_odd_sums_diff_invar half_len len i) - noErrorsSpec). - unfold even_odd_sums_diff_invar, noErrorsSpec. - time "even_odd_sums_diff" prove_refinement. - all: try assumption. - - enough (isBvult 64 a2 (bvMul 64 (intToBv 64 2) a1)) - by (rewrite H in e_maybe; discriminate e_maybe). - rewrite <- e_if. - assert (isBvsle 64 (intToBv 64 0) a4) by (apply isBvslt_to_isBvsle; eauto). - apply isBvult_to_isBvslt_pos; eauto. - + change (intToBv 64 0) with (bvSub 64 (intToBv 64 1) (intToBv 64 1)). - (* apply isBvsle_bvSub_inj_pos. *) - (* I give up I'm done messing around manually with bitvectors for now *) - admit. - + rewrite e_let. - apply isBvslt_pred_l; eauto. - rewrite <- e_assuming; reflexivity. - - (* (e_if4 is a contradiction) *) - admit. - - admit. - - rewrite e_assuming. - change (intToBv 64 2) with (bvAdd 64 (intToBv 64 1) (intToBv 64 1)). - rewrite <- bvAdd_assoc. - rewrite <- isBvslt_suc_r. - + admit. - + admit. -Admitted. diff --git a/heapster/examples/bc-annot/foo.bc b/heapster/examples/bc-annot/foo.bc deleted file mode 100644 index 2a2b58ba95..0000000000 Binary files a/heapster/examples/bc-annot/foo.bc and /dev/null differ diff --git a/heapster/examples/bc-annot/foo.ll b/heapster/examples/bc-annot/foo.ll deleted file mode 100644 index 78653057e0..0000000000 --- a/heapster/examples/bc-annot/foo.ll +++ /dev/null @@ -1,87 +0,0 @@ -; ModuleID = 'poly.bc' -source_filename = "poly.c" -target datalayout = "e-m:o-i64:64-f80:128-n8:16:32:64-S128" -target triple = "x86_64-apple-macosx10.16.0" - -@.ghosts = private unnamed_addr constant [42 x i8] c"frm:llvmframe 64,a:llvmptr 64,b:llvmptr 64", align 1 -@.spec = private unnamed_addr constant [90 x i8] c"arg0:eq(top1),arg1:eq(top0),top1:true,top0:ptr((R,0) |-> eq(arg0)),frm:llvmframe [b:8,a:8]", align 1 -define void @heapster.require(...) { ret void } -; Function Attrs: noinline nounwind optnone ssp uwtable - -define i64 @foo(i64*, i64) #0 !dbg !8 { - %3 = alloca i64*, align 8, !heapster !100 - %4 = alloca i64, align 4 - store i64* %0, i64** %3, align 8 - call void @llvm.dbg.declare(metadata i64** %3, metadata !13, metadata !DIExpression()), !dbg !14 - store i64 %1, i64* %4, align 4 - call void @llvm.dbg.declare(metadata i64* %4, metadata !15, metadata !DIExpression()), !dbg !16 - %5 = load i64, i64* %4, align 4, !dbg !17 - %6 = icmp sgt i64 %5, 0, !dbg !19 - br i1 %6, label %7, label %10, !dbg !20 - -7: ; preds = %2 - %8 = load i64, i64* %4, align 4, !dbg !21 - %9 = load i64*, i64** %3, align 8, !dbg !23 - store i64 %8, i64* %9, align 4, !dbg !24 - br label %13, !dbg !25 - -10: ; preds = %2 - %11 = load i64, i64* %4, align 4, !dbg !26 - %12 = load i64*, i64** %3, align 8, !dbg !28 - store i64 %11, i64* %12, align 4, !dbg !29 - br label %13 - -13: ; preds = %10, %7 - call void (...) @heapster.require( - i8* getelementptr inbounds ([42 x i8], [42 x i8]* @.ghosts, i64 0, i64 0), - i8* getelementptr inbounds ([90 x i8], [90 x i8]* @.spec, i64 0, i64 0), - i64 %1, - i64* %0 - ) - - ret i64 0, !dbg !30 -} - -; Function Attrs: nounwind readnone speculatable -declare void @llvm.dbg.declare(metadata, metadata, metadata) #1 - -attributes #0 = { noinline nounwind optnone ssp uwtable "correctly-rounded-divide-sqrt-fp-math"="false" "disable-tail-calls"="false" "less-precise-fpmad"="false" "min-legal-vector-width"="0" "no-frame-pointer-elim"="true" "no-frame-pointer-elim-non-leaf" "no-infs-fp-math"="false" "no-jump-tables"="false" "no-nans-fp-math"="false" "no-signed-zeros-fp-math"="false" "no-trapping-math"="false" "stack-protector-buffer-size"="8" "target-cpu"="penryn" "target-features"="+cx16,+cx8,+fxsr,+mmx,+sahf,+sse,+sse2,+sse3,+sse4.1,+ssse3,+x87" "unsafe-fp-math"="false" "use-soft-float"="false" } -attributes #1 = { nounwind readnone speculatable } - -!llvm.dbg.cu = !{!0} -!llvm.module.flags = !{!3, !4, !5, !6} -!llvm.ident = !{!7} - -!0 = distinct !DICompileUnit(language: DW_LANG_C99, file: !1, producer: "clang version 9.0.1 ", isOptimized: false, runtimeVersion: 0, emissionKind: FullDebug, enums: !2, nameTableKind: GNU) -!1 = !DIFile(filename: "poly.c", directory: "/Users/abakst/prj/saw-script/heapster-saw/examples/bc-annot") -!2 = !{} -!3 = !{i64 2, !"Dwarf Version", i64 4} -!4 = !{i64 2, !"Debug Info Version", i64 3} -!5 = !{i64 1, !"wchar_size", i64 4} -!6 = !{i64 7, !"PIC Level", i64 2} -!7 = !{!"clang version 9.0.1 "} -!8 = distinct !DISubprogram(name: "foo", scope: !1, file: !1, line: 5, type: !9, scopeLine: 5, flags: DIFlagPrototyped, spFlags: DISPFlagDefinition, unit: !0, retainedNodes: !2) -!9 = !DISubroutineType(types: !10) -!10 = !{!11, !12, !11} -!11 = !DIBasicType(name: "int", size: 32, encoding: DW_ATE_signed) -!12 = !DIDerivedType(tag: DW_TAG_pointer_type, baseType: !11, size: 64) -!13 = !DILocalVariable(name: "a", arg: 1, scope: !8, file: !1, line: 5, type: !12) -!14 = !DILocation(line: 5, column: 14, scope: !8) -!15 = !DILocalVariable(name: "b", arg: 2, scope: !8, file: !1, line: 5, type: !11) -!16 = !DILocation(line: 5, column: 21, scope: !8) -!17 = !DILocation(line: 7, column: 7, scope: !18) -!18 = distinct !DILexicalBlock(scope: !8, file: !1, line: 7, column: 7) -!19 = !DILocation(line: 7, column: 9, scope: !18) -!20 = !DILocation(line: 7, column: 7, scope: !8) -!21 = !DILocation(line: 8, column: 10, scope: !22) -!22 = distinct !DILexicalBlock(scope: !18, file: !1, line: 7, column: 14) -!23 = !DILocation(line: 8, column: 6, scope: !22) -!24 = !DILocation(line: 8, column: 8, scope: !22) -!25 = !DILocation(line: 9, column: 3, scope: !22) -!26 = !DILocation(line: 10, column: 10, scope: !27) -!27 = distinct !DILexicalBlock(scope: !18, file: !1, line: 9, column: 10) -!28 = !DILocation(line: 10, column: 6, scope: !27) -!29 = !DILocation(line: 10, column: 8, scope: !27) -!30 = !DILocation(line: 13, column: 3, scope: !8) -!100 = !{} -!101 = !{!"some spec...", !100} diff --git a/heapster/examples/bc-annot/foo.saw b/heapster/examples/bc-annot/foo.saw deleted file mode 100644 index 078a7766c9..0000000000 --- a/heapster/examples/bc-annot/foo.saw +++ /dev/null @@ -1,13 +0,0 @@ -enable_experimental; - -env <- heapster_init_env_from_file "foo.sawcore" "foo.bc"; -heapster_define_perm env "int64" " " "llvmptr 64" "exists x:bv 64.eq(llvmword(x))"; - -heapster_assume_fun env "heapster.require" -"(). empty -o empty" "returnM #() ()"; - -f <- heapster_find_symbol env "foo"; - -heapster_typecheck_fun env "foo" "(). arg0:ptr((W,0) |-> true),arg1:int64<> -o ret:true"; - -heapster_export_coq env "foo_gen.v"; diff --git a/heapster/examples/bc-annot/foo.sawcore b/heapster/examples/bc-annot/foo.sawcore deleted file mode 100644 index b759a3f762..0000000000 --- a/heapster/examples/bc-annot/foo.sawcore +++ /dev/null @@ -1,3 +0,0 @@ -module poly where - -import Prelude; \ No newline at end of file diff --git a/heapster/examples/c_data.bc b/heapster/examples/c_data.bc deleted file mode 100644 index aa54b529b2..0000000000 Binary files a/heapster/examples/c_data.bc and /dev/null differ diff --git a/heapster/examples/c_data.c b/heapster/examples/c_data.c deleted file mode 100644 index 627db7f6c6..0000000000 --- a/heapster/examples/c_data.c +++ /dev/null @@ -1,45 +0,0 @@ -#include -#include -#include - -/* Increment the first byte pointed to by a 64-bit word pointer */ -void incr_u64_ptr_byte (uint64_t *x) { - uint8_t *x_byte = (uint8_t*)x; - (*x_byte)++; -} - -typedef struct padded_struct { - uint64_t padded1; - uint8_t padded2; - uint64_t padded3; - uint8_t padded4; -} padded_struct; - -/* Allocated a padded_struct */ -padded_struct *alloc_padded_struct (void) { - padded_struct *ret = malloc (sizeof(padded_struct)); - ret->padded1 = 0; - ret->padded2 = 0; - ret->padded3 = 0; - ret->padded4 = 0; - return ret; -} - -/* Increment all fields of a padded_struct */ -void padded_struct_incr_all (padded_struct *p) { - p->padded1++; - p->padded2++; - p->padded3++; - p->padded4++; -} - -/* Test endianness by reading the first byte of a word */ -int64_t is_little_endian () { - int64_t x = 1; - int8_t is_le = *(int8_t*)(&x); - return is_le; -} - -int main (int argc, char **argv) { - printf ("Little endian test: %lli\n", is_little_endian()); -} diff --git a/heapster/examples/c_data.saw b/heapster/examples/c_data.saw deleted file mode 100644 index a9ca04c642..0000000000 --- a/heapster/examples/c_data.saw +++ /dev/null @@ -1,58 +0,0 @@ - -enable_experimental; -env <- heapster_init_env "c_data" "c_data.bc"; - -/*** - *** Type Definitions - ***/ - -// Integer types -heapster_define_perm env "int8" " " "llvmptr 8" "exists x:bv 8.eq(llvmword(x))"; -heapster_define_perm env "int64" " " "llvmptr 64" "exists x:bv 64.eq(llvmword(x))"; - -// padded_struct type -heapster_define_llvmshape env "u64" 64 "" "fieldsh(int64<>)"; - -heapster_define_llvmshape env "padded_struct" 64 "" - "fieldsh(int64<>);fieldsh(8,int8<>);fieldsh(56,true); \ - \ fieldsh(int64<>);fieldsh(8,int8<>);fieldsh(56,true)"; - - -/*** - *** Assumed Functions - ***/ - -heapster_assume_fun env "malloc" - "(sz:bv 64). arg0:eq(llvmword(8*sz)) -o \ - \ arg0:true, ret:array(W,0, \ - \ retS VoidEv \ - \ (BVVec 64 sz #()) \ - \ (genBVVec 64 sz #() (\\ (i:Vec 64 Bool) (_:is_bvult 64 i sz) -> ()))"; - - -/*** - *** Type-Checked Functions - ***/ - -// incr_u64_ptr_byte -heapster_typecheck_fun env "incr_u64_ptr_byte" - "(). arg0:ptr((W,0) |-> int64<>) -o arg0:ptr((W,0) |-> int64<>)"; - -// alloc_padded_struct -heapster_typecheck_fun env "alloc_padded_struct" - "(). empty -o ret:memblock(W,0,32,padded_struct<>)"; - -// padded_struct_incr_all -heapster_typecheck_fun env "padded_struct_incr_all" - "(). arg0:memblock(W,0,32,padded_struct<>) -o arg0:memblock(W,0,32,padded_struct<>)"; - -// is_little_endian -heapster_typecheck_fun env "is_little_endian" - "(). empty -o ret:int64<>"; - -/*** - *** Export to Coq - ***/ - -heapster_export_coq env "c_data_gen.v"; diff --git a/heapster/examples/c_data_proofs.v b/heapster/examples/c_data_proofs.v deleted file mode 100644 index cdb6fe0a6f..0000000000 --- a/heapster/examples/c_data_proofs.v +++ /dev/null @@ -1,32 +0,0 @@ -From Coq Require Import Lists.List. -From Coq Require Import String. -From Coq Require Import Vectors.Vector. -From CryptolToCoq Require Import SAWCoreScaffolding. -From CryptolToCoq Require Import SAWCoreVectorsAsCoqVectors. -From CryptolToCoq Require Import SAWCoreBitvectors. - -From CryptolToCoq Require Import SAWCorePrelude. -From EnTree Require Import Automation. - -Require Import Examples.common. -Require Import Examples.c_data_gen. -Import c_data. - -Import SAWCorePrelude. - - -Set Bullet Behavior "Strict Subproofs". - -Global Hint Unfold malloc: automation. - -Lemma no_errors_incr_u64_ptr_byte x: - spec_refines_eq (incr_u64_ptr_byte x) (safety_spec (x)). -Proof. solve_trivial_spec 0 0. Qed. - -Lemma no_errors_alloc_padded_struct : - spec_refines_eq alloc_padded_struct (safety_spec tt). -Proof. solve_trivial_spec 0 0; solve_trivial_sidecondition. Qed. - -Lemma no_errors_padded_struct_incr_all x0: - spec_refines_eq (padded_struct_incr_all x0) (safety_spec (x0)). -Proof. solve_trivial_spec 0 0; solve_trivial_sidecondition. Qed. diff --git a/heapster/examples/clearbufs.bc b/heapster/examples/clearbufs.bc deleted file mode 100644 index 7484039808..0000000000 Binary files a/heapster/examples/clearbufs.bc and /dev/null differ diff --git a/heapster/examples/clearbufs.c b/heapster/examples/clearbufs.c deleted file mode 100644 index 3002b50b35..0000000000 --- a/heapster/examples/clearbufs.c +++ /dev/null @@ -1,32 +0,0 @@ -#include -#include - -typedef struct bufs { - struct bufs * next; - int64_t len; - int64_t data []; -} bufs; - -void clearbufs (bufs * lst) -{ - // NOTE: the input value of lst is stored in a stack-allocated variable, which - // is also called lst below, but is called lp in the paper. This is sort-of - // like the following code, except that the following would actually make a - // second stack slot for variable lp, unlike the paper example. - // - // bufs **lp = alloca(8) - // *lp = lst; - - while (1) { - // NOTE: reading lst here and testing for NULL - // - // bufs *l = lst = *lp - // if (l == NULL) { ... } - if (lst == NULL) { - return; - } else { - lst->data[0] = 0; - lst = lst->next; - } - } -} diff --git a/heapster/examples/clearbufs.saw b/heapster/examples/clearbufs.saw deleted file mode 100644 index 51d05f210c..0000000000 --- a/heapster/examples/clearbufs.saw +++ /dev/null @@ -1,25 +0,0 @@ -enable_experimental; -env <- heapster_init_env_from_file "clearbufs.sawcore" "clearbufs.bc"; - -// Integer types -heapster_define_perm env "int64" " " "llvmptr 64" "exists x:bv 64.eq(llvmword(x))"; - -// FIXME: get reachability perms working again! -heapster_define_reachability_perm env "Bufs" - "x:llvmptr 64" "llvmptr 64" - "eq(x) or exists len:(bv 64).ptr((W,0) |-> Bufs) * \ - \ ptr((W,8) |-> eq(llvmword(len))) * \ - \ array(W, 16, ))" - "\\ (x y : Bufs) -> transMbox x y"; - -heapster_block_entry_hint env "clearbufs" 3 - "top1:llvmptr 64" - "frm:llvmframe 64,ghost:llvmptr 64" - "top1:Bufs, \ - \ arg0:ptr((W,0) |-> eq(ghost)), \ - \ ghost:Bufs,frm:llvmframe [arg0:8]"; - -heapster_typecheck_fun env "clearbufs" - "(). arg0:Bufs -o arg0:Bufs"; - -heapster_export_coq env "clearbufs_gen.v"; diff --git a/heapster/examples/clearbufs.sawcore b/heapster/examples/clearbufs.sawcore deleted file mode 100644 index dc26285e33..0000000000 --- a/heapster/examples/clearbufs.sawcore +++ /dev/null @@ -1,74 +0,0 @@ - -module clearbufs where - -import SpecM; - -V64 : sort 0; -V64 = Vec 64 Bool; - --- Harcoded 64 length bitvector value 16, used for mbox definitions -bv64_16 : Vec 64 Bool; -bv64_16 = [False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,True,False,False,False,False]; - --- An inductive type formulation of the Mbox type; this is just for --- documentation purposes, and isn't used in the below -data Mbox_Ind : sort 0 where { - Mbox_Ind_nil : Mbox_Ind; - Mbox_Ind_cons : Mbox_Ind -> (len : Vec 64 Bool) -> BVVec 64 len (Vec 64 Bool) -> Mbox_Ind; -} - --- Type description for the Mbox type, which is equivalent to Mbox_Ind -MboxDesc : TpDesc; -MboxDesc = - (Tp_Sum - Tp_Unit - (Tp_Sigma - (Kind_Expr (Kind_bv 64)) - (Tp_Pair - (varKindExpr Kind_Tp 1) - (Tp_BVVec 64 (varKindExpr (Kind_Expr (Kind_bv 64)) 0) - (Tp_Kind (Kind_Expr (Kind_bv 64))))))); - --- The type described by MboxDesc -Mbox : sort 0; -Mbox = indElem (unfoldIndTpDesc nilTpEnv MboxDesc); - -{- Mbox__rec : (P : Mbox -> sort 0) -> - (P Mbox_nil) -> - ((m:Mbox) -> P m -> (len:Vec 64 Bool) -> (d:BVVec 64 bv64_16 (Vec 64 Bool)) -> P (Mbox_cons m len d)) -> - (m:Mbox) -> P m; -Mbox__rec P f1 f2 m = Mbox#rec P f1 f2 m; -} - ---unfoldMbox : Mbox -> Either #() (Mbox * Vec 64 Bool * BVVec 64 bv64_16 (Vec 64 Bool)); -primitive -unfoldMbox : Mbox -> Either #() (Sigma (V64) (\ (len : V64) -> Mbox * BVVec 64 len (Vec 64 Bool))); - -{-unfoldMbox m = - Mbox__rec (\ (_:Mbox) -> Either #() (Mbox * Vec 64 Bool * BVVec 64 bv64_16 (Vec 64 Bool) * #())) - (Left #() (Mbox * Vec 64 Bool * BVVec 64 bv64_16 (Vec 64 Bool) * #()) ()) - (\ (m:Mbox) (_:Either #() (Mbox * Vec 64 Bool * BVVec 64 bv64_16 (Vec 64 Bool) * #())) (len:Vec 64 Bool) (d:BVVec 64 bv64_16 (Vec 64 Bool)) -> - Right #() (Mbox * Vec 64 Bool * BVVec 64 bv64_16 (Vec 64 Bool) * #()) (m, len, d, ())) - m; - -} - -primitive -foldMbox : Either #() (Sigma (V64) (\ (len : V64) -> Mbox * BVVec 64 len (Vec 64 Bool))) -> Mbox; - ---(Mbox * Vec 64 Bool * (BVVec 64 bv64_16 (Vec 64 Bool)) * #()) -> Mbox; -{- -foldMbox = - either #() (Mbox * Vec 64 Bool * (BVVec 64 bv64_16 (Vec 64 Bool)) * #()) Mbox - (\ (_:#()) -> Mbox_nil) - (\ (tup : (Mbox * Vec 64 Bool * (BVVec 64 bv64_16 (Vec 64 Bool)) * #())) -> - Mbox_cons tup.1 tup.2 tup.3); - -} - -primitive -transMbox : Mbox -> Mbox -> Mbox; -{- -transMbox m1 m2 = - Mbox__rec (\ (_ : Mbox) -> Mbox) - m2 - (\ (_ : Mbox) (rec:Mbox) (len : Vec 64 Bool) (vec : BVVec 64 bv64_16 (Vec 64 Bool)) -> Mbox_cons rec len vec) - m1; --} diff --git a/heapster/examples/clearbufs_proofs.v b/heapster/examples/clearbufs_proofs.v deleted file mode 100644 index 9ec69873e1..0000000000 --- a/heapster/examples/clearbufs_proofs.v +++ /dev/null @@ -1,14 +0,0 @@ -From Coq Require Import Lists.List. -From Coq Require Import String. -From Coq Require Import Vectors.Vector. -From CryptolToCoq Require Import SAWCoreScaffolding. -From CryptolToCoq Require Import SAWCoreVectorsAsCoqVectors. -From CryptolToCoq Require Import SAWCoreBitvectors. - -From CryptolToCoq Require Import SAWCorePrelude. -From CryptolToCoq Require Import CompMExtra. - -Require Import Examples.clearbufs_gen. -Import clearbufs. - -(* Eval cbn in clearbufs__tuple_fun. *) diff --git a/heapster/examples/common.v b/heapster/examples/common.v deleted file mode 100644 index 98786d08eb..0000000000 --- a/heapster/examples/common.v +++ /dev/null @@ -1,154 +0,0 @@ -(* -* Common definitions and tactics that make the examples easier to -* state and prove. Some or all of these could go into an automation file -* so we can start building functionality. *) - -From Coq Require Import Lists.List. -From Coq Require Import String. -From Coq Require Import Vectors.Vector. -From CryptolToCoq Require Import SAWCoreScaffolding. -From CryptolToCoq Require Import SAWCoreVectorsAsCoqVectors. -From CryptolToCoq Require Import SAWCoreBitvectors. - -From CryptolToCoq Require Import SAWCorePrelude. -From CryptolToCoq Require Import SpecMExtra. -From EnTree Require Import Automation. - -Require Import Coq.Program.Tactics. (* Great tacticals, move to automation. Perhaps `Require Export`? *) - - -Global Set Bullet Behavior "Strict Subproofs". - - -(** *Basic Coq tactics These are natural extensions of the Coq - standard library. I generally try to use names that are compatible - with those used in opther projects to help new users. - - We should consider moveing them at the top level - *) - -Ltac break_match:= - match goal with - |- context [match ?a with _ => _ end] => destruct a - end. -Ltac break_match_hyp:= - match goal with - [ H:context [match ?a with _ => _ end] |- _] => destruct a - end. - -Ltac forget_as term name:= - let Hforget := fresh in - remember term as name eqn:Hforget; clear Hforget. - - -(** *Basic Spec definitions *) - -(* Spec when all events and returns are expected to be the same *) -Definition spec_refines_eq {E Γ R}: - Rel (SpecM E Γ R) (SpecM E Γ R):= - @spec_refines E E Γ Γ eqPreRel eqPostRel R R eq. - -(* The spec fro things that have no errors. *) -Definition safety_spec {E Γ R A} {QT: QuantType R}: forall a: A, SpecM E Γ R:= - total_spec (fun _ => True) (fun _ _ => True). - - -(** * Tactics for solving trivial spec refinement *) - -(* unfolds the corresponding to the `fun__bodies` of a spec. *) -Ltac unfold_bodies:= - match goal with |- context[MultiFixS _ _ _ ?X__bodies] => unfold X__bodies end. - -(* | Unfolds a function applied to an arbitrary number of -arguments. Might fail if the function is a transparent definition of -an applied relation. *) -Ltac unfold_head T := - match T with - | ?T _ => unfold_head T - | ?T => unfold T; unfold_bodies - end. - -(* | Unfolds a function definition `func` and its body `func__bodies` *) -Create HintDb automation. -Ltac unfold_function:= - try unfold spec_refines_eq, safety_spec; - match goal with - | |- spec_refines _ _ _ ?fun_applied _ => let T := fun_applied in - unfold_head T - end; autounfold with automation. - -(* The follwoing functions are for automatically matching arguments, - in a spec trivial spec *) -Ltac PreCase_conjunction x y:= - eapply Logic.and;[exact (x=y)| ]. - -Ltac cont_join x tl cont:= - match tl with - | (?front, ?final) => - PreCase_conjunction x final; (cont front) - | _ => exact (x = tl) - end. - -Ltac SubGoal ls1 ls2 cont:= - match ls1 with - | (?x0 ; ?tl1 ) => SubGoal tl1 ls2 ltac:(fun tl2 => cont_join x0 tl2 cont) - | _ => cont ls2 - end. - -(* Ltac for trivial PreCase *) -Ltac PreCase_Trivial:= - match goal with - |- PreCase _ _ ?ls1 (?ls2; tt) => - SubGoal ls1 ls2 ltac:(fun ls => exact True) (* last part is only triggered if the lists are empty*) - end. - -(* Ltac for trivial PostCase *) -Ltac list_zip ls1 ls2:= - match ls1 with - | (?x, ?ls1') => match ls2 with - | (?y, ?ls2') => - apply Logic.and; - [list_zip ls1' ls2' | exact (x = y)] - | _ => fail "Mismatched lists" - end - | _ => exact (ls1 = ls2) - end. - -Ltac PostCase_Trivial:= - match goal with - |- PostCase _ _ _ _ ?ls1 ?ls2 => list_zip ls1 ls2 - end. - - -Ltac solve_prepost_case n m:= - prepost_case n m; - [PreCase_Trivial - | PostCase_Trivial - | prepost_exclude_remaining]. - -(* | This tactic solves many trivial spec refinements, specially good - when proving there is no error, which is generally trivial. *) -Ltac solve_trivial_spec n m:= - intros; unfold_function; prove_refinement; - [wellfounded_none | solve_prepost_case n m| prove_refinement_continue]. - -Ltac solve_trivial_sidecondition := - repeat break_match; repeat break_match_hyp; destruct_conjs; subst; tauto. - -(** *Tactics for clarity*) - -(* | This tactic allows you to forget errors, the precondition, -postcondition and relations to clearly see what we are proving.*) -Ltac clarify_goal_tutorial:= - match goal with - |- context [ErrorS _ ?st] => - let error_msg:=fresh "error_msg" in - forget_as st error_msg - end; - match goal with - | |- Automation.spec_refines ?pre ?post ?RR _ _ => - let PRE:=fresh "PRE" in - let POST:=fresh "POST" in - let Relation:=fresh "Relation" in - forget_as pre PRE; forget_as post POST; forget_as RR Relation - end. diff --git a/heapster/examples/dilithium.patch b/heapster/examples/dilithium.patch deleted file mode 100644 index 36c9e175e3..0000000000 --- a/heapster/examples/dilithium.patch +++ /dev/null @@ -1,216 +0,0 @@ -diff -ruN dilithium/ref/Makefile dilithium-modified/ref/Makefile ---- dilithium/ref/Makefile 2024-01-23 19:23:52 -+++ dilithium-modified/ref/Makefile 2024-01-23 19:28:48 -@@ -1,6 +1,7 @@ --CC ?= /usr/bin/cc -+CC = wllvm - CFLAGS += -Wall -Wextra -Wpedantic -Wmissing-prototypes -Wredundant-decls \ - -Wshadow -Wvla -Wpointer-arith -O3 -fomit-frame-pointer -+BCFLAGS = -O0 -g - NISTFLAGS += -Wno-unused-result -O3 -fomit-frame-pointer - SOURCES = sign.c packing.c polyvec.c poly.c ntt.c reduce.c rounding.c - HEADERS = config.h params.h api.h sign.h packing.h polyvec.h poly.h ntt.h \ -@@ -37,16 +38,24 @@ - $(CC) -shared -fPIC $(CFLAGS) -o $@ $< - - libpqcrystals_dilithium2_ref.so: $(SOURCES) $(HEADERS) symmetric-shake.c -- $(CC) -shared -fPIC $(CFLAGS) -DDILITHIUM_MODE=2 \ -+ $(CC) -shared -fPIC $(BCFLAGS) -DDILITHIUM_MODE=2 \ - -o $@ $(SOURCES) symmetric-shake.c - - libpqcrystals_dilithium3_ref.so: $(SOURCES) $(HEADERS) symmetric-shake.c -- $(CC) -shared -fPIC $(CFLAGS) -DDILITHIUM_MODE=3 \ -+ $(CC) -shared -fPIC $(BCFLAGS) -DDILITHIUM_MODE=3 \ - -o $@ $(SOURCES) symmetric-shake.c - - libpqcrystals_dilithium5_ref.so: $(SOURCES) $(HEADERS) symmetric-shake.c -- $(CC) -shared -fPIC $(CFLAGS) -DDILITHIUM_MODE=5 \ -+ $(CC) -shared -fPIC $(BCFLAGS) -DDILITHIUM_MODE=5 \ - -o $@ $(SOURCES) symmetric-shake.c -+ -+%.bc: % -+ extract-bc $< -+ -+bitcode: \ -+ libpqcrystals_dilithium2_ref.so.bc \ -+ libpqcrystals_dilithium3_ref.so.bc \ -+ libpqcrystals_dilithium5_ref.so.bc \ - - test/test_dilithium2: test/test_dilithium.c randombytes.c $(KECCAK_SOURCES) \ - $(KECCAK_HEADERS) -diff -ruN dilithium/ref/sign.c dilithium-modified/ref/sign.c ---- dilithium/ref/sign.c 2024-01-23 19:23:52 -+++ dilithium-modified/ref/sign.c 2024-01-23 19:28:48 -@@ -1,4 +1,5 @@ - #include -+#include - #include "params.h" - #include "sign.h" - #include "packing.h" -@@ -22,6 +23,7 @@ - **************************************************/ - int crypto_sign_keypair(uint8_t *pk, uint8_t *sk) { - uint8_t seedbuf[2*SEEDBYTES + CRHBYTES]; -+ uint8_t seedbuf_rand[SEEDBYTES]; - uint8_t tr[TRBYTES]; - const uint8_t *rho, *rhoprime, *key; - polyvecl mat[K]; -@@ -29,11 +31,11 @@ - polyveck s2, t1, t0; - - /* Get randomness for rho, rhoprime and key */ -- randombytes(seedbuf, SEEDBYTES); -- shake256(seedbuf, 2*SEEDBYTES + CRHBYTES, seedbuf, SEEDBYTES); -+ randombytes(seedbuf_rand, SEEDBYTES); -+ shake256(seedbuf, 2*SEEDBYTES + CRHBYTES, seedbuf_rand, SEEDBYTES); - rho = seedbuf; -- rhoprime = rho + SEEDBYTES; -- key = rhoprime + CRHBYTES; -+ rhoprime = seedbuf + SEEDBYTES; -+ key = seedbuf + SEEDBYTES + CRHBYTES; - - /* Expand matrix */ - polyvec_matrix_expand(mat, rho); -@@ -83,21 +85,17 @@ - size_t mlen, - const uint8_t *sk) - { -+ uint8_t sig_w1_packedbytes[K*POLYW1_PACKEDBYTES]; -+ uint8_t sig_ctildebytes[CTILDEBYTES]; - unsigned int n; -- uint8_t seedbuf[2*SEEDBYTES + TRBYTES + RNDBYTES + 2*CRHBYTES]; -- uint8_t *rho, *tr, *key, *mu, *rhoprime, *rnd; -+ uint8_t rho[SEEDBYTES], tr[TRBYTES], key[SEEDBYTES], -+ rnd[RNDBYTES], mu[CRHBYTES], rhoprime[CRHBYTES]; - uint16_t nonce = 0; - polyvecl mat[K], s1, y, z; - polyveck t0, s2, w1, w0, h; - poly cp; - keccak_state state; - -- rho = seedbuf; -- tr = rho + SEEDBYTES; -- key = tr + TRBYTES; -- rnd = key + SEEDBYTES; -- mu = rnd + RNDBYTES; -- rhoprime = mu + CRHBYTES; - unpack_sk(rho, tr, key, &t0, &s1, &s2, sk); - - -@@ -111,10 +109,17 @@ - #ifdef DILITHIUM_RANDOMIZED_SIGNING - randombytes(rnd, RNDBYTES); - #else -- for(n=0;n Either a b"; -cryptol_add_prim_type "Either" "Either" eith_tp; - -left_fun <- parse_core "left"; -cryptol_add_prim "Either" "Left" left_fun; - -right_fun <- parse_core "right"; -cryptol_add_prim "Either" "Right" right_fun; - -either_fun <- parse_core "either"; -cryptol_add_prim "Either" "either" either_fun; - -import "Either.cry"; diff --git a/heapster/examples/exp_explosion.bc b/heapster/examples/exp_explosion.bc deleted file mode 100644 index 964a64d1ba..0000000000 Binary files a/heapster/examples/exp_explosion.bc and /dev/null differ diff --git a/heapster/examples/exp_explosion.c b/heapster/examples/exp_explosion.c deleted file mode 100644 index 4c32d58c0f..0000000000 --- a/heapster/examples/exp_explosion.c +++ /dev/null @@ -1,23 +0,0 @@ -#include -#include - -#define op(x,y) x ^ (y << 1) - -int64_t exp_explosion(int64_t x0) { - int64_t x1 = op(x0, x0); - int64_t x2 = op(x1, x1); - int64_t x3 = op(x2, x2); - int64_t x4 = op(x3, x3); - int64_t x5 = op(x4, x4); - int64_t x6 = op(x5, x5); - int64_t x7 = op(x6, x6); - int64_t x8 = op(x7, x7); - int64_t x9 = op(x8, x8); - int64_t x10 = op(x9, x9); - int64_t x11 = op(x10, x10); - int64_t x12 = op(x11, x11); - int64_t x13 = op(x12, x12); - int64_t x14 = op(x13, x13); - int64_t x15 = op(x14, x14); - return x15; -} diff --git a/heapster/examples/exp_explosion.cry b/heapster/examples/exp_explosion.cry deleted file mode 100644 index 6a2b5cc5a0..0000000000 --- a/heapster/examples/exp_explosion.cry +++ /dev/null @@ -1,23 +0,0 @@ - -module ExpExplosion where - -op : [64] -> [64] -> [64] -op x y = x ^ (y << (1 : [6])) - -exp_explosion_spec : [64] -> [64] -exp_explosion_spec x0 = x15 - where x1 = op x0 x0 - x2 = op x1 x1 - x3 = op x2 x2 - x4 = op x3 x3 - x5 = op x4 x4 - x6 = op x5 x5 - x7 = op x6 x6 - x8 = op x7 x7 - x9 = op x8 x8 - x10 = op x9 x9 - x11 = op x10 x10 - x12 = op x11 x11 - x13 = op x12 x12 - x14 = op x13 x13 - x15 = op x14 x14 diff --git a/heapster/examples/exp_explosion.saw b/heapster/examples/exp_explosion.saw deleted file mode 100644 index d27dd66b27..0000000000 --- a/heapster/examples/exp_explosion.saw +++ /dev/null @@ -1,9 +0,0 @@ -enable_experimental; -env <- heapster_init_env "exp_explosion" "exp_explosion.bc"; - -heapster_define_perm env "int64" " " "llvmptr 64" "exists x:bv 64.eq(llvmword(x))"; - -heapster_typecheck_fun env "exp_explosion" - "(). arg0:int64<> -o ret:int64<>"; - -heapster_export_coq env "exp_explosion_gen.v"; diff --git a/heapster/examples/exp_explosion_mr_solver.saw b/heapster/examples/exp_explosion_mr_solver.saw deleted file mode 100644 index f4833cd98f..0000000000 --- a/heapster/examples/exp_explosion_mr_solver.saw +++ /dev/null @@ -1,6 +0,0 @@ -include "exp_explosion.saw"; - -import "exp_explosion.cry"; - -let exp_explosion = parse_core_mod "exp_explosion" "exp_explosion"; -prove_extcore mrsolver (refines [] exp_explosion {{ exp_explosion_spec }}); diff --git a/heapster/examples/exp_explosion_proofs.v b/heapster/examples/exp_explosion_proofs.v deleted file mode 100644 index 8d839f3196..0000000000 --- a/heapster/examples/exp_explosion_proofs.v +++ /dev/null @@ -1,20 +0,0 @@ -From Coq Require Import Lists.List. -From Coq Require Import String. -From Coq Require Import Vectors.Vector. -From CryptolToCoq Require Import SAWCoreScaffolding. -From CryptolToCoq Require Import SAWCoreVectorsAsCoqVectors. -From CryptolToCoq Require Import SAWCoreBitvectors. - -From CryptolToCoq Require Import SAWCorePrelude. -From CryptolToCoq Require Import CompMExtra. - -Require Import Examples.exp_explosion_gen. -Import exp_explosion. - -Import SAWCorePrelude. - -Lemma no_errors_explosion : refinesFun exp_explosion (fun _ => noErrorsSpec). -Proof. - unfold exp_explosion, exp_explosion__tuple_fun, noErrorsSpec. - time "no_errors_exp_explosion" prove_refinement. -Qed. diff --git a/heapster/examples/fun_ptr.c b/heapster/examples/fun_ptr.c deleted file mode 100644 index fde1538a6f..0000000000 --- a/heapster/examples/fun_ptr.c +++ /dev/null @@ -1,12 +0,0 @@ - -int bar (int x) { - return x+1; -} - -int foo (int (*f)(int)) { - return f (1); -} - -int call_foo () { - return foo (&bar); -} diff --git a/heapster/examples/global_var.bc b/heapster/examples/global_var.bc deleted file mode 100644 index 0cb09c9699..0000000000 Binary files a/heapster/examples/global_var.bc and /dev/null differ diff --git a/heapster/examples/global_var.c b/heapster/examples/global_var.c deleted file mode 100644 index 6975003bce..0000000000 --- a/heapster/examples/global_var.c +++ /dev/null @@ -1,56 +0,0 @@ -#include -#include - -/* A very simple acquire/release lock for some shared data */ - -int64_t shared_data = 0; -int64_t lock = 0; - -/* A spin lock; returns 1 after acquireing lock, otherwise runs forever. - (Not robust to concurrent semantics) */ -int64_t acquire_lock(int64_t** data) { - while (lock != 0) { - continue; - } - lock = 1; - *data = &shared_data; - return 1; -} - -/* To be called after a thread is done accessing the shared data. */ -void release_lock(void) { - lock = 0; - return; -} - - -int64_t acquire_release_acquire_release(void) { - - int64_t* data; - acquire_lock(&data); - *data = 42; - release_lock(); - - acquire_lock(&data); - if (data == NULL) { - return -1; - } - int64_t val = *data; - release_lock(); - return val; -} - -int64_t acquire_release_fail(void) { - int64_t* data; - acquire_lock(&data); - *data = 42; - release_lock(); - - *data = 84; - - // shared data should still be 42 - acquire_lock(&data); - int64_t val = *data; - release_lock(); - return val; -} diff --git a/heapster/examples/global_var.saw b/heapster/examples/global_var.saw deleted file mode 100644 index 5aa413ece8..0000000000 --- a/heapster/examples/global_var.saw +++ /dev/null @@ -1,77 +0,0 @@ -enable_experimental; -env <- heapster_init_env_from_file "global_var.sawcore" "global_var.bc"; - -// Integer types -heapster_define_perm env "int64" " " "llvmptr 64" "exists x:bv 64.eq(llvmword(x))"; - - -// Demonstrates one technique for dealing with global variables and environment -// permissions like locks - - - -// A heapster type for the lock global variable" -// -// The rwmodality makes the permission not copyable when provided the write -// modality. -// -// When extracted to Coq, u:has_lock_perm and u:can_lock_perm are -// bitvectors representing the value stored in the shared_data variable -heapster_define_opaque_perm env "has_lock_perm" - "rw:rwmodality, dat:llvmptr 64" - "unit" - "Vec 64 Bool" - "Tp_bitvector 64"; - -heapster_define_opaque_perm env "can_lock_perm" - "rw:rwmodality" - "unit" - "Vec 64 Bool" - "Tp_bitvector 64"; - -// Need to axiomatize acquire_lock because it touches the global variables -heapster_assume_fun env - "acquire_lock" - - "(u:unit). \ - \ arg0:ptr((W,0) |-> true), \ - \ u:can_lock_perm \ - \ -o \ - \ (dat:llvmptr 64). \ - \ ret:eq(llvmword(1)), \ - \ arg0:ptr((W,0) |-> eq(dat)), \ - \ dat:ptr((W,0) |-> int64<>), \ - \ u:has_lock_perm" - - "acquireLockM"; - -heapster_assume_fun env - "release_lock" - - "(u:unit, dat:llvmptr 64). \ - \ u:has_lock_perm, \ - \ dat:ptr((W,0) |-> int64<>) \ - \ -o \ - \ ret:true, \ - \ u:can_lock_perm" - - "releaseLockM"; - - - -heapster_typecheck_fun env - "acquire_release_acquire_release" - "(u:unit). u:can_lock_perm \ - \ -o \ - \ ret:int64<>, u:can_lock_perm"; - -// FIXME: this is meant to fail; figure out how to check that it does in CI... -/* -heapster_typecheck_fun env - "acquire_release_fail" - "(u:unit). u:can_lock_perm \ - \ -o \ - \ ret:int64<>, u:can_lock_perm"; -*/ - -heapster_export_coq env "global_var_gen.v"; diff --git a/heapster/examples/global_var.sawcore b/heapster/examples/global_var.sawcore deleted file mode 100644 index 9fad6aae80..0000000000 --- a/heapster/examples/global_var.sawcore +++ /dev/null @@ -1,9 +0,0 @@ -module GlobalVar where - -import SpecM; - -acquireLockM : Vec 64 Bool -> SpecM VoidEv (Vec 64 Bool * Vec 64 Bool); -acquireLockM u = retS VoidEv (Vec 64 Bool * Vec 64 Bool) (u,u); - -releaseLockM : Vec 64 Bool -> Vec 64 Bool -> SpecM VoidEv (Vec 64 Bool); -releaseLockM u new_u = retS VoidEv (Vec 64 Bool) new_u; diff --git a/heapster/examples/global_var_proofs.v b/heapster/examples/global_var_proofs.v deleted file mode 100644 index 7011518cf0..0000000000 --- a/heapster/examples/global_var_proofs.v +++ /dev/null @@ -1,56 +0,0 @@ -From Coq Require Import Lists.List. -From Coq Require Import String. -From Coq Require Import Vectors.Vector. -From CryptolToCoq Require Import SAWCoreScaffolding. -From CryptolToCoq Require Import SAWCoreVectorsAsCoqVectors. -From CryptolToCoq Require Import SAWCoreBitvectors. -From CryptolToCoq Require Import SAWCorePrelude. -From CryptolToCoq Require Import CompMExtra. - - - -Require Import Examples.global_var_gen. -Import GlobalVar. - -Import SAWCorePrelude. - -Lemma no_errors_acquire_release_acquire_release : - refinesFun acquire_release_acquire_release (fun _ => noErrorsSpec). -Proof. - unfold acquire_release_acquire_release, - acquire_release_acquire_release__tuple_fun, - noErrorsSpec, - acquireLockM, releaseLockM. - prove_refinement. -Qed. - - -Definition acquire_release_acquire_release_spec (x : bitvector 64) - : CompM (can_lock_perm * bitvector 64) := - returnM (intToBv 64 42, intToBv 64 42). - -Lemma spec_acquire_release_acquire_release : - refinesFun acquire_release_acquire_release - acquire_release_acquire_release_spec. -Proof. - unfold acquire_release_acquire_release, - acquire_release_acquire_release__tuple_fun, - acquire_release_acquire_release_spec, - acquireLockM, releaseLockM, - projT2. - prove_refinement. -Qed. - - -Definition errorSpec {A} : CompM A := existsM (fun (s : string) => errorM s). - -Lemma errors_acquire_release_fail : refinesFun acquire_release_fail - (fun _ => errorSpec). -Proof. - unfold acquire_release_fail, acquire_release_fail__tuple_fun, - errorSpec, - acquireLockM, releaseLockM, - projT2. - prove_refinement. -Qed. - diff --git a/heapster/examples/gt0.c b/heapster/examples/gt0.c deleted file mode 100644 index 62abf6e979..0000000000 --- a/heapster/examples/gt0.c +++ /dev/null @@ -1,6 +0,0 @@ -#include -#include - -uint64_t gt0(uint64_t x) { - if (x > 0) { return 1; } else { return 0; } -} diff --git a/heapster/examples/higher_order.cry b/heapster/examples/higher_order.cry deleted file mode 100644 index 9326ad2160..0000000000 --- a/heapster/examples/higher_order.cry +++ /dev/null @@ -1,14 +0,0 @@ - -module HigherOrder where - -a_fun : [64] -> [64] -a_fun x = x + 6 - -b_fun : [64] -> [64] -b_fun x = 6 + x - -higher_order_1 : [8] -> ([64] -> [64]) -> ([8], [64] -> [64]) -higher_order_1 x f = if x == 0 then (0, a_fun) else (x, b_fun) - -higher_order_2 : [8] -> ([64] -> [64]) -> ([8], [64] -> [64]) -higher_order_2 x f = (x, b_fun) diff --git a/heapster/examples/higher_order_mr_solver.saw b/heapster/examples/higher_order_mr_solver.saw deleted file mode 100644 index b0b1119811..0000000000 --- a/heapster/examples/higher_order_mr_solver.saw +++ /dev/null @@ -1,5 +0,0 @@ -enable_experimental; - -import "higher_order.cry"; - -prove_extcore mrsolver (refines [] {{ higher_order_1 }} {{ higher_order_2 }}); diff --git a/heapster/examples/io.bc b/heapster/examples/io.bc deleted file mode 100644 index fbb708c6d3..0000000000 Binary files a/heapster/examples/io.bc and /dev/null differ diff --git a/heapster/examples/io.c b/heapster/examples/io.c deleted file mode 100644 index a683d373e3..0000000000 --- a/heapster/examples/io.c +++ /dev/null @@ -1,7 +0,0 @@ -#include - -#define HELLO "Hello, World!" - -void hello_world () { - write (1, HELLO, sizeof(HELLO)); -} diff --git a/heapster/examples/io.saw b/heapster/examples/io.saw deleted file mode 100644 index 1d3596f361..0000000000 --- a/heapster/examples/io.saw +++ /dev/null @@ -1,30 +0,0 @@ -enable_experimental; -env <- heapster_init_env_from_file "io.sawcore" "io.bc"; - -// Set the event type -heapster_set_event_type env "ioEv"; - -// Integer types -heapster_define_perm env "int64" " " "llvmptr 64" "exists x:bv 64.eq(llvmword(x))"; -heapster_define_perm env "int32" " " "llvmptr 32" "exists x:bv 32.eq(llvmword(x))"; -heapster_define_perm env "int8" " " "llvmptr 8" "exists x:bv 8.eq(llvmword(x))"; - -heapster_define_perm env "int8array" "rw:rwmodality,len:bv 64" "llvmptr 64" - "array(rw,0,))"; - -// Assume the read and write functions call their corresponding events -heapster_assume_fun env "\01_write" - "(len:bv 64). \ - \ arg0:int32<>, arg1:int8array, arg2:eq(llvmword(len)) -o ret:int64<>" - "\\ (len:Vec 64 Bool) (fd:Vec 32 Bool) (buf:buffer len) -> \ - \ triggerS ioEv (writeEv fd len buf)"; - - -/// -/// And now to start type-checking! -/// - -heapster_typecheck_fun env "hello_world" "(). empty -o empty"; - -// Finally, export everything to Coq -heapster_export_coq env "io_gen.v"; diff --git a/heapster/examples/io.sawcore b/heapster/examples/io.sawcore deleted file mode 100644 index ae972d04a4..0000000000 --- a/heapster/examples/io.sawcore +++ /dev/null @@ -1,31 +0,0 @@ - -module io where - -import SpecM; - -bitvector : Nat -> sort 0; -bitvector n = Vec n Bool; - --- The type of buffers of a given length -buffer : bitvector 64 -> sort 0; -buffer len = BVVec 64 len (bitvector 8); - -data ioEvArgs : sort 0 where { - writeEv : bitvector 32 -> (len:bitvector 64) -> buffer len -> - ioEvArgs; - readEv : bitvector 32 -> bitvector 64 -> ioEvArgs; -} - -ioEvRet : ioEvArgs -> sort 0; -ioEvRet args = - ioEvArgs#rec - (\ (_:ioEvArgs) -> sort 0) - (\ (_:bitvector 32) (len:bitvector 64) (_:buffer len) -> bitvector 64) - (\ (_:bitvector 32) (len:bitvector 64) -> - Sigma (bitvector 64) - (\ (len_ret:bitvector 64) -> - is_bvule 64 len_ret len * buffer len_ret)) - args; - -ioEv : EvType; -ioEv = Build_EvType ioEvArgs ioEvRet; diff --git a/heapster/examples/io_proofs.v b/heapster/examples/io_proofs.v deleted file mode 100644 index 859b2fd35d..0000000000 --- a/heapster/examples/io_proofs.v +++ /dev/null @@ -1,19 +0,0 @@ -From Coq Require Import Lists.List. -From Coq Require Import String. -From Coq Require Import Vectors.Vector. -From CryptolToCoq Require Import SAWCoreScaffolding. -From CryptolToCoq Require Import SAWCoreVectorsAsCoqVectors. -From CryptolToCoq Require Import SAWCoreBitvectors. - -From CryptolToCoq Require Import SAWCorePrelude. -From CryptolToCoq Require Import SpecMExtra. -From EnTree Require Import Automation. -Import SAWCorePrelude. -Import SpecMNotations. -Local Open Scope entree_scope. - -Require Import Examples.io_gen. -Import io. - -Print hello_world__bodies. -Print __x1_write. diff --git a/heapster/examples/iter_linked_list.bc b/heapster/examples/iter_linked_list.bc deleted file mode 100644 index 5026c38d46..0000000000 Binary files a/heapster/examples/iter_linked_list.bc and /dev/null differ diff --git a/heapster/examples/iter_linked_list.c b/heapster/examples/iter_linked_list.c deleted file mode 100644 index 71f52d339c..0000000000 --- a/heapster/examples/iter_linked_list.c +++ /dev/null @@ -1,31 +0,0 @@ -#include -#include - -typedef struct list64_t { - int64_t data; - struct list64_t *next; -} list64_t; - -/* Test if a specific value is in a list, returning 1 if so and 0 otherwise */ -int64_t is_elem (int64_t x, list64_t *l) { - for (; l != NULL; l = l->next) { - if (l->data == x) - return 1; - } - return 0; -} - -/* Compute the length of a list */ -int64_t length (list64_t *l) { - int64_t len = 0; - for (; l != NULL; l = l->next) { - ++len; - } - return len; -} - -/* Increment every element of a linked list */ -void incr_list (list64_t *l) { - for (; l != NULL; l = l->next) - l->data++; -} diff --git a/heapster/examples/iter_linked_list.saw b/heapster/examples/iter_linked_list.saw deleted file mode 100644 index eb63176803..0000000000 --- a/heapster/examples/iter_linked_list.saw +++ /dev/null @@ -1,48 +0,0 @@ -enable_experimental; -env <- heapster_init_env_from_file "iter_linked_list.sawcore" "iter_linked_list.bc"; - -// Integer types -heapster_define_perm env "int64" " " "llvmptr 64" "exists x:bv 64.eq(llvmword(x))"; - -heapster_define_reachability_perm env "ListF" - "X:perm(llvmptr 64), l:lifetime, rw:rwmodality, y:llvmptr 64" - "llvmptr 64" - "eq(y) or [l]ptr((rw,0) |-> X) * [l]ptr((rw,8) |-> ListF)" - "appendList"; - -heapster_block_entry_hint env "is_elem" 3 - "top_ptr:llvmptr 64, top_ptr1:llvmptr 64" - "ghost_frm:llvmframe 64, ghost_ptr:llvmptr 64" - "top_ptr:int64<>, top_ptr1:true, \ - \ arg0:ptr((W,0) |-> true), arg1:ptr((W,0) |-> eq(top_ptr)), \ - \ arg2:ptr((W,0) |-> eq(ghost_ptr)), \ - \ ghost_ptr:ListF,always,R,llvmword(0)>, \ - \ ghost_frm:llvmframe [arg2:8, arg1:8, arg0:8]"; - -heapster_typecheck_fun env "is_elem" - "(). arg0:int64<>, arg1:ListF,always,R,llvmword(0)> -o \ - \ arg0:true, arg1:true, ret:int64<>"; - -heapster_block_entry_hint env "incr_list" 3 - "top1:llvmptr 64" - "frm:llvmframe 64,ghost:llvmptr 64" - "top1:ListF,always,W,ghost>, \ - \ arg0:ptr((W,0) |-> eq(ghost)), \ - \ ghost:ListF,always,W,llvmword(0)>, frm:llvmframe [arg0:8]"; - -heapster_typecheck_fun env "incr_list" - "(). arg0:ListF,always,W,llvmword(0)> -o \ - \ arg0:ListF,always,W,llvmword(0)>, ret:true"; - -heapster_block_entry_hint env "length" 3 - "top1:llvmptr 64" - "frm:llvmframe 64, ghost:llvmptr 64" - "top1:ListF,always,W,ghost>, \ - \ arg0:ptr((W,0) |-> eq(ghost)), arg1:ptr((W,0) |-> int64<>), \ - \ ghost:ListF,always,W,llvmword(0)>, frm:llvmframe [arg1:8,arg0:8]"; - -heapster_typecheck_fun env "length" - "(). arg0:ListF,always,W,llvmword(0)> -o \ - \ arg0:true, ret:int64<>"; - -heapster_export_coq env "iter_linked_list_gen.v"; diff --git a/heapster/examples/iter_linked_list.sawcore b/heapster/examples/iter_linked_list.sawcore deleted file mode 100644 index 077cd0ecea..0000000000 --- a/heapster/examples/iter_linked_list.sawcore +++ /dev/null @@ -1,82 +0,0 @@ - -module iter_linked_list where - -import SpecM; - --- Type description for the List type over a single free variable for a type --- description that describes the elements -ListDesc : TpDesc; -ListDesc = - (Tp_Sum - Tp_Unit - (Tp_Pair - (varKindExpr Kind_Tp 1) - (varKindExpr Kind_Tp 0))); - --- The type described by ListDesc -ListTpF : TpDesc -> sort 0; -ListTpF T = indElem (unfoldIndTpDesc (envConsElem Kind_Tp T nilTpEnv) ListDesc); - -primitive appendList : (T:TpDesc) -> ListTpF T -> ListTpF T -> ListTpF T; - --- FIXME: get the following definitions working -{- -List_def : (a:sort 0) -> sort 0; -List_def a = List a; - -appendList : (a:sort 0) -> List a -> List a -> List a; -appendList a l1 l2 = - List__rec a (\ (_:List a) -> List a) l2 - (\ (x:a) (_:List a) (rec:List a) -> Cons a x rec) - l1; - -data ListF (a b:sort 0) : sort 0 where { - NilF : b -> ListF a b; - ConsF : a -> ListF a b -> ListF a b; -} - --- A definition for the List datatype; currently needed as a workaround in Heapster -ListF_def : (a b:sort 0) -> sort 0; -ListF_def a b = ListF a b; - -ListF__rec : (a b:sort 0) -> (P : ListF a b -> sort 0) -> - ((x:b) -> P (NilF a b x)) -> - ((x:a) -> (l:ListF a b) -> P l -> P (ConsF a b x l)) -> - (l:ListF a b) -> P l; -ListF__rec a b P f1 f2 l = ListF#rec a b P f1 f2 l; - -unfoldListF : (a b:sort 0) -> ListF a b -> Either b (a * ListF a b); -unfoldListF a b l = - ListF__rec a b (\ (_:ListF a b) -> Either b (a * ListF a b)) - (\ (x:b) -> Left b (a * ListF a b) x) - (\ (x:a) (l:ListF a b) (_:Either b (a * ListF a b)) -> - Right b (a * ListF a b) (x, l)) - l; - -foldListF : (a b:sort 0) -> Either b (a * ListF a b) -> ListF a b; -foldListF a b = - either b (a * ListF a b) (ListF a b) - (\ (x : b) -> NilF a b x) - (\ (tup : (a * ListF a b)) -> - ConsF a b tup.(1) tup.(2)); - -getListF : (a b:sort 0) -> ListF a b -> b; -getListF a b = - ListF__rec a b (\ (_:ListF a b) -> b) - (\ (x:b) -> x) - (\ (_:a) (_:ListF a b) (rec:b) -> rec); - -putListF : (a b c:sort 0) -> ListF a b -> c -> ListF a c; -putListF a b c l c_val = - ListF__rec a b (\ (_:ListF a b) -> ListF a c) - (\ (_:b) -> NilF a c c_val) - (\ (x:a) (_:ListF a b) (rec:ListF a c) -> ConsF a c x rec) - l; - -transListF : (a b:sort 0) -> ListF a #() -> ListF a b -> ListF a b; -transListF a b l1 l2 = - ListF__rec a #() (\ (_:ListF a #()) -> ListF a b) - (\ (_:#()) -> l2) - (\ (x:a) (_:ListF a #()) (rec:ListF a b) -> ConsF a b x rec) - l1; --} diff --git a/heapster/examples/iter_linked_list_proofs.v b/heapster/examples/iter_linked_list_proofs.v deleted file mode 100644 index faa30957b2..0000000000 --- a/heapster/examples/iter_linked_list_proofs.v +++ /dev/null @@ -1,115 +0,0 @@ -From Coq Require Import Lists.List. -From Coq Require Import String. -From Coq Require Import Vectors.Vector. -From CryptolToCoq Require Import SAWCoreScaffolding. -From CryptolToCoq Require Import SAWCoreVectorsAsCoqVectors. -From CryptolToCoq Require Import SAWCoreBitvectors. - -From CryptolToCoq Require Import SAWCorePrelude. -From CryptolToCoq Require Import CompMExtra. - -Require Import Examples.iter_linked_list_gen. -Import iter_linked_list. - -Import SAWCorePrelude. - - -Lemma appendList_Nil_r a l : appendList a l List.nil = l. -Proof. - induction l; eauto. - simpl; f_equal; eauto. -Qed. - -Hint Rewrite appendList_Nil_r : refinesM. - - -Lemma no_errors_is_elem : - refinesFun is_elem (fun _ _ => noErrorsSpec). -Proof. - unfold is_elem, is_elem__tuple_fun. - prove_refinement_match_letRecM_l. - - exact (fun _ _ => noErrorsSpec). - unfold noErrorsSpec. - prove_refinement. -Qed. - -Definition is_elem_pure (x:bitvector 64) (l:list (bitvector 64)) - : bitvector 64 := - list_rect (fun _ => bitvector 64) - (intToBv 64 0) - (fun y l' rec => if bvEq 64 y x then intToBv 64 1 else rec) l. - -Lemma is_elem_pure_ref : - refinesFun is_elem (fun x l => returnM (is_elem_pure x l)). -Proof. - unfold is_elem, is_elem__tuple_fun. - prove_refinement_match_letRecM_l. - - exact (fun x l => returnM (is_elem_pure x l)). - unfold is_elem_pure. - prove_refinement. - rewrite appendList_Nil_r; reflexivity. -Qed. - -Definition is_elem_spec (x:bitvector 64) (l:list (bitvector 64)) - : CompM (bitvector 64) := - orM (assertM (List.In x l) >> returnM (intToBv 64 1)) - (assertM (~ List.In x l) >> returnM (intToBv 64 0)). - -Lemma is_elem_spec_ref : refinesFun is_elem is_elem_spec. -Proof. - unfold is_elem, is_elem__tuple_fun, is_elem_spec. - prove_refinement_match_letRecM_l. - - exact is_elem_spec. - unfold is_elem_spec. - prove_refinement. - (* The a0 = [] case. *) - - continue_prove_refinement_right. - easy. - (* The a0 = (s1 :: a1) case where a = s1. *) - - continue_prove_refinement_left. - left; easy. - (* The a0 = (s1 :: a1) case where a <> s1, and we inductively assume - the left assertion of our specification (in the letRec) *) - - continue_prove_refinement_left. - rewrite appendList_Nil_r in e_assert. - right; easy. - (* The a0 = (s1 :: a1) case where a <> s1, and we inductively assume - the right assertion of our specification (in the letRec) *) - - continue_prove_refinement_right. - rewrite appendList_Nil_r in e_assert. - intros []; easy. - (* The a0 = (s1 :: a1) case where a <> s1, and we inductively assume - the left assertion of our specification (out of the letRec) *) - - continue_prove_refinement_left. - rewrite appendList_Nil_r in e_assert; easy. - (* The a0 = (s1 :: a1) case where a <> s1, and we inductively assume - the right assertion of our specification (out of the letRec) *) - - continue_prove_refinement_right. - rewrite appendList_Nil_r in e_assert; easy. -Qed. - - -Definition incr_list_invar := - @list_rect (bitvector 64) (fun _ => Prop) True - (fun x _ rec => isBvslt 64 x (bvsmax 64) /\ rec). - -Arguments incr_list_invar !l. - -Lemma no_errors_incr_list : - refinesFun incr_list (fun l => assumingM (incr_list_invar l) noErrorsSpec). -Proof. - unfold incr_list, incr_list__tuple_fun. - prove_refinement_match_letRecM_l. - - exact (fun _ l => assumingM (incr_list_invar l) noErrorsSpec). - unfold noErrorsSpec, BVVec, bitvector in * |- *. - time "no_errors_incr_list" prove_refinement. - all: try destruct e_assuming as [?e_assuming ?e_assuming]; - try destruct e_assuming0 as [?e_assuming ?e_assuming]; - try destruct e_assuming1 as [?e_assuming ?e_assuming]; cbn - [bvsmax] in *. - (* All but one of the remaining goals are taken care of by assumptions we have in scope: *) - all: try rewrite appendList_Nil_r; try split; eauto. - (* We just have to show this case is impossible by virtue of our loop invariant: *) - apply isBvslt_suc_r in e_assuming0. - rewrite <- e_assuming0, e_if in e_if0. - apply isBvslt_antirefl in e_if0; contradiction. -Qed. diff --git a/heapster/examples/linked_list.bc b/heapster/examples/linked_list.bc deleted file mode 100644 index d8d8693240..0000000000 Binary files a/heapster/examples/linked_list.bc and /dev/null differ diff --git a/heapster/examples/linked_list.c b/heapster/examples/linked_list.c deleted file mode 100644 index 0643443c92..0000000000 --- a/heapster/examples/linked_list.c +++ /dev/null @@ -1,82 +0,0 @@ -#include -#include - -typedef struct list64_t { - int64_t data; - struct list64_t *next; -} list64_t; - -/* Test if a value is the head of a list, returning 1 if so and 0 otherwiese */ -int64_t is_head (int64_t x, list64_t *l) { - if (l == NULL) { - return 0; - } else if (l->data == x) { - return 1; - } else { - return 0; - } -} - -/* Test if a specific value is in a list, returning 1 if so and 0 otherwise */ -int64_t is_elem (int64_t x, list64_t *l) { - if (l == NULL) { - return 0; - } else if (l->data == x) { - return 1; - } else { - return is_elem (x, l->next); - } -} - -/* Test if some element of a list satisfies a given predicate */ -int64_t any (int64_t (*pred) (int64_t), list64_t *l) { - if (l == NULL) { - return 0; - } else if (pred (l->data)) { - return 1; - } else { - return any (pred, l->next); - } -} - -/* Serach for a specific value in a list */ -list64_t *find_elem (int64_t x, list64_t *l) { - if (l == NULL) { - return NULL; - } else if (l->data == x) { - return l; - } else { - return find_elem (x, l->next); - } -} - -/* Insert a value into a sorted list */ -list64_t *sorted_insert (int64_t x, list64_t *l) { - if (l == NULL) { - list64_t *ret = malloc (sizeof (struct list64_t)); - ret->data = x; - ret->next = NULL; - return ret; - } else if (x <= l->data) { - list64_t *ret = malloc (sizeof (struct list64_t)); - ret->data = x; - ret->next = l; - return ret; - } else { - l -> next = sorted_insert (x, l->next); - return l; - } -} -/* Insert an already-allocated list element into a sorted list */ -list64_t *sorted_insert_no_malloc (list64_t *x, list64_t *l) { - if (l == NULL) { - x -> next = NULL; - return x; - } else if (x -> data <= l->data) { - x -> next = l; - return x; - } else { - l -> next = sorted_insert_no_malloc (x, l->next); - return l; - } -} diff --git a/heapster/examples/linked_list.cry b/heapster/examples/linked_list.cry deleted file mode 100644 index 113c3f2571..0000000000 --- a/heapster/examples/linked_list.cry +++ /dev/null @@ -1,27 +0,0 @@ - -module LinkedList where - -import Either - -primitive type List : * -> * - -primitive foldList : {a} Either () (a, List a) -> List a -primitive unfoldList : {a} List a -> Either () (a, List a) - -nil : {a} List a -nil = foldList (Left ()) - -cons : {a} a -> List a -> List a -cons x l = foldList (Right (x,l)) - -is_elem_spec : [64] -> List [64] -> [64] -is_elem_spec x l = - either (\ _ -> 0) (\ (y,l') -> if x == y then 1 else is_elem_spec x l') - (unfoldList l) - -sorted_insert_spec : [64] -> List [64] -> List [64] -sorted_insert_spec x l = - either (\ _ -> cons x nil) - (\ (y,l') -> if x <=$ y then cons x (cons y l') - else cons y (sorted_insert_spec x l')) - (unfoldList l) diff --git a/heapster/examples/linked_list.saw b/heapster/examples/linked_list.saw deleted file mode 100644 index e888bb85a9..0000000000 --- a/heapster/examples/linked_list.saw +++ /dev/null @@ -1,39 +0,0 @@ -enable_experimental; -env <- heapster_init_env_from_file "linked_list.sawcore" "linked_list.bc"; - -// Integer types -heapster_define_perm env "int64" " " "llvmptr 64" "exists x:bv 64.eq(llvmword(x))"; - -heapster_define_recursive_perm env "LList" - "X:perm(llvmptr 64), l:lifetime, rw:rwmodality" - "llvmptr 64" - "eq(llvmword(0)) or [l]ptr((rw,0) |-> X) * [l]ptr((rw,8) |-> LList)"; - -heapster_typecheck_fun env "is_elem" - "(). arg0:int64<>, arg1:LList,always,R> -o \ - \ arg0:true, arg1:true, ret:int64<>"; - -heapster_assume_fun env "malloc" - "(sz:bv 64). arg0:eq(llvmword(8*sz)) -o \ - \ arg0:true, ret:array(W,0, -o arg0:true, ret:int64<>), \ - \ arg1:LList,always,R> -o \ - \ arg0:true, arg1:true, ret:int64<>"; - -heapster_typecheck_fun env "find_elem" - "(). arg0:int64<>, arg1:LList,always,W> -o \ - \ arg0:true, arg1:true, ret:LList,always,W>"; - -heapster_typecheck_fun env "sorted_insert" - "(). arg0:int64<>, arg1:LList,always,W> -o \ - \ arg0:true, arg1:true, ret:LList,always,W>"; - -heapster_typecheck_fun env "sorted_insert_no_malloc" - "(). arg0:ptr((W,0) |-> int64<>) * ptr((W,8) |-> eq(llvmword(0))), \ - \ arg1:LList,always,W> -o \ - \ arg0:true, arg1:true, ret:LList,always,W>"; - -heapster_export_coq env "linked_list_gen.v"; diff --git a/heapster/examples/linked_list.sawcore b/heapster/examples/linked_list.sawcore deleted file mode 100644 index 025fdea7d3..0000000000 --- a/heapster/examples/linked_list.sawcore +++ /dev/null @@ -1,9 +0,0 @@ - -module linked_list where - -import SpecM; - -mallocSpec : (sz:Vec 64 Bool) -> SpecM VoidEv (BVVec 64 sz #()); -mallocSpec sz = - retS VoidEv (BVVec 64 sz #()) - (genBVVec 64 sz #() (\ (i:Vec 64 Bool) (_:is_bvult 64 i sz) -> ())); diff --git a/heapster/examples/linked_list_mr_solver.saw b/heapster/examples/linked_list_mr_solver.saw deleted file mode 100644 index 9eec7bf536..0000000000 --- a/heapster/examples/linked_list_mr_solver.saw +++ /dev/null @@ -1,65 +0,0 @@ -include "linked_list.saw"; - -/*** - *** Setup Cryptol environment - ***/ - -include "either.saw"; - -list_tp <- parse_core "\\ (a:sort 0) -> List a"; -cryptol_add_prim_type "LinkedList" "List" list_tp; - -fold_fun <- parse_core "foldList"; -cryptol_add_prim "LinkedList" "foldList" fold_fun; - -unfold_fun <- parse_core "unfoldList"; -cryptol_add_prim "LinkedList" "unfoldList" unfold_fun; - -import "linked_list.cry"; - - -/*** - *** The actual tests - ***/ - -heapster_typecheck_fun env "is_head" - "(). arg0:int64<>, arg1:List,always,R> -o \ - \ arg0:true, arg1:true, ret:int64<>"; - -let is_head = parse_core_mod "linked_list" "is_head"; -prove_extcore mrsolver (refines [] is_head is_head); - -let is_elem = parse_core_mod "linked_list" "is_elem"; -prove_extcore mrsolver (refines [] is_elem is_elem); - -is_elem_noErrorsSpec <- parse_core - "\\ (x:Vec 64 Bool) (y:List (Vec 64 Bool)) -> \ - \ fixS VoidEv emptyFunStack \ - \ (Vec 64 Bool * List (Vec 64 Bool)) \ - \ (\\ (_ : Vec 64 Bool * List (Vec 64 Bool)) -> Vec 64 Bool) \ - \ (\\ (f : fixSFun VoidEv emptyFunStack \ - \ (Vec 64 Bool * List (Vec 64 Bool)) \ - \ (\\ (pr : Vec 64 Bool * List (Vec 64 Bool)) -> \ - \ Vec 64 Bool)) \ - \ (x : Vec 64 Bool * List (Vec 64 Bool)) -> \ - \ orS VoidEv (fixSStack (Vec 64 Bool * List (Vec 64 Bool)) \ - \ (\\ (_ : Vec 64 Bool * List (Vec 64 Bool)) -> \ - \ Vec 64 Bool)) \ - \ (Vec 64 Bool) \ - \ (existsS VoidEv (fixSStack (Vec 64 Bool * List (Vec 64 Bool)) \ - \ (\\ (_ : Vec 64 Bool * List (Vec 64 Bool)) -> \ - \ Vec 64 Bool)) \ - \ (Vec 64 Bool)) \ - \ (f x)) (x, y)"; -prove_extcore mrsolver (refines [] is_elem is_elem_noErrorsSpec); - -prove_extcore mrsolver (refines [] is_elem {{ is_elem_spec }}); - - -monadify_term {{ Right }}; -monadify_term {{ Left }}; -monadify_term {{ nil }}; -monadify_term {{ cons }}; - -let sorted_insert_no_malloc = parse_core_mod "linked_list" "sorted_insert_no_malloc"; -prove_extcore mrsolver (refines [] sorted_insert_no_malloc {{ sorted_insert_spec }}); diff --git a/heapster/examples/linked_list_proofs.v b/heapster/examples/linked_list_proofs.v deleted file mode 100644 index b543239d72..0000000000 --- a/heapster/examples/linked_list_proofs.v +++ /dev/null @@ -1,381 +0,0 @@ -From Coq Require Import Lists.List. -From Coq Require Import String. -From Coq Require Import Vectors.Vector. -From CryptolToCoq Require Import SAWCoreScaffolding. -From CryptolToCoq Require Import SAWCoreVectorsAsCoqVectors. -From CryptolToCoq Require Import SAWCoreBitvectors. - -From CryptolToCoq Require Import SAWCorePrelude. -From CryptolToCoq Require Import SpecMExtra. -From EnTree Require Import Automation. -Import SAWCorePrelude. -Import SpecMNotations. -Local Open Scope entree_scope. - -Require Import Examples.linked_list_gen. -Import linked_list. - - -(* QOL: nicer names for list arguments *) -#[local] Hint Extern 901 (IntroArg Any (list _) _) => - let e := fresh "l" in IntroArg_intro e : refines prepostcond. -#[local] Hint Extern 901 (IntroArg Any (List_def _) _) => - let e := fresh "l" in IntroArg_intro e : refines prepostcond. -#[local] Hint Extern 901 (IntroArg RetAny list _) => - let e := fresh "r_l" in IntroArg_intro e : refines prepostcond. -#[local] Hint Extern 901 (IntroArg RetAny List_def _) => - let e := fresh "r_l" in IntroArg_intro e : refines prepostcond. - - -(* List destruction automation *) - -Arguments FunsTo_Nil {a}. -Arguments FunsTo_Cons {a tp}. - -Lemma spec_refines_either_unfoldList_nil_l (E1 E2 : EvType) Γ1 Γ2 R1 R2 - (RPre : SpecPreRel E1 E2 Γ1 Γ2) (RPost : SpecPostRel E1 E2 Γ1 Γ2) - (RR : Rel R1 R2) A f g (P : SpecM E2 Γ2 R2) : - spec_refines RPre RPost RR (f tt) P -> - spec_refines RPre RPost RR (eithers _ (FunsTo_Cons f (FunsTo_Cons g FunsTo_Nil)) - (unfoldList A nil)) P. -Proof. eauto. Qed. - -Lemma spec_refines_either_unfoldList_cons_l (E1 E2 : EvType) Γ1 Γ2 R1 R2 - (RPre : SpecPreRel E1 E2 Γ1 Γ2) (RPost : SpecPostRel E1 E2 Γ1 Γ2) - (RR : Rel R1 R2) A a l f g (P : SpecM E2 Γ2 R2) : - spec_refines RPre RPost RR (g (a, l)) P -> - spec_refines RPre RPost RR (eithers _ (FunsTo_Cons f (FunsTo_Cons g FunsTo_Nil)) - (unfoldList A (a :: l))) P. -Proof. eauto. Qed. - -Ltac eithers_unfoldList A l := - let l' := eval cbn [ fst snd projT1 ] in l in - lazymatch l' with - | nil => - simple apply (spec_refines_either_unfoldList_nil_l _ _ _ _ _ _ _ _ _ A) - | ?a :: ?l0 => - simple apply (spec_refines_either_unfoldList_cons_l _ _ _ _ _ _ _ _ _ A a l0) - | _ => let a := fresh "x" in - let l0 := fresh "l0" in - let eq := fresh "e_destruct" in - destruct l' as [| a l0 ] eqn:eq; - [ eithers_unfoldList A (@nil A) | eithers_unfoldList A (a :: l0) ]; - simpl foldList; cbn [ list_rect ] in *; - cbn [ fst snd projT1 ]; - revert eq; apply (IntroArg_fold Destruct) - end. - -Global Hint Extern 100 (spec_refines _ _ _ (eithers _ _ (unfoldList ?A ?l)) _) => - eithers_unfoldList A l : refines. -Global Hint Extern 100 (spec_refines _ _ _ _ (eithers _ _ (unfoldList ?A ?l))) => - eithers_unfoldList A l : refines. - -Global Hint Extern 901 (RelGoal _) => - progress (simpl foldList in *; cbn [ list_rect ] in *) : refines. - -Global Hint Extern 100 (Shelve (list_rect _ _ _ ?m)) => - progress cbn [ list_rect ] in * : refines. -Global Hint Extern 100 (Shelve (list_rect _ _ _ ?m)) => - progress cbn [ list_rect ] in * : refines. - -Lemma IntroArg_eq_list_nil_nil n A goal : - goal -> IntroArg n (@nil A = nil) (fun _ => goal). -Proof. do 2 intro; eauto. Qed. - -Lemma IntroArg_eq_list_cons_cons n A (a1 a2 : A) l1 l2 goal : - IntroArg n (a1 = a2) (fun _ => IntroArg n (l1 = l1) (fun _ => goal)) -> - IntroArg n (a1 :: l1 = a2 :: l2) (fun _ => goal). -Proof. intros H eq; dependent destruction eq; apply H; eauto. Qed. - -Lemma IntroArg_eq_list_nil_cons n A (a : A) l goal : - IntroArg n (nil = a :: l) (fun _ => goal). -Proof. intro eq; dependent destruction eq. Qed. - -Lemma IntroArg_eq_list_cons_nil n A (a : A) l goal : - IntroArg n (a :: l = nil) (fun _ => goal). -Proof. intro eq; dependent destruction eq. Qed. - -Global Hint Extern 101 (nil = nil) => - simple apply IntroArg_eq_list_nil_nil : refines. -Global Hint Extern 101 (_ :: _ = _ :: _) => - simple apply IntroArg_eq_list_cons_cons : refines. -Global Hint Extern 101 (nil = _ :: _) => - simple apply IntroArg_eq_list_nil_cons : refines. -Global Hint Extern 101 (_ :: _ = nil) => - simple apply IntroArg_eq_list_nil_cons : refines. - -Lemma is_elem_spec_ref x l : - spec_refines eqPreRel eqPostRel eq - (is_elem x l) - (total_spec (fun _ => True) - (fun '(x, l) r => (~ List.In x l /\ r = intToBv 64 0) - \/ (List.In x l /\ r = intToBv 64 1)) - (x, l)). -Proof. - unfold is_elem, is_elem__bodies. - prove_refinement. - - wellfounded_decreasing_nat. - exact (length l0). - - prepost_case 0 0. - + exact (x0 = x1 /\ l0 = l1). - + exact (r = r0). - + prepost_exclude_remaining. - - time "is_elem_spec_ref" prove_refinement_continue. - all: try ((left ; split; [eauto | easy]) || - (right; split; [eauto | easy])); simpl. - 1-2: apply bvEq_eq in e_if; eauto. - 1-2: apply bvEq_neq in e_if. - 1-2: destruct H as [[]|[]]; [ left | right ]. - 1-4: split; eauto. - 1-2: intros []; eauto. -Qed. - - -(* =========== TODO: Update the below with the new automation =========== *) -(* - -Lemma no_errors_is_elem x l : - spec_refines eqPreRel eqPostRel eq (is_elem x l) no_errors_spec. -Proof. - unfold is_elem, no_errors_spec. - time "no_errors_is_elem" prove_refinement. -Qed. - -Lemma no_errors_is_elem_manual : refinesFun is_elem (fun _ _ => noErrorsSpec). -Proof. - unfold is_elem, is_elem__tuple_fun, sawLet_def. - unfold noErrorsSpec. - apply refinesFun_multiFixM_fst; intros x l. - apply refinesM_letRecM_Nil_l. - apply refinesM_either_l; intros. - - eapply refinesM_existsM_r. reflexivity. - - apply refinesM_if_l; intros. - + eapply refinesM_existsM_r. reflexivity. - + rewrite existsM_bindM. - apply refinesM_existsM_l; intros. rewrite returnM_bindM. - eapply refinesM_existsM_r. reflexivity. -Qed. - -(* -Fixpoint is_elem_spec (x:bitvector 64) (l:W64List) : CompM (bitvector 64) := - match l with - | W64Nil => returnM (intToBv 64 0) - | W64Cons y l' => - if bvEq 64 y x then returnM (intToBv 64 1) else - is_elem_spec x l' - end. -*) - -Definition is_elem_fun (x:bitvector 64) : - list (bitvector 64) -> CompM (bitvector 64) := - list_rect (fun _ => CompM (bitvector 64)) - (returnM (intToBv 64 0)) - (fun y l' rec => - if bvEq 64 y x then returnM (intToBv 64 1) else rec). - -Arguments is_elem_fun /. - -Lemma is_elem_fun_ref : refinesFun is_elem is_elem_fun. -Proof. - unfold is_elem, is_elem__tuple_fun, is_elem_fun, List_def. - time "is_elem_fun_ref" prove_refinement. -Qed. - -Lemma is_elem_fun_ref_manual : refinesFun is_elem is_elem_fun. -Proof. - unfold is_elem, is_elem__tuple_fun, is_elem_fun, sawLet_def. - apply refinesFun_multiFixM_fst; intros x l. - apply refinesM_letRecM_Nil_l. simpl. - apply refinesM_either_l; intros [] e_either. - all: destruct l; cbn [ unfoldList list_rect ] in *. - all: try (injection e_either; intros; subst); try discriminate e_either. - - reflexivity. - - apply refinesM_if_r; intro e_if; unfold_projs; rewrite e_if; simpl. - + reflexivity. - + rewrite bindM_returnM_CompM. - reflexivity. -Qed. - -(* The pure version of is_elem *) -Definition is_elem_pure (x:bitvector 64) (l:list (bitvector 64)) - : bitvector 64 := - (list_rect (fun _ => bitvector 64) - (intToBv 64 0) - (fun y l' rec => - if bvEq 64 y x then intToBv 64 1 else rec) l). - -Arguments is_elem_pure /. - -Definition is_elem_lrt : LetRecType := - LRT_Fun (bitvector 64) (fun _ => - LRT_Fun (list (bitvector 64)) (fun _ => - LRT_Ret (bitvector 64))). - -Lemma is_elem_pure_fun_ref : @refinesFun is_elem_lrt is_elem_fun (fun x l => returnM (is_elem_pure x l)). -Proof. - unfold is_elem_fun, is_elem_lrt, is_elem_pure. - time "is_elem_pure_fun_ref" prove_refinement. -Qed. - -Lemma is_elem_pure_fun_ref_manual : @refinesFun is_elem_lrt is_elem_fun (fun x l => returnM (is_elem_pure x l)). -Proof. - unfold is_elem_fun, is_elem_pure. - intros x l; induction l; simpl. - - reflexivity. - - apply refinesM_if_l; intro H; rewrite H. - + reflexivity. - + exact IHl. -Qed. - -Lemma is_elem_pure_ref : refinesFun is_elem (fun x l => returnM (is_elem_pure x l)). -Proof. - unfold is_elem, is_elem__tuple_fun, is_elem_pure, List_def. - time "is_elem_pure_ref" prove_refinement. -Qed. - - -(* A high-level specification of is_elem *) -Definition is_elem_spec (x:bitvector 64) (l:list (bitvector 64)) - : CompM (bitvector 64) := - orM - (assertM (List.In x l) >> returnM (intToBv 64 1)) - (assertM (~ List.In x l) >> returnM (intToBv 64 0)). - -Arguments is_elem_spec /. - -Lemma is_elem_spec_ref : refinesFun is_elem is_elem_spec. -Proof. - unfold is_elem, is_elem__tuple_fun, is_elem_spec. - time "is_elem_spec_ref" prove_refinement. - (* The a0 = [] case. *) - - continue_prove_refinement_right. - easy. - (* The a0 = (s1 :: a1) case where a = s1. *) - - continue_prove_refinement_left. - now left. - (* The a0 = (s1 :: a1) case where a <> s1, and we inductively assume - the left assertion of our specification *) - - continue_prove_refinement_left. - now right. - (* The a0 = (s1 :: a1) case where a <> s1, and we inductively assume - the right assertion of our specification *) - - continue_prove_refinement_right. - now intros []. -Qed. - - -Section any. - - Lemma refinesM_bind_lr A B (x y : CompM A) (f g : A -> CompM B) : - refinesM x y -> @refinesFun (LRT_Fun A (fun _ => LRT_Ret B)) f g -> - refinesM (x >>= f) (y >>= g). - Proof. - unfold refinesM, bindM, MonadBindOp_OptionT, bindM, MonadBindOp_SetM. - intros x_ref f_ref b H. - destruct H as [ a xa H ]. - exists a. - - apply x_ref. - assumption. - - destruct a. - + apply f_ref. - assumption. - + assumption. - Qed. - - Hint Resolve refinesM_bind_lr | 0 : refinesM. - - Definition any_fun (f:bitvector 64 -> CompM (bitvector 64)) : - list (bitvector 64) -> CompM (bitvector 64) := - list_rect (fun _ => CompM (bitvector 64)) - (returnM (intToBv 64 0)) - (fun y l' rec => - f y >>= fun call_ret_val => - if negb (bvEq 64 call_ret_val (intToBv 64 0)) - then returnM (intToBv 64 1) else rec). - - Lemma any_fun_ref : refinesFun any any_fun. - Proof. - unfold any, any__tuple_fun, any_fun. - time "any_fun_ref" prove_refinement. - Qed. - - Local Arguments noErrorsSpec : simpl never. - - Lemma no_errors_any : refinesFun any (fun pred _ => assumingM - (forall x, refinesM (pred x) noErrorsSpec) - noErrorsSpec). - Proof. - unfold any, any__tuple_fun. (* unfold noErrorsSpec at 1. *) - time "no_errors_any (1/2)" prove_refinement with NoRewrite. - - unfold noErrorsSpec; prove_refinement. - - rewrite (e_assuming v). - unfold noErrorsSpec at 1. - time "no_errors_any (2/2)" prove_refinement. - + unfold noErrorsSpec; prove_refinement. - + prove_refinement; assumption. - Qed. - -End any. - -(* -Arguments sorted_insert__tuple_fun /. -Eval simpl in sorted_insert__tuple_fun. -Print sorted_insert__tuple_fun. -*) - -Lemma no_errors_find_elem : refinesFun find_elem (fun _ _ => noErrorsSpec). -Proof. - unfold find_elem, find_elem__tuple_fun, noErrorsSpec. - time "no_errors_find_elem" prove_refinement. -Qed. - -Definition find_elem_fun (x: bitvector 64) : - list (bitvector 64) -> CompM (list (bitvector 64)) := - list_rect (fun _ => CompM (list (bitvector 64))) - (returnM List.nil) - (fun y l' rec => - if bvEq 64 y x - then returnM (y :: l') - else rec). - -Lemma find_elem_fun_ref : refinesFun find_elem find_elem_fun. -Proof. - unfold find_elem, find_elem__tuple_fun, find_elem_fun. - time "find_elem_fun_ref" prove_refinement. -Qed. - -Lemma no_errors_sorted_insert : refinesFun sorted_insert (fun _ _ => noErrorsSpec). -Proof. - unfold sorted_insert, sorted_insert__tuple_fun, mallocSpec, noErrorsSpec. - time "no_errors_sorted_insert" prove_refinement. -Qed. - -Definition sorted_insert_fun (x: bitvector 64) : - list (bitvector 64) -> CompM (list (bitvector 64)) := - list_rect (fun _ => CompM (list (bitvector 64))) - (returnM (x :: List.nil)) - (fun y l' rec => - if bvsle 64 x y - then returnM (x :: y :: l') - else rec >>= (fun l => returnM (y :: l))). - -Lemma sorted_insert_fun_ref : refinesFun sorted_insert sorted_insert_fun. -Proof. - unfold sorted_insert, sorted_insert__tuple_fun, sorted_insert_fun, mallocSpec. - time "sorted_insert_fun_ref" prove_refinement. -Qed. - -Lemma no_errors_sorted_insert_no_malloc : refinesFun sorted_insert_no_malloc (fun _ _ => noErrorsSpec). -Proof. - unfold sorted_insert_no_malloc, sorted_insert_no_malloc__tuple_fun, mallocSpec, noErrorsSpec. - time "no_errors_sorted_insert_no_malloc" prove_refinement. -Qed. - -(* Same spec as sorted_insert *) -Lemma sorted_insert_no_malloc_fun_ref : refinesFun sorted_insert_no_malloc sorted_insert_fun. -Proof. - unfold sorted_insert_no_malloc, sorted_insert_no_malloc__tuple_fun, sorted_insert_fun. - time "sorted_insert_no_malloc_fun_ref" prove_refinement. -Qed. - -*) \ No newline at end of file diff --git a/heapster/examples/loops.bc b/heapster/examples/loops.bc deleted file mode 100644 index 1bc1849e36..0000000000 Binary files a/heapster/examples/loops.bc and /dev/null differ diff --git a/heapster/examples/loops.c b/heapster/examples/loops.c deleted file mode 100644 index 0d18fc1386..0000000000 --- a/heapster/examples/loops.c +++ /dev/null @@ -1,29 +0,0 @@ -#include -#include - -/* Add two numbers using a while loop that repeatedly increments */ -int64_t add_loop (int64_t x, int64_t y) { - uint64_t ret = x; - for (uint64_t i = y; i > 0; -- i) { - ret++; - } - return ret; -} - -/* Returns the sign of the sum of the two inputs, using add_loop! */ -int64_t sign_of_sum (int64_t x, int64_t y) { - int64_t d = add_loop(x, y); - if (d > 0) { - return 1; - } else if (d < 0) { - return -1; - } else { - return 0; - } -} - -/* Returns 1 if x < y+z, -1 if x > y+z, and 0 otherwise, using add_loop - for the sum and sign_of_sum for the comparison! */ -int64_t compare_sum (int64_t x, int64_t y, int64_t z) { - return sign_of_sum(-x, add_loop(y, z)); -} \ No newline at end of file diff --git a/heapster/examples/loops.saw b/heapster/examples/loops.saw deleted file mode 100644 index 835ca507b3..0000000000 --- a/heapster/examples/loops.saw +++ /dev/null @@ -1,24 +0,0 @@ -enable_experimental; -env <- heapster_init_env_from_file "loops.sawcore" "loops.bc"; - -// Integer types -heapster_define_perm env "int64" " " "llvmptr 64" "exists x:bv 64.eq(llvmword(x))"; - -heapster_block_entry_hint env "add_loop" 3 - "top0:llvmptr 64, top1:llvmptr 64" - "frm:llvmframe 64, x0:llvmptr 64, x1:llvmptr 64" - "top0:int64<>, top1:int64<>, \ - \ arg0:ptr((W,0) |-> int64<>), arg1:ptr((W,0) |-> int64<>), \ - \ frm:llvmframe [arg1:8,arg0:8,x1:8,x0:8], \ - \ x0:ptr((W,0) |-> true), x1:ptr((W,0) |-> true)"; - -heapster_typecheck_fun env "add_loop" - "(). arg0:int64<>, arg1:int64<> -o ret:int64<>"; - -heapster_typecheck_fun env "sign_of_sum" - "(). arg0:int64<>, arg1:int64<> -o ret:int64<>"; - -heapster_typecheck_fun env "compare_sum" - "(). arg0:int64<>, arg1:int64<>, arg2:int64<> -o ret:int64<>"; - -heapster_export_coq env "loops_gen.v"; diff --git a/heapster/examples/loops.sawcore b/heapster/examples/loops.sawcore deleted file mode 100644 index dc3de6aa49..0000000000 --- a/heapster/examples/loops.sawcore +++ /dev/null @@ -1,4 +0,0 @@ - -module loops where - -import SpecM; diff --git a/heapster/examples/loops_proofs.v b/heapster/examples/loops_proofs.v deleted file mode 100644 index 7b7bb378d0..0000000000 --- a/heapster/examples/loops_proofs.v +++ /dev/null @@ -1,135 +0,0 @@ -From Coq Require Import Lists.List. -From Coq Require Import String. -From Coq Require Import Vectors.Vector. -From CryptolToCoq Require Import SAWCoreScaffolding. -From CryptolToCoq Require Import SAWCoreVectorsAsCoqVectors. -From CryptolToCoq Require Import SAWCoreBitvectors. - -From CryptolToCoq Require Import SAWCorePrelude. -From CryptolToCoq Require Import CompMExtra. - -Require Import Examples.loops_gen. -Import loops. - -Import SAWCorePrelude. - - -Lemma no_errors_add_loop : refinesFun add_loop (fun _ _ => noErrorsSpec). -Proof. - unfold add_loop, add_loop__tuple_fun. - prove_refinement_match_letRecM_l. - - exact (fun _ _ _ _ => noErrorsSpec). - unfold noErrorsSpec. - time "no_errors_add_loop" prove_refinement. -Qed. - - -Lemma add_loop_spec_ref : refinesFun add_loop (fun x y => returnM (bvAdd 64 x y)). -Proof. - unfold add_loop, add_loop__tuple_fun. - prove_refinement_match_letRecM_l. - - exact (fun _ _ ret i => returnM (bvAdd 64 ret i)). - time "add_loop_spec_ref" prove_refinement. - - rewrite bvAdd_assoc. - rewrite (bvAdd_comm _ a4). - rewrite <- (bvAdd_assoc _ _ _ a4). - rewrite bvAdd_id_l. - reflexivity. - - rewrite isBvule_n_zero in e_if. - rewrite e_if, bvAdd_id_r. - reflexivity. -Qed. - - -(* Add `add_loop_spec_ref` to the hint database. Unfortunately, Coq will not unfold refinesFun - and add_loop_spec when rewriting, and the only workaround I know right now is this :/ *) -Definition add_loop_spec_ref' : ltac:(let tp := type of add_loop_spec_ref in - let tp' := eval unfold refinesFun in tp - in exact tp') := add_loop_spec_ref. -Hint Rewrite add_loop_spec_ref' : refinement_proofs. - -Lemma no_errors_sign_of_sum : refinesFun sign_of_sum (fun _ _ => noErrorsSpec). -Proof. - unfold sign_of_sum, sign_of_sum__tuple_fun, noErrorsSpec. - time "no_errors_sign_of_sum" prove_refinement. -Qed. - -Definition sign_of_sum_spec (x y : bitvector 64) : CompM (bitvector 64) := - orM ( assertM (isBvslt _ (intToBv _ 0) (bvAdd _ x y)) >> returnM (intToBv _ 1)) - (orM (assertM (isBvslt _ (bvAdd _ x y) (intToBv _ 0)) >> returnM (intToBv _ (-1))) - (assertM (bvAdd _ x y = intToBv _ 0) >> returnM (intToBv _ 0))). - -Lemma sign_of_sum_spec_ref : refinesFun sign_of_sum sign_of_sum_spec. -Proof. - unfold sign_of_sum, sign_of_sum__tuple_fun, sign_of_sum_spec. - time "sign_of_sum_spec_ref" prove_refinement. - - continue_prove_refinement_left. - assumption. - - continue_prove_refinement_right; - continue_prove_refinement_left. - assumption. - - continue_prove_refinement_right; - continue_prove_refinement_right. - apply isBvsle_antisymm; assumption. -Qed. - - -(* Add `no_errors_sign_of_sum` to the hint database. Unfortunately, Coq will not unfold refinesFun - and no_errors_sign_of_sum when rewriting, and the only workaround I know right now is this :/ *) -Definition no_errors_sign_of_sum' : ltac:(let tp := type of no_errors_sign_of_sum in - let tp' := eval unfold refinesFun, noErrorsSpec in tp - in exact tp') := no_errors_sign_of_sum. -Hint Rewrite no_errors_sign_of_sum' : refinement_proofs. - -Lemma no_errors_compare_sum : - refinesFun compare_sum (fun x _ _ => assumingM (isBvslt 64 (bvsmin 64) x) - noErrorsSpec). -Proof. - unfold compare_sum, compare_sum__tuple_fun, noErrorsSpec. - time "no_errors_compare_sum" prove_refinement. - - assumption. (* doesn't matter what we put here *) - - rewrite bvNeg_bvslt_zero_iff in e_if; eauto. - rewrite e_if in e_if0. - apply isBvslt_antirefl in e_if0; contradiction. -Qed. - - -(* Remove `no_errors_sign_of_sum` from the database! *) -Remove Hints no_errors_sign_of_sum' : refinement_proofs. - -(* Add `sign_of_sum_spec_ref` to the hint database. Unfortunately, Coq will not unfold refinesFun - and no_errors_sign_of_sum when rewriting, and the only workaround I know right now is this :/ *) -Definition sign_of_sum_spec_ref' : ltac:(let tp := type of sign_of_sum_spec_ref in - let tp' := eval unfold refinesFun, sign_of_sum_spec in tp - in exact tp') := sign_of_sum_spec_ref. -Hint Rewrite sign_of_sum_spec_ref' : refinement_proofs. - - -Definition compare_sum_spec (x y z : bitvector 64) : CompM (bitvector 64) := - assumingM (isBvslt 64 (bvsmin 64) x /\ bvSubOverflow 64 (bvAdd 64 y z) x = false) - (orM ( assertM (isBvslt _ x (bvAdd _ y z)) >> returnM (intToBv _ 1)) - (orM (assertM (isBvslt _ (bvAdd _ y z) x) >> returnM (intToBv _ (-1))) - (assertM (x = bvAdd _ y z) >> returnM (intToBv _ 0)))). - -Lemma compare_sum_spec_ref : refinesFun compare_sum compare_sum_spec. -Proof. - unfold compare_sum, compare_sum__tuple_fun, compare_sum_spec. - time "compare_sum_spec_ref" prove_refinement. - all: try rewrite bvSub_zero_n, bvAdd_comm, <- bvSub_eq_bvAdd_neg in e_assert. - (* Note that there are two versions of each case because of the if! *) - (* The `x < y + z` case: *) - 1,4: continue_prove_refinement_left. - 1,2: apply bvslt_bvSub_r; eauto. - (* The `x > y + z` case: *) - 1,3: continue_prove_refinement_right; - continue_prove_refinement_left. - 1,2: apply bvslt_bvSub_l; eauto. - (* The `x = y + z` case: *) - 1,2: continue_prove_refinement_right; - continue_prove_refinement_right. - 1,2: rewrite bvEq_bvSub_r; symmetry; eauto. - (* The remaining case follows from our precondition (same as no_errors) *) - rewrite bvNeg_bvslt_zero_iff in e_if0; eauto. - rewrite e_if0 in e_if1. - apply isBvslt_antirefl in e_if1; contradiction. -Qed. diff --git a/heapster/examples/mbox.bc b/heapster/examples/mbox.bc deleted file mode 100644 index c18374f8b5..0000000000 Binary files a/heapster/examples/mbox.bc and /dev/null differ diff --git a/heapster/examples/mbox.c b/heapster/examples/mbox.c deleted file mode 100644 index 6631a14abd..0000000000 --- a/heapster/examples/mbox.c +++ /dev/null @@ -1,500 +0,0 @@ - -#include -#include -#include - -///////////////////////////////////////////////////////////////////////////////////// -// Types of errors charbydis may make - -#define SUCCESS 0 -#define INVALID_LENGTH 1 -#define NO_POLICY_FOR_THIS_CONNECTION 2 -#define NO_STATE_FOR_THIS_CONNECTION 3 -#define SAD_OUT_OF_MEMORY 4 -#define TRANSPORT_MODE_UNSUPPORTED 5 -#define INVALID_SEQUENCE_NUMBER 6 -#define UNKNOWN_SPI 7 -#define MBOX_ALREADY_FREED 8 -#define MBOX_OUT_OF_MEMORY 9 -#define INVALID_PROTOCOL 10 -#define BUFFER_COPY_ERROR 11 -#define MBOX_COPY_ERROR 12 -#define MBOX_SPLIT_ERROR 13 -#define PARSE_ERROR 14 -#define FILE_ERROR 15 -#define SAD_STATE_SRC_MISSING 16 -#define SAD_STATE_DST_MISSING 17 -#define SAD_STATE_SPI_MISSING 18 -#define SAD_STATE_MODE_MISSING 19 -#define SAD_STATE_AUTH_ALGO_MISSING 20 -#define SAD_STATE_ENC_ALGO_MISSING 21 -#define UNIMPLEMENTED 22 -#define MBOX_NULL_ERROR 23 -#define SAD_KEY_MISSING 24 -#define AUTH_FAILURE 25 - -typedef uint32_t error; - -char *err_str(error e) { - switch (e) { - case SUCCESS: - return "success"; - case INVALID_LENGTH: - return "invalid length"; - case NO_POLICY_FOR_THIS_CONNECTION: - return "no policy for this connection"; - case NO_STATE_FOR_THIS_CONNECTION: - return "no state for this connection"; - case SAD_OUT_OF_MEMORY: - return "SAD is out of memory"; - case TRANSPORT_MODE_UNSUPPORTED: - return "transport mode is unsupported"; - case INVALID_SEQUENCE_NUMBER: - return "invalid sequence number"; - case UNKNOWN_SPI: - return "unknown SPI"; - case MBOX_ALREADY_FREED: - return "mbox already freed"; - case MBOX_OUT_OF_MEMORY: - return "mbox out of memory"; - case INVALID_PROTOCOL: - return "packet contains invalid protocol"; - case BUFFER_COPY_ERROR: - return "error copying buffers"; - case MBOX_COPY_ERROR: - return "error copying mboxes"; - case MBOX_SPLIT_ERROR: - return "error splitting mboxes"; - case PARSE_ERROR: - return "parse error"; - case SAD_STATE_SRC_MISSING: - return "SAD src field missing"; - case SAD_STATE_DST_MISSING: - return "SAD dst field missing"; - case SAD_STATE_SPI_MISSING: - return "SAD spi field missing"; - case SAD_STATE_MODE_MISSING: - return "SAD esp_mode field missing"; - case SAD_STATE_AUTH_ALGO_MISSING: - return "SAD auth_algo field missing"; - case SAD_STATE_ENC_ALGO_MISSING: - return "SAD enc_algo field missing"; - case UNIMPLEMENTED: - return "unimplemented"; - case MBOX_NULL_ERROR: - return "tried to operate on a null mbox pointer"; - case SAD_KEY_MISSING: - return "SAD key is missing"; - case AUTH_FAILURE: - return "authentication failed"; - } - return "unknown error"; -} - -///////////////////////////////////////////////////////////////////////////////////// -// memory management - -#define MBOX_SIZE 128 - -typedef struct mbox { - size_t start; - size_t len; - struct mbox *next; - uint8_t data[MBOX_SIZE]; -} mbox; - -#include -#include -#include - -#define MEM_POOL_SIZE 10000 -#define MIN(x, y) (((x) < (y)) ? (x) : (y)) - -static mbox mem_pool[MEM_POOL_SIZE]; -static bool mem_in_use[MEM_POOL_SIZE] = {false}; -static size_t search_index = 0; // Avoid searching through the whole pool - -#include - -bool mbox_all_freed() { - for (size_t i = 0; i < MEM_POOL_SIZE; i++) { - if (mem_in_use[i]) { - printf("mbox %lu in use\n", i); - return false; - } - } - return true; -} - -mbox *mbox_new() { - // Linear scan through the mem_pool, looking for an available mbox. - for (; search_index < MEM_POOL_SIZE; search_index++) { - if (!mem_in_use[search_index]) { - // Found one. Initialize it. - mem_in_use[search_index] = true; - mbox *m = &mem_pool[search_index]; - // bzero(m, sizeof(mbox)); - memset(m, 0, sizeof(mbox)); - m->len = MBOX_SIZE; - search_index += 1; - return m; - } - } - return NULL; -} - -error mbox_free(mbox *m) { - if (m == NULL) { - return 0; - } - size_t mid = m - mem_pool; - if (mem_in_use[mid]) { - mem_in_use[mid] = false; - search_index = MIN(search_index, mid); - return 0; - } - return MBOX_ALREADY_FREED; -} - -error mbox_free_chain(mbox *m) { - while (m != NULL) { - mbox *mbox_next = m->next; - error err = mbox_free(m); - if (err != 0) { - return err; - } - m = mbox_next; - } - return 0; -} - -mbox *mbox_from_buffer(const uint8_t *inp, size_t len) { - mbox *head = mbox_new(); - if (head == NULL) { - return NULL; - } - if (len < MBOX_SIZE) { - // If the size of the data is small, we only need one mbox - memcpy(head->data, inp, len); - head->len = len; - return head; - } else { - // Start the mbox chain - memcpy(head->data, inp, MBOX_SIZE); - } - mbox *prev = head; - for (size_t i = MBOX_SIZE; i < len; i += MBOX_SIZE) { - // Get a new mbox - mbox *cur = mbox_new(); - if (cur == NULL) { - return NULL; - } - // Add it to the chain - prev->next = cur; - if (len - i < MBOX_SIZE) { - // If we're at the end of data, end the chain - memcpy(cur->data, inp + i, len - i); - cur->len = len - i; - } else { - // Otherwise copy away - memcpy(cur->data, inp + i, MBOX_SIZE); - } - prev = cur; - } - return head; -} - -size_t mbox_to_buffer(uint8_t *buf, size_t buf_len, const mbox *m, size_t offset) { - if (m == NULL) { - return 0; - } - // Exhaust offset first - if (m->len < offset) { - return mbox_to_buffer(buf, buf_len, m->next, offset - m->len); - } - // Follow the mbox chain, copying bytes into the output buffer - size_t bytes_copied = 0; - while (m != NULL) { - // printf("buf_len = %lu, bytes_copied = %lu, m->len = %lu, offset = - // %lu\n", - // buf_len, bytes_copied, m->len, offset); - if (buf_len - bytes_copied < m->len - offset) { - // Ran out of space in the output buffer - // Fill up the remaining and abort - size_t amt_remaining = buf_len - bytes_copied; - memcpy(buf + bytes_copied, m->data + m->start + offset, amt_remaining); - return bytes_copied + amt_remaining; - } - memcpy(buf + bytes_copied, m->data + m->start + offset, m->len - offset); - bytes_copied += m->len - offset; - offset = 0; - m = m->next; - } - return bytes_copied; -} - -void mbox_to_buffer_rec(uint8_t *buf, size_t buf_len, const mbox *m) { - if (m == NULL) { - return; - } - size_t bytes_to_copy = m->len; - if (buf_len >= bytes_to_copy) { - // buffer bigger than mbox - memcpy(buf, m->data + m->start, bytes_to_copy); - mbox_to_buffer_rec(buf + bytes_to_copy, buf_len - bytes_to_copy, m->next); - } else { - // buffer smaller than mbox - memcpy(buf, m->data + m->start, buf_len); - } - return; -} - -size_t mbox_len(const mbox *m) { - // Add up the cumulative lengths of the mbox chain - size_t total = 0; - while (m != NULL) { - total += m->len; - m = m->next; - } - return total; -} - -void mbox_concat(mbox *x, mbox *y) { - if (x != NULL) { - x->next = y; - } -} - -void mbox_concat_chains(mbox *x, mbox *y) { - if (x == NULL || y == NULL) { - return; - } - - // Find the last item in the chain of x - while (1) { - if (x->next == NULL) { - break; - } - x = x->next; - } - mbox_concat(x, y); -} - -// Drop and de-allocate bytes from the start of an mbox. -void mbox_drop(mbox *m, size_t ix) { - if (m == NULL) { - return; - } else if (ix >= m->len) { - mbox_drop(m->next, ix - m->len); - m->start = 0; - m->len = 0; - return; - } - m->start = m->start + ix; - m->len = m->len - ix; -} - -// Extract the first ix bytes into its own mbox. -// Returns the mbox starting at ix, and modifies m to contain only the rest -mbox *mbox_split_at(mbox **m, size_t ix) { - if (m == NULL || *m == NULL) { - return NULL; - } else if (ix == 0) { - mbox* ret = *m; - *m = NULL; - return ret; - } else if (ix == (*m)->len) { - mbox* nxt = (*m)->next; - (*m)->next = NULL; - return nxt; - } else if (ix > (*m)->len) { - return mbox_split_at(&((*m)->next), ix - (*m)->len); - } - - mbox *new = mbox_new(); - if (new == NULL) { - return NULL; - } - - memcpy(new->data, (*m)->data + ix, (*m)->len - ix); - new->len = (*m)->len - ix; - new->next = (*m)->next; - (*m)->next = NULL; - (*m)->len = ix; - - return new; -} - -// Copy a single mbox -mbox *mbox_copy(const mbox *src) { - if (src == NULL) { - return NULL; - } - mbox *dst = mbox_new(); - if (dst == NULL) { - return 0; // Out of memory - } - memcpy(dst->data + src->start, src->data + src->start, src->len); - dst->start = src->start; - dst->len = src->len; - return dst; -} - -// Clone a whole mbox chain -mbox *mbox_copy_chain(const mbox *src, size_t len) { - if (len == 0) { - return NULL; - } - mbox *head = mbox_copy(src); - if (head == NULL || src == NULL) { - return NULL; - } - if (head->len >= len) { - head->len = len; - return head; - } - mbox *rest = mbox_copy_chain(src->next, len - head->len); - if (rest != NULL) { - mbox_concat(head, rest); - } - return head; -} - -// Detach the first mbox from the chain, returning it. -mbox *mbox_detach(mbox **m) { - if (*m == NULL) { - return NULL; - } - mbox *n = *m; - *m = (*m)->next; - n->next = NULL; - return n; -} - -mbox *mbox_detach_from_end(mbox **m, size_t length_from_end) { - return mbox_split_at(m, mbox_len(*m) - length_from_end); -} - -// Treat the bytes inside m as an integer, incrementing them -// Useful for IVs -error mbox_increment(mbox *m) { - if (m == NULL) { - return MBOX_NULL_ERROR; - } - if (MBOX_SIZE != 128 || m->start != 0 || m->len != MBOX_SIZE) { - return UNIMPLEMENTED; - } - - // Heapster doesn't like the casts in the following couple lines, so they - // are reimplemented in a hideous way below. - if (++((uint64_t *)m->data)[0] == 0) { - ++((uint64_t *)m->data)[1]; - } - - // Here is how to perform this computation in a little-endian way: - /* - for (uint64_t i = 0; i < 16; ++i) { - if (++(m->data[i]) == 0) - break; - } - */ - - // first 64 bits - // uint64_t byte0 = m->data[0]; uint64_t byte1 = m->data[1]; - // uint64_t byte2 = m->data[2]; uint64_t byte3 = m->data[3]; - // uint64_t byte4 = m->data[4]; uint64_t byte5 = m->data[5]; - // uint64_t byte6 = m->data[6]; uint64_t byte7 = m->data[7]; - // uint64_t joined_bytes = - // (byte0 << 56) & (byte1 << 48) & (byte2 << 40) & (byte3 << 32) & - // (byte4 << 24) & (byte5 << 16) & (byte6 << 8) & byte7; - // joined_bytes++; - // printf("joined bytes: %lu\n", joined_bytes); - // printf("should be: %lu\n", ++((uint64_t *)m->data)[0]); - // byte0 = (joined_bytes & 0xFF00000000000000) >> 56; - // byte1 = (joined_bytes & 0x00FF000000000000) >> 48; - // byte2 = (joined_bytes & 0x0000FF0000000000) >> 40; - // byte3 = (joined_bytes & 0x000000FF00000000) >> 32; - // byte4 = (joined_bytes & 0x00000000FF000000) >> 24; - // byte5 = (joined_bytes & 0x0000000000FF0000) >> 16; - // byte6 = (joined_bytes & 0x000000000000FF00) >> 8; - // byte7 = (joined_bytes & 0x00000000000000FF); - // m->data[0] = byte0; m->data[1] = byte1; - // m->data[2] = byte2; m->data[3] = byte3; - // m->data[4] = byte4; m->data[5] = byte5; - // m->data[6] = byte6; m->data[7] = byte7; - - // if (joined_bytes == 0) { - // byte0 = m->data[8]; byte1 = m->data[9]; - // byte2 = m->data[10]; byte3 = m->data[11]; - // byte4 = m->data[12]; byte5 = m->data[13]; - // byte6 = m->data[14]; byte7 = m->data[15]; - // joined_bytes = - // (byte0 << 56) & (byte1 << 48) & (byte2 << 40) & (byte3 << 32) & - // (byte4 << 24) & (byte5 << 16) & (byte6 << 8) & byte7; - // joined_bytes++; - // byte0 = (joined_bytes & 0xFF00000000000000) >> 56; - // byte1 = (joined_bytes & 0x00FF000000000000) >> 48; - // byte2 = (joined_bytes & 0x0000FF0000000000) >> 40; - // byte3 = (joined_bytes & 0x000000FF00000000) >> 32; - // byte4 = (joined_bytes & 0x00000000FF000000) >> 24; - // byte5 = (joined_bytes & 0x0000000000FF0000) >> 16; - // byte6 = (joined_bytes & 0x000000000000FF00) >> 8; - // byte7 = (joined_bytes & 0x00000000000000FF); - // m->data[8] = byte0; m->data[9] = byte1; - // m->data[10] = byte2; m->data[11] = byte3; - // m->data[12] = byte4; m->data[13] = byte5; - // m->data[14] = byte6; m->data[15] = byte7; - // } - return SUCCESS; -} - -error mbox_randomize(mbox *m) { - if (m == NULL) { - return MBOX_NULL_ERROR; - } - for (size_t i = m->start; i < m->len; i++) { - m->data[i] = rand(); - } - return SUCCESS; -} - -// returns 1 if the two mboxes are equal, 0 if they are not -int mbox_eq(mbox *m, mbox *n) { - if (m == NULL && n == NULL) { - // If they are both NULL, they are equal - return 1; - } - if (m == NULL || n == NULL) { - // If only one is NULL, they are unequal - return 0; - } - - size_t mi = m->start; // current index into m - size_t ni = n->start; // current index into n - while (1) { - if (m == NULL && n == NULL) { - // If they are both NULL, they are equal - return 1; - } - if (m == NULL || n == NULL) { - // If only one is NULL, they are unequal - return 0; - } - if (m->data[mi++] != n->data[ni++]) { - return 0; - } - if (mi >= m->len) { - m = m->next; - if (m != NULL) { - mi = m->start; - } - } - if (ni >= n->len) { - n = n->next; - if (n != NULL) { - ni = n->start; - } - } - } - return 1; -} diff --git a/heapster/examples/mbox.saw b/heapster/examples/mbox.saw deleted file mode 100644 index b435976788..0000000000 --- a/heapster/examples/mbox.saw +++ /dev/null @@ -1,281 +0,0 @@ -//------------------------------------------------------------------------------ -// This file contains the SAW code that runs the Heapster type checking for -// the mbox.c file in Charybdis, and then generates Coq specifications for -// verification. -//------------------------------------------------------------------------------ - - -//------------------------------------------------------------------------------ -// Initialization -enable_experimental; -env <- heapster_init_env_from_file "mbox.sawcore" "mbox.bc"; - - -//------------------------------------------------------------------------------ -// Permissions abbreviations used in other places - -heapster_define_perm env "int8" " " "llvmptr 8" "exists x:bv 8.eq(llvmword(x))"; - -heapster_define_perm env "int32" " " "llvmptr 32" "exists x:bv 32.eq(llvmword(x))"; - -heapster_define_perm env "int64" " " "llvmptr 64" "exists x:bv 64.eq(llvmword(x))"; - -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(rw1, 0, <240, *1, fieldsh (int64<>)) * ptr((rw2, 1920) |-> int64<>)"; - -// FIXME: get reachability perms working again! -heapster_define_reachability_perm env "mbox" - "rw:rwmodality, x:llvmptr 64" - "llvmptr 64" - "eq(x) or (ptr((rw,0) |-> int64<>) * ptr((rw,8) |-> int64<>) * \ - \ ptr((rw,16) |-> mbox) * array(W, 24, <128, *1, fieldsh(8,int8<>)))" - "transMbox"; - -// heapster_define_perm env "mbox_nonnull" -// "rw:rwmodality, p:perm (llvmptr 64)" -// "llvmptr 64" -// "ptr((rw,0) |-> int64<>) * ptr((rw,8) |-> int64<>) * \ -// \ ptr((rw,16) |-> int64<>) * ptr((rw,24) |-> mbox) * \ -// \ array(32, <128, *1, [(rw,0,8) |-> int8<>])"; - -heapster_define_perm env "byte_array" - "rw:rwmodality, len:bv 64" - "llvmptr 64" - "array(W, 0, ))"; - -heapster_define_perm env "boolean" " " "llvmptr 1" "exists x:bv 1.eq(llvmword(x))"; - - -//------------------------------------------------------------------------------ -// LLVM intrinsics - -// memcpy i64 -// heapster_assume_fun env "llvm.memcpy.p0i8.p0i8.i64" -// "(X:perm(llvmptr 64), Y:perm(llvmptr 64)). \ -// \ arg0:(exists x:bv 1.X), arg1:(exists x:bv 1.Y), arg2:true, arg3:true -o \ -// \ arg0:(exists x:bv 1.Y), arg1:(exists x:bv 1.Y)" -// "\\ (X:sort 0) (Y:sort 0) (_:SigBV1 X) (y:SigBV1 Y) -> \ -// \ returnM (SigBV1 Y * (SigBV1 Y * #())) (y, (y, ()))"; - -// heapster_assume_fun env "llvm.memcpy.p0i8.p0i8.i64" -// "(len:bv 64). arg0:byte_array, arg1:byte_array, \ -// \ arg2:eq(llvmword(len)), arg3:true -o \ -// \ arg0:byte_array, arg1:byte_array" -// "\\ (len:Vec 64 Bool) (x y:BVVec 64 len (Vec 8 Bool)) -> \ -// \ returnM (BVVec 64 len (Vec 8 Bool) * (BVVec 64 len (Vec 8 Bool) * #())) (y, (y, ()))"; - -heapster_assume_fun env "llvm.objectsize.i64.p0i8" "().empty -o empty" - "retS VoidEv #() ()"; - -heapster_assume_fun env "__memcpy_chk" - "(len:bv 64). arg0:byte_array, arg1:byte_array, arg2:eq(llvmword (len)) -o \ - \ arg0:byte_array, arg1:byte_array" - "\\ (len:Vec 64 Bool) (_ src : BVVec 64 len (Vec 8 Bool)) -> \ - \ retS VoidEv \ - \ (BVVec 64 len (Vec 8 Bool) * BVVec 64 len (Vec 8 Bool)) (src, src)"; - - -//------------------------------------------------------------------------------ -// Permissions for stdlib functions - -heapster_assume_fun env "rand" "().empty -o ret:int32<>" "randSpec"; - - -//------------------------------------------------------------------------------ -// mbox.c - - -heapster_assume_fun env "mbox_all_freed" - "(). empty -o ret:boolean<>" - "mboxAllFreedSpec"; - - -heapster_assume_fun env "mbox_new" - "(). empty -o ret:mbox" - "mboxNewSpec"; - - -heapster_assume_fun env "mbox_free" - "(). arg0:ptr((W,0) |-> true) * ptr((W,8) |-> true) * ptr((W,16) |-> true) * \ - \ array(W, 24, <128, *1, fieldsh(8,int8<>)) -o \ - \ arg0:true, ret:int32<>" - "mboxFreeSpec"; - - -heapster_block_entry_hint env "mbox_free_chain" 3 - "top1:llvmptr 64" - "frm:llvmframe 64" - "top1:true, \ - \ arg0:ptr((W,0,32) |-> true), arg1:ptr((W,0) |-> mbox), \ - \ arg2:ptr((W,0) |-> true), arg3:ptr((W,0,32) |-> true), \ - \ frm:llvmframe [arg3:4,arg2:8,arg1:8,arg0:4]"; - -heapster_typecheck_fun env "mbox_free_chain" - "(). arg0:mbox -o arg0:true, ret:int32<>"; - - -heapster_block_entry_hint env "mbox_eq" 29 - "top1:llvmptr 64, top2:llvmptr 64" - "frm:llvmframe 64, x0:llvmptr 64, x1:llvmptr 64" - "top1:mbox, top2:mbox, \ - \ arg0:ptr((W,0,32) |-> true), arg1:ptr((W,0) |-> eq(x0)), \ - \ arg2:ptr((W,0) |-> eq(x1)), arg3:ptr((W,0) |-> int64<>), arg4:ptr((W,0) |-> int64<>), \ - \ frm:llvmframe [arg4:8, arg3:8, arg2:8, arg1:8, arg0:4], \ - \ x0:mbox, x1:mbox"; - -heapster_typecheck_fun env "mbox_eq" - "(). arg0:mbox, arg1:mbox -o \ - \ arg0:mbox, arg1:mbox, ret:int32<>"; - - -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(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(W, 24, <128, *1, fieldsh(8, int8<>)), \ - \ ghost1:true"; - -heapster_typecheck_fun env "mbox_from_buffer" - "(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(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)), \ - \ arg3:ptr((W,0) |-> eq(ghost0)), arg4:ptr((W,0) |-> int64<>), \ - \ arg5:ptr((W,0) |-> int64<>), arg6:ptr((W,0) |-> true), \ - \ frm:llvmframe [arg6:8, arg5:8, arg4:8, arg3:8, arg2:8, arg1:8, arg0:8], \ - \ ghost0:mbox"; - -heapster_typecheck_fun env "mbox_to_buffer" - "(len:bv 64). arg0:array(W, 0,)), \ - \ arg1:eq(llvmword(len)), arg2:mbox, arg3:int64<> -o \ - \ 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(W, 0,)), \ - \ arg1:eq(llvmword(len)), arg2:mbox -o \ - \ arg0:array(W, 0,)), \ - \ arg1:true, arg2:mbox, ret:true"; - -// heapster_typecheck_fun env "mbox_to_buffer_rec" -// "(len:bv 64). arg0:byte_array, arg1:eq(llvmword(len)), \ -// \ arg2:mbox, arg3:int64<> -o \ -// \ arg0:byte_array, arg1:true, \ -// \ arg2:mbox, arg3:true, ret:int64<>"; - - -heapster_block_entry_hint env "mbox_len" 3 - "top1:llvmptr 64" - "frm:llvmframe 64, ghost:llvmptr 64" - "top1:mbox, \ - \ arg0:ptr((W,0) |-> eq(ghost)), arg1:ptr((W,0) |-> int64<>), \ - \ frm:llvmframe [arg1:8, arg0:8], \ - \ ghost:mbox"; - -heapster_typecheck_fun env "mbox_len" - "(). arg0:mbox -o arg0:mbox, ret:int64<>"; - - -heapster_typecheck_fun env "mbox_concat" - "(). arg0:mbox, arg1:mbox -o \ - \ arg0:mbox, arg1:true"; - - -heapster_block_entry_hint env "mbox_concat_chains" 16 - "top1:llvmptr 64, top2:llvmptr 64" - "frm:llvmframe 64, x0:llvmptr 64" - "top1:mbox, top2:mbox, \ - \ 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(W, 24, <128, *1, fieldsh(8, int8<>))"; - -heapster_typecheck_fun env "mbox_concat_chains" - "(). arg0:mbox, arg1:mbox -o \ - \ arg0:mbox"; - - -heapster_typecheck_fun env "mbox_split_at" - "(). arg0:ptr((W,0) |-> mbox), arg1:int64<> -o \ - \ arg0:ptr((W,0) |-> mbox), arg1:true, ret:mbox"; - - -heapster_typecheck_fun env "mbox_copy" - "(). arg0:mbox -o \ - \ arg0:mbox, ret:mbox"; - -// heapster_typecheck_fun env "mbox_copy" -// "(). arg0:mbox_nonnull> -o arg0:true, ret:mbox"; - - -// heapster_block_entry_hint env "mbox_copy_chain" 51 -// "top1:llvmptr 64, top2:llvmptr 64" -// "frm:llvmframe 64" -// "top1:true, top2:true, \ -// \ arg0:ptr((W,0) |-> eq(llvmword(true))), \ -// \ arg1:ptr((W,0) |-> eq(top2)), \ -// \ frm:llvmframe [arg1:8,arg0:8], \ -// \ x0:mbox"; - -// heapster_block_entry_hint env "mbox_copy_chain" 7 -// "top1:llvmptr 64, top2:llvmptr 64" -// "frm:llvmframe 64" -// "top1:mbox, top2:mbox, frm:llvmframe []"; - -heapster_typecheck_fun env "mbox_copy_chain" - "(). arg0:mbox, arg1:int64<> -o \ - \ arg0:mbox, arg1:true, ret:mbox"; - - -heapster_typecheck_fun env "mbox_detach" - "(). arg0:ptr((W,0) |-> mbox) -o \ - \ arg0:ptr((W,0) |-> mbox), ret:mbox"; - - -heapster_typecheck_fun env "mbox_detach_from_end" - "(). arg0:ptr((W,0) |-> mbox), arg1:int64<> -o \ - \ arg0:ptr((W,0) |-> mbox), arg1:true, ret:mbox"; - - -heapster_typecheck_fun env "mbox_increment" - "(). arg0:mbox -o arg0:mbox, ret:int32<>"; - - -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(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]"; - -heapster_typecheck_fun env "mbox_randomize" - "(). arg0:mbox -o arg0:mbox, ret:int32<>"; - - -heapster_typecheck_fun env "mbox_drop" - "(). arg0:mbox, arg1:int64<> -o \ - \ arg0:mbox, arg1:true"; - - -//------------------------------------------------------------------------------ -// Export to coq for verification -heapster_export_coq env "mbox_gen.v"; diff --git a/heapster/examples/mbox.sawcore b/heapster/examples/mbox.sawcore deleted file mode 100644 index 718a865c5f..0000000000 --- a/heapster/examples/mbox.sawcore +++ /dev/null @@ -1,108 +0,0 @@ -module mbox where - -import SpecM; - -SigBV1 : sort 0 -> sort 0; -SigBV1 a = Sigma (Vec 1 Bool) (\ (_:Vec 1 Bool) -> a); - -getSBoxValueSpec : Vec 64 Bool -> - SpecM VoidEv (Vec 64 Bool); -getSBoxValueSpec x = retS VoidEv (Vec 64 Bool) x; - --- Hardcoded 64 length bitvector value 16, used for mbox definitions -bv64_16 : Vec 64 Bool; -bv64_16 = [False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,True,False,False,False,False]; - -bv64_128 : Vec 64 Bool; -bv64_128 = [False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,True,False,False,False,False,False,False,False]; - - --- An inductive type formulation of the Mbox type; this is just for --- documentation purposes, and isn't used in the below -data Mbox_Ind : sort 0 where { - Mbox_Ind_nil : Mbox_Ind; - Mbox_Ind_cons : Vec 64 Bool -> Vec 64 Bool -> Mbox_Ind -> - BVVec 64 bv64_128 (Vec 8 Bool) -> Mbox_Ind; -} - --- Type description for the Mbox type, which is equivalent to Mbox_Ind -MboxDesc : TpDesc; -MboxDesc = - (Tp_Sum - Tp_Unit - (Tp_Pair (Tp_bitvector 64) - (Tp_Pair (Tp_bitvector 64) - (Tp_Pair (varKindExpr Kind_Tp 0) - (Tp_BVVec 64 (TpExpr_Const (Kind_bv 64) bv64_128) (Tp_bitvector 8)))))); - --- The type described by MboxDesc -Mbox : sort 0; -Mbox = indElem (unfoldIndTpDesc nilTpEnv MboxDesc); - -primitive transMbox : Mbox -> Mbox -> Mbox; - --- FIXME: figure out how to write some of these using the TpDesc version of Mbox -{- -Mbox__rec : (P : Mbox -> sort 0) -> - (P Mbox_nil) -> - ((strt:Vec 64 Bool) -> (len:Vec 64 Bool) -> (m:Mbox) -> P m -> (d:BVVec 64 bv64_128 (Vec 8 Bool)) -> P (Mbox_cons strt len m d)) -> - (m:Mbox) -> P m; -Mbox__rec P f1 f2 m = Mbox#rec P f1 f2 m; - -unfoldMbox : Mbox -> Either #() (Vec 64 Bool * Vec 64 Bool * Mbox * BVVec 64 bv64_128 (Vec 8 Bool)); -unfoldMbox m = - Mbox__rec (\ (_:Mbox) -> Either #() (Vec 64 Bool * Vec 64 Bool * Mbox * BVVec 64 bv64_128 (Vec 8 Bool))) - (Left #() (Vec 64 Bool * Vec 64 Bool * Mbox * BVVec 64 bv64_128 (Vec 8 Bool)) ()) - (\ (strt:Vec 64 Bool) (len:Vec 64 Bool) (m:Mbox) (_:Either #() (Vec 64 Bool * Vec 64 Bool * Mbox * BVVec 64 bv64_128 (Vec 8 Bool))) (d:BVVec 64 bv64_128 (Vec 8 Bool)) -> - Right #() (Vec 64 Bool * Vec 64 Bool * Mbox * BVVec 64 bv64_128 (Vec 8 Bool)) (strt, len, m, d)) - m; - -foldMbox : Either #() (Vec 64 Bool * Vec 64 Bool * Mbox * BVVec 64 bv64_128 (Vec 8 Bool)) -> Mbox; -foldMbox = - either #() (Vec 64 Bool * Vec 64 Bool * Mbox * BVVec 64 bv64_128 (Vec 8 Bool)) Mbox - (\ (_:#()) -> Mbox_nil) - (\ (tup : (Vec 64 Bool * Vec 64 Bool * Mbox * BVVec 64 bv64_128 (Vec 8 Bool))) -> - Mbox_cons tup.1 tup.2 tup.3 tup.(2).(2).(2)); - -{- -getMbox : (a : sort 0) -> Mbox a -> a; -getMbox a = - Mbox__rec a (\ (_ : Mbox a) -> a) - (\ (x : a) -> x) - (\ (_ : Vec 64 Bool) (_ : Vec 64 Bool) (_ : Mbox a) (rec : a) (_ : BVVec 64 bv64_128 (Vec 8 Bool)) -> rec); - -putMbox : (a b : sort 0) -> Mbox a -> b -> Mbox b; -putMbox a b m b_val = - Mbox__rec a (\ (_ : Mbox a) -> Mbox b) - (\ (_ : a) -> Mbox_nil b b_val) - (\ (strt : Vec 64 Bool) (len : Vec 64 Bool) (_ : Mbox a) (rec : Mbox b) (vec : BVVec 64 bv64_128 (Vec 8 Bool) -> Mbox_cons b strt len rec vec) - m; --} - -transMbox : Mbox -> Mbox -> Mbox; -transMbox m1 m2 = - Mbox__rec (\ (_ : Mbox) -> Mbox) - m2 - (\ (strt : Vec 64 Bool) (len : Vec 64 Bool) (_ : Mbox) (rec : Mbox) (vec : BVVec 64 bv64_128 (Vec 8 Bool)) -> Mbox_cons strt len rec vec) - m1; --} - -{- -mboxNewSpec : SpecM VoidEv (Mbox); -mboxNewSpec = - retS VoidEv Mbox - (Mbox_cons (bvNat 64 0) (bvNat 64 0) Mbox_nil (genBVVec 64 bv64_128 (Vec 8 Bool) (\ (i:Vec 64 Bool) (_:is_bvult 64 i bv64_128) -> (bvNat 8 0)))); --} - -primitive -mboxNewSpec : SpecM VoidEv Mbox; - -mboxFreeSpec : BVVec 64 bv64_128 (Vec 8 Bool) -> - SpecM VoidEv (Vec 32 Bool); -mboxFreeSpec _ = retS VoidEv (Vec 32 Bool) (bvNat 32 0); - -mboxAllFreedSpec : SpecM VoidEv (Vec 1 Bool); -mboxAllFreedSpec = retS VoidEv (Vec 1 Bool) (bvNat 1 0); - -randSpec : SpecM VoidEv (Vec 32 Bool); -randSpec = existsS VoidEv (Vec 32 Bool); diff --git a/heapster/examples/mbox_proofs.v b/heapster/examples/mbox_proofs.v deleted file mode 100644 index 6c3cc37968..0000000000 --- a/heapster/examples/mbox_proofs.v +++ /dev/null @@ -1,1106 +0,0 @@ -From Coq Require Import Lists.List. -From Coq Require Import Logic.FunctionalExtensionality. -From Coq Require Import String. -From Coq Require Import Vectors.Vector. -From CryptolToCoq Require Import SAWCoreScaffolding. -From CryptolToCoq Require Import SAWCoreVectorsAsCoqVectors. -From CryptolToCoq Require Import SAWCoreBitvectors. -From CryptolToCoq Require Import SAWCorePrelude. -From CryptolToCoq Require Import SAWCorePreludeExtra. -From CryptolToCoq Require Import SpecMExtra. -From EnTree Require Import Automation. -Import SAWCorePrelude. -Import SpecMNotations. -Local Open Scope entree_scope. - -(* (* All of this for BoolDecidableEqDepSet.UIP, from: - https://stackoverflow.com/questions/50924127/record-equality-in-coq *) -From Coq Require Import Logic.Eqdep_dec. -Module BoolDecidableSet <: DecidableSet. -Definition U := bool. -Definition eq_dec := Bool.bool_dec. -End BoolDecidableSet. -Module BoolDecidableEqDepSet := DecidableEqDepSet BoolDecidableSet. *) - -Require Import Examples.mbox_gen. -Import mbox. - - -(* Bitvector lemmas *) - -Lemma bvAdd_Sub_cancel w a b : - bvAdd w a (bvSub w b a) = b. -Proof. holds_for_bits_up_to_3. Qed. - -Lemma UIP_bool (x y : bool) (p1 p2 : x = y) : p1 = p2. -Proof. - apply Eqdep_dec.UIP_dec. apply Bool.bool_dec. -Qed. - -Lemma updSlice_slice_identity - (m : BVVec 64 bv64_128 (bitvector 8)) - (strt len : bitvector 64) - (pf0 : isBvule 64 strt bv64_128) - (pf1 : isBvule 64 len (bvSub 64 bv64_128 strt)) : - updSliceBVVec 64 bv64_128 (bitvector 8) m strt len - (sliceBVVec 64 bv64_128 (bitvector 8) strt len pf0 pf1 m) = m. -Proof. - rewrite <- (gen_at_BVVec _ _ _ m) at 3. - unfold updSliceBVVec. - f_equal. - extensionality i. extensionality pf. - destruct (bvule 64 strt i) eqn:X. - - destruct (bvultWithProof 64 (bvSub 64 i strt) len) eqn:Y; simpl. - * reflexivity. - * unfold sliceBVVec, takeBVVec, dropBVVec. - do 2 rewrite at_gen_BVVec. - generalize - (bvult_sub_add_bvult 64 - (bvSub 64 i strt) - strt - bv64_128 pf0 - (trans_bvult_bvule - 64 - (bvSub 64 i strt) - len - (bvSub 64 bv64_128 strt) - _1 - pf1)) as H. - rewrite bvAdd_Sub_cancel. intros H. - rewrite (UIP_bool _ _ H pf). - reflexivity. - - reflexivity. -Qed. - -Lemma isBvule_bvSub_remove w a b c : - isBvule w c b -> - isBvule w a (bvSub w b c) -> - isBvule w a b. -Proof. holds_for_bits_up_to_3. Qed. - -Lemma isBvult_impl_lt_bvToNat w a b : - isBvult w a b -> bvToNat w a < bvToNat w b. -Admitted. - -Lemma isBvult_bvSub_bvAdd_1 w x y : - isBvult w y x -> - isBvult w (bvSub w x (bvAdd w y (intToBv w 1))) - (bvSub w x y). -Proof. holds_for_bits_up_to_3. Qed. - - -(* QuantType instance for Mbox *) - -Global Instance QuantType_bitvector {w} : QuantType (bitvector w) := - { quantEnc := QEnc_nat; - quantEnum := bvNat w; - quantEnumInv := bvToNat w; - quantEnumSurjective := bvNat_bvToNat w }. - -Lemma gen_sawAt_eq n a v `{Inhabited a} : - gen n a (sawAt n a v) = v. -Proof. dependent induction v; simpl; f_equal. apply IHv. Qed. - -Program Global Instance QuantType_BVVec_bitvector {w len A} - `{Inhabited A} `{QuantType A} : QuantType (BVVec w len A) := - { quantEnc := QEnc_fun QEnc_nat (quantEnc (A:=A)); - quantEnum := fun f => gen _ _ (fun i => quantEnum (f i)); - quantEnumInv := fun v i => quantEnumInv (sawAt _ _ v i) }. -Next Obligation. - erewrite <- gen_sawAt_eq with (v := a) at 1. - apply gen_domain_eq; intro. - apply quantEnumSurjective. -Qed. - -Fixpoint mbox_to_list (m : Mbox) : list (bitvector 64 * bitvector 64 * - BVVec 64 bv64_128 (bitvector 8)) := - match m with - | Mbox_nil => nil - | Mbox_cons strt len m' d => (strt, len, d) :: mbox_to_list m' - end. - -Fixpoint mbox_from_list (l : list (bitvector 64 * bitvector 64 * - BVVec 64 bv64_128 (bitvector 8))) : Mbox := - match l with - | nil => Mbox_nil - | (strt, len, d) :: l' => Mbox_cons strt len (mbox_from_list l') d - end. - -Lemma QuantType_Mbox_surjective m : - mbox_from_list (quantEnum (quantEnumInv (mbox_to_list m))) = m. -Proof. - rewrite quantEnumSurjective. - induction m; simpl; f_equal; eauto. -Qed. - -Program Global Instance QuantType_Mbox : QuantType Mbox := - { quantEnc := - quantEnc (A := list (bitvector 64 * bitvector 64 * - BVVec 64 bv64_128 (bitvector 8))); - quantEnum := fun s => mbox_from_list (quantEnum s); - quantEnumInv := fun m => quantEnumInv (mbox_to_list m); - quantEnumSurjective := QuantType_Mbox_surjective }. - - -(* QOL: nicer names for mbox arguments *) -#[local] Hint Extern 901 (IntroArg Any Mbox _) => - let e := fresh "m" in IntroArg_intro e : refines prepostcond. -#[local] Hint Extern 901 (IntroArg Any Mbox_def _) => - let e := fresh "m" in IntroArg_intro e : refines prepostcond. -#[local] Hint Extern 901 (IntroArg RetAny Mbox _) => - let e := fresh "r_m" in IntroArg_intro e : refines prepostcond. -#[local] Hint Extern 901 (IntroArg RetAny Mbox_def _) => - let e := fresh "r_m" in IntroArg_intro e : refines prepostcond. - - -(* Mbox destruction automation *) - -Arguments FunsTo_Nil {a}. -Arguments FunsTo_Cons {a tp}. - -Lemma spec_refines_either_unfoldMbox_nil_l (E1 E2 : EvType) Γ1 Γ2 R1 R2 - (RPre : SpecPreRel E1 E2 Γ1 Γ2) (RPost : SpecPostRel E1 E2 Γ1 Γ2) - (RR : Rel R1 R2) f g (P : SpecM E2 Γ2 R2) : - spec_refines RPre RPost RR (f tt) P -> - spec_refines RPre RPost RR (eithers _ (FunsTo_Cons f (FunsTo_Cons g FunsTo_Nil)) - (unfoldMbox Mbox_nil)) P. -Proof. eauto. Qed. - -Lemma spec_refines_either_unfoldMbox_cons_l (E1 E2 : EvType) Γ1 Γ2 R1 R2 - (RPre : SpecPreRel E1 E2 Γ1 Γ2) (RPost : SpecPostRel E1 E2 Γ1 Γ2) - (RR : Rel R1 R2) strt len m d f g (P : SpecM E2 Γ2 R2) : - spec_refines RPre RPost RR (g (strt, (len, (m, d)))) P -> - spec_refines RPre RPost RR (eithers _ (FunsTo_Cons f (FunsTo_Cons g FunsTo_Nil)) - (unfoldMbox (Mbox_cons strt len m d))) P. -Proof. eauto. Qed. - -Ltac eithers_unfoldMbox m := - let m' := eval cbn [ fst snd projT1 ] in m in - lazymatch m' with - | Mbox_nil => - simple apply spec_refines_either_unfoldMbox_nil_l - | Mbox_cons ?strt ?len ?m0 ?d => - simple apply (spec_refines_either_unfoldMbox_cons_l _ _ _ _ _ _ _ _ _ strt len m0 d) - | _ => let strt := fresh "strt" in - let len := fresh "len" in - let m0 := fresh "m" in - let d := fresh "d" in - let eq := fresh "e_destruct" in - destruct m' as [| strt len m0 d ] eqn:eq; - [ eithers_unfoldMbox Mbox_nil - | eithers_unfoldMbox (Mbox_cons strt len m0 d) ]; - simpl foldMbox; cbn [ Mbox__rec Mbox_rect ] in *; - cbn [ fst snd projT1 ]; - revert eq; apply (IntroArg_fold Destruct) - end. - -Global Hint Extern 100 (spec_refines _ _ _ (eithers _ _ (unfoldMbox ?m)) _) => - eithers_unfoldMbox m : refines. -Global Hint Extern 100 (spec_refines _ _ _ _ (eithers _ _ (unfoldMbox ?m))) => - eithers_unfoldMbox m : refines. - -Global Hint Extern 901 (RelGoal _) => - progress (simpl foldMbox in *; cbn [ Mbox__rec Mbox_rect ] in *) : refines. - -Global Hint Extern 100 (Shelve (Mbox__rec _ _ _ ?m)) => - progress cbn [ Mbox__rec Mbox_rect ] in * : refines. -Global Hint Extern 100 (Shelve (Mbox_rect _ _ _ ?m)) => - progress cbn [ Mbox__rec Mbox_rect ] in * : refines. - -Lemma IntroArg_eq_Mbox_nil_nil n goal : - goal -> IntroArg n (Mbox_nil = Mbox_nil) (fun _ => goal). -Proof. do 2 intro; eauto. Qed. - -Lemma IntroArg_eq_Mbox_cons_cons n strt1 strt2 len1 len2 m1 m2 d1 d2 goal : - IntroArg n (strt1 = strt2) (fun _ => IntroArg n (len1 = len2) (fun _ => - IntroArg n (m1 = m2) (fun _ => IntroArg n (d1 = d2) (fun _ => goal)))) -> - IntroArg n (Mbox_cons strt1 len1 m1 d1 = Mbox_cons strt2 len2 m2 d2) (fun _ => goal). -Proof. intros H eq; dependent destruction eq; apply H; eauto. Qed. - -Lemma IntroArg_eq_Mbox_nil_cons n strt len m d goal : - IntroArg n (Mbox_nil = Mbox_cons strt len m d) (fun _ => goal). -Proof. intro eq; dependent destruction eq. Qed. - -Lemma IntroArg_eq_Mbox_cons_nil n strt len m d goal : - IntroArg n (Mbox_cons strt len m d = Mbox_nil) (fun _ => goal). -Proof. intro eq; dependent destruction eq. Qed. - -Global Hint Extern 101 (Mbox_nil = Mbox_nil) => - simple apply IntroArg_eq_Mbox_nil_nil : refines. -Global Hint Extern 101 (Mbox_cons _ _ _ _ = Mbox_cons _ _ _ _) => - simple apply IntroArg_eq_Mbox_cons_cons : refines. -Global Hint Extern 101 (Mbox_nil = Mbox_cons _ _ _ _) => - simple apply IntroArg_eq_Mbox_nil_cons : refines. -Global Hint Extern 101 (Mbox_cons _ _ _ _ = Mbox_nil) => - simple apply IntroArg_eq_Mbox_nil_cons : refines. - -Lemma transMbox_Mbox_nil_r m : transMbox m Mbox_nil = m. -Proof. - induction m; eauto. - simpl; f_equal; eauto. -Qed. - -Lemma transMbox_assoc m1 m2 m3 : - transMbox (transMbox m1 m2) m3 = transMbox m1 (transMbox m2 m3). -Proof. - induction m1; eauto. - simpl; f_equal; eauto. -Qed. - -#[local] Hint Rewrite transMbox_Mbox_nil_r transMbox_assoc : refines. - - -(* Helper functions and lemmas *) - -Tactic Notation "rewrite_transMbox_Mbox_nil_r_dep" "in" ident(H1) := - revert H1; rewrite transMbox_Mbox_nil_r; intros H1. -Tactic Notation "rewrite_transMbox_Mbox_nil_r_dep" "in" ident(H1) ident(H2) := - revert H1 H2; rewrite transMbox_Mbox_nil_r; intros H1 H2. -Tactic Notation "rewrite_transMbox_Mbox_nil_r_dep" "in" ident(H1) ident(H2) ident(H3) := - revert H1 H2 H3; rewrite transMbox_Mbox_nil_r; intros H1 H2 H3. - -Definition mbox_chain_length := - Mbox_rect (fun _ => nat) O (fun _ _ _ rec _ => S rec). - -Lemma mbox_chain_length_transMbox m1 m2 : - mbox_chain_length (transMbox m1 m2) = mbox_chain_length m1 + mbox_chain_length m2. -Proof. induction m1; simpl; eauto. Qed. - - -(** * mbox_free_chain *) - -Lemma mbox_free_chain_spec_ref m - : spec_refines eqPreRel eqPostRel eq - (mbox_free_chain m) - (total_spec (fun _ => True) (fun _ r => r = intToBv 32 0) (1, m)). -Proof. - unfold mbox_free_chain, mbox_free_chain__bodies, mboxFreeSpec. - prove_refinement. - - wellfounded_decreasing_nat. - exact (a + mbox_chain_length m0). - - prepost_case 0 0. - + exact (m0 = m1 /\ a = 1). - + exact (r = r0). - prepost_case 1 0. - + exact (m0 = m1 /\ a = 0). - + exact (r = r0). - prepost_exclude_remaining. - - time "mbox_free_chain_spec_ref" prove_refinement_continue. -Time Qed. - - -(** * mbox_concat *) - -Definition mbox_concat_spec (x y : Mbox) : Mbox := - Mbox_rect _ Mbox_nil (fun strt len _ _ d => Mbox_cons strt len y d) x. - -Lemma mbox_concat_spec_ref m1 m2 - : spec_refines eqPreRel eqPostRel eq - (mbox_concat m1 m2) - (total_spec (fun _ => True) - (fun '(m1', m2') r => r = mbox_concat_spec m1' m2') - (m1, m2)). -Proof. - unfold mbox_concat, mbox_concat__bodies. - prove_refinement. - - wellfounded_none. - - prepost_case 0 0. - + exact (m = m3 /\ m0 = m4). - + exact (r_m = r_m0). - prepost_exclude_remaining. - - time "mbox_concat_spec_ref" prove_refinement_continue. -Time Qed. - -#[local] Hint Resolve mbox_concat_spec_ref : refines_proofs. - - -(** * mbox_concat_chains (two proofs) *) - -Lemma mbox_rect_identity m : - Mbox_rect _ Mbox_nil (fun strt len _ rec d => Mbox_cons strt len rec d) m = m. -Proof. induction m; simpl; try f_equal; eauto. Qed. - -Definition mbox_concat_chains_spec (m1 m2 : Mbox) : Mbox := - if mbox_chain_length m1 =? 0 then Mbox_nil else transMbox m1 m2. - -(* Proof 1: A version where the arguments to total_spec match the recursive - structure of the function: with one argument keeping track of the Mbox - blocks seen, and the other keeping track of the blocks yet to be seen. - Thus, the decreasing nat is just the length of this second Mbox. *) -Lemma mbox_concat_chains_spec_ref__dec_args m1 m2 - : spec_refines eqPreRel eqPostRel eq - (mbox_concat_chains m1 m2) - (total_spec (fun _ => True) - (fun '(_, m, m1', m2') r => r = mbox_concat_chains_spec (transMbox m m1') m2') - (1, Mbox_nil, m1, m2)). -Proof. - unfold mbox_concat_chains, mbox_concat_chains__bodies, mbox_concat_chains_spec. - prove_refinement. - - wellfounded_decreasing_nat. - exact (a + mbox_chain_length m0). - - prepost_case 0 0. - + exact (Mbox_nil = m3 /\ m = m4 /\ m0 = m5 /\ a = 1). - + exact (r_m = r_m0). - prepost_case 1 0. - + exact (m = m4 /\ Mbox_cons x x0 m3 a = m5 /\ m0 = m6 /\ a0 = 0). - + exact (r_m = r_m0). - prepost_exclude_remaining. - - time "mbox_concat_chains_spec_ref__dec_args" prove_refinement_continue. - + rewrite mbox_chain_length_transMbox, Nat.add_comm. - reflexivity. -Time Qed. - -(* Proof 2: A version where one argument to total_spec is designated as the - 'fuel' - in this case starting at mbox_chain_length m1 and decreasing - each call - but the actual Mbox argument (m1) stays constant. *) -Lemma mbox_concat_chains_spec_ref__fuel m1 m2 - : spec_refines eqPreRel eqPostRel eq - (mbox_concat_chains m1 m2) - (total_spec (fun _ => True) - (fun '(_, m1', m2') r => r = mbox_concat_chains_spec m1' m2') - (mbox_chain_length m1, m1, m2)). -Proof. - unfold mbox_concat_chains, mbox_concat_chains__bodies, mbox_concat_chains_spec. - prove_refinement. - - wellfounded_decreasing_nat. - exact a. - - prepost_case 0 0. - + exact (m = m3 /\ m0 = m4 /\ a = mbox_chain_length m). - + exact (r_m = r_m0). - prepost_case 1 0. - + exact (transMbox m (Mbox_cons x x0 m3 a) = m4 /\ m0 = m5 /\ - a0 = mbox_chain_length m3). - + exact (r_m = r_m0). - prepost_exclude_remaining. - - time "mbox_concat_chains_spec_ref__fuel" prove_refinement_continue. - + rewrite mbox_chain_length_transMbox, Nat.add_comm. - reflexivity. -Time Qed. - - -(** * mbox_detach *) - -Definition mbox_detach_spec : Mbox -> Mbox * Mbox := - Mbox_rect _ (Mbox_nil, Mbox_nil) - (fun strt len next _ d => (next, (Mbox_cons strt len Mbox_nil d))). - -Lemma mbox_detach_spec_ref m - : spec_refines eqPreRel eqPostRel eq - (mbox_detach m) - (total_spec (fun _ => True) - (fun m r => r = mbox_detach_spec m) m). -Proof. - unfold mbox_detach, mbox_detach__bodies. - prove_refinement. - - wellfounded_none. - - prepost_case 0 0. - + exact (m0 = m1). - + exact (r_m = r_m1 /\ r_m0 = r_m2). - prepost_exclude_remaining. - - time "mbox_detach_spec_ref" prove_refinement_continue. -Time Qed. - - -(** * mbox_drop *) - -Definition mbox_drop_spec : Mbox -> bitvector 64 -> Mbox := - Mbox_rect _ (fun _ => Mbox_nil) (fun strt len next rec d ix => - if bvule 64 len ix - then Mbox_cons (intToBv 64 0) (intToBv 64 0) (rec (bvSub 64 ix len)) d - else Mbox_cons (bvAdd 64 strt ix) (bvSub 64 len ix) next d). - -Lemma mbox_drop_spec_ref m x - : spec_refines eqPreRel eqPostRel eq - (mbox_drop m x) - (total_spec (fun _ => True) - (fun '(m, x) r => r = mbox_drop_spec m x) - (m, x)). -Proof. - unfold mbox_drop, mbox_drop__bodies, mbox_drop_spec. - prove_refinement. - - wellfounded_decreasing_nat. - exact (mbox_chain_length m0). - - prepost_case 0 0. - + exact (m0 = m1 /\ x0 = x1). - + exact (r_m = r_m0). - prepost_exclude_remaining. - - time "mbox_drop_spec_ref" prove_refinement_continue. - all: rewrite e_if; reflexivity. -Time Qed. - - -(** * mbox_len (two proofs) *) - -Definition mbox_len_spec : Mbox -> bitvector 64 := - Mbox__rec (fun _ => bitvector 64) (intToBv 64 0) - (fun strt len m rec d => bvAdd 64 rec len). - -Lemma mbox_len_spec_transMbox m1 m2 : - mbox_len_spec (transMbox m1 m2) = - bvAdd 64 (mbox_len_spec m1) (mbox_len_spec m2). -Proof. - induction m1 as [|strt len m1' IH d]; simpl. - - rewrite bvAdd_id_l. - reflexivity. - - rewrite IH. - rewrite 2 bvAdd_assoc. - rewrite (bvAdd_comm _ len). - reflexivity. -Qed. - -(* Proof 1: A version where the arguments to total_spec match the recursive - structure of the function: with one argument keeping track of the Mbox - blocks seen, and the other keeping track of the blocks yet to be seen. - Thus, the decreasing nat is just the length of this second Mbox. *) -Lemma mbox_len_spec_ref__dec_args m - : spec_refines eqPreRel eqPostRel eq - (mbox_len m) - (total_spec (fun _ => True) - (fun '(_, m1', m2') r => r = (transMbox m1' m2', mbox_len_spec (transMbox m1' m2'))) - (1, Mbox_nil, m)). -Proof. - unfold mbox_len, mbox_len__bodies. - prove_refinement. - - wellfounded_decreasing_nat. - exact (a + mbox_chain_length m1). - - prepost_case 0 0. - + exact (m0 = m2 /\ m1 = Mbox_nil /\ 1 = a). - + exact (r_m = r_m0 /\ r_x = r_x0). - - prepost_case 1 0. - + exact (m0 = m2 /\ m1 = m3 /\ 0 = a - /\ mbox_len_spec m0 = x). - + exact (r_m = r_m0 /\ r_x = r_x0). - prepost_exclude_remaining. - - time "mbox_len_spec_ref__dec_args" prove_refinement_continue. - + rewrite mbox_len_spec_transMbox. - simpl. - rewrite bvAdd_id_l. - reflexivity. -Time Qed. - -(* Proof 1: A version where one argument to total_spec is designated as the - 'fuel' - in this case starting at mbox_chain_length m and decreasing - each call - but the actual Mbox argument (m) stays constant. *) -Lemma mbox_len_spec_ref__fuel m - : spec_refines eqPreRel eqPostRel eq - (mbox_len m) - (total_spec (fun _ => True) - (fun '(_, _, m') r => r = (m', mbox_len_spec m')) - (1, mbox_chain_length m, m)). -Proof. - unfold mbox_len, mbox_len__bodies, Mbox_def. - prove_refinement. - - wellfounded_decreasing_nat. - exact (a + a0). - - prepost_case 0 0. - + exact (m0 = m1 /\ 1 = a /\ mbox_chain_length m0 = a0). - + exact (r_m = r_m0 /\ r_x = r_x0). - - prepost_case 1 0. - + exact (transMbox m0 m1 = m2 /\ 0 = a /\ mbox_chain_length m1 = a0 - /\ mbox_len_spec m0 = x). - + exact (r_m = r_m0 /\ r_x = r_x0). - prepost_exclude_remaining. - - time "mbox_len_spec_ref__fuel" prove_refinement_continue. - + rewrite mbox_len_spec_transMbox. - simpl. - rewrite bvAdd_id_l. - reflexivity. -Time Qed. - -#[local] Hint Resolve mbox_len_spec_ref__fuel : refines_proofs. - - -(** * mbox_copy *) - -Definition Mbox_cons_valid (strt len : bitvector 64) : Prop := - isBvule 64 strt (intToBv 64 128) /\ - isBvule 64 len (bvSub 64 (intToBv 64 128) strt). - -Lemma Mbox_cons_valid_proof_irrel - (strt len : bitvector 64) - (p1 p2 : Mbox_cons_valid strt len) : - p1 = p2. -Proof. - destruct p1 as [X1 Y1], p2 as [X2 Y2]. - f_equal; apply UIP_bool. -Qed. - -Definition mbox_copy_precond : Mbox -> Prop := - Mbox__rec (fun _ => Prop) - True - (fun strt len _ _ _ => Mbox_cons_valid strt len). - -Definition empty_mbox_d := genBVVec 64 (intToBv 64 128) (bitvector 8) (fun i _ => bvNat 8 0). - -(* Return d0, but with the bits in the range [strt, strt+len] replaced with the - corresponding bits from d1. *) -Definition conjSliceBVVec (strt len : bitvector 64) pf0 pf1 d0 d1 : BVVec 64 bv64_128 (bitvector 8) := - updSliceBVVec 64 (intToBv 64 128) _ d0 strt len - (sliceBVVec 64 (intToBv 64 128) _ strt len pf0 pf1 d1). - -Definition mbox_copy_spec - : forall (m : Mbox), - mbox_copy_precond m -> Mbox := - Mbox__rec (fun m' => mbox_copy_precond m' -> Mbox) - (fun _ => Mbox_nil) - (fun strt len m' _ d valid => - match valid with - | conj pf0 pf1 => - Mbox_cons strt len Mbox_nil - (conjSliceBVVec strt len pf0 pf1 empty_mbox_d d) - end). - -Lemma mbox_copy_nil (m : Mbox) (precond : mbox_copy_precond m) : - mbox_copy_spec m precond = Mbox_nil -> - m = Mbox_nil. -Proof. - destruct m, precond; simpl. - - reflexivity. - - discriminate. -Qed. - -Lemma mbox_copy_spec_ref m - : spec_refines eqPreRel eqPostRel eq - (mbox_copy m) - (total_spec (fun m' => mbox_copy_precond m') - (fun m' r => exists (precond : mbox_copy_precond m'), - r = (m', mbox_copy_spec m' precond)) - m). -Proof. - unfold mbox_copy, mbox_copy__bodies, mboxNewSpec. - (* Yikes! The below functions may or may not be defined depending on what - machine compiled mbox.bc *) - try unfold llvm__x2ememcpy__x2ep0i8__x2ep0i8__x2ei64. - try unfold llvm__x2eobjectsize__x2ei64__x2ep0i8, __memcpy_chk. - prove_refinement. - - wellfounded_none. - - prepost_case 0 0. - + exact (m0 = m1). - + exact (r_m = r_m1 /\ r_m0 = r_m2). - prepost_exclude_remaining. - - unfold mbox_copy_precond, mbox_copy_spec, Mbox_cons_valid, - empty_mbox_d, conjSliceBVVec in *. - time "mbox_copy_spec_ref" prove_refinement_continue. - + rewrite updSlice_slice_identity. - reflexivity. - + rewrite and_bool_eq_false, 2 isBvslt_def_opp in e_if. - destruct e_if. - * change (intToBv 64 9223372036854775808) with (bvsmin 64) in H. - destruct (not_isBvslt_bvsmin _ _ H). - * change (intToBv 64 9223372036854775807) with (bvsmax 64) in H. - destruct (not_isBvslt_bvsmax _ _ H). - (* All the remaining existential variables don't matter *) - Unshelve. all: eauto. -Time Qed. - -#[local] Hint Resolve mbox_copy_spec_ref : refines_proofs. - - -(** * mbox_copy_chain *) - -Definition mbox_copy_chain_precond : Mbox -> Prop := - Mbox_rect (fun _ => Prop) True (fun strt len _ rec _ => - Mbox_cons_valid strt len /\ rec). - -Definition mbox_copy_chain_spec - : forall (m : Mbox), - bitvector 64 -> mbox_copy_chain_precond m -> Mbox := - Mbox_rect (fun m => bitvector 64 -> mbox_copy_chain_precond m -> Mbox) - (fun _ _ => Mbox_nil) - (fun strt len m rec d src_len valid => - if bvEq 64 src_len (intToBv 64 0) - then Mbox_nil - else - match valid with - | conj (conj pf0 pf1) pfrec => - let d_copy := conjSliceBVVec strt len pf0 pf1 empty_mbox_d d in - let head := Mbox_cons strt len Mbox_nil d_copy in - if bvule 64 src_len len - then Mbox_cons strt src_len Mbox_nil d_copy - else Mbox_cons strt len (rec (bvSub 64 src_len len) pfrec) d_copy - end). - -Lemma mbox_copy_chain_precond_to_copy_precond : - forall (m : Mbox), - mbox_copy_chain_precond m -> mbox_copy_precond m. -Proof. - intros m copy_chain_precond. destruct m. - - assumption. - - destruct copy_chain_precond. assumption. -Qed. - -Lemma mbox_copy_chain_len_0 - (m : Mbox) - (precond : mbox_copy_chain_precond m) : - mbox_copy_chain_spec m (intToBv 64 0) precond = Mbox_nil. -Proof. - destruct m; reflexivity. -Qed. - -Lemma mbox_copy_chain_precond_proof_irrel - (m : Mbox) - (p1 p2 : mbox_copy_chain_precond m) : - p1 = p2. -Proof. - induction m. - - destruct p1, p2. reflexivity. - - destruct p1 as [X1 Y1], p2 as [X2 Y2]. - f_equal. - + apply Mbox_cons_valid_proof_irrel. - + apply IHm. -Qed. - -Lemma mbox_copy_chain_spec_ref m src_len - : spec_refines eqPreRel eqPostRel eq - (mbox_copy_chain m src_len) - (total_spec (fun '(m', _) => mbox_copy_chain_precond m') - (fun '(m', src_len') r => exists (precond : mbox_copy_chain_precond m'), - r = (m', mbox_copy_chain_spec m' src_len' precond)) - (m, src_len)). -Proof. - unfold mbox_copy_chain, mbox_copy_chain__bodies. - prove_refinement. - - wellfounded_decreasing_nat. - exact (mbox_chain_length m0). - - prepost_case 0 0. - + exact (m0 = m1 /\ x = x0). - + exact (r_m = r_m1 /\ r_m0 = r_m2). - prepost_exclude_remaining. - - unfold mbox_copy_chain_precond, mbox_copy_chain_spec, Mbox_cons_valid. - time "mbox_copy_chain_spec_ref" prove_refinement_continue. - + rewrite bvEq_eq in e_if. - replace x - with (intToBv 64 0) - by bvEq_eq. - rewrite mbox_copy_chain_len_0. - reflexivity. - + apply (mbox_copy_chain_precond_to_copy_precond _ e_assume). - + rewrite_transMbox_Mbox_nil_r_dep in a e_destruct. - apply mbox_copy_nil in e_destruct. - subst m0. - reflexivity. - + rewrite transMbox_Mbox_nil_r in e_destruct0. - symmetry. assumption. - + rewrite transMbox_Mbox_nil_r in e_destruct0. - subst m0. - reflexivity. - + rewrite transMbox_Mbox_nil_r in e_destruct0. - symmetry. assumption. - + rewrite_transMbox_Mbox_nil_r_dep in a e_destruct e_destruct0. - instantiate (1 := e_assume). - subst m0. - destruct a as [pf0 pf1]. - destruct e_assume as [[X Y] Z]. - simpl in e_destruct. - injection e_destruct as h1 h2 h3 h4. - subst strt len m1 d. - simpl. - rewrite e_if. - rewrite e_if0. - replace pf0 with X by (apply UIP_bool). - replace pf1 with Y by (apply UIP_bool). - reflexivity. - + rewrite transMbox_Mbox_nil_r in e_destruct0. - subst m0. - destruct e_assume as [XY Z]. - apply Z. - + rewrite transMbox_Mbox_nil_r in e_destruct0. - subst m0. - reflexivity. - + rewrite transMbox_Mbox_nil_r in e_destruct0. - subst m0. - destruct e_assume as [XY Z]. - apply Z. - + rewrite transMbox_Mbox_nil_r in e_destruct0. - subst m0. - destruct H as [precond e]. - injection e as e1 e2. - rewrite transMbox_Mbox_nil_r in e1. - subst r_m1. - reflexivity. - + rewrite_transMbox_Mbox_nil_r_dep in a e_destruct. - rewrite transMbox_Mbox_nil_r in *. - instantiate (1 := e_assume). - subst m0. - destruct a as [pf0 pf1]. - destruct e_assume as [[X Y] Z]. - simpl in e_destruct. - injection e_destruct as h1 h2 h3 h4. - subst strt len m1 d. - simpl. - rewrite e_if. - rewrite e_if0. - destruct H as [precond e]. - injection e as e1 e2. - replace Z - with precond - by (apply mbox_copy_chain_precond_proof_irrel). - rewrite <- e2. - replace pf0 with X by (apply UIP_bool). - replace pf1 with Y by (apply UIP_bool). - reflexivity. - + rewrite transMbox_Mbox_nil_r in *. - subst m0. - destruct H as [precond e]. - injection e as e1 e2. - subst r_m1. - reflexivity. - + rewrite_transMbox_Mbox_nil_r_dep in a e_destruct. - rewrite transMbox_Mbox_nil_r in *. - instantiate (1 := e_assume). - subst m0. - destruct a as [pf0 pf1]. - destruct e_assume as [[X Y] Z]. - simpl in e_destruct. - injection e_destruct as h1 h2 h3 h4. - subst strt len m1 d. - simpl. - rewrite e_if. - rewrite e_if0. - destruct H as [precond e]. - injection e as e1 e2. - replace Z - with precond - by (apply mbox_copy_chain_precond_proof_irrel). - rewrite <- e2. - replace pf0 with X by (apply UIP_bool). - replace pf1 with Y by (apply UIP_bool). - reflexivity. - (* All the remaining existential variables don't matter *) - Unshelve. all: eauto. -Qed. - -#[local] Hint Resolve mbox_copy_chain_spec_ref : refines_proofs. - - -(** * mbox_split_at *) - -Definition mbox_split_at_precond : Mbox -> bitvector 64 -> Prop := - Mbox_rect (fun _ => bitvector 64 -> Prop) - (fun _ => True) - (fun _ len _ rec _ ix => - Mbox_cons_valid ix (bvSub 64 len ix) /\ rec (bvSub 64 ix len)). - -Lemma mbox_split_at_precond_proof_irrel : - forall (m : Mbox) - (ix : bitvector 64) - (p1 p2 : mbox_split_at_precond m ix), - p1 = p2. -Proof. - intros m. induction m; intros ix p1 p2. - - destruct p1, p2. reflexivity. - - destruct p1 as [X1 Y1], p2 as [X2 Y2]. - f_equal. - + apply Mbox_cons_valid_proof_irrel. - + apply IHm. -Qed. - -Definition mbox_split_at_spec : - forall (m : Mbox) (ix : bitvector 64), - mbox_split_at_precond m ix -> Mbox * Mbox := - Mbox_rect (fun m => forall (ix : bitvector 64), mbox_split_at_precond m ix -> Mbox * Mbox) - (fun _ _ => (Mbox_nil, Mbox_nil)) - (fun strt len m rec d ix precond => - if bvEq 64 ix (intToBv 64 0) - then (Mbox_nil, Mbox_cons strt len m d) - else - if bvEq 64 ix len - then (Mbox_cons strt len Mbox_nil d, m) - else - match precond with - | conj (conj pf0 pf1) precond_rec => - if bvult 64 len ix - then let res := rec (bvSub 64 ix len) precond_rec in - (Mbox_cons strt len (fst res) d, snd res) - else (Mbox_cons strt ix Mbox_nil d, - Mbox_cons (bvNat 64 0) (bvSub 64 len ix) m - (updSliceBVVec 64 bv64_128 _ empty_mbox_d (intToBv 64 0) (bvSub 64 len ix) - (sliceBVVec 64 bv64_128 _ ix (bvSub 64 len ix) pf0 pf1 d))) - end). - -Lemma mbox_split_at_spec_ref m ix - : spec_refines eqPreRel eqPostRel eq - (mbox_split_at m ix) - (total_spec (fun '(m, ix) => mbox_split_at_precond m ix) - (fun '(m, ix) r => exists (precond : mbox_split_at_precond m ix), - r = mbox_split_at_spec m ix precond) - (m, ix)). -Proof. - unfold mbox_split_at, mbox_split_at__bodies, mboxNewSpec. - (* Yikes! The below functions may or may not be defined depending on what - machine compiled mbox.bc *) - try unfold llvm__x2ememcpy__x2ep0i8__x2ep0i8__x2ei64. - try unfold llvm__x2eobjectsize__x2ei64__x2ep0i8, __memcpy_chk. - prove_refinement. - - wellfounded_decreasing_nat. - exact (mbox_chain_length m0). - - prepost_case 0 0. - + exact (m0 = m1 /\ x = x0). - + exact (r_m = r_m1 /\ r_m0 = r_m2). - prepost_exclude_remaining. - - unfold mbox_split_at_precond, mbox_split_at_spec, Mbox_cons_valid, - empty_mbox_d, conjSliceBVVec in *. - time "mbox_split_at_spec_ref" prove_refinement_continue. - + simpl. - rewrite e_if. - reflexivity. - + simpl. - rewrite e_if. - rewrite e_if0. - reflexivity. - + simpl. - rewrite e_if. - rewrite e_if0. - unshelve instantiate (1 := _). - { split; assumption. } - destruct e_assume as [X Y]. - rewrite e_if1. - reflexivity. - + rewrite_transMbox_Mbox_nil_r_dep in r_m1 r_m2 H. - destruct H as [precond e]. - replace e_assume0 - with precond - by (apply mbox_split_at_precond_proof_irrel). - apply (f_equal fst) in e. - simpl in e. - subst r_m1. - reflexivity. - + rewrite_transMbox_Mbox_nil_r_dep in r_m1 r_m2 H. - destruct H as [precond e]. - replace e_assume0 - with precond - by (apply mbox_split_at_precond_proof_irrel). - apply (f_equal snd) in e. - simpl in e. - assumption. - + rewrite bvSub_n_zero in H. - destruct e_assume. - specialize - (isBvule_bvSub_remove - _ (bvSub 64 len x) - (intToBv 64 128) - x i i0) - as Hcontra. - contradiction. - + destruct e_assume as [H0contra H3]. - contradiction. - + destruct e_assume as [H2contra H4]. - contradiction. - + rewrite e_if. - rewrite e_if0. - rewrite e_if1. - unshelve instantiate (1 := _). - { split; assumption. } - instantiate (2 := a0). - instantiate (1 := a1). - destruct e_assume as [X Y]. - replace a0 with X by (apply UIP_bool). - replace a1 with Y by (apply UIP_bool). - reflexivity. - + rewrite updSlice_slice_identity. - split; reflexivity. - + rewrite and_bool_eq_false, 2 isBvslt_def_opp in e_if2. - destruct e_if2. - * change (intToBv 64 9223372036854775808) with (bvsmin 64) in H. - destruct (not_isBvslt_bvsmin _ _ H). - * change (intToBv 64 9223372036854775807) with (bvsmax 64) in H. - destruct (not_isBvslt_bvsmax _ _ H). - (* All the remaining existential variables don't matter *) - Unshelve. all: (try destruct e_assume; simpl; eauto). -Qed. - -#[local] Hint Resolve mbox_split_at_spec_ref : refines_proofs. - - -(** * mbox_detach_from_end *) - -Definition mbox_detach_from_end_precond - (m : Mbox) - (length_from_end : bitvector 64) - : Prop := - mbox_split_at_precond m (bvSub 64 (mbox_len_spec m) length_from_end). - -Definition mbox_detach_from_end_spec - (m : Mbox) - (length_from_end : bitvector 64) - (precond : mbox_detach_from_end_precond m length_from_end) - : Mbox * Mbox := - mbox_split_at_spec m (bvSub 64 (mbox_len_spec m) length_from_end) precond. - -Lemma mbox_detach_from_end_spec_ref m length_from_end - : spec_refines eqPreRel eqPostRel eq - (mbox_detach_from_end m length_from_end) - (total_spec (fun '(m', length_from_end') => - mbox_detach_from_end_precond m' length_from_end') - (fun '(m', length_from_end') r => - exists (precond : mbox_detach_from_end_precond m' length_from_end'), - r = mbox_detach_from_end_spec m' length_from_end' precond) - (m, length_from_end)). -Proof. - unfold mbox_detach_from_end, mbox_detach_from_end__bodies. - prove_refinement. - - wellfounded_none. - - prepost_case 0 0. - + exact (m0 = m1 /\ x = x0). - + exact (r_m = r_m1 /\ r_m0 = r_m2). - prepost_exclude_remaining. - - unfold mbox_detach_from_end_precond, mbox_detach_from_end_spec. - - time "mbox_detach_from_end_spec_ref" prove_refinement_continue. - Ltac busywork a e_assert := simpl in *; - repeat rewrite_transMbox_Mbox_nil_r_dep in a e_assert. - + unshelve instantiate (1 := _). - { busywork a e_assert. apply a. } - busywork a e_assert. - rewrite -> e_assert. - reflexivity. - + unshelve instantiate (1 := _). - { busywork a e_assert. apply a. } - busywork a e_assert. - rewrite -> e_assert. - reflexivity. -Qed. - - -(** * mbox_randomize *) - -Lemma atBVVec_upd_out_of_range w len A a v i j pf : - bvEq w i j = false -> - atBVVec w len A v i pf = - atBVVec w len A (updBVVec w len A v j a) i pf. -Proof. - intros. unfold updBVVec. - rewrite at_gen_BVVec. - rewrite H. reflexivity. -Qed. - -(* True iff both inputs are Mbox_null, or both inputs are - Mbox_cons where the values of strt, len, and m are equal, - and the values of d are equal only outside of the range - defined by strt and len. *) -Definition mbox_eq_up_to_head_data (m1 m2 : Mbox) : Prop := - Mbox__rec (fun _ => Prop) - (Mbox__rec (fun _ => Prop) True (fun _ _ _ _ _ => False) m2) - (fun strt1 len1 m1 _ d1 => - Mbox__rec (fun _ => Prop) False (fun strt2 len2 m2 _ d2 => - strt1 = strt2 /\ len1 = len2 /\ m1 = m2 /\ - forall i (pf : isBvult 64 i bv64_128), - isBvslt 64 i strt1 \/ isBvsle 64 len1 i -> - atBVVec _ _ _ d1 i pf = atBVVec _ _ _ d2 i pf) m2) m1. - -Lemma mbox_eq_up_to_head_data_trans m1 m2 m3 : - mbox_eq_up_to_head_data m1 m2 -> - mbox_eq_up_to_head_data m2 m3 -> - mbox_eq_up_to_head_data m1 m3. -Proof. - destruct m1 as [|strt1 len1 m1 d1], - m2 as [|strt2 len2 m2 d2], - m3 as [|strt3 len3 m3 d3]; simpl. - all: intros; contradiction || eauto. - destruct H as [? [? []]], H0 as [? [? []]]; repeat split; eauto. - - transitivity strt2; eauto. - - transitivity len2; eauto. - - transitivity m2; eauto. - - intros. transitivity (atBVVec 64 bv64_128 (bitvector 8) d2 i pf). - + apply H3. eauto. - + apply H6. destruct H, H1. eauto. -Qed. - -Definition mbox_head_len_sub_strt : Mbox -> nat := - Mbox_rect (fun _ => nat) 0 (fun strt len _ _ _ => - bvToNat 64 (bvSub 64 len strt)). - -Definition mbox_randomize_precond : Mbox -> Prop := - Mbox_rect (fun _ => Prop) True (fun strt len _ _ _ => - (* 0 <= strt <= len < 128 *) - isBvsle 64 (intToBv 64 0) strt /\ isBvsle 64 strt len /\ - isBvslt 64 len (intToBv 64 128)). - -Definition SUCCESS := intToBv 32 0. -Definition MBOX_NULL_ERROR := intToBv 32 23. - -Definition mbox_randomize_ret m := - Mbox__rec (fun _ => bitvector 32) MBOX_NULL_ERROR - (fun _ _ _ _ _ => SUCCESS) m. - -Definition mbox_randomize_invar (strt len i : bitvector 64) : Prop := - (* strt <= i <= len *) - isBvsle 64 strt i /\ isBvsle 64 i len. - -Lemma mbox_randomize_spec_ref m - : spec_refines eqPreRel eqPostRel eq - (mbox_randomize m) - (total_spec (fun '(_, m') => mbox_randomize_precond m') - (fun '(_, m') '(r_m, r_x) => mbox_eq_up_to_head_data m' r_m - /\ r_x = mbox_randomize_ret m') - (1 + mbox_head_len_sub_strt m, m)). -Proof. - unfold mbox_randomize, mbox_randomize__bodies, randSpec. - prove_refinement. - - wellfounded_decreasing_nat. - exact a. - - prepost_case 0 0. - + exact (m0 = m1 /\ a = 1 + mbox_head_len_sub_strt m0). - + exact (r_m = r_m0 /\ r_x = r_x0). - prepost_case 1 0. - + exact (Mbox_cons x x0 m0 a = m1 /\ - a0 = bvToNat 64 (bvSub 64 x0 x1) /\ - mbox_randomize_invar x x0 x1). - + exact (r_m = r_m0 /\ r_x = r_x0). - prepost_exclude_remaining. - - unfold mbox_head_len_sub_strt, mbox_randomize_precond, - mbox_randomize_invar in *. - time "mbox_randomize_spec_ref" prove_refinement_continue. - (* mbox_eq_up_to_head_data goals *) - 1-3: rewrite transMbox_Mbox_nil_r in H. - 1-3: destruct H. - 1-3: assumption. - (* Showing the error case of the array bounds check is impossible by virtue *) - (* of our loop invariant *) - 1-2: enough (isBvult 64 call3 (intToBv 64 128)) by contradiction. - 1-2: destruct e_assume as [?e_assume [?e_assume ?e_assume]]. - 1-2: rewrite isBvult_def in e_if; rewrite e_if. - 1-2: eapply isBvult_to_isBvslt_pos; [| reflexivity | assumption ]. - 1-2: rewrite e_assume, e_assume0; reflexivity. - (* Showing the loop invariant holds inductively *) - 1-9: destruct e_assume as [?e_assume [?e_assume ?e_assume]]; try assumption. - + apply isBvult_impl_lt_bvToNat, isBvult_bvSub_bvAdd_1; eauto. - + rewrite H. apply isBvsle_suc_r. - rewrite H0, e_assume1. - reflexivity. - + apply isBvslt_to_isBvsle_suc. - apply isBvult_to_isBvslt_pos; eauto. - * rewrite e_assume; eauto. - * rewrite <- e_assume0; eauto. - (* more step mbox_eq_up_to_head_data goals *) - 1-3: rewrite transMbox_Mbox_nil_r in H2. - 1-3: destruct H2. - 1-2: destruct e_assume as [?e_assume [?e_assume ?e_assume]]. - 1-2: rewrite H in e_assume. - 1-2: rewrite isBvult_def in e_if. - 1-2: apply isBvult_to_isBvslt_pos in e_if; - [| assumption | rewrite <- H0; assumption ]. - 1-2: eapply mbox_eq_up_to_head_data_trans; eauto. - 1-2: repeat split; eauto; intros. - 1-2: apply atBVVec_upd_out_of_range. - 1-2: destruct H4 as [?H | ?H]; [| rewrite bvEq_sym ]. - 1-4: apply isBvslt_to_bvEq_false. - + rewrite <- H; assumption. - + rewrite H4 in e_if; assumption. - + rewrite <- H; assumption. - + rewrite H4 in e_if; assumption. - + rewrite H3. simpl. reflexivity. - (* Showing the error case of the overflow check is impossible by virtue of *) - (* our loop invariant *) - 1-2: destruct e_assume as [?e_assume [?e_assume ?e_assume]]. - 1-2: rewrite H in e_assume; rewrite <- H0 in e_assume1. - 1-2: rewrite and_bool_eq_false in e_if0. - 1-2: do 2 rewrite isBvslt_def_opp in e_if0. - 1-2: destruct e_if0 as [?e_if | ?e_if]; - [ rewrite <- e_assume in e_if0 | rewrite e_assume1 in e_if0 ]. - 1-4: vm_compute in e_if0; discriminate e_if0. - (* final mbox_eq_up_to_head_data goals *) - + simpl. repeat split. - + simpl. repeat split. - (* All the remaining existential variables don't matter *) - Unshelve. all: eauto. -Qed. diff --git a/heapster/examples/memcpy.bc b/heapster/examples/memcpy.bc deleted file mode 100644 index 20fe1b1373..0000000000 Binary files a/heapster/examples/memcpy.bc and /dev/null differ diff --git a/heapster/examples/memcpy.c b/heapster/examples/memcpy.c deleted file mode 100644 index f39ccb1a73..0000000000 --- a/heapster/examples/memcpy.c +++ /dev/null @@ -1,21 +0,0 @@ -#include -#include -#include - -int64_t copy_int (int64_t x) { - int64_t y; - memcpy (&y, &x, sizeof (int64_t)); - return y; -} - -int64_t copy_ptr_contents (int64_t *x) { - int64_t y; - memcpy (&y, x, sizeof (int64_t)); - return y; -} - -void copy_ptr (int64_t *x) { - int64_t *y; - memcpy (&y, &x, sizeof (int64_t*)); - *y = 5; -} diff --git a/heapster/examples/memcpy.saw b/heapster/examples/memcpy.saw deleted file mode 100644 index dc37382064..0000000000 --- a/heapster/examples/memcpy.saw +++ /dev/null @@ -1,25 +0,0 @@ -enable_experimental; -env <- heapster_init_env_from_file "memcpy.sawcore" "memcpy.bc"; - -// Integer types -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, \ - \ b:llvmblock 64, len:bv 64). \ - \ arg0:[l1]memblock(W,0,len,emptysh), arg1:[l2]memblock(rw,0,len,eqsh(len,b)), \ - \ arg2:eq(llvmword(len)) -o \ - \ arg0:[l1]memblock(W,0,len,eqsh(len,b)), arg1:[l2]memblock(rw,0,len,eqsh(len,b))" - "\\ (len:Vec 64 Bool) -> retS VoidEv #() ()"; - - -heapster_typecheck_fun env "copy_int" - "().arg0:int64<> -o ret:int64<>"; - -heapster_typecheck_fun env "copy_ptr_contents" - "().arg0:ptr((R,0) |-> int64<>) -o ret:int64<>"; - -heapster_typecheck_fun env "copy_ptr" - "().arg0:ptr((W,0) |-> int64<>) -o arg0:ptr((W,0) |-> int64<>)"; - -heapster_export_coq env "memcpy_gen.v"; diff --git a/heapster/examples/memcpy.sawcore b/heapster/examples/memcpy.sawcore deleted file mode 100644 index 0e8b8ce9a0..0000000000 --- a/heapster/examples/memcpy.sawcore +++ /dev/null @@ -1,9 +0,0 @@ - -module memcpy where - -import SpecM; - -mallocSpec : (sz:Vec 64 Bool) -> SpecM VoidEv (BVVec 64 sz #()); -mallocSpec sz = - retS VoidEv (BVVec 64 sz #()) - (genBVVec 64 sz #() (\ (i:Vec 64 Bool) (_:is_bvult 64 i sz) -> ())); diff --git a/heapster/examples/memcpy_proofs.v b/heapster/examples/memcpy_proofs.v deleted file mode 100644 index b408371e89..0000000000 --- a/heapster/examples/memcpy_proofs.v +++ /dev/null @@ -1,33 +0,0 @@ -From Coq Require Import Lists.List. -From Coq Require Import String. -From Coq Require Import Vectors.Vector. -From CryptolToCoq Require Import SAWCoreScaffolding. -From CryptolToCoq Require Import SAWCoreVectorsAsCoqVectors. -From CryptolToCoq Require Import SAWCoreBitvectors. - -From CryptolToCoq Require Import SAWCorePrelude. -From CryptolToCoq Require Import CompMExtra. - -Require Import Examples.memcpy_gen. -Import memcpy. - -Import SAWCorePrelude. - - -Lemma no_errors_copy_int : refinesFun copy_int (fun _ => noErrorsSpec). -Proof. - unfold copy_int, copy_int__tuple_fun, noErrorsSpec, llvm__x2ememcpy__x2ep0i8__x2ep0i8__x2ei64. - prove_refinement. -Qed. - -Lemma no_errors_copy_ptr_contents : refinesFun copy_ptr_contents (fun _ => noErrorsSpec). -Proof. - unfold copy_ptr_contents, copy_ptr_contents__tuple_fun, noErrorsSpec, llvm__x2ememcpy__x2ep0i8__x2ep0i8__x2ei64. - prove_refinement. -Qed. - -Lemma no_errors_copy_ptr : refinesFun copy_ptr (fun _ => noErrorsSpec). -Proof. - unfold copy_ptr, copy_ptr__tuple_fun, noErrorsSpec, llvm__x2ememcpy__x2ep0i8__x2ep0i8__x2ei64. - prove_refinement. -Qed. diff --git a/heapster/examples/poly_linked_list.c b/heapster/examples/poly_linked_list.c deleted file mode 100644 index 97248cd96d..0000000000 --- a/heapster/examples/poly_linked_list.c +++ /dev/null @@ -1,19 +0,0 @@ -#include -#include - -/* A "polymorphic" linked list uses elements that can be cast to pointers or integers */ -typedef struct list_t { - uintptr_t data; - struct list_t *next; -} list_t; - -/* Test if some element of a list satisfies a given predicate */ -int64_t any (int64_t (*pred) (uintptr_t), list_t *l) { - if (l == NULL) { - return 0; - } else if (pred (l->data)) { - return 1; - } else { - return any (pred, l->next); - } -} diff --git a/heapster/examples/poly_linked_list.saw b/heapster/examples/poly_linked_list.saw deleted file mode 100644 index a5cfe1a7c3..0000000000 --- a/heapster/examples/poly_linked_list.saw +++ /dev/null @@ -1,10 +0,0 @@ -// This script expects to be run from the directory it is in -enable_experimental; -env <- heapster_init_env "poly_linked_list" "poly_linked_list.bc"; - -heapster_define_recursive_perm env "list64" "l:lifetime, rw:rwmodality" "llvmptr 64" ["eq(llvmword(0))","[l]ptr((rw,0) |-> exists x:(bv 64).eq(llvmword(x))) * ptr((rw,8) |-> list64)"] "W64List" "foldW64List" "unfoldW64List"; - -// this doesn't work... -heapster_typecheck_fun env "any" "(X:perm(llvmptr 64)).arg0:llvmfunptr{1,64}(().arg0:X -o arg0:X, ret:exists x:(bv 64).eq(llvmword(x))), arg1:list64 -o arg0:true, arg1:true, ret:exists x:(bv 64).eq(llvmword(x))"; - -heapster_export_coq env "poly_linked_list.v"; diff --git a/heapster/examples/ptr.c b/heapster/examples/ptr.c deleted file mode 100644 index 6e1c4a43d1..0000000000 --- a/heapster/examples/ptr.c +++ /dev/null @@ -1,6 +0,0 @@ -#include -#include - -uint64_t is_null(void *x) { - if (x == NULL) { return 1; } else { return 0; } -} diff --git a/heapster/examples/rust_data.bc b/heapster/examples/rust_data.bc deleted file mode 100644 index 0469401e80..0000000000 Binary files a/heapster/examples/rust_data.bc and /dev/null differ diff --git a/heapster/examples/rust_data.rs b/heapster/examples/rust_data.rs deleted file mode 100644 index aa6e6ec9b7..0000000000 --- a/heapster/examples/rust_data.rs +++ /dev/null @@ -1,738 +0,0 @@ -use std::collections::{HashMap}; -use std::fmt; -use std::convert::{Infallible}; - -/* -/* A function that immediately panics */ -pub fn get_out () -> ! { - panic!("Uh oh!") -} -*/ - -/* The logical and operation as a function on bool */ -pub fn bool_and (x:bool, y:bool) -> bool { - x & y -} - -/* The logical and operation as a function on bools in a pair */ -pub fn bool_and_pair (xy:(bool,bool)) -> bool { - xy.0 & xy.1 -} - -/* Read two integers from references and return their sum */ -pub fn ref_sum <'a,'b> (x:&'a u64, y:&'a u64) -> u64 { - return *x + *y; -} - -/* Double the integer pointed to by a reference by duplicating the reference and - * passing it to ref_sum */ -pub fn double_dup_ref <'a> (x:&'a u64) -> u64 { - return ref_sum (x, x); -} - -#[repr(C)] -pub struct BoolStruct { fst_bool:bool,snd_bool:bool } - -/* The logical and operation as a function on bools in a struct */ -pub fn bool_and_struct (xy:BoolStruct) -> bool { - xy.fst_bool & xy.snd_bool -} - -/* A struct containing 2 32-bit values, to test how structs that fit into 1 - * 64-bit value are represented */ -#[repr(C)] -pub struct TwoValues(u32,u32); - -pub fn mk_two_values (x1:u32,x2:u32) -> TwoValues { - TwoValues(x1,x2) -} - -pub extern fn mk_two_values_extern (x1:u32,x2:u32) -> TwoValues { - TwoValues(x1,x2) -} - -pub fn mk_two_values_opt (x1:u32,x2:u32) -> Option { - Some(TwoValues(x1,x2)) -} - -pub fn two_values_proj1 (x:TwoValues) -> u32 { - match x { - TwoValues(x1,_) => x1 - } -} - -pub fn two_values_proj1_ref <'a> (x:&'a mut TwoValues) -> &'a mut u32 { - &mut x.1 -} - -pub extern fn two_values_proj1_extern (x:TwoValues) -> u32 { - match x { - TwoValues(x1,_) => x1 - } -} - -/* A struct containing 3 32-bit values, to test how structs that fit but don't - * fill up 2 64-bit values are represented */ -#[repr(C)] -pub struct ThreeValues(u32,u32,u32); - -pub fn mk_three_values (x1:u32,x2:u32,x3:u32) -> ThreeValues { - ThreeValues(x1,x2,x3) -} - -pub extern fn mk_three_values_extern (x1:u32,x2:u32,x3:u32) -> ThreeValues { - ThreeValues(x1,x2,x3) -} - -pub fn three_values_proj1 (x:ThreeValues) -> u32 { - match x { - ThreeValues(x1,_,_) => x1 - } -} - -pub extern fn three_values_proj1_extern (x:ThreeValues) -> u32 { - match x { - ThreeValues(x1,_,_) => x1 - } -} - - -/* A struct containing 4 32-bit values, to test how structs that fit into 2 - * 64-bit values are represented */ -#[repr(C)] -pub struct FourValues(u32,u32,u32,u32); - -pub fn mk_four_values (x1:u32,x2:u32,x3:u32,x4:u32) -> FourValues { - FourValues(x1,x2,x3,x4) -} - -pub extern fn mk_four_values_extern (x1:u32,x2:u32,x3:u32,x4:u32) -> FourValues { - FourValues(x1,x2,x3,x4) -} - -pub fn four_values_proj1 (x:FourValues) -> u32 { - match x { - FourValues(x1,_,_,_) => x1 - } -} - -pub extern fn four_values_proj1_extern (x:FourValues) -> u32 { - match x { - FourValues(x1,_,_,_) => x1 - } -} - - -/* A struct containing 5 32-bit values, to test how structs that do not quite - * fit into 2 64-bit values are represented */ -#[repr(C)] -pub struct FiveValues(u32,u32,u32,u32,u32); - -pub fn mk_five_values (x1:u32,x2:u32,x3:u32,x4:u32,x5:u32) -> FiveValues { - FiveValues(x1,x2,x3,x4,x5) -} - -pub extern fn mk_five_values_extern (x1:u32,x2:u32,x3:u32,x4:u32,x5:u32) - -> FiveValues { - FiveValues(x1,x2,x3,x4,x5) -} - -pub fn mk_five_values_opt (x1:u32,x2:u32,x3:u32,x4:u32,x5:u32) -> Option { - Some(FiveValues(x1,x2,x3,x4,x5)) -} - -pub fn proj_five_values (i:u64, fvs:FiveValues) -> u32 { - match fvs { - FiveValues(x0,x1,x2,x3,x4) => - match i { - 0 => x0, - 1 => x1, - 2 => x2, - 3 => x3, - _ => x4 - } - } -} - -pub fn mk_proj0_five_values (x1:u32,x2:u32,x3:u32,x4:u32,x5:u32) -> u32 { - proj_five_values (0, mk_five_values (x1,x2,x3,x4,x5)) -} - - -/* Test if a Result is Ok or Err */ -pub fn test_result <'a> (r:&'a Result) -> bool { - match r { - Ok(_) => true, - Err(_) => false - } -} - -/* Make a Result whose other branch is uninhabited */ -pub fn mk_result_infallible (x:u64) -> Result { - Err(x) -} - -/* Extract a value from a Result whose other branch is uninhabited */ -pub fn extract_from_result_infallible <'a> (r:&'a Result) -> u64 { - match r { - Ok(i) => match *i { }, - Err(x) => *x, - } -} - -/* Sum of two types; yes, this is like Result, but defined locally so we can - * make an impl block on it */ -#[derive(Clone, Debug, PartialEq)] -#[repr(C,u64)] -pub enum Sum { - Left (X), - Right (Y) -} - - -/*** - *** Some tests for how Rust compiles functions on enums - ***/ - -impl Sum { - pub fn test_sum_impl (&self) -> bool { - match self { - Sum::Left(_) => true, - Sum::Right(_) => false - } - } - - pub fn mk_u64_sum_left (x:u64) -> Self { - Sum::Left (x) - } - - pub extern fn mk_u64_sum_left_extern (x:u64) -> Self { - Sum::Left (x) - } - - pub fn mk_u64_sum_left_add3 (x:&u64, y:u64, z:u64) -> Self { - Sum::Left (*x+y+z) - } -} - -pub fn mk_sum_left_asym (x:u32) -> Sum { - Sum::Left (x) -} - -pub fn mk_string_sum_left (x:&str) -> Sum { - Sum::Left (x.to_string()) -} - -pub fn mk_sum_sum_left (x:Sum) -> Sum,u64> { - Sum::Left (x) -} - -pub extern fn mk_sum_sum_left_extern (x:Sum) -> Sum,u64> { - Sum::Left (x) -} - -pub fn mk_sum_sum_left_asym (x:Sum) -> Sum,u64> { - Sum::Left (x) -} - -pub extern fn mk_sum_sum_left_asym_extern (x:Sum) -> Sum,u64> { - Sum::Left (x) -} - - -pub fn elim_sum_u64_u64 (x:Sum) -> u64 { - match x { - Sum::Left (x) => x, - Sum::Right (x) => x, - } -} - - -/* A struct containing a string */ -#[repr(C)] -pub struct StrStruct(String); - -impl StrStruct { - /* Constructor for StrStruct */ - pub fn new(name: &str) -> StrStruct { - StrStruct(name.to_string()) - } - - // &str not considered FFI safe, so Rust doesn't like extern here - /* - pub extern fn new_extern(name: &str) -> StrStruct { - StrStruct(name.to_string()) - } - */ - - /* Accessor for StrStruct */ - pub fn name(&self) -> String { - match self { - StrStruct(s) => s.to_string(), - } - } - - // String not considered FFI safe, so Rust doesn't like extern here - /* - pub extern fn name_extern(&self) -> String { - match self { - StrStruct(s) => s.to_string(), - } - } - */ - - /* Version of name that maps to &str */ - pub fn name_str (&self) -> &str { - match self { - StrStruct(s) => s.as_str(), - } - } - - // &str not considered FFI safe, so Rust doesn't like extern here - /* - pub extern fn name_str_extern (&self) -> &str { - match self { - StrStruct(s) => s.as_str(), - } - } - */ -} - -/* A struct with a mix of different field types */ -#[derive(Clone, Debug, PartialEq)] -#[repr(C)] -pub struct MixedStruct { - pub s: String, - pub i1: u64, - pub i2: u64, -} - -impl MixedStruct { - pub fn get_s(&self) -> String { - self.s.clone() - } - - pub fn get_i1(&self) -> u64 { - self.i1 - } - - pub fn get_i2(&self) -> u64 { - self.i2 - } -} - -impl fmt::Display for MixedStruct { - fn fmt<'a, 'b>(&'a self, f: &'b mut fmt::Formatter) -> fmt::Result { - write!(f, "s = {}, i1 = {}, i2 = {}", self.s, self.i1, self.i2) - } -} - -/* A 'true' enum */ -#[derive(Clone, Debug, PartialEq)] -#[repr(u64)] -pub enum TrueEnum { - Foo, - Bar, - Baz, -} - -pub fn cycle_true_enum (te: &TrueEnum) -> TrueEnum { - match te { - TrueEnum::Foo => TrueEnum::Bar, - TrueEnum::Bar => TrueEnum::Baz, - TrueEnum::Baz => TrueEnum::Foo, - } -} - -impl fmt::Display for TrueEnum { - fn fmt<'a, 'b>(&'a self, f: &'b mut fmt::Formatter) -> fmt::Result { - match self { - TrueEnum::Foo => f.write_str ("Foo"), - TrueEnum::Bar => f.write_str ("Bar"), - TrueEnum::Baz => f.write_str ("Baz"), - /* - TrueEnum::Foo => write!(f,"Foo"), - TrueEnum::Bar => write!(f,"Bar"), - TrueEnum::Baz => write!(f,"Baz"), - */ - } - } -} - - -/*** - *** Pointers and References - ***/ - -pub fn box_read (p:Box) -> u64 { - *p -} - - -/*** - *** Slices and Arrays - ***/ - -pub fn index_one_array (x:[u64; 1]) -> u64 { - x[0] -} - -pub fn index_two_array (x:[u64; 2]) -> u64 { - x[0] -} - -pub fn index_three_array (x:[u64; 3]) -> u64 { - x[0] -} - - -/*** - *** Linked Lists - ***/ - -/* A linked list */ -#[derive(Clone, Debug, PartialEq)] -#[repr(C,u64)] -pub enum LList { - Nil, - Cons (X,Box>) -} - -/* Test if a list is empty */ -pub fn list_is_empty (l: &LList) -> bool { - match l { - LList::Nil => true, - LList::Cons (_,_) => false - } -} - -/* Get the head of a linked list or return an error */ -pub fn list_head (l: &LList) -> Box> { - match l { - LList::Nil => Box::new(Sum::Right (())), - LList::Cons (x,_) => Box::new(Sum::Left (*x)) - } -} - -/* Get the head of a linked list or return an error, in an impl block */ -impl LList { - pub fn list_head_impl (&self) -> Result { - match self { - LList::Nil => Err (()), - LList::Cons (x,_) => Ok (*x) - } - } -} - -/* A linked list specialized to 64-bit elements */ -#[derive(Clone, Debug, PartialEq)] -#[repr(C,u64)] -pub enum List64 { - Nil64, - Cons64 (u64,Box) -} - -pub fn box_list64_clone<'a>(x:&'a Box) -> Box { - return x.clone(); -} - -pub fn list64_clone<'a>(x:&'a List64) -> List64 { - match &x { - List64::Nil64 => List64::Nil64, - List64::Cons64(h,t) => List64::Cons64(*h,box_list64_clone(t)), - } -} - -/* Test if a List64 is empty */ -pub fn list64_is_empty (l: &List64) -> bool { - match l { - List64::Nil64 => true, - List64::Cons64 (_,_) => false - } -} - -/* Return the tail of a List64, or None if it is the empty list */ -pub fn list64_tail (l: List64) -> Option { - match l { - List64::Nil64 => None, - List64::Cons64 (_,tl) => Some (*tl) - } -} - -/* Sum the elements of a List64 */ -pub fn list64_sum(l:&List64) -> u64 { - match l { - List64::Nil64 => 0, - List64::Cons64 (x,rest) => x + list64_sum (rest), - } -} - -/* Return a mutable reference to the head of a list, or None if it is empty */ -pub fn list64_head_mut <'a> (l:&'a mut List64) -> Option<&'a mut u64> { - match l { - List64::Nil64 => None, - List64::Cons64 (h,_) => Some (h), - } -} - -/* Return a mutable reference to the tail of a list, or None if it is empty */ -pub fn list64_tail_mut <'a> (l:&'a mut List64) -> Option<&'a mut List64> { - match l { - List64::Nil64 => None, - List64::Cons64 (_,t) => Some (t), - } -} - -/* Truncate a List64 to just one element */ -pub fn list64_truncate <'a> (l:&'a mut List64) { - match list64_tail_mut(l) { - Some (tl) => *tl = List64::Nil64, - None => () - } -} - -/* Find an element in a List64 and return a mutable reference to it */ -pub fn list64_find_mut <'a> (x:u64, l:&'a mut List64) -> Option<&'a mut u64> { - match l { - List64::Nil64 => None, - List64::Cons64 (y,rest) => - if x == *y { Some (y) } else { list64_find_mut (x,rest) } - } -} - -/* Build a HashMap with a String key already mapped to a list */ -pub fn hash_map_for_string_and_list64 (str:String, - l:List64) -> HashMap { - let mut map = HashMap::new(); - map.insert (str, l); - return map; -} - -pub fn opt_hash_map_for_string_and_list64 (str:String, - l:List64) -> Option> { - Some(hash_map_for_string_and_list64 (str,l)) -} - - -/* Sum the List64s in a HashMap */ -pub fn sum_hash_map_string_list64 (map:&HashMap) -> u64 { - let mut ret:u64 = 0; - for (_,l) in map.iter() { - ret += list64_sum (l); - } - return ret; -} - -/* Insert a mapping into m from the greatest of x and y to the other */ -pub fn hash_map_insert_gt_to_le (m: &mut HashMap, x:u64, y:u64) -> () { - if x > y { - m.insert (x, y); - } else { - m.insert (y, x); - } -} - -/* A binary tree */ -pub enum BinTree { - BinLeaf (X), - BinNode (Box>,Box>) -} - -pub fn bintree_is_leaf (t: &BinTree) -> bool { - match *t { - BinTree::BinLeaf (_) => true, - BinTree::BinNode (_,_) => false - } -} - - -/* A tree whose internal nodes contain vectors of children */ -pub enum Tree { - Leaf (X), - Node (Vec>) -} - -pub fn tree_is_leaf (t: &Tree) -> bool { - match *t { - Tree::Leaf (_) => true, - Tree::Node (_) => false - } -} - -/* Sum all leaves in a tree */ -/* -pub fn tree_sum (t: &Tree) -> u64 { - let mut acc = 0; - match *t { - Tree::Leaf (x) => x, - Tree::Node (children) => - for u in children { - acc += tree_sum (u); - } - acc; - } -} -*/ - -/* A 20-element enum that just wraps around type X */ -#[repr(u64)] -pub enum Enum20 { - Enum20_0(X), - Enum20_1(X), - Enum20_2(X), - Enum20_3(X), - Enum20_4(X), - Enum20_5(X), - Enum20_6(X), - Enum20_7(X), - Enum20_8(X), - Enum20_9(X), - Enum20_10(X), - Enum20_11(X), - Enum20_12(X), - Enum20_13(X), - Enum20_14(X), - Enum20_15(X), - Enum20_16(X), - Enum20_17(X), - Enum20_18(X), - Enum20_19(X), -} - -pub fn enum20_list_proj<'a> (x:&'a Enum20>) -> &'a LList { - match x { - Enum20::Enum20_0(l) => l, - Enum20::Enum20_1(l) => l, - Enum20::Enum20_2(l) => l, - Enum20::Enum20_3(l) => l, - Enum20::Enum20_4(l) => l, - Enum20::Enum20_5(l) => l, - Enum20::Enum20_6(l) => l, - Enum20::Enum20_7(l) => l, - Enum20::Enum20_8(l) => l, - Enum20::Enum20_9(l) => l, - Enum20::Enum20_10(l) => l, - Enum20::Enum20_11(l) => l, - Enum20::Enum20_12(l) => l, - Enum20::Enum20_13(l) => l, - Enum20::Enum20_14(l) => l, - Enum20::Enum20_15(l) => l, - Enum20::Enum20_16(l) => l, - Enum20::Enum20_17(l) => l, - Enum20::Enum20_18(l) => l, - Enum20::Enum20_19(l) => l, - } -} - -/* A non-empty list type with 20 separate constructors */ -#[repr(u64)] -pub enum List10 { - List10Head(X), - List10_0(X,Box>), - List10_1(X,Box>), - List10_2(X,Box>), - List10_3(X,Box>), - List10_4(X,Box>), - List10_5(X,Box>), - List10_6(X,Box>), - List10_7(X,Box>), - List10_8(X,Box>), - List10_9(X,Box>), -} - -pub fn list10_head<'a> (x:&'a List10>) -> &'a LList { - match x { - List10::List10Head(l) => l, - List10::List10_0(l,_) => l, - List10::List10_1(l,_) => l, - List10::List10_2(l,_) => l, - List10::List10_3(l,_) => l, - List10::List10_4(l,_) => l, - List10::List10_5(l,_) => l, - List10::List10_6(l,_) => l, - List10::List10_7(l,_) => l, - List10::List10_8(l,_) => l, - List10::List10_9(l,_) => l, - } -} - - -/* A non-empty list type with 20 separate constructors */ -#[repr(u64)] -pub enum List20 { - List20Head(X), - List20_0(X,Box>), - List20_1(X,Box>), - List20_2(X,Box>), - List20_3(X,Box>), - List20_4(X,Box>), - List20_5(X,Box>), - List20_6(X,Box>), - List20_7(X,Box>), - List20_8(X,Box>), - List20_9(X,Box>), - List20_10(X,Box>), - List20_11(X,Box>), - List20_12(X,Box>), - List20_13(X,Box>), - List20_14(X,Box>), - List20_15(X,Box>), - List20_16(X,Box>), - List20_17(X,Box>), - List20_18(X,Box>), - List20_19(X,Box>), -} - -pub fn list20_head<'a> (x:&'a List20>) -> &'a LList { - match x { - List20::List20Head(l) => l, - List20::List20_0(l,_) => l, - List20::List20_1(l,_) => l, - List20::List20_2(l,_) => l, - List20::List20_3(l,_) => l, - List20::List20_4(l,_) => l, - List20::List20_5(l,_) => l, - List20::List20_6(l,_) => l, - List20::List20_7(l,_) => l, - List20::List20_8(l,_) => l, - List20::List20_9(l,_) => l, - List20::List20_10(l,_) => l, - List20::List20_11(l,_) => l, - List20::List20_12(l,_) => l, - List20::List20_13(l,_) => l, - List20::List20_14(l,_) => l, - List20::List20_15(l,_) => l, - List20::List20_16(l,_) => l, - List20::List20_17(l,_) => l, - List20::List20_18(l,_) => l, - List20::List20_19(l,_) => l, - } -} - -impl Clone for List20 { - fn clone<'a>(&'a self) -> Self { - match &self { - List20::List20Head(b) => List20::List20Head(*b), - List20::List20_0(h,t) => List20::List20_0(*h,t.clone()), - List20::List20_1(h,t) => List20::List20_1(*h,t.clone()), - List20::List20_2(h,t) => List20::List20_2(*h,t.clone()), - List20::List20_3(h,t) => List20::List20_3(*h,t.clone()), - List20::List20_4(h,t) => List20::List20_4(*h,t.clone()), - List20::List20_5(h,t) => List20::List20_5(*h,t.clone()), - List20::List20_6(h,t) => List20::List20_6(*h,t.clone()), - List20::List20_7(h,t) => List20::List20_7(*h,t.clone()), - List20::List20_8(h,t) => List20::List20_8(*h,t.clone()), - List20::List20_9(h,t) => List20::List20_9(*h,t.clone()), - List20::List20_10(h,t) => List20::List20_10(*h,t.clone()), - List20::List20_11(h,t) => List20::List20_11(*h,t.clone()), - List20::List20_12(h,t) => List20::List20_12(*h,t.clone()), - List20::List20_13(h,t) => List20::List20_13(*h,t.clone()), - List20::List20_14(h,t) => List20::List20_14(*h,t.clone()), - List20::List20_15(h,t) => List20::List20_15(*h,t.clone()), - List20::List20_16(h,t) => List20::List20_16(*h,t.clone()), - List20::List20_17(h,t) => List20::List20_17(*h,t.clone()), - List20::List20_18(h,t) => List20::List20_18(*h,t.clone()), - List20::List20_19(h,t) => List20::List20_19(*h,t.clone()), - } - } -} diff --git a/heapster/examples/rust_data.saw b/heapster/examples/rust_data.saw deleted file mode 100644 index f62a51212f..0000000000 --- a/heapster/examples/rust_data.saw +++ /dev/null @@ -1,665 +0,0 @@ -enable_experimental; -env <- heapster_init_env_from_file "rust_data.sawcore" "rust_data.bc"; - -/*** - *** Types - ***/ - -// Integer types -heapster_define_perm env "int64" " " "llvmptr 64" "exists x:bv 64.eq(llvmword(x))"; -heapster_define_perm env "int32" " " "llvmptr 32" "exists x:bv 32.eq(llvmword(x))"; -heapster_define_perm env "int8" " " "llvmptr 8" "exists x:bv 8.eq(llvmword(x))"; -heapster_define_perm env "int1" " " "llvmptr 1" "exists x:bv 1.eq(llvmword(x))"; - -heapster_define_llvmshape env "u64" 64 "" "fieldsh(int64<>)"; -heapster_define_llvmshape env "u32" 64 "" "fieldsh(32,int32<>)"; -heapster_define_llvmshape env "u8" 64 "" "fieldsh(8,int8<>)"; - -heapster_define_llvmshape env "usize" 64 "" "fieldsh(int64<>)"; -heapster_define_llvmshape env "char" 64 "" "fieldsh(32,int32<>)"; - -// bool type -heapster_define_llvmshape env "bool" 64 "" "fieldsh(1,int1<>)"; - -// Box type -heapster_define_llvmshape env "Box" 64 "T:llvmshape 64" "ptrsh(T)"; - -// Result type -heapster_define_rust_type env "pub enum Result { Ok (X), Err (Y) }"; - -// Infallable type -heapster_define_llvmshape env "Infallible" 64 "" "falsesh"; - -// Sum type -heapster_define_rust_type env "pub enum Sum { Left (X), Right (Y) }"; - -// The Option type -heapster_define_rust_type env "pub enum Option { None, Some (X) }"; - -// Location type from std::panic -heapster_define_llvmshape env "panic::Location" 64 "" - "exsh len:bv 64.ptrsh(arraysh())); fieldsh(eq(llvmword(len))); u32<>; u32<>"; - -// The str type -// For now we have to define the shape explicitly without the int8 name because -// 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())"; -//heapster_define_rust_type env "type str = [u8];"; - -// The String type -heapster_define_llvmshape env "String" 64 "" - "exsh cap:bv 64. ptrsh(arraysh())); \ - \ fieldsh(int64<>);fieldsh(eq(llvmword(cap)))"; - -// List type -//heapster_define_llvmshape env "List" 64 -// "L:perm(llvmptr 64), X:llvmshape 64" -// "fieldsh(eq(llvmword(0))) orsh (fieldsh(eq(llvmword(1))); X; fieldsh(L))"; -//heapster_define_recursive_perm env "ListPerm" -// "X:llvmshape 64, Xlen:bv 64, rw:rwmodality, l:lifetime" -// "llvmptr 64" -// ["[l]memblock(rw,0,Xlen + 16,List,X>)"] -// "\\ (X:sort 0) (_:Vec 64 Bool) -> List X" -// "\\ (X:sort 0) (_:Vec 64 Bool) -> foldListPermH X" -// "\\ (X:sort 0) (_:Vec 64 Bool) -> unfoldListPermH X"; -heapster_define_rust_type env "pub enum LList { Nil, Cons (X,Box>) }"; - -// The Rust Void type is really a general existential type; this is not directly -// representable in the Rust type system, but it is in Heapster! -//heapster_define_llvmshape env "Void" 64 "" "exsh T:llvmshape 64.T"; -// -// Doh! Except the above looks like a dynamically-sized type to Heapster! So we -// instead just make Void an opaque type -heapster_define_opaque_llvmshape env "Void" 64 "" "64" "#()" "Tp_Kind (Kind_Expr Kind_unit)"; - -// Location type from std::panic -heapster_define_llvmshape env "panic::Location" 64 "" - "exsh len:bv 64.ptrsh(arraysh())); \ - \ fieldsh(eq(llvmword(len))); u32<>; u32<>"; - -// List64 type -heapster_define_rust_type env "pub enum List64 { Nil64, Cons64 (u64,Box) }"; - -// The TwoValues, ThreeValues, FourValues, and FiveValues types -heapster_define_rust_type env "pub struct TwoValues(u32,u32);"; -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_rust_type env - "pub struct MixedStruct { pub s: String, pub i1: u64, pub i2: u64, }"; - -// TrueEnum type -heapster_define_rust_type env "pub enum TrueEnum { Foo, Bar, Baz }"; - -// Opaque type for Vec -heapster_define_opaque_llvmshape env "Vec" 64 - "T:llvmshape 64" "24" - "\\ (T:TpDesc) -> ListDescType T" - "ListDesc"; - -// Opaque type for HashMap -heapster_define_opaque_llvmshape env "HashMap" 64 - "T:llvmshape 64, U:llvmshape 64" "56" - "\\ (T:TpDesc) (U:TpDesc) -> ListDescType (Tp_Pair T U)" - "Tp_TpSubst ListDesc (Tp_Pair (Tp_Var 1) (Tp_Var 0))"; - -// BinTree type -heapster_define_rust_type env - "pub enum BinTree { BinLeaf (X), BinNode (Box>,Box>) }"; - -// Tree type -// FIXME: this does not work yet because Heapster cannot yet handle recursive types -// where the type being defined is passed to an opaque or recursvie type -//heapster_define_rust_type env "pub enum Tree { Leaf (X), Node (Vec>) }"; - -// Enum20 type -heapster_define_rust_type env - "pub enum Enum20 { \ - \ Enum20_0(X), Enum20_1(X), Enum20_2(X), Enum20_3(X), Enum20_4(X), \ - \ Enum20_5(X), Enum20_6(X), Enum20_7(X), Enum20_8(X), Enum20_9(X), \ - \ Enum20_10(X), Enum20_11(X), Enum20_12(X), Enum20_13(X), Enum20_14(X), \ - \ Enum20_15(X), Enum20_16(X), Enum20_17(X), Enum20_18(X), Enum20_19(X), }"; - -// List10 type -heapster_define_rust_type env - "pub enum List10 { \ - \ List10_Head(X,Box>), List10_0(X,Box>), \ - \ List10_1(X,Box>), List10_2(X,Box>), \ - \ List10_3(X,Box>), List10_4(X,Box>), \ - \ List10_5(X,Box>), List10_6(X,Box>), \ - \ List10_7(X,Box>), List10_8(X,Box>), \ - \ List10_9(X,Box>), }"; - -// List20 type -heapster_define_rust_type env - "pub enum List20 { \ - \ List20Head(X), List20_0(X,Box>), \ - \ List20_1(X,Box>), List20_2(X,Box>), \ - \ List20_3(X,Box>), List20_4(X,Box>), \ - \ List20_5(X,Box>), List20_6(X,Box>), \ - \ List20_7(X,Box>), List20_8(X,Box>), \ - \ List20_9(X,Box>), List20_10(X,Box>), \ - \ List20_11(X,Box>), List20_12(X,Box>), \ - \ List20_13(X,Box>), List20_14(X,Box>), \ - \ List20_15(X,Box>), List20_16(X,Box>), \ - \ List20_17(X,Box>), List20_18(X,Box>), \ - \ List20_19(X,Box>), }"; - - -/*** - *** Rust Formatting Types - ***/ - -// fmt::Error type -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 -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" -// "pub enum Result { Ok (), Err (fmt::Error) }"; - -// fmt::Formatter type -heapster_define_opaque_llvmshape env "fmt::Formatter" 64 "" "64" "#()" "Tp_Unit"; - -// fmt::Alignment type -heapster_define_rust_type_qual env "fmt" - "pub enum Alignment { Left, Right, Center, Unknown,}"; - -// fmt::Count type -heapster_define_rust_type_qual env "fmt" - "pub enum Count { Is(usize), Param(usize), NextParam, Implied,}"; - -// fmt::FormatSpec -heapster_define_rust_type_qual env "fmt" - "pub struct FormatSpec { pub fill: char, pub align: fmt::Alignment, \ - \ pub flags: u32, pub precision: fmt::Count, \ - \ pub width: fmt::Count, }"; - -// fmt::Position -heapster_define_rust_type_qual env "fmt" - "pub enum Position { Next, At(usize),}"; - -// fmt::Argument type -heapster_define_rust_type_qual env "fmt" - "pub struct Argument { pub position: fmt::Position, \ - \ pub format: fmt::FormatSpec,}"; - -// fmt::ArgumentV1 type -heapster_define_rust_type_qual env "fmt" - "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" -// "pub struct Arguments<'a> { pieces: &'a [&'a str], \ -// \ fmt: Option<&'a [fmt::Argument]>, \ -// \ 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 - ***/ - -// exchange_malloc -exchange_malloc_sym <- heapster_find_symbol env "15exchange_malloc"; -//heapster_assume_fun_rename env exchange_malloc_sym "exchange_malloc" -// "(len:bv 64). arg0:eq(llvmword(len)), arg1:true -o -// \ ret:array(0, true])" -// "\\ (len:Vec 64 Bool) -> returnM (BVVec 64 len #()) (repeatBVVec 64 len #() ())"; -heapster_assume_fun_rename env exchange_malloc_sym "exchange_malloc" - "(len:bv 64). arg0:eq(llvmword(len)), arg1:true -o \ - \ ret:memblock(W,0,len,emptysh)" - "\\ (len:Vec 64 Bool) -> retS VoidEv #() ()"; - -// llvm.uadd.with.overflow.i64 -heapster_assume_fun env "llvm.uadd.with.overflow.i64" - "(). arg0:int64<>, arg1:int64<> -o ret:struct(int64<>,int1<>)" - "\\ (x y:Vec 64 Bool) -> \ - \ retS VoidEv \ - \ (Vec 64 Bool * Vec 1 Bool) \ - \ (bvAdd 64 x y, single Bool (bvCarry 64 x y))"; - -// llvm.expect.i1 -heapster_assume_fun env "llvm.expect.i1" - "().arg0:int1<>, arg1:int1<> -o ret:int1<>" - "\\ (x y:Vec 1 Bool) -> retS VoidEv (Vec 1 Bool) x"; - - -// memcpy -heapster_assume_fun env "llvm.memcpy.p0i8.p0i8.i64" - "(rw:rwmodality, l1:lifetime, l2:lifetime, \ - \ b:llvmblock 64, len:bv 64). \ - \ arg0:[l1]memblock(W,0,len,emptysh), arg1:[l2]memblock(rw,0,len,eqsh(len,b)), \ - \ arg2:eq(llvmword(len)) -o \ - \ arg0:[l1]memblock(W,0,len,eqsh(len,b)), arg1:[l2]memblock(rw,0,len,eqsh(len,b))" - "\\ (len:Vec 64 Bool) -> retS VoidEv #() ()"; - -// Box>::clone -box_list20_u64_clone_sym <- heapster_find_symbol_with_type env - "alloc..boxed..Box$LT$T$C$A$GT$$u20$as$u20$core..clone..Clone$GT$5clone" - "%\"List20\"*(%\"List20\"**)"; -heapster_assume_fun_rename_prim env box_list20_u64_clone_sym "box_list20_u64_clone" - "<'a> fn(x:&'a Box>) -> Box>"; - -// alloc::box_free -BoxFree_funs <- heapster_find_symbols_with_type env "alloc8box_free" "void(i64*)"; -for BoxFree_funs - (\ x -> - // FIXME: this should have type memblock(W,0,len,emptysh) -o empty, but the - // length len is given by the type at which this is instantiated, i.e., the - // T at which this instance of box_free has type Unique -> (), and there - // is no way to reconstruct T from the symbol name or its type, so we give - // it the weaker type saying it consumes no permissions, and assume that - // the code which calls it, generated by rustc, drops the pointer it passes - // to boxfree before using it again. We could have it take in a memblock - // permission with existential length and shape, but that would require - // handling existential lengths... - heapster_assume_fun_rename_prim env x x - "(). empty -o empty"); - -// ::to_string -to_string_str <- heapster_find_symbol env - "$LT$str$u20$as$u20$alloc..string..ToString$GT$9to_string"; -heapster_assume_fun_rename_prim env to_string_str "to_string_str" - "<'a> fn (&'a str) -> String"; - -// core::panicking::panic -panicking_panic_sym <- heapster_find_symbol env "9panicking5panic"; -heapster_assume_fun_rename_prim env panicking_panic_sym "panicking_panic" - "<'a, 'b> fn (&'a str, &'b panic::Location) -> !"; -// FIXME: the above should use the 'static lifetime, which needs Heapster support - -// 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), -// \ arg1:array(0, int8<>]), \ -// \ arg2:eq(llvmword(len)) -o \ -// \ arg0:exists len':bv 64. ptr((W,0) |-> array(0, int8<>])) * \ -// \ ptr((W,8) |-> int64<>) * ptr((W,16) |-> eq(llvmword(len')))" -// "\\ (len:Vec 64 Bool) (_:#()) (str:BVVec 64 len (Vec 8 Bool)) -> \ -// \ returnM (Sigma (Vec 64 Bool) (\\ (len':Vec 64 Bool) -> \ -// \ BVVec 64 len' (Vec 8 Bool) * Vec 64 Bool * #())) \ -// \ (exists (Vec 64 Bool) (\\ (len':Vec 64 Bool) -> \ -// \ BVVec 64 len' (Vec 8 Bool) * Vec 64 Bool * #()) len (str, len, ()))"; - -// 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(R,0,)), \ -// \ arg2:eq(llvmword(len)) -o \ -// \ arg0:memblock(W,0,24,String<>)" -// "\\ (len:Vec 64 Bool) (_:#()) (str:BVVec 64 len (Vec 8 Bool)) -> \ -// \ returnM (Sigma (Vec 64 Bool) (\\ (len':Vec 64 Bool) -> \ -// \ BVVec 64 len' (Vec 8 Bool) * Vec 64 Bool * #())) \ -// \ (exists (Vec 64 Bool) (\\ (len':Vec 64 Bool) -> \ -// \ BVVec 64 len' (Vec 8 Bool) * Vec 64 Bool * #()) len (str, len, ()))"; - -// FIXME: this is the correct version, with a lifetime argument -//heapster_assume_fun_rename env to_string_str "to_string_str" -// "(ps:lowned_perm, l:lifetime, len:bv 64). \ -// \ l:lowned ps, arg0:[l]memblock(W,0,24,emptysh), \ -// \ arg1:array(0, int8<>]), arg2:eq(llvmword(len)) -o \ -// \ l:lowned ps, arg0:[l]memblock(W,0,24,String<>)" -// "\\ (len:Vec 64 Bool) (_:#()) (str:BVVec 64 len (Vec 8 Bool)) -> \ -// \ returnM (Sigma (Vec 64 Bool) (\\ (len':Vec 64 Bool) -> \ -// \ BVVec 64 len' (Vec 8 Bool) * Vec 64 Bool * #())) \ -// \ (exists (Vec 64 Bool) (\\ (len':Vec 64 Bool) -> \ -// \ BVVec 64 len' (Vec 8 Bool) * Vec 64 Bool * #()) len (str, len, ()))"; - - -// HashMap::insert -// FIXME: we currently pretend this always returns None -hashmap_u64_u64_insert_sym <- heapster_find_symbol_with_type env - "std11collections4hash3map24HashMap$LT$K$C$V$C$S$GT$6insert" - "{ i64,\ -\ i64 }(%\"std::collections::hash::map::HashMap\"*,\ -\ i64, i64)"; -heapster_assume_fun_rename_prim env hashmap_u64_u64_insert_sym "hashmap_u64_u64_insert" - "<'a> fn (&'a mut HashMap,u64,u64) -> Option"; -//heapster_assume_fun_rename env hashmap_u64_u64_insert_sym "hashmap_u64_u64_insert" -// "<'a> fn (&'a mut HashMap,u64,u64) -> Option" -// "\\ (endl:HashMap (Vec 64 Bool) (Vec 64 Bool) * #() -> \ -// \ CompM (HashMap (Vec 64 Bool) (Vec 64 Bool) * #())) \ -// \ (h:HashMap (Vec 64 Bool) (Vec 64 Bool)) (k:Vec 64 Bool) (v:Vec 64 Bool) -> \ -// \ returnM ((#() -> CompM (HashMap (Vec 64 Bool) (Vec 64 Bool) * #())) * \ -// \ Either #() (Vec 64 Bool) * #()) \ -// \ ((\\ (_:#()) -> returnM (HashMap (Vec 64 Bool) (Vec 64 Bool) * #()) \ -// \ (Cons (Vec 64 Bool * Vec 64 Bool) (k,v) h, ())), \ -// \ Left #() (Vec 64 Bool) (), ())"; - -hashmap_String_List64_insert_sym <- heapster_find_symbol_with_type env - "std11collections4hash3map24HashMap$LT$K$C$V$C$S$GT$6insert" - "void(%\"core::option::Option\"*,\ -\ %\"std::collections::hash::map::HashMap\"*,\ -\ %\"alloc::string::String\"*, %List64*)"; -// FIXME: assume hashmap_String_List64_insert_sym - -// String::deref -string_deref <- heapster_find_trait_method_symbol env - "core::ops::deref::Deref::deref"; -heapster_assume_fun_rename_prim env string_deref "string_deref" - "<'a> fn (&'a String) -> &'a str"; - -// String::fmt -string_fmt <- heapster_find_trait_method_symbol env - "core::fmt::Display::fmt"; -heapster_assume_fun_rename_prim env string_fmt "String_fmt" - "<'a, 'b> fn(&'a String, f: &'b mut fmt::Formatter) -> fmt::Result"; -//heapster_typecheck_fun_rename env string_fmt "String_fmt" -// "<'a, 'b> fn(&'a String, f: &'b mut fmt::Formatter) -> fmt::Result"; - -/* -String__fmt_sym <- heapster_find_trait_method_symbol env "core::fmt::Display::fmt"; -// heapster_assume_fun_rename env String__fmt_sym "String__fmt" -// "<'a, 'b> fn(&'a String, f: &'b mut fmt::Formatter) -> fmt::Result" -// "\\ (end_a : List (Vec 8 Bool) * #() -> CompM (List (Vec 8 Bool) * #())) \ -// \ (end_b : #() * #() -> CompM (#() * #())) (str:List (Vec 8 Bool)) (fmt : #()) -> \ -// \ returnM ((#() -> CompM (List (Vec 8 Bool) * #())) * \ -// \ (#() -> CompM (#() * #())) * Either #() #() * #()) \ -// \ ((\\ (_:#()) -> returnM (List (Vec 8 Bool) * #()) \ -// \ (str, ())), \ -// \ (\\ (_:#()) -> returnM (#() * #()) ((), ())), \ -// \ Left #() #() (), ())"; -heapster_assume_fun_rename_prim env String__fmt_sym "String__fmt" - "<'a, 'b> fn(&'a String, f: &'b mut fmt::Formatter) -> fmt::Result"; -*/ - -// core::fmt::Display::fmt -// FIXME: why does this not match the normal symbol pattern for traits? -u64_fmt <- heapster_find_symbol env - "core3fmt3num3imp52_$LT$impl$u20$core..fmt..Display"; -heapster_assume_fun_rename_prim env u64_fmt "u64_fmt" - "<'a, 'b> fn(&'a u64, f: &'b mut fmt::Formatter) -> fmt::Result"; - - -// A "dummy" type for an arbitrary 64-bit LLVM value with no permissions -heapster_define_llvmshape env "Any" 64 "" "fieldsh(true)"; - -// ArgumentV1::new -ArgumentV1_new_syms <- heapster_find_symbols env "10ArgumentV13new"; -for ArgumentV1_new_syms (\ sym -> heapster_assume_fun_rename_prim env sym sym - "<> fn (x:Any, f:Any) -> fmt::ArgumentV1"); -//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"; - -// 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 [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"; -heapster_assume_fun_rename_prim env Formatter__write_str_sym "Formatter__write_str" - "<'a,'b> fn (&'a mut fmt::Formatter, &'b str) -> fmt::Result"; - -// Formatter::write_fmt -Formatter__write_fmt_sym <- heapster_find_symbol env "9Formatter9write_fmt"; -heapster_assume_fun_rename_prim env Formatter__write_fmt_sym "Formatter__write_fmt" - "<'a> fn (&'a mut fmt::Formatter, fmt::Arguments) -> fmt::Result"; - -// std::panicking::begin_panic -// FIXME: add this back in when we add get_out back -//begin_panic_sym <- heapster_find_symbol env "3std9panicking11begin_panic17"; -//heapster_assume_fun_rename_prim env begin_panic_sym "begin_panic" "<'a, 'b> fn(&'a str, &'b panic::Location) -> !"; - - -/*** - *** Type-Checked Functions - ***/ - -// FIXME: SAW cannot currently handle get_out in the binary -//get_out_sym <- heapster_find_symbol env "7get_out"; -//heapster_typecheck_fun_rename env get_out_sym "get_out" "<> fn() -> !"; - -// bool_and -bool_and_sym <- heapster_find_symbol env "8bool_and"; -heapster_typecheck_fun_rename env bool_and_sym "bool_and" "<> fn (bool,bool) -> bool"; - -// mk_two_values -// FIXME: this requires type-checking to split a 64-bit field into 2 32-bit fields -/* -mk_two_values_sym <- heapster_find_symbol env "13mk_two_values"; -heapster_typecheck_fun_rename env mk_two_values_sym "mk_two_values" "<> fn (u32,u32) -> TwoValues"; -*/ - -// mk_five_values -mk_five_values_sym <- heapster_find_symbol env "14mk_five_values"; -heapster_typecheck_fun_rename env mk_five_values_sym "mk_five_values" - "<> fn (x1:u32,x2:u32,x3:u32,x4:u32,x5:u32) -> FiveValues"; - -// proj_five_values -proj_five_values_sym <- heapster_find_symbol env "16proj_five_values"; -heapster_typecheck_fun_rename env proj_five_values_sym "proj_five_values" - "<> fn (i:u64, fvs:FiveValues) -> u32"; - -// mk_proj0_five_values -mk_proj0_five_values_sym <- heapster_find_symbol env "20mk_proj0_five_values"; -heapster_typecheck_fun_rename env mk_proj0_five_values_sym "mk_proj0_five_values" - "<> fn (x1:u32,x2:u32,x3:u32,x4:u32,x5:u32) -> u32"; - -// ref_sum -ref_sum_sym <- heapster_find_symbol env "7ref_sum"; -heapster_typecheck_fun_rename env ref_sum_sym "ref_sum" - "<'a,'b> fn (x:&'a u64, y:&'a u64) -> u64"; - -// double_dup_ref -double_dup_ref_sym <- heapster_find_symbol env "14double_dup_ref"; -heapster_typecheck_fun_rename env double_dup_ref_sym "double_dup_ref" - "<'a,'b> fn (x:&'a u64) -> u64"; - -// test_result -test_result_sym <- heapster_find_symbol env "11test_result"; -// FIXME: Get this working again -// heapster_typecheck_fun_rename env test_result_sym "test_result" -// "<'a> fn (r:&'a Result) -> bool"; -//heapster_typecheck_fun_rename env test_result_sym "test_result" -// "().arg0:memblock(R,0,16,Result),fieldsh(int64<>)>) -o ret:int1<>"; - -// mk_result_infallible -mk_result_infallible_sym <- heapster_find_symbol env "20mk_result_infallible"; -heapster_typecheck_fun_rename env mk_result_infallible_sym "mk_result_infallible" - "<> fn (x:u64) -> Result"; - -// extract_from_result_infallible -extract_from_result_infallible_sym <- heapster_find_symbol env "30extract_from_result_infallible"; -// FIXME: Get this working again -// heapster_typecheck_fun_rename env extract_from_result_infallible_sym "extract_from_result_infallible" -// "<'a> fn (r:&'a Result) -> u64"; - - -// test_sum_impl -test_sum_impl_sym <- heapster_find_symbol env "13test_sum_impl"; -heapster_typecheck_fun_rename env test_sum_impl_sym "test_sum_impl" - "().arg0:memblock(R,0,16,Sum),fieldsh(int64<>)>) -o ret:int1<>"; - -// elim_sum_u64_u64 -// FIXME: needs to handle enums that are small enough to fit in arguments -/* -elim_sum_u64_u64_sym <- heapster_find_symbol env "16elim_sum_u64_u64"; -heapster_typecheck_fun_rename env elim_sum_u64_u64_sym "elim_sum_u64_u64" - "<> fn (x:Sum) -> u64"; -*/ - -// NOTE: Fails because of `clone` in the implementation -// MixedStruct::get_s -// mixed_struct_get_s <- heapster_find_symbol env "11MixedStruct5get_s"; -// heapster_typecheck_fun_rename env mixed_struct_get_s "MixedStruct_get_s" -// "<'a> fn (m:&'a MixedStruct) -> String"; - -// MixedStruct::get_i1 -mixed_struct_get_i1 <- heapster_find_symbol env "11MixedStruct6get_i1"; -heapster_typecheck_fun_rename env mixed_struct_get_i1 "MixedStruct_get_i1" - "<'a> fn (m:&'a MixedStruct) -> u64"; - -// MixedStruct::get_i2 -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 -// 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"; -heapster_typecheck_fun_rename env TrueEnum__fmt_sym "TrueEnum__fmt" - "<'a, 'b> fn (&'a TrueEnum, f: &'b mut fmt::Formatter) -> fmt::Result"; - -// list_is_empty -list_is_empty_sym <- heapster_find_symbol env "13list_is_empty"; -heapster_typecheck_fun_rename env list_is_empty_sym "list_is_empty" - "<'a> fn (l: &'a LList) -> bool"; -//heapster_typecheck_fun_rename env list_is_empty_sym "list_is_empty" -// "(rw:rwmodality).arg0:ListPerm),8,rw,always> -o ret:int1<>"; - -// list_head -list_head_sym <- heapster_find_symbol env "9list_head"; -heapster_typecheck_fun_rename env list_head_sym "list_head" - "<'a> fn (l: &'a LList) -> Box>"; -//heapster_typecheck_fun_rename env list_head_sym "list_head" -// "(rw:rwmodality). arg0:LList),8,rw,always> -o \ -// \ ret:memblock(W,0,16,Result),emptysh>)"; - -// list_head_impl -list_head_impl_sym <- heapster_find_symbol env "14list_head_impl"; -heapster_typecheck_fun_rename env list_head_impl_sym "list_head_impl" - "<'a> fn (l: &'a LList) -> Result"; -//heapster_typecheck_fun_rename env list_head_impl_sym "list_head_impl" -// "(rw:rwmodality). arg0:LList),8,rw,always> -o \ -// \ ret:(struct(eq(llvmword(0)), exists z:bv 64. eq(llvmword(z)))) or \ -// \ (struct(eq(llvmword(1)),true))"; - -// list64_is_empty -list64_is_empty_sym <- heapster_find_symbol env "15list64_is_empty"; -heapster_typecheck_fun_rename env list_is_empty_sym "list64_is_empty" - "<'a> fn (l: &'a List64<>) -> bool"; - -// box_list64_clone -box_list64_clone_sym <- heapster_find_symbol env "16box_list64_clone"; -heapster_assume_fun_rename_prim env box_list64_clone_sym "box_list64_clone" - "<'a> fn(x:&'a Box) -> Box"; - -// list64_clone -list64_clone_sym <- heapster_find_symbol env "12list64_clone"; -heapster_typecheck_fun_rename env list64_clone_sym "list64_clone" - "<'a> fn (x:&'a List64) -> List64"; - -// list64_tail -list64_tail_sym <- heapster_find_symbol env "11list64_tail"; -// FIXME: get this working again -// heapster_typecheck_fun_rename env list64_tail_sym "list64_tail" -// "<> fn (l:List64) -> Option"; - -// list64_head_mut -list64_head_mut_sym <- heapster_find_symbol env "15list64_head_mut"; -heapster_typecheck_fun_rename env list64_head_mut_sym "list64_head_mut" - "<'a> fn (l:&'a mut List64) -> Option<&'a mut u64>"; - -// list64_find_mut -list64_find_mut_sym <- heapster_find_symbol env "15list64_find_mut"; -heapster_typecheck_fun_rename env list64_find_mut_sym "list64_find_mut" - "<'a> fn (x:u64, l:&'a mut List64) -> Option<&'a mut u64>"; - -/* -hash_map_insert_gt_to_le_sym <- heapster_find_symbol env "hash_map_insert_gt_to_le"; -heapster_typecheck_fun_rename - env hash_map_insert_gt_to_le_sym - "hash_map_insert_gt_to_le" - "<'a> fn (m: &'a mut HashMap, x:u64, y:u64) -> ()"; - -// StrStruct::new -str_struct_new <- heapster_find_symbol env "9StrStruct3new"; -heapster_typecheck_fun_rename env str_struct_new "str_struct_new" - "<'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" - "<'a> fn (t: &'a BinTree) -> bool"; - -enum20_list_proj_sym <- heapster_find_symbol env "16enum20_list_proj"; -heapster_typecheck_fun_rename env enum20_list_proj_sym "enum20_list_proj" - "<'a> fn (x:&'a Enum20>) -> &'a LList"; - -list10_head_sym <- heapster_find_symbol env "11list10_head"; -heapster_typecheck_fun_rename env list10_head_sym "list10_head" - "<'a> fn (x:&'a List10>) -> &'a LList"; - -list20_u64_clone_sym <- heapster_find_symbol env - "List20$LT$u64$GT$$u20$as$u20$core..clone..Clone$GT$5clone"; -heapster_typecheck_fun_rename env list20_u64_clone_sym "list20_u64_clone" - "<'a> fn (&'a List20) -> List20"; - -heapster_set_translation_checks env false; -list20_head_sym <- heapster_find_symbol env "11list20_head"; -heapster_typecheck_fun_rename env list20_head_sym "list20_head" - "<'a> fn (x:&'a List20>) -> &'a LList"; -*/ - - -/*** - *** Export to Coq - ***/ - -heapster_export_coq env "rust_data_gen.v"; diff --git a/heapster/examples/rust_data.sawcore b/heapster/examples/rust_data.sawcore deleted file mode 100644 index 43eca0d96b..0000000000 --- a/heapster/examples/rust_data.sawcore +++ /dev/null @@ -1,14 +0,0 @@ - -module rust_data where - -import SpecM; - --- A type description for the list type over a type description T contained in --- deBruijn index 0 (which is index 1 inside the Tp_Ind constructor) -ListDesc : TpDesc; -ListDesc = Tp_Ind (Tp_Sum Tp_Unit (Tp_Pair (Tp_Var 1) (Tp_Var 0))); - --- Convert ListDesc applied to a type argument given by type description to a --- type -ListDescType : TpDesc -> sort 0; -ListDescType T = indElem (Tp_Sum Tp_Unit (Tp_Pair T (Tp_Ind (Tp_Sum Tp_Unit (Tp_Pair T (Tp_Var 0)))))); diff --git a/heapster/examples/rust_data_proofs.v b/heapster/examples/rust_data_proofs.v deleted file mode 100644 index 2e03ac14d3..0000000000 --- a/heapster/examples/rust_data_proofs.v +++ /dev/null @@ -1,48 +0,0 @@ -From Coq Require Import Lists.List. -From Coq Require Import String. -From Coq Require Import Vectors.Vector. -From CryptolToCoq Require Import SAWCoreScaffolding. -From CryptolToCoq Require Import SAWCoreVectorsAsCoqVectors. -From CryptolToCoq Require Import SAWCoreBitvectors. - -From CryptolToCoq Require Import SAWCorePrelude. -From CryptolToCoq Require Import CompMExtra. - -Require Import Examples.rust_data_gen. -Import rust_data. - -Import SAWCorePrelude. - -(* Print bool_and__tuple_fun. *) - -(* Print test_result__tuple_fun. *) - -(* Print test_sum_impl__tuple_fun. *) - -(* Print list_is_empty__tuple_fun. *) - -(* Print list_head__tuple_fun. *) - -(* Print list_head_impl__tuple_fun. *) - -(* Print str_struct_new__tuple_fun. *) - -(* 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. -Qed. - -Definition str_struct_new_spec (len:bitvector 64) (_:unit) - (str:BVVec 64 len (bitvector 8)) : - CompM {len' : bitvector 64 - & (BVVec 64 len' (bitvector 8) * (bitvector 64 * unit))%type} := - returnM (existT (fun len' => (BVVec 64 len' (bitvector 8) * (bitvector 64 * unit))%type) len (str, (len, tt))). - -Lemma str_struct_new_correct : refinesFun str_struct_new str_struct_new_spec. -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/examples/rust_just_translation.saw b/heapster/examples/rust_just_translation.saw deleted file mode 100644 index 9d8035e3b7..0000000000 --- a/heapster/examples/rust_just_translation.saw +++ /dev/null @@ -1,87 +0,0 @@ -// This file demonstrates how to use the `heapster_trans_rust_type` -// command to translate rust signatures to heapster. -enable_experimental; - -// Integer types This is wrong... we don't need an environment. -env <- heapster_init_env_from_file "rust_data.sawcore" "rust_data.bc"; - -print "Define Rust types."; -/*** - *** Types - ***/ - -// Integer types -heapster_define_perm env "int64" " " "llvmptr 64" "exists x:bv 64.eq(llvmword(x))"; -heapster_define_perm env "int32" " " "llvmptr 32" "exists x:bv 32.eq(llvmword(x))"; -heapster_define_perm env "int8" " " "llvmptr 8" "exists x:bv 8.eq(llvmword(x))"; -heapster_define_perm env "int1" " " "llvmptr 1" "exists x:bv 1.eq(llvmword(x))"; - -heapster_define_llvmshape env "u64" 64 "" "fieldsh(int64<>)"; -heapster_define_llvmshape env "u32" 64 "" "fieldsh(32,int32<>)"; -heapster_define_llvmshape env "u8" 64 "" "fieldsh(8,int8<>)"; - -heapster_define_llvmshape env "usize" 64 "" "fieldsh(int64<>)"; -heapster_define_llvmshape env "char" 64 "" "fieldsh(32,int32<>)"; - -// bool type -heapster_define_llvmshape env "bool" 64 "" "fieldsh(1,int1<>)"; - -// Box type -heapster_define_llvmshape env "Box" 64 "T:llvmshape 64" "ptrsh(T)"; - -// Result type -heapster_define_rust_type env "pub enum Result { Ok (X), Err (Y) }"; - -// Infallable type -heapster_define_llvmshape env "Infallible" 64 "" "falsesh"; - -// Sum type -heapster_define_rust_type env "pub enum Sum { Left (X), Right (Y) }"; - -// The Option type -heapster_define_rust_type env "pub enum Option { None, Some (X) }"; - - -print ""; -print "-----------------------------------------------"; -print "Translate 'unit'"; -print "Rust: \n<> fn () -> ()"; -print "Heapster:"; -heapster_trans_rust_type env "<> fn () -> ()"; - -print ""; -print "-----------------------------------------------"; -print "Translate 'add'"; -print "Rust: \n<> fn (x:u64, y:u64) -> u64"; -print "Heapster:"; -heapster_trans_rust_type env "<> fn (x:u64, y:u64) -> u64"; - - -print ""; -print "-----------------------------------------------"; -print "Translate 'Ptr add'"; -print "Rust: \n<'a,'b> fn (x:&'a u64, y:&'a u64) -> u64"; -print "Heapster:"; -heapster_trans_rust_type env "<'a,'b> fn (x:&'a u64, y:&'a u64) -> u64"; - -print ""; -print "-----------------------------------------------"; -print "Translate 'array length'"; -print "Rust: \n<'a> fn (x:&'a [u64]) -> u64"; -print "Heapster:"; -heapster_trans_rust_type env "<'a> fn (x:&'a [u64]) -> u64"; - - -print ""; -print "-----------------------------------------------"; -print "Translate 'add two array'"; -print "Rust: \n<'a, 'b, 'c> fn (l1:&'a [u64], l2:&'b [u64]) -> &'c [u64]"; -print "Heapster:"; -heapster_trans_rust_type env "<'a, 'b, 'c> fn (l1:&'a [u64], l2:&'b [u64]) -> &'c [u64]"; - -print ""; -print "-----------------------------------------------"; -print "Translate 'add two array in place'"; -print "Rust: \n<'a, 'b> fn (l1:&'a mut[u64], l2:&'b [u64]) -> ()"; -print "Heapster:"; -heapster_trans_rust_type env "<'a, 'b> fn (l1:&'a mut[u64], l2:&'b [u64]) -> ()"; diff --git a/heapster/examples/rust_lifetimes.bc b/heapster/examples/rust_lifetimes.bc deleted file mode 100644 index 63a4e84544..0000000000 Binary files a/heapster/examples/rust_lifetimes.bc and /dev/null differ diff --git a/heapster/examples/rust_lifetimes.rs b/heapster/examples/rust_lifetimes.rs deleted file mode 100644 index 7d50c93eb7..0000000000 --- a/heapster/examples/rust_lifetimes.rs +++ /dev/null @@ -1,59 +0,0 @@ - -pub fn mux_mut_refs_u64 <'a> (x1: &'a mut u64, x2: &'a mut u64, b: bool) -> &'a mut u64 { - if b { - return x1; - } else { - return x2; - } -} - -pub fn mux_mut_refs_poly <'a,X> (x1: &'a mut X, x2: &'a mut X, b: bool) -> &'a mut X { - if b { - return x1; - } else { - return x2; - } -} - -pub fn use_mux_mut_refs () -> u64 { - let mut i1:u64 = 5; - let mut i2:u64 = 42; - let r = mux_mut_refs_u64 (&mut i1, &mut i2, true); - *r = *r + 1; - i1 = i1 + 1; - return i1; -} - -pub fn use_mux_mut_refs2 <'a,'b> (x1: &'a mut u64, x2: &'b mut u64) -> u64 { - let r = mux_mut_refs_poly (x1,x2,true); - *r = *r + 1; - *x1 = *x1 + *x2; - return *x1; -} - -pub fn mux3_mut_refs_u64 <'a> (x1: &'a mut u64, x2: &'a mut u64, - x3: &'a mut u64, i: u64) -> &'a mut u64 { - if i == 0 { - return x1; - } else if i == 1 { - return x2; - } else { - return x3; - } -} - -pub fn use_mux3_mut_refs <'a,'b,'c> (x1: &'a mut u64, x2: &'b mut u64, - x3: &'c mut u64) -> u64 { - let r = mux3_mut_refs_u64 (x1,x2,x3,2); - *r = *r + 1; - *x1 = *x1 + *x2 + *x3; - return *x1; -} - -pub fn use_mux3_mut_refs_onel <'a> (x1: &'a mut u64, x2: &'a mut u64, - x3: &'a mut u64) -> u64 { - let r = mux3_mut_refs_u64 (x1,x2,x3,2); - *r = *r + 1; - *x1 = *x1 + *x2 + *x3; - return *x1; -} diff --git a/heapster/examples/rust_lifetimes.saw b/heapster/examples/rust_lifetimes.saw deleted file mode 100644 index 26e8fb29b2..0000000000 --- a/heapster/examples/rust_lifetimes.saw +++ /dev/null @@ -1,98 +0,0 @@ -enable_experimental; -env <- heapster_init_env_from_file "rust_lifetimes.sawcore" "rust_lifetimes.bc"; - -/*** - *** Types - ***/ - -// Integer perms -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 "int1" " " "llvmptr 1" "exists x:bv 1.eq(llvmword(x))"; - -// Integer shapes -heapster_define_llvmshape env "u64" 64 "" "fieldsh(int64<>)"; - -// bool type -heapster_define_llvmshape env "bool" 64 "" "fieldsh(1,int1<>)"; - - -/*** - *** Assumed Functions - ***/ - -// llvm.uadd.with.overflow.i64 -heapster_assume_fun env "llvm.uadd.with.overflow.i64" - "(). arg0:int64<>, arg1:int64<> -o \ - \ ret:struct(int64<>,int1<>)" - "\\ (x y:Vec 64 Bool) -> \ - \ retS VoidEv (Vec 64 Bool * Vec 1 Bool) \ - \ (bvAdd 64 x y, gen 1 Bool (\\ (_:Nat) -> bvCarry 64 x y))"; - -// llvm.expect.i1 -heapster_assume_fun env "llvm.expect.i1" - "().arg0:int1<>, arg1:int1<> -o ret:int1<>" - "\\ (x y:Vec 1 Bool) -> retS VoidEv (Vec 1 Bool) x"; - -// core::panicking::panic -//panic_sym <- heapster_find_symbol env "5panic"; -//heapster_assume_fun_rename env panic_sym "panic" -// "().empty -o empty" "returnM (Vec 1 Bool) x"; - - -/*** - *** Type-Checked Functions - ***/ - -// FIXME: Get this working again -/* -// mux_mut_refs_u64 -mux_mut_refs_u64_sym <- heapster_find_symbol env "16mux_mut_refs_u64"; -heapster_typecheck_fun_rename env mux_mut_refs_u64_sym "mux_mut_refs_u64" - "<'a> fn (x1: &'a mut u64, x2: &'a mut u64, b: bool) -> &'a mut u64"; - // "(l:lifetime, l1:lifetime ,l2:lifetime). \ - // \ l:lowned(arg0:[l]memblock(R,0,8,u64<>), arg1:[l]memblock(R,0,8,u64<>) -o \ - // \ arg0:[l1]memblock(W,0,8,u64<>), arg1:[l2]memblock(W,0,8,u64<>)), \ - // \ arg0:[l]memblock(W,0,8,u64<>), arg1:[l]memblock(W,0,8,u64<>), arg2:int1<> -o \ - // \ l:lowned (ret:[l]memblock(R,0,8,u64<>) -o \ - // \ arg0:[l1]memblock(W,0,8,u64<>), arg1:[l2]memblock(W,0,8,u64<>)), \ - // \ ret:[l]memblock(W,0,8,u64<>)"; - -// mux_mut_refs_poly -mux_mut_refs_poly_u64_sym <- heapster_find_symbol env "17mux_mut_refs_poly"; -heapster_typecheck_fun_rename env mux_mut_refs_poly_u64_sym "mux_mut_refs_poly_u64" - "<'a> fn (x1: &'a mut u64, x2: &'a mut u64, b: bool) -> &'a mut u64"; - -// use_mux_mut_refs -use_mux_mut_refs_sym <- heapster_find_symbol env "16use_mux_mut_refs"; -heapster_typecheck_fun_rename env use_mux_mut_refs_sym "use_mux_mut_refs" - "(). empty -o ret:int64<>"; - -// use_mux_mut_refs2 -use_mux_mut_refs2_sym <- heapster_find_symbol env "17use_mux_mut_refs2"; -heapster_typecheck_fun_rename env use_mux_mut_refs2_sym "use_mux_mut_refs2" - "<'a,'b> fn (x1: &'a mut u64, x2: &'b mut u64) -> u64"; - -// mux3_mut_refs_u64 -mux3_mut_refs_u64_sym <- heapster_find_symbol env "17mux3_mut_refs_u64"; -heapster_typecheck_fun_rename env mux3_mut_refs_u64_sym "mux3_mut_refs_u64" - "<'a> fn (x1: &'a mut u64, x2: &'a mut u64, \ - \ x3: &'a mut u64, i: u64) -> &'a mut u64"; - -// use_mux3_mut_refs -use_mux3_mut_refs_sym <- heapster_find_symbol env "17use_mux3_mut_refs"; -heapster_typecheck_fun_rename env use_mux3_mut_refs_sym "use_mux3_mut_refs" - "<'a,'b,'c> fn (x1: &'a mut u64, x2: &'b mut u64, x3: &'c mut u64) -> u64"; - -// use_mux3_mut_refs_onel -use_mux3_mut_refs_onel_sym <- heapster_find_symbol env "22use_mux3_mut_refs_onel"; -heapster_typecheck_fun_rename env use_mux3_mut_refs_onel_sym - "use_mux3_mut_refs_onel" - "<'a> fn (x1: &'a mut u64, x2: &'a mut u64, x3: &'a mut u64) -> u64"; -*/ - -/*** - *** Export to Coq - ***/ - -heapster_export_coq env "rust_lifetimes_gen.v"; diff --git a/heapster/examples/rust_lifetimes.sawcore b/heapster/examples/rust_lifetimes.sawcore deleted file mode 100644 index 4e447e3b31..0000000000 --- a/heapster/examples/rust_lifetimes.sawcore +++ /dev/null @@ -1,19 +0,0 @@ - -module rust_lifetimes where - -import SpecM; - -unfoldListPermH : (a:sort 0) -> List a -> Either #() (#() * a * List a); -unfoldListPermH a l = - List__rec a (\ (_:List a) -> Either #() (#() * a * List a)) - (Left #() (#() * a * List a) ()) - (\ (x:a) (l:List a) (_:Either #() (#() * a * List a)) -> - Right #() (#() * a * List a) ((), x, l)) - l; - -foldListPermH : (a:sort 0) -> Either #() (#() * a * List a) -> List a; -foldListPermH a = - either #() (#() * a * List a) (List a) - (\ (_ : #()) -> Nil a) - (\ (tup : (#() * a * List a)) -> - Cons a tup.(2).(1) tup.(2).(2)); diff --git a/heapster/examples/rust_lifetimes_proofs.v b/heapster/examples/rust_lifetimes_proofs.v deleted file mode 100644 index 98d91b751b..0000000000 --- a/heapster/examples/rust_lifetimes_proofs.v +++ /dev/null @@ -1,18 +0,0 @@ -From Coq Require Import Lists.List. -From Coq Require Import String. -From Coq Require Import Vectors.Vector. -From CryptolToCoq Require Import SAWCoreScaffolding. -From CryptolToCoq Require Import SAWCoreVectorsAsCoqVectors. -From CryptolToCoq Require Import SAWCoreBitvectors. - -From CryptolToCoq Require Import SAWCorePrelude. -From CryptolToCoq Require Import CompMExtra. - -Require Import Examples.rust_lifetimes_gen. -Import rust_lifetimes. - -Import SAWCorePrelude. - -(* Print mux_mut_refs_u64__tuple_fun. *) - -(* Print use_mux_mut_refs__tuple_fun. *) diff --git a/heapster/examples/sha512.bc b/heapster/examples/sha512.bc deleted file mode 100644 index a8b922d8df..0000000000 Binary files a/heapster/examples/sha512.bc and /dev/null differ diff --git a/heapster/examples/sha512.c b/heapster/examples/sha512.c deleted file mode 100644 index b5a9690c00..0000000000 --- a/heapster/examples/sha512.c +++ /dev/null @@ -1,329 +0,0 @@ -// ============================================================================ -// The code in this file is based off of that in: -// https://github.com/awslabs/aws-lc/ -// (commit: d84d2f329dccbc7f3866eab54951bd012e317041) -// ============================================================================ - -#include -#include -#include - -// ============================================================================ -// Helper functions from crypto/internal.h -// ============================================================================ - -static inline void *OPENSSL_memcpy(void *dst, const void *src, size_t n) { - if (n == 0) { - return dst; - } - - return memcpy(dst, src, n); -} - -static inline uint32_t CRYPTO_bswap4(uint32_t x) { - x = (x >> 16) | (x << 16); - x = ((x & 0xff00ff00) >> 8) | ((x & 0x00ff00ff) << 8); - return x; -} - -static inline uint64_t CRYPTO_bswap8(uint64_t x) { - return CRYPTO_bswap4(x >> 32) | (((uint64_t)CRYPTO_bswap4(x)) << 32); -} - -static inline uint64_t CRYPTO_load_u64_be(const void *ptr) { - uint64_t ret; - OPENSSL_memcpy(&ret, ptr, sizeof(ret)); - return CRYPTO_bswap8(ret); -} - -// ============================================================================ -// The defintion of sha512_block_data_order from crypto/fipsmodule/sha/sha512.c -// with only one addition (return_state), needed for Heapster typechecking -// ============================================================================ - -// Used in sha512_block_data_order below, needed for Heapster typechecking -void return_state(uint64_t *state) { } - -static const uint64_t K512[80] = { - UINT64_C(0x428a2f98d728ae22), UINT64_C(0x7137449123ef65cd), - UINT64_C(0xb5c0fbcfec4d3b2f), UINT64_C(0xe9b5dba58189dbbc), - UINT64_C(0x3956c25bf348b538), UINT64_C(0x59f111f1b605d019), - UINT64_C(0x923f82a4af194f9b), UINT64_C(0xab1c5ed5da6d8118), - UINT64_C(0xd807aa98a3030242), UINT64_C(0x12835b0145706fbe), - UINT64_C(0x243185be4ee4b28c), UINT64_C(0x550c7dc3d5ffb4e2), - UINT64_C(0x72be5d74f27b896f), UINT64_C(0x80deb1fe3b1696b1), - UINT64_C(0x9bdc06a725c71235), UINT64_C(0xc19bf174cf692694), - UINT64_C(0xe49b69c19ef14ad2), UINT64_C(0xefbe4786384f25e3), - UINT64_C(0x0fc19dc68b8cd5b5), UINT64_C(0x240ca1cc77ac9c65), - UINT64_C(0x2de92c6f592b0275), UINT64_C(0x4a7484aa6ea6e483), - UINT64_C(0x5cb0a9dcbd41fbd4), UINT64_C(0x76f988da831153b5), - UINT64_C(0x983e5152ee66dfab), UINT64_C(0xa831c66d2db43210), - UINT64_C(0xb00327c898fb213f), UINT64_C(0xbf597fc7beef0ee4), - UINT64_C(0xc6e00bf33da88fc2), UINT64_C(0xd5a79147930aa725), - UINT64_C(0x06ca6351e003826f), UINT64_C(0x142929670a0e6e70), - UINT64_C(0x27b70a8546d22ffc), UINT64_C(0x2e1b21385c26c926), - UINT64_C(0x4d2c6dfc5ac42aed), UINT64_C(0x53380d139d95b3df), - UINT64_C(0x650a73548baf63de), UINT64_C(0x766a0abb3c77b2a8), - UINT64_C(0x81c2c92e47edaee6), UINT64_C(0x92722c851482353b), - UINT64_C(0xa2bfe8a14cf10364), UINT64_C(0xa81a664bbc423001), - UINT64_C(0xc24b8b70d0f89791), UINT64_C(0xc76c51a30654be30), - UINT64_C(0xd192e819d6ef5218), UINT64_C(0xd69906245565a910), - UINT64_C(0xf40e35855771202a), UINT64_C(0x106aa07032bbd1b8), - UINT64_C(0x19a4c116b8d2d0c8), UINT64_C(0x1e376c085141ab53), - UINT64_C(0x2748774cdf8eeb99), UINT64_C(0x34b0bcb5e19b48a8), - UINT64_C(0x391c0cb3c5c95a63), UINT64_C(0x4ed8aa4ae3418acb), - UINT64_C(0x5b9cca4f7763e373), UINT64_C(0x682e6ff3d6b2b8a3), - UINT64_C(0x748f82ee5defb2fc), UINT64_C(0x78a5636f43172f60), - UINT64_C(0x84c87814a1f0ab72), UINT64_C(0x8cc702081a6439ec), - UINT64_C(0x90befffa23631e28), UINT64_C(0xa4506cebde82bde9), - UINT64_C(0xbef9a3f7b2c67915), UINT64_C(0xc67178f2e372532b), - UINT64_C(0xca273eceea26619c), UINT64_C(0xd186b8c721c0c207), - UINT64_C(0xeada7dd6cde0eb1e), UINT64_C(0xf57d4f7fee6ed178), - UINT64_C(0x06f067aa72176fba), UINT64_C(0x0a637dc5a2c898a6), - UINT64_C(0x113f9804bef90dae), UINT64_C(0x1b710b35131c471b), - UINT64_C(0x28db77f523047d84), UINT64_C(0x32caab7b40c72493), - UINT64_C(0x3c9ebe0a15c9bebc), UINT64_C(0x431d67c49c100d4c), - UINT64_C(0x4cc5d4becb3e42b6), UINT64_C(0x597f299cfc657e2a), - UINT64_C(0x5fcb6fab3ad6faec), UINT64_C(0x6c44198c4a475817), -}; - -#define ROTR(x, s) (((x) >> s) | (x) << (64 - s)) - -#define Sigma0(x) (ROTR((x), 28) ^ ROTR((x), 34) ^ ROTR((x), 39)) -#define Sigma1(x) (ROTR((x), 14) ^ ROTR((x), 18) ^ ROTR((x), 41)) -#define sigma0(x) (ROTR((x), 1) ^ ROTR((x), 8) ^ ((x) >> 7)) -#define sigma1(x) (ROTR((x), 19) ^ ROTR((x), 61) ^ ((x) >> 6)) - -#define Ch(x, y, z) (((x) & (y)) ^ ((~(x)) & (z))) -#define Maj(x, y, z) (((x) & (y)) ^ ((x) & (z)) ^ ((y) & (z))) - -#define ROUND_00_15(i, a, b, c, d, e, f, g, h) \ - do { \ - T1 += h + Sigma1(e) + Ch(e, f, g) + K512[i]; \ - h = Sigma0(a) + Maj(a, b, c); \ - d += T1; \ - h += T1; \ - } while (0) - -#define ROUND_16_80(i, j, a, b, c, d, e, f, g, h, X) \ - do { \ - s0 = X[(j + 1) & 0x0f]; \ - s0 = sigma0(s0); \ - s1 = X[(j + 14) & 0x0f]; \ - s1 = sigma1(s1); \ - T1 = X[(j) & 0x0f] += s0 + s1 + X[(j + 9) & 0x0f]; \ - ROUND_00_15(i + j, a, b, c, d, e, f, g, h); \ - } while (0) - -static void sha512_block_data_order(uint64_t *state, const uint8_t *in, - size_t num) { - uint64_t a, b, c, d, e, f, g, h, s0, s1, T1; - uint64_t X[16]; - int i; - - while (num--) { - - a = state[0]; - b = state[1]; - c = state[2]; - d = state[3]; - e = state[4]; - f = state[5]; - g = state[6]; - h = state[7]; - return_state(state); // for Heapster - - T1 = X[0] = CRYPTO_load_u64_be(in); - ROUND_00_15(0, a, b, c, d, e, f, g, h); - T1 = X[1] = CRYPTO_load_u64_be(in + 8); - ROUND_00_15(1, h, a, b, c, d, e, f, g); - T1 = X[2] = CRYPTO_load_u64_be(in + 2 * 8); - ROUND_00_15(2, g, h, a, b, c, d, e, f); - T1 = X[3] = CRYPTO_load_u64_be(in + 3 * 8); - ROUND_00_15(3, f, g, h, a, b, c, d, e); - T1 = X[4] = CRYPTO_load_u64_be(in + 4 * 8); - ROUND_00_15(4, e, f, g, h, a, b, c, d); - T1 = X[5] = CRYPTO_load_u64_be(in + 5 * 8); - ROUND_00_15(5, d, e, f, g, h, a, b, c); - T1 = X[6] = CRYPTO_load_u64_be(in + 6 * 8); - ROUND_00_15(6, c, d, e, f, g, h, a, b); - T1 = X[7] = CRYPTO_load_u64_be(in + 7 * 8); - ROUND_00_15(7, b, c, d, e, f, g, h, a); - T1 = X[8] = CRYPTO_load_u64_be(in + 8 * 8); - ROUND_00_15(8, a, b, c, d, e, f, g, h); - T1 = X[9] = CRYPTO_load_u64_be(in + 9 * 8); - ROUND_00_15(9, h, a, b, c, d, e, f, g); - T1 = X[10] = CRYPTO_load_u64_be(in + 10 * 8); - ROUND_00_15(10, g, h, a, b, c, d, e, f); - T1 = X[11] = CRYPTO_load_u64_be(in + 11 * 8); - ROUND_00_15(11, f, g, h, a, b, c, d, e); - T1 = X[12] = CRYPTO_load_u64_be(in + 12 * 8); - ROUND_00_15(12, e, f, g, h, a, b, c, d); - T1 = X[13] = CRYPTO_load_u64_be(in + 13 * 8); - ROUND_00_15(13, d, e, f, g, h, a, b, c); - T1 = X[14] = CRYPTO_load_u64_be(in + 14 * 8); - ROUND_00_15(14, c, d, e, f, g, h, a, b); - T1 = X[15] = CRYPTO_load_u64_be(in + 15 * 8); - ROUND_00_15(15, b, c, d, e, f, g, h, a); - - for (i = 16; i < 80; i += 16) { - ROUND_16_80(i, 0, a, b, c, d, e, f, g, h, X); - ROUND_16_80(i, 1, h, a, b, c, d, e, f, g, X); - ROUND_16_80(i, 2, g, h, a, b, c, d, e, f, X); - ROUND_16_80(i, 3, f, g, h, a, b, c, d, e, X); - ROUND_16_80(i, 4, e, f, g, h, a, b, c, d, X); - ROUND_16_80(i, 5, d, e, f, g, h, a, b, c, X); - ROUND_16_80(i, 6, c, d, e, f, g, h, a, b, X); - ROUND_16_80(i, 7, b, c, d, e, f, g, h, a, X); - ROUND_16_80(i, 8, a, b, c, d, e, f, g, h, X); - ROUND_16_80(i, 9, h, a, b, c, d, e, f, g, X); - ROUND_16_80(i, 10, g, h, a, b, c, d, e, f, X); - ROUND_16_80(i, 11, f, g, h, a, b, c, d, e, X); - ROUND_16_80(i, 12, e, f, g, h, a, b, c, d, X); - ROUND_16_80(i, 13, d, e, f, g, h, a, b, c, X); - ROUND_16_80(i, 14, c, d, e, f, g, h, a, b, X); - ROUND_16_80(i, 15, b, c, d, e, f, g, h, a, X); - } - - state[0] += a; - state[1] += b; - state[2] += c; - state[3] += d; - state[4] += e; - state[5] += f; - state[6] += g; - state[7] += h; - - in += 16 * 8; - } -} - - -// ============================================================================ -// A definition equivalent to sha512_block_data_order which uses multiple -// functions, for use with Mr. Solver -// ============================================================================ - -static void round_00_15(uint64_t i, - uint64_t *a, uint64_t *b, uint64_t *c, uint64_t *d, - uint64_t *e, uint64_t *f, uint64_t *g, uint64_t *h, - uint64_t *T1) { - *T1 += *h + Sigma1(*e) + Ch(*e, *f, *g) + K512[i]; - *h = Sigma0(*a) + Maj(*a, *b, *c); - *d += *T1; - *h += *T1; -} - -static void round_16_80(uint64_t i, uint64_t j, - uint64_t *a, uint64_t *b, uint64_t *c, uint64_t *d, - uint64_t *e, uint64_t *f, uint64_t *g, uint64_t *h, - uint64_t *X, - uint64_t* s0, uint64_t *s1, uint64_t *T1) { - *s0 = X[(j + 1) & 0x0f]; - *s0 = sigma0(*s0); - *s1 = X[(j + 14) & 0x0f]; - *s1 = sigma1(*s1); - *T1 = X[(j) & 0x0f] += *s0 + *s1 + X[(j + 9) & 0x0f]; - round_00_15(i + j, a, b, c, d, e, f, g, h, T1); -} - -// Used in processBlock below, needed for Heapster typechecking -void return_X(uint64_t *X) { } - -static void processBlock(uint64_t *a, uint64_t *b, uint64_t *c, uint64_t *d, - uint64_t *e, uint64_t *f, uint64_t *g, uint64_t *h, - const uint8_t *in) { - uint64_t s0, s1, T1; - uint64_t X[16]; - uint64_t i; - - T1 = X[0] = CRYPTO_load_u64_be(in); - round_00_15(0, a, b, c, d, e, f, g, h, &T1); - T1 = X[1] = CRYPTO_load_u64_be(in + 8); - round_00_15(1, h, a, b, c, d, e, f, g, &T1); - T1 = X[2] = CRYPTO_load_u64_be(in + 2 * 8); - round_00_15(2, g, h, a, b, c, d, e, f, &T1); - T1 = X[3] = CRYPTO_load_u64_be(in + 3 * 8); - round_00_15(3, f, g, h, a, b, c, d, e, &T1); - T1 = X[4] = CRYPTO_load_u64_be(in + 4 * 8); - round_00_15(4, e, f, g, h, a, b, c, d, &T1); - T1 = X[5] = CRYPTO_load_u64_be(in + 5 * 8); - round_00_15(5, d, e, f, g, h, a, b, c, &T1); - T1 = X[6] = CRYPTO_load_u64_be(in + 6 * 8); - round_00_15(6, c, d, e, f, g, h, a, b, &T1); - T1 = X[7] = CRYPTO_load_u64_be(in + 7 * 8); - round_00_15(7, b, c, d, e, f, g, h, a, &T1); - T1 = X[8] = CRYPTO_load_u64_be(in + 8 * 8); - round_00_15(8, a, b, c, d, e, f, g, h, &T1); - T1 = X[9] = CRYPTO_load_u64_be(in + 9 * 8); - round_00_15(9, h, a, b, c, d, e, f, g, &T1); - T1 = X[10] = CRYPTO_load_u64_be(in + 10 * 8); - round_00_15(10, g, h, a, b, c, d, e, f, &T1); - T1 = X[11] = CRYPTO_load_u64_be(in + 11 * 8); - round_00_15(11, f, g, h, a, b, c, d, e, &T1); - T1 = X[12] = CRYPTO_load_u64_be(in + 12 * 8); - round_00_15(12, e, f, g, h, a, b, c, d, &T1); - T1 = X[13] = CRYPTO_load_u64_be(in + 13 * 8); - round_00_15(13, d, e, f, g, h, a, b, c, &T1); - T1 = X[14] = CRYPTO_load_u64_be(in + 14 * 8); - round_00_15(14, c, d, e, f, g, h, a, b, &T1); - T1 = X[15] = CRYPTO_load_u64_be(in + 15 * 8); - round_00_15(15, b, c, d, e, f, g, h, a, &T1); - - return_X(X); // for Heapster - - for (i = 16; i < 80; i += 16) { - round_16_80(i, 0, a, b, c, d, e, f, g, h, X, &s0, &s1, &T1); - round_16_80(i, 1, h, a, b, c, d, e, f, g, X, &s0, &s1, &T1); - round_16_80(i, 2, g, h, a, b, c, d, e, f, X, &s0, &s1, &T1); - round_16_80(i, 3, f, g, h, a, b, c, d, e, X, &s0, &s1, &T1); - round_16_80(i, 4, e, f, g, h, a, b, c, d, X, &s0, &s1, &T1); - round_16_80(i, 5, d, e, f, g, h, a, b, c, X, &s0, &s1, &T1); - round_16_80(i, 6, c, d, e, f, g, h, a, b, X, &s0, &s1, &T1); - round_16_80(i, 7, b, c, d, e, f, g, h, a, X, &s0, &s1, &T1); - round_16_80(i, 8, a, b, c, d, e, f, g, h, X, &s0, &s1, &T1); - round_16_80(i, 9, h, a, b, c, d, e, f, g, X, &s0, &s1, &T1); - round_16_80(i, 10, g, h, a, b, c, d, e, f, X, &s0, &s1, &T1); - round_16_80(i, 11, f, g, h, a, b, c, d, e, X, &s0, &s1, &T1); - round_16_80(i, 12, e, f, g, h, a, b, c, d, X, &s0, &s1, &T1); - round_16_80(i, 13, d, e, f, g, h, a, b, c, X, &s0, &s1, &T1); - round_16_80(i, 14, c, d, e, f, g, h, a, b, X, &s0, &s1, &T1); - round_16_80(i, 15, b, c, d, e, f, g, h, a, X, &s0, &s1, &T1); - } -} - -static void processBlocks(uint64_t *state, const uint8_t *in, size_t num) { - uint64_t a, b, c, d, e, f, g, h; - - while (num--) { - - a = state[0]; - b = state[1]; - c = state[2]; - d = state[3]; - e = state[4]; - f = state[5]; - g = state[6]; - h = state[7]; - - processBlock(&a, &b, &c, &d, &e, &f, &g, &h, in); - - state[0] += a; - state[1] += b; - state[2] += c; - state[3] += d; - state[4] += e; - state[5] += f; - state[6] += g; - state[7] += h; - - in += 16 * 8; - } -} - - -// Needed for Heapster to be able to see the static functions above -void dummy(uint64_t *state, const uint8_t *in, size_t num) { - sha512_block_data_order(state, in, num); - processBlocks(state, in, num); -} diff --git a/heapster/examples/sha512.cry b/heapster/examples/sha512.cry deleted file mode 100644 index 0181fc02f2..0000000000 --- a/heapster/examples/sha512.cry +++ /dev/null @@ -1,158 +0,0 @@ - -module SHA512 where - -import SpecPrims - -// ============================================================================ -// These definitions are modified from an outdated version of cryptol-specs's -// SHA512 implementation. -// @see https://github.com/GaloisInc/cryptol-specs/blob/4a0cc3ea4adfa5cffb1ba0fe12076389f0098eae/Primitive/Keyless/Hash/SHA512.cry -// -// The primary changes are type annotations added to SIGMA_0, SIGMA_1, -// sigma_0, and sigma_1 to get monadification to go through. -// ============================================================================ - -type w = 64 - -type j = 80 - -K : [j][w] -K = [ 0x428a2f98d728ae22, 0x7137449123ef65cd, 0xb5c0fbcfec4d3b2f, 0xe9b5dba58189dbbc, - 0x3956c25bf348b538, 0x59f111f1b605d019, 0x923f82a4af194f9b, 0xab1c5ed5da6d8118, - 0xd807aa98a3030242, 0x12835b0145706fbe, 0x243185be4ee4b28c, 0x550c7dc3d5ffb4e2, - 0x72be5d74f27b896f, 0x80deb1fe3b1696b1, 0x9bdc06a725c71235, 0xc19bf174cf692694, - 0xe49b69c19ef14ad2, 0xefbe4786384f25e3, 0x0fc19dc68b8cd5b5, 0x240ca1cc77ac9c65, - 0x2de92c6f592b0275, 0x4a7484aa6ea6e483, 0x5cb0a9dcbd41fbd4, 0x76f988da831153b5, - 0x983e5152ee66dfab, 0xa831c66d2db43210, 0xb00327c898fb213f, 0xbf597fc7beef0ee4, - 0xc6e00bf33da88fc2, 0xd5a79147930aa725, 0x06ca6351e003826f, 0x142929670a0e6e70, - 0x27b70a8546d22ffc, 0x2e1b21385c26c926, 0x4d2c6dfc5ac42aed, 0x53380d139d95b3df, - 0x650a73548baf63de, 0x766a0abb3c77b2a8, 0x81c2c92e47edaee6, 0x92722c851482353b, - 0xa2bfe8a14cf10364, 0xa81a664bbc423001, 0xc24b8b70d0f89791, 0xc76c51a30654be30, - 0xd192e819d6ef5218, 0xd69906245565a910, 0xf40e35855771202a, 0x106aa07032bbd1b8, - 0x19a4c116b8d2d0c8, 0x1e376c085141ab53, 0x2748774cdf8eeb99, 0x34b0bcb5e19b48a8, - 0x391c0cb3c5c95a63, 0x4ed8aa4ae3418acb, 0x5b9cca4f7763e373, 0x682e6ff3d6b2b8a3, - 0x748f82ee5defb2fc, 0x78a5636f43172f60, 0x84c87814a1f0ab72, 0x8cc702081a6439ec, - 0x90befffa23631e28, 0xa4506cebde82bde9, 0xbef9a3f7b2c67915, 0xc67178f2e372532b, - 0xca273eceea26619c, 0xd186b8c721c0c207, 0xeada7dd6cde0eb1e, 0xf57d4f7fee6ed178, - 0x06f067aa72176fba, 0x0a637dc5a2c898a6, 0x113f9804bef90dae, 0x1b710b35131c471b, - 0x28db77f523047d84, 0x32caab7b40c72493, 0x3c9ebe0a15c9bebc, 0x431d67c49c100d4c, - 0x4cc5d4becb3e42b6, 0x597f299cfc657e2a, 0x5fcb6fab3ad6faec, 0x6c44198c4a475817] - -SIGMA_0 : [w] -> [w] -SIGMA_0 x = (x >>> (28 : [w])) ^ (x >>> (34 : [w])) ^ (x >>> (39 : [w])) - -SIGMA_1 : [w] -> [w] -SIGMA_1 x = (x >>> (14 : [w])) ^ (x >>> (18 : [w])) ^ (x >>> (41 : [w])) - -sigma_0 : [w] -> [w] -sigma_0 x = (x >>> (1 : [w])) ^ (x >>> (8 : [w])) ^ (x >> (7 : [w])) - -sigma_1 : [w] -> [w] -sigma_1 x = (x >>> (19 : [w])) ^ (x >>> (61 : [w])) ^ (x >> (6 : [w])) - - -// ============================================================================ -// Definitions from an outdated common module for SHA. -// @see https://github.com/GaloisInc/cryptol-specs/blob/4a0cc3ea4adfa5cffb1ba0fe12076389f0098eae/Primitive/Keyless/Hash/SHA.cry -// ============================================================================ - -Ch : [w] -> [w] -> [w] -> [w] -Ch x y z = (x && y) ^ (~x && z) - -Maj : [w] -> [w] -> [w] -> [w] -Maj x y z = (x && y) ^ (x && z) ^ (y && z) - - -// ============================================================================ -// Cryptol functions which closely match the definitions in sha512.c -// ============================================================================ - -round_00_15_spec : [w] -> - [w] -> [w] -> [w] -> [w] -> [w] -> [w] -> [w] -> [w] -> - [w] -> - ([w], [w], [w], [w], [w], [w], [w], [w], [w]) -round_00_15_spec i a b c d e f g h T1 = - (a, b, c, d', e, f, g, h', T1') - where T1' = T1 + h + SIGMA_1 e + Ch e f g + K @ i - d' = d + T1' - h' = SIGMA_0 a + Maj a b c + T1' - -round_16_80_spec : [w] -> [w] -> - [w] -> [w] -> [w] -> [w] -> [w] -> [w] -> [w] -> [w] -> - [16][w] -> [w] -> - ([w], [w], [w], [w], [w], [w], [w], [w], [16][w], [w], [w], [w]) -round_16_80_spec i j a b c d e f g h X T1 = - (a', b', c', d', e', f', g', h', X', s0', s1', T1'') - where s0' = sigma_0 (X @ ((j + 1) && 15)) - s1' = sigma_1 (X @ ((j + 14) && 15)) - T1' = (X @ (j && 15)) + s0' + s1' + (X @ ((j + 9) && 15)) - X' = update X (j && 15) T1' - (a', b', c', d', e', f', g', h', T1'') = - round_00_15_spec (i + j) a b c d e f g h T1' - -processBlock_spec : [w] -> [w] -> [w] -> [w] -> [w] -> [w] -> [w] -> [w] -> - [16][w] -> - ([w], [w], [w], [w], [w], [w], [w], [w], [16][w]) -processBlock_spec a b c d e f g h in = - processBlock_loop_spec 16 aF bF cF dF eF fF gF hF X T1 in - where (a0,b0,c0,d0,e0,f0,g0,h0,_) = round_00_15_spec 0 a b c d e f g h (in @ ( 0 : [w])) - (h1,a1,b1,c1,d1,e1,f1,g1,_) = round_00_15_spec 1 h0 a0 b0 c0 d0 e0 f0 g0 (in @ ( 1 : [w])) - (g2,h2,a2,b2,c2,d2,e2,f2,_) = round_00_15_spec 2 g1 h1 a1 b1 c1 d1 e1 f1 (in @ ( 2 : [w])) - (f3,g3,h3,a3,b3,c3,d3,e3,_) = round_00_15_spec 3 f2 g2 h2 a2 b2 c2 d2 e2 (in @ ( 3 : [w])) - (e4,f4,g4,h4,a4,b4,c4,d4,_) = round_00_15_spec 4 e3 f3 g3 h3 a3 b3 c3 d3 (in @ ( 4 : [w])) - (d5,e5,f5,g5,h5,a5,b5,c5,_) = round_00_15_spec 5 d4 e4 f4 g4 h4 a4 b4 c4 (in @ ( 5 : [w])) - (c6,d6,e6,f6,g6,h6,a6,b6,_) = round_00_15_spec 6 c5 d5 e5 f5 g5 h5 a5 b5 (in @ ( 6 : [w])) - (b7,c7,d7,e7,f7,g7,h7,a7,_) = round_00_15_spec 7 b6 c6 d6 e6 f6 g6 h6 a6 (in @ ( 7 : [w])) - (a8,b8,c8,d8,e8,f8,g8,h8,_) = round_00_15_spec 8 a7 b7 c7 d7 e7 f7 g7 h7 (in @ ( 8 : [w])) - (h9,a9,b9,c9,d9,e9,f9,g9,_) = round_00_15_spec 9 h8 a8 b8 c8 d8 e8 f8 g8 (in @ ( 9 : [w])) - (gA,hA,aA,bA,cA,dA,eA,fA,_) = round_00_15_spec 10 g9 h9 a9 b9 c9 d9 e9 f9 (in @ (10 : [w])) - (fB,gB,hB,aB,bB,cB,dB,eB,_) = round_00_15_spec 11 fA gA hA aA bA cA dA eA (in @ (11 : [w])) - (eC,fC,gC,hC,aC,bC,cC,dC,_) = round_00_15_spec 12 eB fB gB hB aB bB cB dB (in @ (12 : [w])) - (dD,eD,fD,gD,hD,aD,bD,cD,_) = round_00_15_spec 13 dC eC fC gC hC aC bC cC (in @ (13 : [w])) - (cE,dE,eE,fE,gE,hE,aE,bE,_) = round_00_15_spec 14 cD dD eD fD gD hD aD bD (in @ (14 : [w])) - (bF,cF,dF,eF,fF,gF,hF,aF,T1) = round_00_15_spec 15 bE cE dE eE fE gE hE aE (in @ (15 : [w])) - X = [in @ ( 0 : [w]), in @ ( 1 : [w]), in @ ( 2 : [w]), in @ ( 3 : [w]), - in @ ( 4 : [w]), in @ ( 5 : [w]), in @ ( 6 : [w]), in @ ( 7 : [w]), - in @ ( 8 : [w]), in @ ( 9 : [w]), in @ (10 : [w]), in @ (11 : [w]), - in @ (12 : [w]), in @ (13 : [w]), in @ (14 : [w]), in @ (15 : [w])] - -processBlock_loop_spec : [w] -> - [w] -> [w] -> [w] -> [w] -> [w] -> [w] -> [w] -> [w] -> - [16][w] -> [w] -> [16][w] -> - ([w], [w], [w], [w], [w], [w], [w], [w], [16][w]) -processBlock_loop_spec i a b c d e f g h X T1 in = - if i < 80 then processBlock_loop_spec (i+16) aF bF cF dF eF fF gF hF XF T1F in - else (a,b,c,d,e,f,g,h,in) - where (a0,b0,c0,d0,e0,f0,g0,h0,X0,_,_,T10) = round_16_80_spec i 0 a b c d e f g h X T1 - (h1,a1,b1,c1,d1,e1,f1,g1,X1,_,_,T11) = round_16_80_spec i 1 h0 a0 b0 c0 d0 e0 f0 g0 X0 T10 - (g2,h2,a2,b2,c2,d2,e2,f2,X2,_,_,T12) = round_16_80_spec i 2 g1 h1 a1 b1 c1 d1 e1 f1 X1 T11 - (f3,g3,h3,a3,b3,c3,d3,e3,X3,_,_,T13) = round_16_80_spec i 3 f2 g2 h2 a2 b2 c2 d2 e2 X2 T12 - (e4,f4,g4,h4,a4,b4,c4,d4,X4,_,_,T14) = round_16_80_spec i 4 e3 f3 g3 h3 a3 b3 c3 d3 X3 T13 - (d5,e5,f5,g5,h5,a5,b5,c5,X5,_,_,T15) = round_16_80_spec i 5 d4 e4 f4 g4 h4 a4 b4 c4 X4 T14 - (c6,d6,e6,f6,g6,h6,a6,b6,X6,_,_,T16) = round_16_80_spec i 6 c5 d5 e5 f5 g5 h5 a5 b5 X5 T15 - (b7,c7,d7,e7,f7,g7,h7,a7,X7,_,_,T17) = round_16_80_spec i 7 b6 c6 d6 e6 f6 g6 h6 a6 X6 T16 - (a8,b8,c8,d8,e8,f8,g8,h8,X8,_,_,T18) = round_16_80_spec i 8 a7 b7 c7 d7 e7 f7 g7 h7 X7 T17 - (h9,a9,b9,c9,d9,e9,f9,g9,X9,_,_,T19) = round_16_80_spec i 9 h8 a8 b8 c8 d8 e8 f8 g8 X8 T18 - (gA,hA,aA,bA,cA,dA,eA,fA,XA,_,_,T1A) = round_16_80_spec i 10 g9 h9 a9 b9 c9 d9 e9 f9 X9 T19 - (fB,gB,hB,aB,bB,cB,dB,eB,XB,_,_,T1B) = round_16_80_spec i 11 fA gA hA aA bA cA dA eA XA T1A - (eC,fC,gC,hC,aC,bC,cC,dC,XC,_,_,T1C) = round_16_80_spec i 12 eB fB gB hB aB bB cB dB XB T1B - (dD,eD,fD,gD,hD,aD,bD,cD,XD,_,_,T1D) = round_16_80_spec i 13 dC eC fC gC hC aC bC cC XC T1C - (cE,dE,eE,fE,gE,hE,aE,bE,XE,_,_,T1E) = round_16_80_spec i 14 cD dD eD fD gD hD aD bD XD T1D - (bF,cF,dF,eF,fF,gF,hF,aF,XF,_,_,T1F) = round_16_80_spec i 15 bE cE dE eE fE gE hE aE XE T1E - -processBlocks_spec : {n} Literal n [64] => [8][w] -> [16*n][w] -> - ([8][w], [16*n][w]) -processBlocks_spec state in = processBlocks_loop_spec 0 `n state in - -processBlocks_loop_spec : {n} Literal n [64] => [w] -> [w] -> [8][w] -> - [16*n][w] -> ([8][w], [16*n][w]) -processBlocks_loop_spec i j state in = invariantHint (i + j == `n) ( - if j != 0 then processBlocks_loop_spec (i+1) (j-1) state' in - else (state, in)) - where (a,b,c,d,e,f,g,h) = (state @ ( 0 : [w]), state @ ( 1 : [w]), - state @ ( 2 : [w]), state @ ( 3 : [w]), - state @ ( 4 : [w]), state @ ( 5 : [w]), - state @ ( 6 : [w]), state @ ( 7 : [w])) - in_i = split in @ i - (a',b',c',d',e',f',g',h',_) = processBlock_spec a b c d e f g h in_i - state' = [a', b', c', d', e', f', g', h'] diff --git a/heapster/examples/sha512.saw b/heapster/examples/sha512.saw deleted file mode 100644 index d5968649d6..0000000000 --- a/heapster/examples/sha512.saw +++ /dev/null @@ -1,82 +0,0 @@ -enable_experimental; -env <- heapster_init_env "SHA512" "sha512.bc"; - -// heapster_set_debug_level env 1; - -heapster_define_perm env "int64" " " "llvmptr 64" "exists x:bv 64.eq(llvmword(x))"; -heapster_define_perm env "int32" " " "llvmptr 32" "exists x:bv 32.eq(llvmword(x))"; -heapster_define_perm env "int8" " " "llvmptr 8" "exists x:bv 8.eq(llvmword(x))"; - -// FIXME: We always have rw=W, but without the rw arguments below Heapster -// doesn't realize the perm is not copyable (it needs to unfold named perms). -heapster_define_perm env "int64_ptr" "rw:rwmodality" "llvmptr 64" "ptr((rw,0) |-> int64<>)"; -heapster_define_perm env "true_ptr" "rw:rwmodality" "llvmptr 64" "ptr((rw,0) |-> true)"; - -heapster_assume_fun env "CRYPTO_load_u64_be" - "(). arg0:ptr((R,0) |-> int64<>) -o \ - \ arg0:ptr((R,0) |-> int64<>), ret:int64<>" - "\\ (x:Vec 64 Bool) -> retS VoidEv (Vec 64 Bool * Vec 64 Bool) (x, x)"; - -/* -heapster_typecheck_fun env "return_state" - "(). arg0:array(W,0,<8,*8,fieldsh(int64<>)) -o \ - \ arg0:array(W,0,<8,*8,fieldsh(int64<>))"; - -heapster_set_translation_checks env false; -heapster_typecheck_fun env "sha512_block_data_order" - "(num:bv 64). arg0:array(W,0,<8,*8,fieldsh(int64<>)), \ - \ arg1:array(R,0,<16*num,*8,fieldsh(int64<>)), \ - \ arg2:eq(llvmword(num)) -o \ - \ arg0:array(W,0,<8,*8,fieldsh(int64<>)), \ - \ arg1:array(R,0,<16*num,*8,fieldsh(int64<>)), \ - \ arg2:true, ret:true"; -*/ - -heapster_typecheck_fun env "round_00_15" - "(). arg0:int64<>, \ - \ arg1:int64_ptr, arg2:int64_ptr, arg3:int64_ptr, arg4:int64_ptr, \ - \ arg5:int64_ptr, arg6:int64_ptr, arg7:int64_ptr, arg8:int64_ptr, \ - \ arg9:int64_ptr -o \ - \ arg1:int64_ptr, arg2:int64_ptr, arg3:int64_ptr, arg4:int64_ptr, \ - \ arg5:int64_ptr, arg6:int64_ptr, arg7:int64_ptr, arg8:int64_ptr, \ - \ arg9:int64_ptr, ret:true"; - -heapster_typecheck_fun env "round_16_80" - "(). arg0:int64<>, arg1:int64<>, \ - \ arg2:int64_ptr, arg3:int64_ptr, arg4:int64_ptr, arg5:int64_ptr, \ - \ arg6:int64_ptr, arg7:int64_ptr, arg8:int64_ptr, arg9:int64_ptr, \ - \ arg10:array(W,0,<16,*8,fieldsh(int64<>)), \ - \ arg11:true_ptr, arg12:true_ptr, arg13:int64_ptr -o \ - \ arg2:int64_ptr, arg3:int64_ptr, arg4:int64_ptr, arg5:int64_ptr, \ - \ arg6:int64_ptr, arg7:int64_ptr, arg8:int64_ptr, arg9:int64_ptr, \ - \ arg10:array(W,0,<16,*8,fieldsh(int64<>)), \ - \ arg11:int64_ptr, arg12:int64_ptr, arg13:int64_ptr, ret:true"; - -heapster_typecheck_fun env "return_X" - "(). arg0:array(W,0,<16,*8,fieldsh(int64<>)) -o \ - \ arg0:array(W,0,<16,*8,fieldsh(int64<>))"; - -heapster_set_translation_checks env false; -heapster_typecheck_fun env "processBlock" - "(). arg0:int64_ptr, arg1:int64_ptr, arg2:int64_ptr, \ - \ arg3:int64_ptr, arg4:int64_ptr, arg5:int64_ptr, \ - \ arg6:int64_ptr, arg7:int64_ptr, \ - \ arg8:array(R,0,<16,*8,fieldsh(int64<>)) -o \ - \ arg0:int64_ptr, arg1:int64_ptr, arg2:int64_ptr, \ - \ arg3:int64_ptr, arg4:int64_ptr, arg5:int64_ptr, \ - \ arg6:int64_ptr, arg7:int64_ptr, \ - \ arg8:array(R,0,<16,*8,fieldsh(int64<>)), ret:true"; - -// FIXME: panics with "Cannot translate BV propositions to type descriptions" -/* -heapster_set_translation_checks env false; -heapster_typecheck_fun env "processBlocks" - "(num:bv 64). arg0:array(W,0,<8,*8,fieldsh(int64<>)), \ - \ arg1:(num )), \ - \ arg2:eq(llvmword(num)) -o \ - \ arg0:array(W,0,<8,*8,fieldsh(int64<>)), \ - \ arg1:array(R,0,<16*num,*8,fieldsh(int64<>)), \ - \ arg2:true, ret:true"; -*/ - -heapster_export_coq env "sha512_gen.v"; diff --git a/heapster/examples/sha512_mr_solver.saw b/heapster/examples/sha512_mr_solver.saw deleted file mode 100644 index 5a41fd28a8..0000000000 --- a/heapster/examples/sha512_mr_solver.saw +++ /dev/null @@ -1,33 +0,0 @@ -include "sha512.saw"; - -let round_00_15= parse_core_mod "SHA512" "round_00_15"; -let round_16_80 = parse_core_mod "SHA512" "round_16_80"; -let processBlock = parse_core_mod "SHA512" "processBlock"; -let processBlocks = parse_core_mod "SHA512" "processBlocks"; - -// Test that every function refines itself -// prove_extcore mrsolver (refines [] processBlocks processBlocks); -// prove_extcore mrsolver (refines [] processBlock processBlock); -// prove_extcore mrsolver (refines [] round_16_80 round_16_80); -// prove_extcore mrsolver (refines [] round_00_15 round_00_15); - -import "sha512.cry"; - -thm_round_00_15 <- - prove_extcore mrsolver (refines [] round_00_15 {{ round_00_15_spec }}); - -thm_round_16_80 <- - prove_extcore - (mrsolver_with (addrefns [thm_round_00_15] empty_rs)) - (refines [] round_16_80 {{ round_16_80_spec }}); - -thm_processBlock <- - prove_extcore - (mrsolver_with (addrefns [thm_round_00_15, thm_round_16_80] empty_rs)) - (refines [] processBlock {{ processBlock_spec }}); - -// thm_processBlocks <- -// prove_extcore -// (mrsolver_with (addrefns [thm_processBlock] empty_rs)) -// (refines [] processBlocks {{ processBlocks_spec }}); - diff --git a/heapster/examples/sha512_proofs.v b/heapster/examples/sha512_proofs.v deleted file mode 100644 index ad4fd7101b..0000000000 --- a/heapster/examples/sha512_proofs.v +++ /dev/null @@ -1,15 +0,0 @@ -From Coq Require Import Program.Basics. -From Coq Require Import Lists.List. -From Coq Require Import String. -From Coq Require Import Vectors.Vector. -From CryptolToCoq Require Import SAWCoreScaffolding. -From CryptolToCoq Require Import SAWCoreVectorsAsCoqVectors. -From CryptolToCoq Require Import SAWCoreBitvectors. - -From CryptolToCoq Require Import SAWCorePrelude. -From CryptolToCoq Require Import CompMExtra. - -Import SAWCorePrelude. - -Require Import Examples.sha512_gen. -Import SHA512. diff --git a/heapster/examples/specPrims.saw b/heapster/examples/specPrims.saw deleted file mode 100644 index ea8a818159..0000000000 --- a/heapster/examples/specPrims.saw +++ /dev/null @@ -1,9 +0,0 @@ -/* Helper SAW script for using specification primitives in Cryptol */ - -import "SpecPrims.cry"; - -set_monadification "exists" "SpecM.existsS" true; -set_monadification "forall" "SpecM.forallS" true; -set_monadification "asserting" "SpecM.asserting" true; -set_monadification "assuming" "SpecM.assuming" true; -set_monadification "invariantHint" "SpecM.invariantHint" true; diff --git a/heapster/examples/string_set.bc b/heapster/examples/string_set.bc deleted file mode 100644 index bd1f3fd6a1..0000000000 Binary files a/heapster/examples/string_set.bc and /dev/null differ diff --git a/heapster/examples/string_set.c b/heapster/examples/string_set.c deleted file mode 100644 index a09c85dcb9..0000000000 --- a/heapster/examples/string_set.c +++ /dev/null @@ -1,17 +0,0 @@ -#include -#include - -struct string; -typedef struct string string; - -struct string_set; -typedef struct string_set string_set; - -extern string_set *string_set_empty (); -extern void string_set_insert (string_set *set, string *str); -extern void string_set_remove (string_set *set, string *str); - -void insert_remove (string_set *set, string *str1, string *str2) { - string_set_insert (set, str1); - string_set_remove (set, str2); -} diff --git a/heapster/examples/string_set.saw b/heapster/examples/string_set.saw deleted file mode 100644 index e52debc6a2..0000000000 --- a/heapster/examples/string_set.saw +++ /dev/null @@ -1,44 +0,0 @@ -enable_experimental; - -// Create a Heapster environment from a SAW core file -env <- heapster_init_env_from_file "string_set.sawcore" "string_set.bc"; - - -// Define permissions for strings and for lists being used as sets -heapster_define_opaque_perm env "string" "" "llvmptr 64" "StringTp" "StringDesc"; - - -heapster_define_opaque_perm env "string_set" "rw:rwmodality, l:lifetime" "llvmptr 64" - "StringList" "StringListDesc"; - -// The old way -// heapster_define_opaque_perm env "string_set" "rw:rwmodality, l:lifetime" "llvmptr 64" "StringSet.stringList"; - -// FIXME: update all of these to work with StringTp and StringList -/* -heapster_assume_fun env "string_set_insert" - "(l1:lifetime). arg0:string_set, arg1:string<> -o \ - \ arg0:string_set, arg1:true, ret:true" - "listInsertM String"; -heapster_assume_fun env "string_set_remove" - "(l1:lifetime).arg0:string_set, arg1:string<> -o \ - \ arg0:string_set, arg1:string<>, ret:true" - "listRemoveM String equalString"; - -// The old way: we have to define names to use the functions above -// heapster_assume_fun env "string_set_insert" -// "(l1:lifetime). arg0:string_set, arg1:string<> -o \ -// \ arg0:string_set, arg1:true, ret:true" -// "stringListInsertM"; -// heapster_assume_fun env "string_set_remove" -// "(l1:lifetime). arg0:string_set, arg1:string<> -o \ -// \ arg0:string_set, arg1:string<>, ret:true" -// "stringListRemoveM"; - -// Type-check our insert_remove function -heapster_typecheck_fun env "insert_remove" - "(l:lifetime). arg0:string_set, arg1:string<>, arg2:string<> -o \ - \ arg0:string_set, arg1:true, arg2:string<>"; -*/ - -heapster_export_coq env "string_set_gen.v"; diff --git a/heapster/examples/string_set.sawcore b/heapster/examples/string_set.sawcore deleted file mode 100644 index 3b701208d9..0000000000 --- a/heapster/examples/string_set.sawcore +++ /dev/null @@ -1,61 +0,0 @@ - -module string_set where - -import SpecM; - --- A type description for a string represented as a list of 8-bit characters -StringDesc : TpDesc; -StringDesc = Tp_Ind (Tp_Sum Tp_Unit (Tp_Pair (Tp_bitvector 8) (Tp_Var 0))); - --- The type that StringDesc describes -StringTp : sort 0; -StringTp = indElem (Tp_Sum Tp_Unit (Tp_Pair (Tp_bitvector 8) StringDesc)); - --- A type description for a list of strings -StringListDesc : TpDesc; -StringListDesc = Tp_Ind (Tp_Sum Tp_Unit (Tp_Pair StringDesc (Tp_Var 0))); - --- The type that StringDesc describes -StringList : sort 0; -StringList = indElem (Tp_Sum Tp_Unit (Tp_Pair StringDesc StringListDesc)); - - -listInsertM : (a : sort 0) -> List a -> a -> SpecM VoidEv (List a); -listInsertM a l s = retS VoidEv (List a) (Cons a s l); - -listRemoveM : (a : sort 0) -> (a -> a -> Bool) -> List a -> a -> - SpecM VoidEv (List a * a); -listRemoveM a test_eq l s = - retS - VoidEv - (List a * a) - (List__rec - a (\ (_:List a) -> List a) - (Nil a) - (\ (s':a) (_:List a) (rec:List a) -> - ite (List a) (test_eq s s') rec (Cons a s' rec)) - l, - s); - ----------------------------------------------------------------------- --- Helper defs for Heapster examples - -stringList : sort 0; -stringList = List String; - -stringListInsertM : List String -> String -> SpecM VoidEv (List String); -stringListInsertM l s = retS VoidEv (List String) (Cons String s l); - -stringListRemoveM : List String -> String -> - SpecM VoidEv (stringList * String); -stringListRemoveM l s = - retS - VoidEv - (stringList * String) - (List__rec - String (\ (_:List String) -> List String) - (Nil String) - (\ (s':String) (_:List String) (rec:List String) -> - ite (List String) (equalString s s') rec (Cons String s' rec)) - l, - s); diff --git a/heapster/examples/string_set_proofs.v b/heapster/examples/string_set_proofs.v deleted file mode 100644 index 3680f106ce..0000000000 --- a/heapster/examples/string_set_proofs.v +++ /dev/null @@ -1,14 +0,0 @@ -From Coq Require Import Lists.List. -From Coq Require Import String. -From Coq Require Import Vectors.Vector. -From CryptolToCoq Require Import SAWCoreScaffolding. -From CryptolToCoq Require Import SAWCoreVectorsAsCoqVectors. - -From CryptolToCoq Require Import SAWCorePrelude. -From CryptolToCoq Require Import CompMExtra. - -Require Import Examples.string_set_gen. -Import string_set. -Import SAWCorePrelude. - -(* Print insert_remove__tuple_fun. *) diff --git a/heapster/examples/tutorial_c.bc b/heapster/examples/tutorial_c.bc deleted file mode 100644 index 116253b968..0000000000 Binary files a/heapster/examples/tutorial_c.bc and /dev/null differ diff --git a/heapster/examples/tutorial_c.c b/heapster/examples/tutorial_c.c deleted file mode 100644 index 02e4f6d750..0000000000 --- a/heapster/examples/tutorial_c.c +++ /dev/null @@ -1,17 +0,0 @@ -#include - -// Simple function that adds it's two inputs. -uint64_t add (uint64_t x, uint64_t y) { return x + y; } - -// A copy of `add`, that we will use to miss-type a function -uint64_t add_mistyped (uint64_t x, uint64_t y) { return x + y; } - -// Simple function that increments the value in a pointer -void incr_ptr (uint64_t *x) { *x += 1; } - -// Struct that represents the three coordinates for a 3D vector -typedef struct { uint64_t x; uint64_t y; uint64_t z; } vector3d; - -// function that computes the norm of a 3D vector -// || (x,y,z) || = x^2+y^2+z^2 -uint64_t norm_vector (vector3d *v) { return (v->x * v->x + v->y * v->y + v->z * v->z); } diff --git a/heapster/examples/tutorial_c.saw b/heapster/examples/tutorial_c.saw deleted file mode 100644 index 32a1c47454..0000000000 --- a/heapster/examples/tutorial_c.saw +++ /dev/null @@ -1,23 +0,0 @@ -enable_experimental; -env <- heapster_init_env "tutorial_c" "tutorial_c.bc"; -print "File loaded"; - -heapster_define_perm env "int64" " " "llvmptr 64" "exists x:bv 64.eq(llvmword(x))"; -heapster_typecheck_fun env "add" "().arg0:int64<>, arg1:int64<> -o arg0:true, arg1:true, ret:int64<>"; -print "Type checked add."; - -heapster_typecheck_fun env "add_mistyped" "().arg0:true, arg1:int64<> -o arg0:true, arg1:true, ret:int64<>"; -print "Type checked add_mistyped. This will produce an error in the output."; - -heapster_typecheck_fun env "incr_ptr" "(). arg0:ptr((W,0) |-> int64<>) -o arg0:ptr((W,0) |-> int64<>)"; -print "Type checked incr_ptr."; - -heapster_define_perm env "vec3d" "rw:rwmodality" "llvmptr 64" "ptr((rw,0) |-> int64<>) * ptr((rw,8) |-> int64<>) * ptr((rw,16) |-> int64<>)"; -heapster_typecheck_fun env "norm_vector" "(). arg0:vec3d -o arg0:vec3d, ret:int64<>"; -print "Type checked norm_vector."; - -heapster_export_coq env "tutorial_c_gen.v"; -print "Export to Coq."; - -print "Done."; - diff --git a/heapster/examples/tutorial_c.v b/heapster/examples/tutorial_c.v deleted file mode 100644 index c854be4cf3..0000000000 --- a/heapster/examples/tutorial_c.v +++ /dev/null @@ -1,29 +0,0 @@ - -(** Mandatory imports from saw-core-coq *) -From Coq Require Import Lists.List. -From Coq Require Import String. -From Coq Require Import Vectors.Vector. -From CryptolToCoq Require Import SAWCoreScaffolding. -From CryptolToCoq Require Import SAWCoreVectorsAsCoqVectors. -Import ListNotations. - -(** Post-preamble section specified by you *) -From CryptolToCoq Require Import SAWCorePrelude. -From CryptolToCoq Require Import SAWCoreBitvectors. - -(** Code generated by saw-core-coq *) - -Module tutorial_c. - -Definition add__tuple_fun : CompM.lrtTupleType (CompM.LRT_Cons (CompM.LRT_Fun (SAWCoreVectorsAsCoqVectors.Vec 64 SAWCoreScaffolding.Bool) (fun (perm0 : SAWCoreVectorsAsCoqVectors.Vec 64 SAWCoreScaffolding.Bool) => let var__0 := SAWCoreVectorsAsCoqVectors.Vec 64 SAWCoreScaffolding.Bool in - CompM.LRT_Fun var__0 (fun (perm1 : var__0) => CompM.LRT_Ret (SAWCoreVectorsAsCoqVectors.Vec 64 SAWCoreScaffolding.Bool)))) CompM.LRT_Nil) := - @CompM.multiFixM (CompM.LRT_Cons (CompM.LRT_Fun (SAWCoreVectorsAsCoqVectors.Vec 64 SAWCoreScaffolding.Bool) (fun (perm0 : SAWCoreVectorsAsCoqVectors.Vec 64 SAWCoreScaffolding.Bool) => let var__0 := SAWCoreVectorsAsCoqVectors.Vec 64 SAWCoreScaffolding.Bool in - CompM.LRT_Fun var__0 (fun (perm1 : var__0) => CompM.LRT_Ret (SAWCoreVectorsAsCoqVectors.Vec 64 SAWCoreScaffolding.Bool)))) CompM.LRT_Nil) (fun (add : CompM.lrtToType (CompM.LRT_Fun (SAWCoreVectorsAsCoqVectors.Vec 64 SAWCoreScaffolding.Bool) (fun (perm0 : SAWCoreVectorsAsCoqVectors.Vec 64 SAWCoreScaffolding.Bool) => let var__0 := SAWCoreVectorsAsCoqVectors.Vec 64 SAWCoreScaffolding.Bool in - CompM.LRT_Fun var__0 (fun (perm1 : var__0) => CompM.LRT_Ret (SAWCoreVectorsAsCoqVectors.Vec 64 SAWCoreScaffolding.Bool))))) => pair (fun (p0 : SAWCoreVectorsAsCoqVectors.Vec 64 SAWCoreScaffolding.Bool) (p1 : SAWCoreVectorsAsCoqVectors.Vec 64 SAWCoreScaffolding.Bool) => let var__0 := SAWCoreVectorsAsCoqVectors.Vec 64 SAWCoreScaffolding.Bool in - @CompM.letRecM CompM.LRT_Nil var__0 tt (@returnM CompM _ var__0 (SAWCoreVectorsAsCoqVectors.bvAdd 64 p0 p1))) tt). - -Definition add : CompM.lrtToType (CompM.LRT_Fun (SAWCoreVectorsAsCoqVectors.Vec 64 SAWCoreScaffolding.Bool) (fun (perm0 : SAWCoreVectorsAsCoqVectors.Vec 64 SAWCoreScaffolding.Bool) => let var__0 := SAWCoreVectorsAsCoqVectors.Vec 64 SAWCoreScaffolding.Bool in - CompM.LRT_Fun var__0 (fun (perm1 : var__0) => CompM.LRT_Ret (SAWCoreVectorsAsCoqVectors.Vec 64 SAWCoreScaffolding.Bool)))) := - SAWCoreScaffolding.fst add__tuple_fun. - -End tutorial_c. diff --git a/heapster/examples/tutorial_c_proofs.v b/heapster/examples/tutorial_c_proofs.v deleted file mode 100644 index 099e4cfda4..0000000000 --- a/heapster/examples/tutorial_c_proofs.v +++ /dev/null @@ -1,45 +0,0 @@ -From CryptolToCoq Require Import SAWCoreScaffolding. -From CryptolToCoq Require Import SAWCoreScaffolding. -From CryptolToCoq Require Import SAWCoreVectorsAsCoqVectors. -From CryptolToCoq Require Import SAWCoreBitvectors. -From CryptolToCoq Require Import SAWCorePrelude. - -(* The following 2 lines enables pretty printing*) -From CryptolToCoq Require Import CompMExtra. -Import CompMExtraNotation. Open Scope fun_syntax. - -(* The following 2 lines allows better automatio*) -Require Import Examples.common. -Require Import Coq.Program.Tactics. - -Require Import Examples.tutorial_c_gen. -Import tutorial_c. - -Lemma no_errors_add (x y: bitvector 64) : - spec_refines_eq (add x y) (safety_spec (x,y)). -Proof. solve_trivial_spec 0 0. Qed. - -Lemma no_errors_add_mistyped (x: bitvector 64) : - spec_refines_eq (add_mistyped x) (safety_spec (x)). -Proof. solve_trivial_spec 0 0. - -(* After rewriting the terms for clarity, you can see the - remaining goal says that an `ErrorS` is a refinement of - `RetS`. In other words, it's trying to prove that a trivially - pure function has an error. That's obviously false. *) - clarify_goal_tutorial. -Abort. - -Lemma no_errors_incr_ptr (x: bitvector 64) : - spec_refines_eq (incr_ptr x) (safety_spec x). -Proof. solve_trivial_spec 0 0. Qed. - -Lemma no_errors_norm_vector (x y z: bitvector 64) : - spec_refines_eq (norm_vector x y z) (safety_spec (x, y, z)). -Proof. solve_trivial_spec 0 0. - - (* The remaining goal, is to show that if initial arguments are - equal (for both specs) then at the end of the execution, they - are also equal.*) - destruct_conjs; subst; reflexivity. -Qed. diff --git a/heapster/examples/xor_swap.bc b/heapster/examples/xor_swap.bc deleted file mode 100644 index bf8aca588e..0000000000 Binary files a/heapster/examples/xor_swap.bc and /dev/null differ diff --git a/heapster/examples/xor_swap.c b/heapster/examples/xor_swap.c deleted file mode 100644 index 8baa6e3a71..0000000000 --- a/heapster/examples/xor_swap.c +++ /dev/null @@ -1,8 +0,0 @@ -#include -#include - -void xor_swap(uint64_t *x, uint64_t *y) { - *x = *x ^ *y; - *y = *x ^ *y; - *x = *x ^ *y; -} diff --git a/heapster/examples/xor_swap.saw b/heapster/examples/xor_swap.saw deleted file mode 100644 index b187001b7b..0000000000 --- a/heapster/examples/xor_swap.saw +++ /dev/null @@ -1,11 +0,0 @@ -enable_experimental; -env <- heapster_init_env "xor_swap" "xor_swap.bc"; - -// Integer types -heapster_define_perm env "int64" " " "llvmptr 64" "exists x:bv 64.eq(llvmword(x))"; - -heapster_typecheck_fun env "xor_swap" - "(). arg0: ptr((W,0) |-> int64<>), arg1: ptr((W,0) |-> int64<>) -o \ - \ arg0: ptr((W,0) |-> int64<>), arg1: ptr((W,0) |-> int64<>), ret:true"; - -heapster_export_coq env "xor_swap_gen.v"; diff --git a/heapster/examples/xor_swap_proofs.v b/heapster/examples/xor_swap_proofs.v deleted file mode 100644 index 1736f00e92..0000000000 --- a/heapster/examples/xor_swap_proofs.v +++ /dev/null @@ -1,57 +0,0 @@ -From Coq Require Import Lists.List. -From Coq Require Import String. -From Coq Require Import Vectors.Vector. -From CryptolToCoq Require Import SAWCoreScaffolding. -From CryptolToCoq Require Import SAWCoreVectorsAsCoqVectors. -From CryptolToCoq Require Import SAWCoreBitvectors. - -From CryptolToCoq Require Import SAWCorePrelude. -From EnTree Require Import Automation. - -Require Import Examples.common. -Require Import Examples.xor_swap_gen. -Import xor_swap. - -Set Bullet Behavior "Strict Subproofs". - -Definition xor_swap_spec (x1 x2: bitvector 64) := (x2, x1). -Arguments xor_swap_spec /. - - -(* First prove safety (i.e. no errors) *) -Lemma xor_swap_not_error (x y: bitvector 64) : - spec_refines_eq (xor_swap x y) (safety_spec (x,y)). -Proof. solve_trivial_spec 0 0. Qed. - -Local Hint Extern 10 (spec_refines eqPreRel eqPostRel eq (xor_swap _ _) _) => - simple apply xor_swap_not_error: refine_proofs. - - -(* | Nice notation for better reading in this file*) -Local Infix "^^" := (SAWCorePrelude.bvXor 64) (at level 30). -Lemma bvXor_twice_l: - forall x1 x2 : bitvector 64, x2 ^^ (x2 ^^ x1) = x1. -Proof. - intros; rewrite bvXor_assoc, bvXor_same, bvXor_comm, bvXor_zero. - reflexivity. -Qed. - -Lemma bvXor_twice_r: - forall x1 x2 : bitvector 64, (x1 ^^ x2) ^^ x2 = x1. -Proof. - intros; rewrite <- bvXor_assoc, bvXor_same, bvXor_zero. - reflexivity. -Qed. - -(* | Now we can prove correctness *) -Lemma xor_swap_spec_ref (x y: bitvector 64) : - spec_refines_eq (xor_swap x y) - (total_spec (fun _ => True) (fun xy r => r = xor_swap_spec (fst xy) (snd xy)) - (x,y)). -Proof. solve_trivial_spec 0 0. - - apply bvXor_twice_r. - - apply bvXor_twice_l. -Qed. - -Local Hint Extern 10 (spec_refines eqPreRel eqPostRel eq (xor_swap _ _) _) => - simple apply xor_swap_spec_ref: refine_proofs. diff --git a/heapster/examples/xor_swap_rust.bc b/heapster/examples/xor_swap_rust.bc deleted file mode 100644 index 3d46937f61..0000000000 Binary files a/heapster/examples/xor_swap_rust.bc and /dev/null differ diff --git a/heapster/examples/xor_swap_rust.rs b/heapster/examples/xor_swap_rust.rs deleted file mode 100644 index 8f526ff008..0000000000 --- a/heapster/examples/xor_swap_rust.rs +++ /dev/null @@ -1,13 +0,0 @@ - -// Evaluate a vector of arguments to a new environment -pub fn xor_swap_rust (x:&mut i64, y:&mut i64) { - *x = *x ^ *y; - *y = *x ^ *y; - *x = *x ^ *y; -} - -pub fn main () { - let mut x:i64 = 0; - let mut y:i64 = 1; - xor_swap_rust (&mut x, &mut y); -} diff --git a/heapster/examples/xor_swap_rust.saw b/heapster/examples/xor_swap_rust.saw deleted file mode 100644 index 78685c8b6e..0000000000 --- a/heapster/examples/xor_swap_rust.saw +++ /dev/null @@ -1,17 +0,0 @@ -enable_experimental; -env <- heapster_init_env "xor_swap_rust" "xor_swap_rust.bc"; - -heapster_define_llvmshape env "i64" 64 "" "fieldsh(exists x:bv 64.eq(llvmword(x)))"; - -// FIXME: Get this working again -// xor_swap_sym <- heapster_find_symbol env "13xor_swap_rust13xor_swap_rust"; -// heapster_typecheck_fun_rename env xor_swap_sym "xor_swap_rust" -// "<'a,'b> fn (x:&'a mut i64, y:&'b mut i64)"; - -//heapster_typecheck_fun_rename env xor_swap_sym "xor_swap_rust" -// "(x:bv 64, y:bv 64). arg0:ptr((W,0) |-> eq(llvmword(x))), \ -// \ arg1: ptr((W,0) |-> eq(llvmword(y))) -o \ -// \ arg0: ptr((W,0) |-> exists z:bv 64.eq(llvmword(z))), \ -// \ arg1: ptr((W,0) |-> exists z:bv 64.eq(llvmword(z))), ret:true"; - -heapster_export_coq env "xor_swap_rust_gen.v"; diff --git a/heapster/examples/xor_swap_rust_proofs.v b/heapster/examples/xor_swap_rust_proofs.v deleted file mode 100644 index e7933fb232..0000000000 --- a/heapster/examples/xor_swap_rust_proofs.v +++ /dev/null @@ -1,41 +0,0 @@ - -From Coq Require Import Lists.List. -From Coq Require Import String. -From Coq Require Import Vectors.Vector. -From CryptolToCoq Require Import SAWCoreScaffolding. -From CryptolToCoq Require Import SAWCoreVectorsAsCoqVectors. - -From CryptolToCoq Require Import SAWCorePrelude. -From CryptolToCoq Require Import CompMExtra. - -Require Import Examples.xor_swap_rust_gen. -Import xor_swap_rust. - -(* FIXME: move lemma to SAWCorePrelude...? *) -Lemma bvXor_twice_r n x y : - SAWCorePrelude.bvXor n (SAWCorePrelude.bvXor n x y) y = x. -Proof. - admit. -Admitted. - -(* FIXME: move lemma to SAWCorePrelude...? *) -Lemma bvXor_twice_l n x y : - SAWCorePrelude.bvXor n (SAWCorePrelude.bvXor n y x) y = x. -Proof. - admit. -Admitted. - -(* FIXME: write a spec for xor_swap_rust that works! *) -(* -Definition xor_swap_spec x1 x2 : - CompM (bitvector 64 * (bitvector 64 * unit)) := - returnM (x2, (x1, tt)). -Arguments xor_swap_spec /. - -Lemma xor_swap_correct : refinesFun xor_swap_rust xor_swap_spec. -Proof. - prove_refinement. - rewrite bvXor_twice_r. rewrite bvXor_twice_l. - reflexivity. -Qed. -*) diff --git a/heapster/proverTests/Main.hs b/heapster/proverTests/Main.hs deleted file mode 100644 index 3f888d8041..0000000000 --- a/heapster/proverTests/Main.hs +++ /dev/null @@ -1,254 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE IncoherentInstances #-} -{-# OPTIONS_GHC -Wno-type-defaults #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - -module Main where - -import Data.Binding.Hobbits -import Data.Binding.Hobbits.NameMap(singleton) -import Test.Tasty -import Heapster.Permissions -import Lang.Crucible.LLVM.Bytes -import Lang.Crucible.LLVM.MemModel (LLVMPointerType) -import Heapster.Implication (proveVarImpl, checkVarImpl) -import Test.Tasty.HUnit -import Lang.Crucible.Types (BVType) -import GHC.TypeLits - -infix 5 ===> -infixl 8 \\ -infixl 8 \\\ -infixl 8 \\\\ - -(===>) :: (ToConj p1, ToConj p2) => p1 -> p2 -> Bool -xs ===> ys = conj xs `checkImpl` conj ys - -(\\) :: LLVMArrayPerm w -> [LLVMArrayBorrow w] -> LLVMArrayPerm w -(\\) a bs = a { llvmArrayBorrows = llvmArrayBorrows a ++ bs } - -(\\\) :: (ArrayIndexExpr a1, ArrayIndexExpr a2) => LLVMArrayPerm 64 -> (a1, a2) -> LLVMArrayPerm 64 -(\\\) a (i, l) = a \\ [RangeBorrow (BVRange (toIdx i) (toIdx l))] - -(\\\\) :: (ArrayIndexExpr a) => LLVMArrayPerm 64 -> a -> LLVMArrayPerm 64 -(\\\\) a i = a \\ [FieldBorrow (toIdx i)] - -class t ~ LLVMPointerType 64 => ToAtomic a t | a -> t where - atomic :: a -> AtomicPerm t - -instance t ~ LLVMPointerType 64 => ToAtomic (AtomicPerm t) t where - atomic = id - -instance t ~ LLVMPointerType 64 => ToAtomic (LLVMArrayPerm 64) t where - atomic = Perm_LLVMArray - -class ToConj a where - conj :: a -> ValuePerm (LLVMPointerType 64) - -instance (ToAtomic p t, t ~ LLVMPointerType 64) => ToConj p where - conj x = ValPerm_Conj1 (atomic x) - -instance (ToAtomic p t, t ~ LLVMPointerType 64) => ToConj [p] where - conj = ValPerm_Conj . fmap atomic - -instance (t ~ LLVMPointerType 64) => ToConj [AtomicPerm t] where - conj = ValPerm_Conj - -class ArrayIndexExpr a where - toIdx :: a -> PermExpr (BVType 64) - -instance ArrayIndexExpr (PermExpr (BVType 64)) where - toIdx = id - -instance Integral i => ArrayIndexExpr i where - toIdx i = bvInt (toInteger i) - -instance t ~ BVType 64 => ArrayIndexExpr (Name t) where - toIdx x = PExpr_Var x - -passes :: Bool -> Assertion -passes = assertBool "should succeed" - -fails :: Bool -> Assertion -fails = assertBool "should fail" . not - -withName :: (Name (BVType 64) -> Bool) -> Bool -withName k = mbLift (nu k) - -checkImpl :: ValuePerm (LLVMPointerType 64) -> ValuePerm (LLVMPointerType 64) -> Bool -checkImpl lhs rhs = mbLift (nu $ \x -> checkVarImpl (pset x) (proveVarImpl x perm_rhs)) - where - perm_lhs = lhs - perm_rhs = emptyMb rhs - pset x = PermSet { _varPermMap = singleton x perm_lhs, _distPerms = DistPermsNil } - -memblockPerm :: (ArrayIndexExpr a1, ArrayIndexExpr a2) => - a1 -> a2 -> PermExpr (LLVMShapeType 64) -> LLVMBlockPerm 64 -memblockPerm off len shape = LLVMBlockPerm - { llvmBlockRW = PExpr_Write - , llvmBlockLifetime = PExpr_Always - , llvmBlockOffset = toIdx off - , llvmBlockLen = toIdx len - , llvmBlockShape = shape - } - -intValuePerm :: (KnownNat sz, 1 <= sz) => ValuePerm (LLVMPointerType sz) -intValuePerm = ValPerm_Exists $ nu $ \x -> ValPerm_Eq (PExpr_LLVMWord (PExpr_Var x)) - -fieldShape :: (KnownNat sz, 1 <= sz) => ValuePerm (LLVMPointerType sz) -> PermExpr (LLVMShapeType 64) -fieldShape p = PExpr_FieldShape (LLVMFieldShape p) - -fieldPerm :: ArrayIndexExpr a => a -> ValuePerm (LLVMPointerType w) -> LLVMFieldPerm 64 w -fieldPerm off contents = LLVMFieldPerm - { llvmFieldRW = PExpr_Write - , llvmFieldLifetime = PExpr_Always - , llvmFieldOffset = toIdx off - , llvmFieldContents = contents - } - -field :: (KnownNat sz, 1 <= sz, ArrayIndexExpr a) => - a -> ValuePerm (LLVMPointerType sz) -> AtomicPerm (LLVMPointerType 64) -field off contents = Perm_LLVMField (fieldPerm off contents) - -memblock_int64field :: (ArrayIndexExpr a) => a -> AtomicPerm (LLVMPointerType 64) -memblock_int64field off = Perm_LLVMBlock $ memblockPerm off 8 (fieldShape (intValuePerm @64)) - -memblock_int64array :: (ArrayIndexExpr a1, ArrayIndexExpr a2) => a1 -> a2 -> AtomicPerm (LLVMPointerType 64) -memblock_int64array off len = Perm_LLVMBlock $ memblockPerm off (bvMult 8 (toIdx len)) (arrayShape len 8 (fieldShape (intValuePerm @64))) - -int64field :: ArrayIndexExpr a => a -> AtomicPerm (LLVMPointerType 64) -int64field off = field off (intValuePerm :: ValuePerm (LLVMPointerType 64)) - -int64array :: (ArrayIndexExpr a1, ArrayIndexExpr a2) => a1 -> a2 -> AtomicPerm (LLVMPointerType 64) -int64array off len = Perm_LLVMArray (int64ArrayPerm off len) - -int32array :: (ArrayIndexExpr a1, ArrayIndexExpr a2) => a1 -> a2 -> AtomicPerm (LLVMPointerType 64) -int32array off len = Perm_LLVMArray (int32ArrayPerm off len) - -int64ArrayPerm :: (ArrayIndexExpr a1, ArrayIndexExpr a2) => a1 -> a2 -> LLVMArrayPerm 64 -int64ArrayPerm off len = arrayPerm (toIdx off) (toIdx len) 8 (fieldShape (intValuePerm @64)) - -int32ArrayPerm :: (ArrayIndexExpr a1, ArrayIndexExpr a2) => a1 -> a2 -> LLVMArrayPerm 64 -int32ArrayPerm off len = arrayPerm (toIdx off) (toIdx len) 4 (fieldShape (intValuePerm @32)) - -charShape :: PermExpr (LLVMShapeType 64) -charShape = fieldShape (intValuePerm @8) - -charArray :: (ArrayIndexExpr a1, ArrayIndexExpr a2) => a1 -> a2 -> AtomicPerm (LLVMPointerType 64) -charArray off len = Perm_LLVMArray (arrayPerm (toIdx off) (toIdx len) 1 (fieldShape (intValuePerm @8))) - -str3Block :: (ArrayIndexExpr a) => a -> AtomicPerm (LLVMPointerType 64) -str3Block off = Perm_LLVMBlock $ - memblockPerm off 3 (PExpr_SeqShape charShape (PExpr_SeqShape charShape charShape)) - -arrayPerm :: - PermExpr (BVType w) -> - PermExpr (BVType w) -> - Bytes -> - PermExpr (LLVMShapeType w) -> - LLVMArrayPerm w -arrayPerm off len stride shape = LLVMArrayPerm - { llvmArrayRW = PExpr_Write - , llvmArrayLifetime = PExpr_Always - , llvmArrayOffset = off - , llvmArrayLen = len - , llvmArrayStride = stride - , llvmArrayCellShape = shape - , llvmArrayBorrows = [] - } - -arrayShape :: (ArrayIndexExpr a) => a -> Bytes -> PermExpr (LLVMShapeType 64) -> PermExpr (LLVMShapeType 64) -arrayShape len = PExpr_ArrayShape (toIdx len) - -arrayTests :: TestTree -arrayTests = - testGroup "arrayTests" - [ testCase "too small" $ fails $ int64array 0 3 ===> int64array 0 6 - , testCase "bigger" $ passes $ int64array 0 6 ===> int64array 0 3 - - , testGroup "sum of two arrays" - [ testCase "exact" $ passes $ [ int64array 0 3, int64array 24 3 ] ===> int64array 0 6 - , testCase "larger" $ passes $ [ int64array 0 3, int64array 24 3 ] ===> int64array 0 5 - , testCase "not enough" $ fails $ [ int64array 0 3, int64array 24 3 ] ===> int64array 0 7 - ] - - , testGroup "sum of fields" - [ testCase "some fields" $ passes $ - [ int64field 0, int64field 8, int64field 16 ] ===> int64array 0 3 - , testCase "some extra fields" $ passes $ - [ int64field 0, int64field 8, int64field 16 ] ===> int64array 8 2 - , testCase "insufficient fields (1)" $ fails $ - [ int64field 0, int64field 8, int64field 16 ] ===> int64array 8 3 - , testCase "insufficient fields (2)" $ fails $ - [ int64field 0, int64field 8, int64field 16 ] ===> int64array 0 4 - , testCase "string" $ passes $ str3Block 0 ===> charArray 0 3 - ] - - , testGroup "mix of permission types" - [ testCase "memblocks 1:1" $ passes $ - memblock_int64field 0 ===> int64array 0 1 - , testCase "memblocks insufficient" $ fails $ - [ memblock_int64field 0, memblock_int64field 8 ] ===> int64array 0 3 - , testCase "memblocks array 1:1" $ passes $ - memblock_int64array 0 3 ===> int64array 0 3 - , testCase "memblocks array 2:1" $ passes $ - [ memblock_int64array 8 3, memblock_int64array 32 4 ] ===> int64array 8 7 - ] - - , testGroup "symbolic" - [ testCase "borrowed concrete field" $ fails $ - withName $ \l -> - int64ArrayPerm 0 l \\\\ 0 ===> int64array 0 l - , testCase "borrowed concrete field" $ passes $ - withName $ \l -> - [atomic (int64ArrayPerm 0 l \\\\ 0), int64field 0] ===> int64array 0 l - , testCase "borrowed symbolic field" $ passes $ - withName $ \l -> withName $ \i -> - [atomic (int64ArrayPerm 0 l \\\\ i), int64field (bvMult 8 (toIdx i))] ===> int64array 0 l - , testCase "symbolic length append" $ passes $ - withName $ \l -> - [int64ArrayPerm 0 l, int64ArrayPerm (bvMult 8 (toIdx l)) l] ===> int64array 0 (bvMult 2 (toIdx l)) - ] - - , testGroup "borrows on rhs" - [ testCase "matched borrows" $ passes $ - int64ArrayPerm 0 3 \\\ (1,2) ===> int64ArrayPerm 0 3 \\\ (1,2) - - , testCase "sum of matched borrows" $ passes $ - [ int64ArrayPerm 0 3 \\\ (1,2) , int64ArrayPerm 24 3 ] - ===> int64ArrayPerm 0 6 \\\ (1,2) - - , testCase "borrowed lhs/rhs offset" $ passes $ - [ int64ArrayPerm 24 3, - int64ArrayPerm 48 2 ] ===> int64ArrayPerm 24 5 \\\ (3, 2) - - , testCase "rhs borrow intersects two lhs borrows " $ fails $ - int64ArrayPerm 0 10 \\\ (1, 3) \\\ (7,3) ===> int64ArrayPerm 0 10 \\\ (2,6) - - , testCase "rhs borrow intersects two lhs borrows " $ passes $ - [ int64ArrayPerm 0 5 \\\ (1, 3) \\\ (7,3) - , int64ArrayPerm 8 3 - , int64ArrayPerm 56 3 - ] ===> int64ArrayPerm 0 5 \\\ (2,6) - - , testCase "too much lhs borrowed" $ fails $ int64ArrayPerm 0 10 \\\ (5,2) ===> int64ArrayPerm 0 10 \\\ (5,1) - - , testCase "sum of borrows" $ passes $ - [ int64ArrayPerm 0 3 \\\ (1,2) , int64ArrayPerm 24 4 \\\ (1,2) ] - ===> int64ArrayPerm 0 7 \\\ (1,2) \\\ (3,3) - - , testCase "fully-borrowed refl" $ passes $ - int64ArrayPerm 0 4 \\\ (0, 2) \\\ (2, 2) - ===> int64ArrayPerm 0 4 \\\ (0, 2) \\\ (2, 2) - ] - ] - -main :: IO () -main = defaultMain arrayTests diff --git a/heapster/src/Heapster/CruUtil.hs b/heapster/src/Heapster/CruUtil.hs deleted file mode 100644 index ec0a6c1251..0000000000 --- a/heapster/src/Heapster/CruUtil.hs +++ /dev/null @@ -1,863 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE EmptyCase #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE QuantifiedConstraints #-} - -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Heapster.CruUtil where - -import Data.Text (Text) -import qualified Data.Text as Text -import Data.Reflection -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Functor.Constant -import Data.ByteString -import Numeric -import Numeric.Natural -import qualified Data.BitVector.Sized as BV -import System.FilePath -import GHC.TypeNats (KnownNat, natVal) -import Data.Functor.Product -import Control.Lens hiding ((:>), Index, Empty, ix, op) -import qualified Control.Monad.Fail as Fail -import Data.Binding.Hobbits -import qualified Data.Type.RList as RL - -import What4.ProgramLoc -import What4.Partial -import What4.Interface (StringLiteral(..)) -import What4.Utils.Word16String (Word16String) - -import Data.Parameterized.Context hiding ((:>), empty, take, view) -import qualified Data.Parameterized.Context as Ctx -import Data.Parameterized.TraversableFC -import Data.Parameterized.BoolRepr -import Data.Parameterized.Nonce (Nonce) - --- import qualified Text.PrettyPrint.ANSI.Leijen as PP -import qualified Prettyprinter as PP - -import qualified Text.LLVM.AST as L -import Lang.Crucible.Types -import Lang.Crucible.FunctionHandle -import Lang.Crucible.CFG.Expr -import Lang.Crucible.CFG.Core hiding (App) -import qualified Lang.Crucible.CFG.Core as Core -import Lang.Crucible.LLVM.Bytes -import Lang.Crucible.LLVM.Errors -import Lang.Crucible.LLVM.Errors.MemoryError -import Lang.Crucible.LLVM.Extension -import Lang.Crucible.LLVM.MemModel -import Lang.Crucible.LLVM.Arch.X86 -import Lang.Crucible.LLVM.DataLayout -import qualified Lang.Crucible.LLVM.Errors.Poison as Poison -import qualified Lang.Crucible.LLVM.Errors.UndefinedBehavior as UB -import SAWCore.Term.Functor -import SAWCore.OpenTerm - - --- | The lens into an 'RAssign' associated with a 'Member' proof --- --- FIXME HERE: this should go into Hobbits, possibly using -member :: Member ctx a -> Lens' (RAssign f ctx) (f a) -member memb = lens (RL.get memb) (flip (RL.set memb)) - --- | Traverse an 'RAssign' inside an 'Applicative' --- --- FIXME HERE: move to Hobbits, renaming it just plain 'traverse' -traverseRAssign :: Applicative m => (forall x. f x -> m (g x)) -> - RAssign f c -> m (RAssign g c) -traverseRAssign _ MNil = pure MNil -traverseRAssign f (xs :>: x) = (:>:) <$> traverseRAssign f xs <*> f x - --- FIXME HERE: this should move to Hobbits -instance Closable a => Closable (Maybe a) where - toClosed Nothing = $(mkClosed [| Nothing |]) - toClosed (Just a) = $(mkClosed [| Just |]) `clApply` toClosed a - --- FIXME HERE: this should move to Hobbits -instance (Closable a, Closable b) => Closable (a,b) where - toClosed (a,b) = - $(mkClosed [| (,) |]) `clApply` toClosed a `clApply` toClosed b - - ----------------------------------------------------------------------- --- * Helper Functions for 'NatRepr' and 'KnownNat' ----------------------------------------------------------------------- - --- | A version of 'natVal' that takes a phantom argument with 2 applied type --- functors instead of 1 -natVal2 :: KnownNat w => f (g w) -> Natural -natVal2 (_ :: f (g w)) = natVal (Proxy :: Proxy w) - --- | A version of 'natVal' that takes a phantom argument with 3 applied type --- functors instead of 1 -natVal3 :: KnownNat w => f (g (h w)) -> Natural -natVal3 (_ :: f (g (h w))) = natVal (Proxy :: Proxy w) - --- | A version of 'natVal' that takes a phantom argument with 4 applied type --- functors instead of 1 -natVal4 :: KnownNat w => f (g (h (i w))) -> Natural -natVal4 (_ :: f (g (h (i w)))) = natVal (Proxy :: Proxy w) - --- | A version of 'knownNat' that take a phantom argument -natRepr :: KnownNat w => f w -> NatRepr w -natRepr _ = knownNat - --- | A version of 'natRepr' that take a phantom argument with 2 applied type --- functors instead of 1 -natRepr2 :: KnownNat w => f (g w) -> NatRepr w -natRepr2 _ = knownNat - --- | A version of 'natRepr' that take a phantom argument with 3 applied type --- functors instead of 1 -natRepr3 :: KnownNat w => f (g (h w)) -> NatRepr w -natRepr3 _ = knownNat - --- | A version of 'natRepr' that take a phantom argument with 4 applied type --- functors instead of 1 -natRepr4 :: KnownNat w => f (g (h (i w))) -> NatRepr w -natRepr4 _ = knownNat - --- | A 'NatRepr' for @1@ -oneRepr :: NatRepr 1 -oneRepr = knownRepr - --- | Convert an 'Integral' type to 'NatRepr' that is at least 1, if possible -someNatGeq1 :: Integral a => a -> Maybe (Some (Product NatRepr (LeqProof 1))) -someNatGeq1 i - | Just (Some w) <- someNat i - , Left leq <- decideLeq oneRepr w = Just (Some (Pair w leq)) -someNatGeq1 _ = Nothing - -data SomeKnownNatGeq1 where - SomeKnownNatGeq1 :: (KnownNat n, 1 <= n) => NatRepr n -> SomeKnownNatGeq1 - -someKnownNatGeq1 :: Integral a => a -> Maybe SomeKnownNatGeq1 -someKnownNatGeq1 i - | Just (Some (Pair w LeqProof)) <- someNatGeq1 i - = Just $ withKnownNat w (SomeKnownNatGeq1 w) -someKnownNatGeq1 _ = Nothing - - ----------------------------------------------------------------------- --- * Building 'NuMatching' and 'Closable' Instances for Crucible Types ----------------------------------------------------------------------- - --- | A reification of an object of type @a@ at type level -data ReifiesObj a = forall s. Reifies s a => ReifiesObj (Proxy s) - -$(mkNuMatching [t| forall a. ReifiesObj a |]) - --- | Build a 'ReifiesObj' containing a value -mkReifiesObj :: a -> ReifiesObj a -mkReifiesObj a = reify a ReifiesObj - --- | Project out the value contained in a 'ReifiesObj' -projReifiesObj :: ReifiesObj a -> a -projReifiesObj (ReifiesObj prx) = reflect prx - -instance NuMatching Ident where - nuMatchingProof = unsafeMbTypeRepr - -instance Closable Ident where - toClosed = unsafeClose - -instance Liftable Ident where - mbLift = unClosed . mbLift . fmap toClosed - -instance NuMatching OpenTerm where - nuMatchingProof = unsafeMbTypeRepr - -instance NuMatching GlobalSymbol where - nuMatchingProof = unsafeMbTypeRepr - -instance Closable GlobalSymbol where - toClosed = unsafeClose - -instance Liftable GlobalSymbol where - mbLift = unClosed . mbLift . fmap toClosed - --- | This is copied from 'Lang.Crucible.LLVM.Types', as that module is hidden -globalSymbolName :: GlobalSymbol -> String -globalSymbolName (GlobalSymbol (L.Symbol str)) = str - -instance NuMatching (SymbolRepr tp) where - nuMatchingProof = unsafeMbTypeRepr - -instance NuMatching (BoolRepr tp) where - nuMatchingProof = unsafeMbTypeRepr - -instance Closable (BoolRepr tp) where - toClosed = unsafeClose - -instance Liftable (BoolRepr tp) where - mbLift = unClosed . mbLift . fmap toClosed - -instance NuMatching (NatRepr tp) where - nuMatchingProof = unsafeMbTypeRepr - -instance Closable (NatRepr tp) where - toClosed = unsafeClose - -instance Liftable (NatRepr tp) where - mbLift = unClosed . mbLift . fmap toClosed - -instance NuMatching (TypeRepr tp) where - nuMatchingProof = unsafeMbTypeRepr - -instance Closable (TypeRepr tp) where - toClosed = unsafeClose - -instance Liftable (TypeRepr tp) where - mbLift = unClosed . mbLift . fmap toClosed - - -- FIXME: we will need this instance when we define CruCtx via RAssign -{- -instance ClosableAny1 TypeRepr where - closableAny1 _ = IsClosable --} - -instance NuMatching (BaseTypeRepr tp) where - nuMatchingProof = unsafeMbTypeRepr - -instance Closable (BaseTypeRepr tp) where - toClosed = unsafeClose - -instance Liftable (BaseTypeRepr tp) where - mbLift = unClosed . mbLift . fmap toClosed - --- NOTE: this is handled by the Assignment instance --- instance NuMatching (CtxRepr ctx) where --- nuMatchingProof = isoMbTypeRepr mkKnownReprObj getKnownReprObj - -instance NuMatching (Index ctx a) where - nuMatchingProof = unsafeMbTypeRepr - -instance Closable (Index ctx a) where - toClosed = unsafeClose - -instance Liftable (Index ctx a) where - mbLift = unClosed . mbLift . fmap toClosed - -instance NuMatching Text where - nuMatchingProof = unsafeMbTypeRepr - -instance Closable Text where - toClosed = unsafeClose - -instance Liftable Text where - mbLift = unClosed . mbLift . fmap toClosed - -instance NuMatching ProgramLoc where - nuMatchingProof = unsafeMbTypeRepr - -instance Closable ProgramLoc where - toClosed = unsafeClose - -instance Liftable ProgramLoc where - mbLift = unClosed . mbLift . fmap toClosed - --- | Pretty-print a 'Position' with a \"short\" filename, without the path -ppShortFileName :: Position -> PP.Doc ann -ppShortFileName (SourcePos path l c) = - PP.pretty (takeFileName $ Text.unpack path) - PP.<> PP.colon PP.<> PP.pretty l - PP.<> PP.colon PP.<> PP.pretty c -ppShortFileName (BinaryPos path addr) = - PP.pretty (takeFileName $ Text.unpack path) PP.<> PP.colon PP.<> - PP.pretty "0x" PP.<> PP.pretty (showHex addr "") -ppShortFileName (OtherPos txt) = PP.pretty (Text.unpack txt) -ppShortFileName InternalPos = PP.pretty "internal" - -instance NuMatching ByteString where - nuMatchingProof = unsafeMbTypeRepr - -instance NuMatching (MemoryError sym) where - nuMatchingProof = unsafeMbTypeRepr - -instance NuMatching MemoryErrorReason where - nuMatchingProof = unsafeMbTypeRepr - -instance NuMatching (FnHandle args ret) where - nuMatchingProof = unsafeMbTypeRepr - -instance NuMatching SomeHandle where - nuMatchingProof = unsafeMbTypeRepr - -instance NuMatching (FloatInfoRepr fi) where - nuMatchingProof = unsafeMbTypeRepr - -instance NuMatching RoundingMode where - nuMatchingProof = unsafeMbTypeRepr - -instance NuMatching EndianForm where - nuMatchingProof = unsafeMbTypeRepr - -instance Closable EndianForm where - toClosed BigEndian = $(mkClosed [| BigEndian |]) - toClosed LittleEndian = $(mkClosed [| LittleEndian |]) - -instance Liftable EndianForm where - mbLift = unClosed . mbLift . fmap toClosed - -$(mkNuMatching [t| forall f. NuMatchingAny1 f => Some f |]) -$(mkNuMatching [t| forall f ctx . NuMatchingAny1 f => AssignView f ctx |]) - -viewToAssign :: AssignView f ctx -> Assignment f ctx -viewToAssign AssignEmpty = Ctx.empty -viewToAssign (AssignExtend asgn' f) = extend asgn' f - -instance NuMatchingAny1 f => NuMatching (Assignment f ctx) where - nuMatchingProof = - -- FIXME: inefficient to map a whole Assignment step by step to ViewAssigns, - -- freshen each element, and then map back to the Assignment again; maybe we - -- need to figure out how to use the TraversableFC instance for Assignment - -- here? - isoMbTypeRepr viewAssign viewToAssign - -instance Closable (Assignment TypeRepr ctx) where - toClosed = unsafeClose - -instance Liftable (Assignment TypeRepr ctx) where - mbLift = unClosed . mbLift . fmap toClosed - - -$(mkNuMatching [t| forall f tp. NuMatchingAny1 f => BaseTerm f tp |]) -$(mkNuMatching [t| forall a. NuMatching a => NonEmpty a |]) -$(mkNuMatching [t| forall p v. (NuMatching p, NuMatching v) => Partial p v |]) -$(mkNuMatching [t| X86_80Val |]) --- $(mkNuMatching [t| MemoryLoadError |]) -- NOTE: contains unexported types -$(mkNuMatching [t| forall w. BV.BV w |]) -$(mkNuMatching [t| Word16String |]) -$(mkNuMatching [t| forall s. StringLiteral s |]) -$(mkNuMatching [t| forall s. StringInfoRepr s |]) - -#if __GLASGOW_HASKELL__ >= 902 -$(mkNuMatching [t| forall ext f tp. - (NuMatchingAny1 f, NuMatchingAny1 (ExprExtension ext f)) => - App ext f tp |]) -#else --- See Note [QuantifiedConstraints + TypeFamilies trick] -$(mkNuMatching [t| forall ext f tp exprExt. - ( NuMatchingAny1 f - , exprExt ~ ExprExtension ext f, NuMatchingAny1 exprExt - ) => App ext f tp |]) -#endif - -$(mkNuMatching [t| Bytes |]) -$(mkNuMatching [t| forall v. NuMatching v => Field v |]) -$(mkNuMatching [t| Alignment |]) -$(mkNuMatching [t| UB.PtrComparisonOperator |]) -$(mkNuMatching [t| forall v. NuMatching v => StorageTypeF v |]) -$(mkNuMatching [t| StorageType |]) - -$(mkNuMatching [t| forall f. NuMatchingAny1 f => Poison.Poison f |]) -$(mkNuMatching [t| forall f. NuMatchingAny1 f => UB.UndefinedBehavior f |]) --- $(mkNuMatching [t| forall f. NuMatchingAny1 f => BadBehavior f |]) --- $(mkNuMatching [t| forall f. NuMatchingAny1 f => LLVMSafetyAssertion f |]) -$(mkNuMatching [t| forall f. NuMatchingAny1 f => LLVMSideCondition f |]) - -$(mkNuMatching [t| forall blocks tp. BlockID blocks tp |]) - --- FIXME: Hobbits mkNuMatching cannot handle empty types --- $(mkNuMatching [t| forall f tp. EmptyExprExtension f tp |]) - -instance NuMatching (EmptyExprExtension f tp) where - nuMatchingProof = unsafeMbTypeRepr - -$(mkNuMatching [t| AVXOp1 |]) -$(mkNuMatching [t| forall f tp. NuMatchingAny1 f => ExtX86 f tp |]) - -instance NuMatching (Nonce s tp) where - nuMatchingProof = unsafeMbTypeRepr - -instance Closable (Nonce s tp) where - toClosed = unsafeClose - -instance Liftable (Nonce s tp) where - mbLift = unClosed . mbLift . fmap toClosed - -$(mkNuMatching [t| forall tp. GlobalVar tp |]) -$(mkNuMatching [t| forall f tp. NuMatchingAny1 f => - LLVMExtensionExpr f tp |]) - -{- -$(mkNuMatching [t| forall w f tp. NuMatchingAny1 f => LLVMStmt w f tp |]) --} - -instance Closable (BV.BV w) where - toClosed = unsafeClose - -instance Liftable (BV.BV w) where - mbLift = unClosed . mbLift . fmap toClosed - -instance Closable Bytes where - toClosed (Bytes i) = - $(mkClosed [| Bytes |]) `clApply` (toClosed i) - -instance Liftable Bytes where - mbLift = unClosed . mbLift . fmap toClosed - -instance Closable (StringLiteral si) where - toClosed = unsafeClose - -instance Liftable (StringLiteral si) where - mbLift = unClosed . mbLift . fmap toClosed - -instance Closable (BadBehavior e) where - toClosed = unsafeClose - --- instance NuMatchingAny1 e => Liftable (BadBehavior e) where - -- mbLift = unClosed . mbLift . fmap toClosed - --- NOTE: Crucible objects can never contain any Hobbits names, but \"proving\" --- that would require introspection of opaque types like 'Index' and 'Nonce', --- and would also be inefficient, so we just use 'unsafeClose' - -instance Closable (Block ext cblocks ret args) where - toClosed = unsafeClose - -instance Closable (FnHandle args ret) where - toClosed = unsafeClose - -instance Liftable (FnHandle args ret) where - mbLift fh = unClosed $ mbLift $ fmap toClosed fh - -instance Closable SomeHandle where - toClosed = unsafeClose - -instance Liftable SomeHandle where - mbLift fh = unClosed $ mbLift $ fmap toClosed fh - --- | Close an assignment whose elements are all 'Closable' -closeAssign :: (forall a. f a -> Closed (f a)) -> Assignment f ctx -> - Closed (Assignment f ctx) -closeAssign _ (viewAssign -> AssignEmpty) = $(mkClosed [| Ctx.empty |]) -closeAssign f (viewAssign -> AssignExtend asgn fa) = - $(mkClosed [| Ctx.extend |]) `clApply` closeAssign f asgn `clApply` f fa - - ----------------------------------------------------------------------- --- * Objects Associated with Crucible Types ----------------------------------------------------------------------- - --- FIXME HERE: replace all calls to show tp with our own type-printing function --- that prints in the same format that we are parsing - --- | An element of some representation type functor @f a@ along with a --- 'TypeRepr' for @a@ -data Typed f a = Typed { typedType :: TypeRepr a, typedObj :: f a } - -$(mkNuMatching [t| forall f a. NuMatching (f a) => Typed f a |]) - --- | Cast an existential 'Typed' to a particular type or raise an error -castTypedM :: Fail.MonadFail m => String -> TypeRepr a -> Some (Typed f) -> m (f a) -castTypedM _ tp (Some (Typed tp' f)) - | Just Refl <- testEquality tp tp' = return f -castTypedM str tp (Some (Typed tp' _)) = - fail ("Expected " ++ str ++ " of type " ++ show tp - ++ ", found one of type " ++ show tp') - --- | A expression variable of some existentially quantified type -type TypedName = Some (Typed Name) - - ----------------------------------------------------------------------- --- * Contexts of Crucible Types ----------------------------------------------------------------------- - --- | Convert a Crucible 'Ctx' to a Hobbits 'RList' -type family CtxToRList (ctx :: Ctx k) :: RList k where - CtxToRList EmptyCtx = RNil - CtxToRList (ctx' ::> x) = CtxToRList ctx' :> x - --- | Convert a Hobbits 'RList' to a Crucible 'Ctx' -type family RListToCtx (ctx :: RList k) :: Ctx k where - RListToCtx RNil = EmptyCtx - RListToCtx (ctx' :> x) = RListToCtx ctx' ::> x - --- | Convert a Crucible context of contexts to a Hobbits one -type family CtxCtxToRList (ctx :: Ctx (Ctx k)) :: RList (RList k) where - CtxCtxToRList EmptyCtx = RNil - CtxCtxToRList (ctx' ::> c) = CtxCtxToRList ctx' :> CtxToRList c - --- | Convert a Hobbits context of contexts to a Crucible one -type family RListToCtxCtx (ctx :: RList (RList k)) :: Ctx (Ctx k) where - RListToCtxCtx RNil = EmptyCtx - RListToCtxCtx (ctx' :> c) = RListToCtxCtx ctx' ::> RListToCtx c - --- | Convert a Crucible 'Assignment' to a Hobbits 'RAssign' -assignToRList :: Assignment f ctx -> RAssign f (CtxToRList ctx) -assignToRList asgn = case viewAssign asgn of - AssignEmpty -> MNil - AssignExtend asgn' f -> assignToRList asgn' :>: f - --- | Invert 'assignToRList', converting a Hobbits 'RAssign' over a Hobbits --- context generated by 'CtxToRList' back to a Crucible 'Assignment' -unAssignToRList :: Assignment prx ctx -> RAssign f (CtxToRList ctx) -> - Assignment f ctx -unAssignToRList ctx fs = - let sz = Ctx.size ctx in - Ctx.generate sz $ \ix -> RL.get (indexToMember sz ix) fs - --- | Append two Hobbits 'RAssign's that have been generated by 'assignToRList' -assignToRListAppend :: Assignment prx1 ctx1 -> Assignment prx2 ctx2 -> - RAssign f (CtxToRList ctx1) -> - RAssign f (CtxToRList ctx2) -> - RAssign f (CtxToRList (ctx1 <+> ctx2)) -assignToRListAppend ctx1 ctx2 fs1 fs2 = - assignToRList (unAssignToRList ctx1 fs1 Ctx.<++> unAssignToRList ctx2 fs2) - --- | Convert a Crucible 'Assignment' over a context of contexts to an 'RAssign' --- over a right-list of right-lists -assignToRListRList :: (forall c. f c -> g (CtxToRList c)) -> - Assignment f ctx -> RAssign g (CtxCtxToRList ctx) -assignToRListRList f asgn = case viewAssign asgn of - AssignEmpty -> MNil - AssignExtend asgn' x -> assignToRListRList f asgn' :>: f x - --- | Convert a Hobbits 'RAssign' to a Crucible 'Assignment' -rlistToAssign :: RAssign f ctx -> Assignment f (RListToCtx ctx) -rlistToAssign MNil = Ctx.empty -rlistToAssign (rlist :>: f) = extend (rlistToAssign rlist) f - --- | Convert a Crucible 'Index' to a Hobbits 'Member' -indexToMember :: Size ctx -> Index ctx tp -> Member (CtxToRList ctx) tp -indexToMember sz ix = case viewIndex sz ix of - IndexViewLast _ -> Member_Base - IndexViewInit ix' -> Member_Step $ indexToMember (decSize sz) ix' - --- | Convert a Crucible 'Index' into a Crucible context of contexts into a --- Hobbits 'Member' in the associated 'RList' of 'RList's -indexCtxToMember :: Size ctx -> Index ctx c -> - Member (CtxCtxToRList ctx) (CtxToRList c) -indexCtxToMember sz ix = case viewIndex sz ix of - IndexViewLast _ -> Member_Base - IndexViewInit ix' -> Member_Step $ indexCtxToMember (decSize sz) ix' - --- | A data-level encapsulation of the 'KnownRepr' typeclass -data KnownReprObj f a = KnownRepr f a => KnownReprObj - --- | Build a 'KnownReprObj' using a phantom type -mkKnownReprObj :: KnownRepr f a => prx a -> KnownReprObj f a -mkKnownReprObj _ = KnownReprObj - --- | Extract the representation in a 'KnownReprObj' -unKnownReprObj :: KnownReprObj f a -> f a -unKnownReprObj (KnownReprObj :: KnownReprObj f a) = knownRepr :: f a - -$(mkNuMatching [t| forall f a. KnownReprObj f a |]) - -instance Liftable (KnownReprObj f a) where - mbLift (mbMatch -> [nuMP| KnownReprObj |]) = KnownReprObj - -instance LiftableAny1 (KnownReprObj f) where - mbLiftAny1 = mbLift - -instance Liftable a => LiftableAny1 (Constant a) where - mbLiftAny1 = mbLift - -instance Liftable a => Liftable (Constant a b) where - mbLift (mbMatch -> [nuMP| Data.Functor.Constant.Constant x |]) = Data.Functor.Constant.Constant (mbLift x) - -instance (Liftable a, Liftable b, Liftable c) => Liftable (a,b,c) where - mbLift (mbMatch -> [nuMP| (x,y,z) |]) = (mbLift x, mbLift y, mbLift z) - --- FIXME: this change for issue #28 requires ClosableAny1 to be exported from --- Hobbits -{- --- | A context of Crucible types -type CruCtx = RAssign TypeRepr - --- | Pattern for an empty 'CruCtx' -pattern CruCtxNil :: () => (ctx ~ RNil) => CruCtx ctx -pattern CruCtxNil = MNil - --- | Pattern for a non-empty 'CruCtx' -pattern CruCtxCons :: () => (ctx ~ (ctx' :> a)) => - CruCtx ctx' -> TypeRepr a -> CruCtx ctx -pattern CruCtxCons tps tp <- tps :>: tp - where - CruCtxCons tps tp = tps :>: tp --} - --- | A context of Crucible types --- FIXME: should be defined in terms of 'RAssign' as above -data CruCtx ctx where - CruCtxNil :: CruCtx RNil - CruCtxCons :: CruCtx ctx -> TypeRepr a -> CruCtx (ctx :> a) - --- $(mkNuMatching [t| forall a. CruType a |]) -$(mkNuMatching [t| forall ctx. CruCtx ctx |]) - -instance Liftable (CruCtx ctx) where - mbLift mb_ctx = case mbMatch mb_ctx of - [nuMP| CruCtxNil |] -> CruCtxNil - [nuMP| CruCtxCons ctx a |] -> CruCtxCons (mbLift ctx) (mbLift a) - -instance Closable (CruCtx ctx) where - toClosed CruCtxNil = $(mkClosed [| CruCtxNil |]) - toClosed (CruCtxCons ctx a) = - $(mkClosed [| CruCtxCons |]) `clApply` toClosed ctx `clApply` toClosed a - -instance TestEquality CruCtx where - testEquality CruCtxNil CruCtxNil = Just Refl - testEquality (CruCtxCons ctx1 tp1) (CruCtxCons ctx2 tp2) - | Just Refl <- testEquality ctx1 ctx2 - , Just Refl <- testEquality tp1 tp2 - = Just Refl - testEquality _ _ = Nothing - -instance PP.Pretty (CruCtx ctx) where - pretty = PP.list . helper where - helper :: CruCtx ctx' -> [PP.Doc ann] - helper CruCtxNil = [] - helper (CruCtxCons ctx tp) = helper ctx ++ [PP.pretty tp] - -instance KnownRepr CruCtx RNil where - knownRepr = CruCtxNil - -instance (KnownRepr CruCtx tps, KnownRepr TypeRepr tp) => - KnownRepr CruCtx (tps :> tp) where - knownRepr = CruCtxCons knownRepr knownRepr - --- | Build a 'CruCtx' from a 'CtxRepr' -mkCruCtx :: CtxRepr ctx -> CruCtx (CtxToRList ctx) -mkCruCtx ctx = case viewAssign ctx of - AssignEmpty -> CruCtxNil - AssignExtend ctx' tp -> CruCtxCons (mkCruCtx ctx') tp - --- | Convert a 'CruCtx' to a 'CtxRepr' -cruCtxToRepr :: CruCtx ctx -> CtxRepr (RListToCtx ctx) -cruCtxToRepr CruCtxNil = Ctx.empty -cruCtxToRepr (CruCtxCons ctx tp) = Ctx.extend (cruCtxToRepr ctx) tp - --- | Build a proof that calling 'cruCtxToRepr' followed by 'mkCruCtx' yields --- equal types -cruCtxToReprEq :: CruCtx ctx -> CtxToRList (RListToCtx ctx) :~: ctx -cruCtxToReprEq CruCtxNil = Refl -cruCtxToReprEq (CruCtxCons ctx _tp) = - case cruCtxToReprEq ctx of - Refl -> Refl - --- | Build a proof that calling 'mkCruCtx' followed by 'cruCtxToRepr' yields --- equal types -reprToCruCtxEq :: CtxRepr ctx -> RListToCtx (CtxToRList ctx) :~: ctx -reprToCruCtxEq (viewAssign -> AssignEmpty) = Refl -reprToCruCtxEq (viewAssign -> AssignExtend ctx _) = - case reprToCruCtxEq ctx of - Refl -> Refl - --- | Build a proof that converting a Crucible context of contexts to a list of --- lists and back again is the identity -reprReprToCruCtxCtxEq :: Assignment CtxRepr ctxs -> - RListToCtxCtx (CtxCtxToRList ctxs) :~: ctxs -reprReprToCruCtxCtxEq (viewAssign -> AssignEmpty) = Refl -reprReprToCruCtxCtxEq (viewAssign -> AssignExtend ctxs ctx) - | (Refl, Refl) <- (reprReprToCruCtxCtxEq ctxs, reprToCruCtxEq ctx) = Refl - --- | Convert a 'CruCtx' to an assignment of 'TypeRepr's --- --- FIXME: 'CruCtx' should just be defined as an assignment! -cruCtxToTypes :: CruCtx ctx -> RAssign TypeRepr ctx -cruCtxToTypes CruCtxNil = MNil -cruCtxToTypes (CruCtxCons tps tp) = cruCtxToTypes tps :>: tp - --- | Convert an assignment of 'TypeRepr's to a 'CruCtx' --- --- FIXME: 'CruCtx' should just be defined as an assignment! -cruCtxOfTypes :: RAssign TypeRepr ctx -> CruCtx ctx -cruCtxOfTypes MNil = CruCtxNil -cruCtxOfTypes (tps :>: tp) = CruCtxCons (cruCtxOfTypes tps) tp - -instance Show (CruCtx ctx) where - show = show . cruCtxToRepr - --- | The empty context -emptyCruCtx :: CruCtx RNil -emptyCruCtx = CruCtxNil - --- | Build a singleton crucible context -singletonCruCtx :: TypeRepr tp -> CruCtx (RNil :> tp) -singletonCruCtx tp = CruCtxCons CruCtxNil tp - --- | Add an element to the end of a context -extCruCtx :: KnownRepr TypeRepr a => CruCtx ctx -> CruCtx (ctx :> a) -extCruCtx ctx = CruCtxCons ctx knownRepr - --- | Remove an element from the end of a context -unextCruCtx :: CruCtx (ctx :> a) -> CruCtx ctx -unextCruCtx (CruCtxCons ctx _) = ctx - --- | Append two contexts -appendCruCtx :: CruCtx ctx1 -> CruCtx ctx2 -> CruCtx (ctx1 :++: ctx2) -appendCruCtx ctx1 CruCtxNil = ctx1 -appendCruCtx ctx1 (CruCtxCons ctx2 tp) = CruCtxCons (appendCruCtx ctx1 ctx2) tp - --- | Split a context in two -splitCruCtx :: prx1 ctx1 -> RAssign prx2 ctx2 -> CruCtx (ctx1 :++: ctx2) -> - (CruCtx ctx1, CruCtx ctx2) -splitCruCtx _ MNil cru_ctx = (cru_ctx, CruCtxNil) -splitCruCtx ctx1 (ctx2 :>: _) (CruCtxCons cru_ctx tp) = - let (cru_ctx1, cru_ctx2) = splitCruCtx ctx1 ctx2 cru_ctx in - (cru_ctx1, CruCtxCons cru_ctx2 tp) - --- | Build a 'RAssign' phantom argument from a context of Crucible types -cruCtxProxies :: CruCtx ctx -> RAssign Proxy ctx -cruCtxProxies CruCtxNil = MNil -cruCtxProxies (CruCtxCons ctx _) = cruCtxProxies ctx :>: Proxy - --- | Compute the length of a 'CruCtx' -cruCtxLen :: CruCtx ctx -> Int -cruCtxLen CruCtxNil = 0 -cruCtxLen (CruCtxCons ctx _) = 1 + cruCtxLen ctx - --- | Look up a type in a 'CruCtx' -cruCtxLookup :: CruCtx ctx -> Member ctx a -> TypeRepr a -cruCtxLookup CruCtxNil m = case m of {} -cruCtxLookup (CruCtxCons _ tp) Member_Base = tp -cruCtxLookup (CruCtxCons ctx _) (Member_Step memb) = cruCtxLookup ctx memb - --- | Build a 'CruCtx' of the given length. -cruCtxReplicate :: NatRepr n -> TypeRepr a -> Some CruCtx -cruCtxReplicate n tp = - case isZeroNat n of - ZeroNat -> Some CruCtxNil - NonZeroNat - | Some ctx <- cruCtxReplicate (predNat n) tp - -> Some (CruCtxCons ctx tp) - --- | A representation of a context of types as a sequence of 'KnownRepr' --- instances --- --- FIXME: this can go away when existentials take explicit 'TypeRepr's instead --- of 'KnownRepr TypeRepr' instances, as per issue #79 -type KnownCruCtx = RAssign (KnownReprObj TypeRepr) - --- | Convert a 'KnownCruCtx' to a 'CruCtx' -knownCtxToCruCtx :: KnownCruCtx ctx -> CruCtx ctx -knownCtxToCruCtx MNil = CruCtxNil -knownCtxToCruCtx (ctx :>: KnownReprObj) = - CruCtxCons (knownCtxToCruCtx ctx) knownRepr - - ----------------------------------------------------------------------- --- * Misc Operations on Crucible Objects ----------------------------------------------------------------------- - --- | Get all the registers used in a Crucible statement -stmtInputRegs :: TraverseExt ext => Stmt ext ctx ctx' -> [Some (Reg ctx)] -stmtInputRegs (SetReg _ (Core.App app)) = foldMapFC (\r -> [Some r]) app -stmtInputRegs (ExtendAssign s') = foldMapFC (\r -> [Some r]) s' -stmtInputRegs (CallHandle _ h _ args) = - Some h : foldMapFC (\r -> [Some r]) args -stmtInputRegs (Print msg) = [Some msg] -stmtInputRegs (ReadGlobal _) = [] -stmtInputRegs (WriteGlobal _ r) = [Some r] -stmtInputRegs (FreshConstant _ _) = [] -stmtInputRegs (FreshFloat _ _) = [] -stmtInputRegs (FreshNat _) = [] -stmtInputRegs (NewRefCell _ r) = [Some r] -stmtInputRegs (NewEmptyRefCell _) = [] -stmtInputRegs (ReadRefCell r) = [Some r] -stmtInputRegs (WriteRefCell r1 r2) = [Some r1, Some r2] -stmtInputRegs (DropRefCell r) = [Some r] -stmtInputRegs (Assert r1 r2) = [Some r1, Some r2] -stmtInputRegs (Assume r1 r2) = [Some r1, Some r2] - --- | Get all the input and output registers of a Crucible statement -stmtOutputRegs :: TraverseExt ext => Size ctx' -> Stmt ext ctx ctx' -> - [Some (Reg ctx')] -stmtOutputRegs sz (SetReg _ (Core.App app)) = - foldMapFC (\r -> [Some $ extendReg r]) app ++ [Some $ Reg $ Ctx.lastIndex sz] -stmtOutputRegs sz (ExtendAssign s') = - foldMapFC (\r -> [Some $ extendReg r]) s' ++ [Some $ Reg $ Ctx.lastIndex sz] -stmtOutputRegs sz (CallHandle _ h _ args) = - Some (extendReg h) : foldMapFC (\r -> [Some $ extendReg r]) args - ++ [Some $ Reg $ Ctx.lastIndex sz] -stmtOutputRegs _ (Print msg) = [Some msg] -stmtOutputRegs _ (ReadGlobal _) = [] -stmtOutputRegs _ (WriteGlobal _ r) = [Some r] -stmtOutputRegs _ (FreshConstant _ _) = [] -stmtOutputRegs _ (FreshFloat _ _) = [] -stmtOutputRegs _ (FreshNat _) = [] -stmtOutputRegs sz (NewRefCell _ r) = - [Some $ extendReg r] ++ [Some $ Reg $ Ctx.lastIndex sz] -stmtOutputRegs _ (NewEmptyRefCell _) = [] -stmtOutputRegs sz (ReadRefCell r) = - [Some $ extendReg r] ++ [Some $ Reg $ Ctx.lastIndex sz] -stmtOutputRegs _ (WriteRefCell r1 r2) = [Some r1, Some r2] -stmtOutputRegs _ (DropRefCell r) = [Some r] -stmtOutputRegs _ (Assert r1 r2) = [Some r1, Some r2] -stmtOutputRegs _ (Assume r1 r2) = [Some r1, Some r2] - --- | Get all the registers used in a Crucible 'JumpTarget' -jumpTargetRegs :: JumpTarget blocks ctx -> [Some (Reg ctx)] -jumpTargetRegs (JumpTarget _ _ regs) = foldMapFC (\r -> [Some r]) regs - --- | Get all the registers used in a Crucible 'SwitchTarget' -switchTargetRegs :: SwitchTarget blocks ctx tp -> [Some (Reg ctx)] -switchTargetRegs (SwitchTarget _ _ regs) = foldMapFC (\r -> [Some r]) regs - --- | Get all the registers used in a Crucible termination statement -termStmtRegs :: TermStmt blocks ret ctx -> [Some (Reg ctx)] -termStmtRegs (Jump tgt) = jumpTargetRegs tgt -termStmtRegs (Br cond tgt1 tgt2) = - Some cond : jumpTargetRegs tgt1 ++ jumpTargetRegs tgt2 -termStmtRegs (MaybeBranch _ cond stgt tgt) = - Some cond : switchTargetRegs stgt ++ jumpTargetRegs tgt -termStmtRegs (VariantElim _ cond stgts) = - Some cond : foldMapFC switchTargetRegs stgts -termStmtRegs (Return reg) = [Some reg] -termStmtRegs (TailCall reg _ regs) = - Some reg : foldMapFC (\r -> [Some r]) regs -termStmtRegs (ErrorStmt reg) = [Some reg] - -{- -Note [QuantifiedConstraints + TypeFamilies trick] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GHC 9.2 and later are reasonably adept and combining TypeFamilies with type -classes that have quantified superclasses. This is important, as there are -several places in heapster that require constraints of the form -`NuMatchingAny1 (ExprExtension ext f)`, where NuMatchingAny1 has a quantified -superclass and ExprExtension is a type family. - -Unfortunately, GHC 9.0 and earlier suffer from a bug where constraints of the -form `NuMatchingAny1 (ExprExtension ext f)`. See -https://gitlab.haskell.org/ghc/ghc/-/issues/14860. Thankfully, it is relatively -straightforward to work around the bug. Instead of writing instances like -these: - - instance forall ext f. - NuMatchingAny1 (ExprExtension ext f) => - NuMatchingAny (Foo ext f tp) - -We instead write instances like these, introducing an intermediate `exprExt` -type variable that is used in conjunction with an equality constraint: - - instance forall ext f exprExt. - (exprExt ~ ExprExtension ext f, NuMatchingAny1 exprExt) => - NuMatchingAny (Foo ext f tp) - -A bit tedious, but this version actually works on pre-9.2 GHCs, which is nice. - -I have guarded each use of this trick with CPP so that we remember to remove -this workaround when we drop support for pre-9.2 GHCs. --} diff --git a/heapster/src/Heapster/GenMonad.hs b/heapster/src/Heapster/GenMonad.hs deleted file mode 100644 index 6cba417823..0000000000 --- a/heapster/src/Heapster/GenMonad.hs +++ /dev/null @@ -1,144 +0,0 @@ -{-# Language BlockArguments #-} -{-# Language DeriveFunctor #-} -{-# Language FlexibleInstances, MultiParamTypeClasses #-} -- MonadState -{-# Language PolyKinds #-} -- gopenBinding -{-# Language TypeFamilies #-} -- Equality constraints -{-# Language TypeOperators #-} -- Equality constraints -{-# Language RankNTypes #-} -module Heapster.GenMonad ( - -- * Core definitions - GenStateContT(..), (>>>=), (>>>), - -- * Continuation operations - gcaptureCC, gmapRet, gabortM, gparallel, startBinding, - startNamedBinding, gopenBinding, gopenNamedBinding, - -- * State operations - gmodify, gput, - -- * Transformations - addReader, - ) where - -import Data.Binding.Hobbits ( nuMulti, nuMultiWithElim1, Mb, Name, RAssign ) -import Control.Monad ( ap ) -import Control.Monad.State ( MonadState(get, put) ) -import Control.Monad.Trans.Class ( MonadTrans(lift) ) -import Control.Monad.Trans.Reader -import Data.Proxy -import Heapster.NamedMb - --- | The generalized state-continuation monad -newtype GenStateContT s1 r1 s2 r2 m a = GenStateContT { - runGenStateContT :: s2 -> (s1 -> a -> m r1) -> m r2 - } deriving Functor - --- | Sequence two 'GenStateCont' values. Type-changing analogue of '>>=' -(>>>=) :: GenStateContT s2 r2 s1 r1 m a -> (a -> GenStateContT s3 r3 s2 r2 m b) -> GenStateContT s3 r3 s1 r1 m b -x >>>= y = GenStateContT \s1 z -> runGenStateContT x s1 \s2 a -> runGenStateContT (y a) s2 z - --- | Sequence two 'GenStateCont' values ignoring the return value. Type-changing analogue of '>>' -(>>>) :: GenStateContT s2 r2 s1 r1 m a -> GenStateContT s3 r3 s2 r2 m b -> GenStateContT s3 r3 s1 r1 m b -m1 >>> m2 = m1 >>>= \_ -> m2 - -infixl 1 >>>=, >>> - --- NB. These instance must be specified as --- instance (s1 ~ s2, r1 ~ r2) => Applicative (GenStateContT s1 r1 s2 r2) where --- instead of --- instance Applicative (GenStateContT s r s r) where --- in order to ensure they are quickly selected by GHC even when it's not --- immediately obvious that the types are equal. - -instance (s1 ~ s2, r1 ~ r2) => Applicative (GenStateContT s1 r1 s2 r2 m) where - pure x = GenStateContT \s k -> k s x - (<*>) = ap - -instance (s1 ~ s2, r1 ~ r2) => Monad (GenStateContT s1 r1 s2 r2 m) where - (>>=) = (>>>=) - -instance (s1 ~ s2, r1 ~ r2) => MonadTrans (GenStateContT s1 r1 s2 r2) where - lift m = gcaptureCC (m >>=) - ------------------------------------------------------------------------ --- Continuation operations ------------------------------------------------------------------------ - --- | Capture the current continuation while preserving the state. -gcaptureCC :: ((a -> m r1) -> m r2) -> GenStateContT s r1 s r2 m a -gcaptureCC f = GenStateContT \s k -> f (k s) - --- | Run two generalized monad computations \"in parallel\" and combine their --- results -gparallel :: - (m r1 -> m r2 -> m r3) -> - GenStateContT s1 r s2 r1 m a -> - GenStateContT s1 r s2 r2 m a -> - GenStateContT s1 r s2 r3 m a -gparallel f (GenStateContT m1) (GenStateContT m2) = GenStateContT \s k -> f (m1 s k) (m2 s k) - --- | Abort the current state-continuation computation and just return an @r2@ -gabortM :: m r2 -> GenStateContT s1 r1 s2 r2 m a -gabortM ret = GenStateContT \_ _ -> ret - ------------------------------------------------------------------------ --- State operations ------------------------------------------------------------------------ - -instance (s1 ~ s2, r1 ~ r2) => MonadState s1 (GenStateContT s1 r1 s2 r2 m) where - get = GenStateContT \s k -> k s s - put = gput - --- | Overwrite the previous state value (with the ability to change its type) -gput :: s -> GenStateContT s r s_ r m () -gput s = GenStateContT \_ k -> k s () - ------------------------------------------------------------------------ --- Derived operations ------------------------------------------------------------------------ - --- | Apply a function to the state to update it. -gmodify :: (s -> t) -> GenStateContT t r s r m () -gmodify f = get >>>= gput . f - --- | Map a function over the final return value. -gmapRet :: (m r1 -> m r2) -> GenStateContT s r1 s r2 m () -gmapRet f_ret = gcaptureCC \k -> f_ret (k ()) - --- | Name-binding in the generalized continuation monad (FIXME: explain) -gopenBinding :: - (Mb ctx (m b1) -> m r2) -> - Mb ctx b2 -> - GenStateContT s b1 s r2 m (RAssign Name ctx, b2) -gopenBinding f_ret mb_a = - gcaptureCC \k -> - f_ret $ flip nuMultiWithElim1 mb_a $ \names a -> - k (names, a) - --- | Name-binding in the generalized continuation monad (FIXME: explain) -gopenNamedBinding :: - (NamedMb ctx (m b1) -> m r2) -> - NamedMb ctx b2 -> - GenStateContT s b1 s r2 m (RAssign Name ctx, b2) -gopenNamedBinding f_ret mb_a = - gcaptureCC \k -> - f_ret $ flip nuMultiWithElim1Named mb_a $ \names a -> - k (names, a) - --- | Name-binding in the generalized continuation monad (FIXME: explain) -startBinding :: - RAssign Proxy ctx -> - (Mb ctx (m r1) -> m r2) -> - GenStateContT s r1 s r2 m (RAssign Name ctx) -startBinding tps f_ret = gcaptureCC (f_ret . nuMulti tps) - --- | Name-binding in the generalized continuation monad (FIXME: explain) -startNamedBinding :: - RAssign StringF ctx -> - (NamedMb ctx (m r1) -> m r2) -> - GenStateContT s r1 s r2 m (RAssign Name ctx) -startNamedBinding tps f_ret = gcaptureCC (f_ret . nuMultiNamed tps) - -addReader :: GenStateContT s1 r1 s2 r2 m a -> GenStateContT s1 r1 s2 r2 (ReaderT e m) a -addReader (GenStateContT m) = - GenStateContT \s2 k -> - ReaderT \e -> - m s2 \s1 a -> - runReaderT (k s1 a) e diff --git a/heapster/src/Heapster/HintExtract.hs b/heapster/src/Heapster/HintExtract.hs deleted file mode 100644 index 2e14491711..0000000000 --- a/heapster/src/Heapster/HintExtract.hs +++ /dev/null @@ -1,289 +0,0 @@ -{-# Language OverloadedStrings #-} -{-# Language PatternSynonyms #-} -{-# Language TypeApplications #-} -{-# Language TypeOperators #-} -{-# Language ScopedTypeVariables #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ParallelListComp #-} -{-# LANGUAGE LambdaCase #-} - -module Heapster.HintExtract ( heapsterRequireName, extractHints ) where - -import Data.String (fromString) -import Data.Functor.Constant (Constant(..)) -import Control.Lens ((^.)) -import Control.Monad.Except -import Data.Maybe (fromMaybe, maybeToList) -import qualified Data.Map as Map -import Data.Char (chr) -import Text.LLVM.AST as L - -import Data.Parameterized (toListFC, fmapFC, (:~:)(..), testEquality) -import qualified Data.Parameterized.Context as Ctx -import Data.Parameterized.TraversableFC (traverseFC) - -import Data.Type.RList (mapRAssign, (:++:)) -import Lang.Crucible.LLVM.Extension ( LLVM, LLVMStmt(..)) -import Lang.Crucible.CFG.Core ( Some(Some) - , CtxRepr - , CFG(..) - , Reg(..) - - , Block(..) - , blockStmts - , StmtSeq(..) - , Stmt (..), BlockID ) - -import Heapster.CruUtil -import Heapster.ParsedCtx -import Heapster.PatternMatchUtil -import Heapster.Permissions -import Heapster.PermParser - -heapsterRequireName :: String -heapsterRequireName = "heapster.require" - --- | The monad we use for extracting hints, which just has 'String' errors -type ExtractM = Except String - --- | Extract block hints from calls to @heapster.require@ in the Crucible CFG. -extractHints :: - forall ghosts args outs blocks init ret. - PermEnv -> - [L.Module] {- ^ The original source modules: used for finding constant values (i.e. spec strings) -} -> - FunPerm ghosts args outs ret {- ^ The FunPerm corresponding to the CFG we are scanning -} -> - CFG LLVM blocks init ret {- ^ The Crucible CFG for which to build the block hint map -} -> - Either String (Ctx.Assignment (Constant (Maybe Hint)) blocks) -extractHints env modules perm cfg = - runExcept $ traverseFC extractHint (cfgBlockMap cfg) - where - globals = - Map.fromList - [ (globalSym g, str) | m <- modules, - g <- modGlobals m, - ValString chars <- maybeToList (globalValue g), - let str = chr . fromEnum <$> chars ] - - extractHint :: Block LLVM blocks ret ctx -> - ExtractM (Constant (Maybe Hint) ctx) - extractHint block = - extractBlockHints env globals (funPermTops perm) block >>= \case - Just (SomeHintSpec ghosts valuePerms) -> - return $ Constant $ Just (mkBlockEntryHint - cfg - (blockID block) - (funPermTops perm) - ghosts - valuePerms) - _ -> return $ Constant Nothing - --- | Packs up the ghosts in a parsed hint permission spec -data SomeHintSpec tops ctx where - SomeHintSpec :: - CruCtx ghosts -> - MbValuePerms ((tops :++: CtxToRList ctx) :++: ghosts) -> - SomeHintSpec tops ctx - --- | Try to find a hint in a Block -extractBlockHints :: - forall blocks ret ctx tops. - PermEnv -> - Map.Map L.Symbol String {- ^ Globals map -} -> - CruCtx tops {- ^ top context derived from current function's perm -} -> - Block LLVM blocks ret ctx -> - ExtractM (Maybe (SomeHintSpec tops ctx)) -extractBlockHints env globals tops block = - extractStmtsHint who env globals tops inputs stmts - where - stmts = block ^. blockStmts - inputs = blockInputs block - who = show (blockID block) - --- | Test if a sequence of statements starts with the Crucible representation of --- a call to the dummy function @heapster.require@ -extractStmtsHint :: - forall blocks ret ctx tops. - String -> - PermEnv -> - Map.Map L.Symbol String {- ^ globals -} -> - CruCtx tops {- ^ top context derived from current function's perm -} -> - CtxRepr ctx {- ^ block arguments -} -> - StmtSeq LLVM blocks ret ctx -> - ExtractM (Maybe (SomeHintSpec tops ctx)) -extractStmtsHint who env globals tops inputs = loop Ctx.zeroSize - where - loop :: - forall rest. - Ctx.Size rest -> - StmtSeq LLVM blocks ret (ctx Ctx.<+> rest) -> - ExtractM (Maybe (SomeHintSpec tops ctx)) - loop sz_rest s = - extractHintFromSequence who env globals tops inputs sz_rest s >>= \case - Just p -> return $ Just p - _ | ConsStmt _ s' rest <- s -> - let inc_rest :: forall tp. Ctx.Size (rest Ctx.::> tp) - inc_rest = Ctx.incSize sz_rest in - case s' of - SetReg{} -> loop inc_rest rest - ExtendAssign{} -> loop inc_rest rest - CallHandle{} -> loop inc_rest rest - Print{} -> loop sz_rest rest - ReadGlobal{} -> loop inc_rest rest - WriteGlobal{} -> loop sz_rest rest - FreshConstant {} -> loop inc_rest rest - FreshFloat {} -> loop inc_rest rest - FreshNat {} -> loop inc_rest rest - NewRefCell {} -> loop inc_rest rest - NewEmptyRefCell {} -> loop inc_rest rest - ReadRefCell {} -> loop inc_rest rest - WriteRefCell {} -> loop sz_rest rest - DropRefCell {} -> loop sz_rest rest - Assert {} -> loop sz_rest rest - Assume {} -> loop sz_rest rest - _ -> return Nothing - --- | Try to recognize the sequence of Crucible instructions leading up to --- a call to heapster.require. If found, build a hint by parsing the provided --- (global) ghost context string and spec string by looking them up --- in the global map. --- --- Will throw an error if the @require@ is malformed (malformed spec strings --- or references out-of-scope values) -extractHintFromSequence :: - forall tops ctx rest blocks ret. - String -> - PermEnv -> - Map.Map L.Symbol String {- ^ globals -} -> - CruCtx tops {- ^ toplevel context -} -> - CtxRepr ctx {- ^ block arguments -} -> - Ctx.Size rest {- ^ keeps track of how deep we are into the current block -} -> - StmtSeq LLVM blocks ret (ctx Ctx.<+> rest) -> - ExtractM (Maybe (SomeHintSpec tops ctx)) -extractHintFromSequence who env globals tops blockIns sz s = - case s of - ConsStmt _ (ExtendAssign (LLVM_ResolveGlobal _ _ f)) - (ConsStmt _ (ExtendAssign (LLVM_ResolveGlobal _ _ ghosts)) - (ConsStmt _ (ExtendAssign (LLVM_ResolveGlobal _ _ spec)) - (ConsStmt _ (ExtendAssign (LLVM_LoadHandle _ _ ptr _ _)) - (ConsStmt _ (CallHandle _ fh _ actuals) _)))) - | globalSymbolName f == heapsterRequireName - , Just Refl <- testEquality ptr fnPtrReg - , Just Refl <- testEquality fh fnHdlReg - , Just ghosts_str <- Map.lookup (fromString (globalSymbolName ghosts)) globals - , Just spec_str <- Map.lookup (fromString (globalSymbolName spec)) globals -> - -- The first two arguments are the ghost/spec strings. - -- we can't "demote" their contexts to block args since they're globals - -- and hence loaded in this block - let (_, _, args) = expectLengthAtLeastTwo $ toListFC Some actuals in - -- "demote" the context of each reg to the block input context, - -- proving that each arg is in fact defined in a previous block - -- (and is thus valid for use in this spec) - case sequence (toBlockArg (Ctx.size blockIns) sizeAtCall <$> args) of - Just demoted -> - Just <$> requireArgsToHint who env blockIns tops demoted ghosts_str spec_str - Nothing -> - throwError (who ++ ": spec refers to block-defined expressions") - - _ -> return Nothing - - where - fnPtrReg :: forall a b tp. Reg (ctx Ctx.<+> rest Ctx.::> tp Ctx.::> a Ctx.::> b) tp - fnPtrReg = Reg (Ctx.skipIndex (Ctx.skipIndex (Ctx.nextIndex (Ctx.addSize (Ctx.size blockIns) sz)))) - - fnHdlReg :: forall a b c tp. Reg ((ctx Ctx.<+> rest) Ctx.::> a Ctx.::> b Ctx.::> c Ctx.::> tp) tp - fnHdlReg = Reg (Ctx.lastIndex (Ctx.addSize (Ctx.size blockIns) sizeAtCall)) - - sizeAtCall :: forall a b c d. Ctx.Size (rest Ctx.::> a Ctx.::> b Ctx.::> c Ctx.::> d) - sizeAtCall = Ctx.incSize (Ctx.incSize (Ctx.incSize (Ctx.incSize sz))) - --- | Assemble a Hint --- --- Will throw an error if the @require@ is malformed (malformed spec strings --- or references out-of-scope values) -requireArgsToHint :: - String {-^ A string representing the block in which this call appears (for errors) -} -> - PermEnv -> - CtxRepr ctx {-^ The block arguments -} -> - CruCtx tops {-^ Toplevel arguments -} -> - [Some (Reg ctx)] {-^ The actual arguments to the require, demoted to block args -} -> - String {-^ The ghost ctx to parse -} -> - String {-^ The permissions to parse -} -> - ExtractM (SomeHintSpec tops ctx) -requireArgsToHint who env blockIns tops args ghostString specString = - case parseParsedCtxString who env ghostString of - Just (Some ghost_ctx) -> - let full_ctx = appendParsedCtx (appendParsedCtx top_ctx ctx_rename) ghost_ctx - sub = buildHintSub blockIns args - ctx = mkArgsParsedCtx (mkCruCtx blockIns) - top_ctx = mkTopParsedCtx tops - ctx_rename = renameParsedCtx sub ctx - in maybe (throwError (who ++ ": error parsing permissions")) - (return . SomeHintSpec (parsedCtxCtx ghost_ctx)) - (parsePermsString who env full_ctx specString) - Nothing -> - throwError (who ++ ": error parsing ghost context") - --- | Apply a substitution to the names in a ParsedCtx -renameParsedCtx :: [(String, String)] -> ParsedCtx ctx -> ParsedCtx ctx -renameParsedCtx sub ctx = ctx { parsedCtxNames = renamed } - where - renamed = mapRAssign (\(Constant x) -> - Constant (substNames x)) (parsedCtxNames ctx) - substNames x = fromMaybe x (lookup x sub) - --- | Build a susbstitution to apply to block arguments based on the actual --- arguments provided to a @requires@ call, i.e. given --- @heapster.require(..., ..., %11, %50)@ --- if @%11@ corresponds to block argument 1 and @%50@ to block argument 0, --- with block arg 2 unused, then return the substitution --- @[("arg1", "arg0"), ("arg1, arg0"), ("arg2", "arg2")]@ -buildHintSub :: - forall block_args. - CtxRepr block_args -> - [Some (Reg block_args)] -> - [(String, String)] -buildHintSub blockArgs args = usedSub - where - argNames = someRegName <$> args - unusedNames = argNamei <$> [length argNames .. (Ctx.sizeInt (Ctx.size blockArgs))] - usedSub = [ (a, argNamei i) | i <- [0..] | a <- argNames ++ unusedNames ] - --- | Check if we can use a register in a smaller context, and --- return the register indexed by the new context if so. -toBlockArg :: - Ctx.Size block_args -> - Ctx.Size rest -> - Some (Reg (block_args Ctx.<+> rest)) -> - Maybe (Some (Reg block_args)) -toBlockArg argsSz _restSz reg = - case reg of - Some (Reg idx) -> - do Some idx' <- Ctx.intIndex (Ctx.indexVal idx) argsSz - pure $ Some $ Reg idx' - --- | Constructor for block entry hints -mkBlockEntryHint :: - forall blocks init ret top_args ghosts args. - CFG LLVM blocks init ret -> - BlockID blocks args -> - CruCtx top_args -> - CruCtx ghosts -> - MbValuePerms ((top_args :++: CtxToRList args) :++: ghosts) -> - Hint -mkBlockEntryHint cfg blockId tops ghosts valPerms = - Hint_Block $ BlockHint h blocks blockId entryHint - where - entryHint = BlockEntryHintSort tops ghosts valPerms - h = cfgHandle cfg - blocks = fmapFC blockInputs $ cfgBlockMap cfg - --- | Like mkArgParsedContext, but with all of the names --- set to \"topi\" instead of \"argi\" -mkTopParsedCtx :: CruCtx ctx -> ParsedCtx ctx -mkTopParsedCtx = mkPrefixParsedCtx "top" - -someRegName :: Some (Reg ctx) -> String -someRegName (Some (Reg i)) = argNamei (Ctx.indexVal i) - -argNamei :: Int -> String -argNamei i = "arg" ++ show i diff --git a/heapster/src/Heapster/IDESupport.hs b/heapster/src/Heapster/IDESupport.hs deleted file mode 100644 index e53b1857e2..0000000000 --- a/heapster/src/Heapster/IDESupport.hs +++ /dev/null @@ -1,332 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE PolyKinds #-} -module Heapster.IDESupport where - -import Control.Monad.Reader - ( MonadReader (ask, local), - ReaderT (..), - ) -import Data.Aeson (ToJSON, Value, encodeFile) -import Data.Binding.Hobbits - ( Liftable (..), - Mb, - NuMatching (..), - RList, - mbMatch, - nuMP, - nuMultiWithElim1, - unsafeMbTypeRepr, - Name, - ) -import Data.Kind (Type) -import Data.Maybe (catMaybes, listToMaybe, mapMaybe) -import Data.Parameterized.Some (Some (..)) -import qualified Data.Text as T -import qualified Data.Type.RList as RL -import GHC.Generics (Generic) -import Lang.Crucible.FunctionHandle -import Lang.Crucible.Types (CrucibleType) -import What4.FunctionName (FunctionName (functionName)) -import What4.ProgramLoc - ( Position (BinaryPos, InternalPos, OtherPos, SourcePos), - ProgramLoc (..), - ) - -import Heapster.CruUtil -import Heapster.Permissions -import Heapster.Implication -import Heapster.TypedCrucible -import Heapster.SAWTranslation (SomeTypedCFG (..)) -import Heapster.JSONExport(ppToJson) -import Data.Type.RList (mapRAssign) -import Data.Functor.Constant -import Control.Monad.Writer -import Data.Binding.Hobbits.NameMap (NameMap) -import qualified Data.Binding.Hobbits.NameMap as NameMap -import Heapster.NamedMb - --- | The entry point for dumping a Heapster environment to a file for IDE --- consumption. -printIDEInfo :: PermEnv -> [Some SomeTypedCFG] -> FilePath -> PPInfo -> IO () -printIDEInfo _penv tcfgs file ppinfo = - encodeFile file $ IDELog (runWithLoc ppinfo tcfgs) - - -type ExtractionM = ReaderT (PPInfo, ProgramLoc, String) (Writer [LogEntry]) - -emit :: LogEntry -> ExtractionM () -emit entry = tell [entry] - -gather :: ExtractionM () -> ExtractionM [LogEntry] -gather m = snd <$> listen m - --- | A single entry in the IDE info dump log. At a bare minimum, this must --- include a location and corresponding permission. Once the basics are --- working, we can enrich the information we log. -data LogEntry - = LogEntry - { leLocation :: String - , leEntryId :: LogEntryID - , leCallers :: [LogEntryID] - , leFunctionName :: String - , lePermissions :: [(String, String, Value)] - } - | LogError - { lerrLocation :: String - , lerrError :: String - , lerrFunctionName :: String - } - | LogImpl - { limplLocation :: String - , limplExport :: Value - , limplFunctionName :: String - } - - deriving (Generic, Show) -instance ToJSON LogEntry -instance NuMatching LogEntry where - nuMatchingProof = unsafeMbTypeRepr -instance Liftable LogEntry where - mbLift mb = case mbMatch mb of - [nuMP| LogEntry v w x y z |] -> - LogEntry (mbLift v) (mbLift w) (mbLift x) (mbLift y) (mbLift z) - [nuMP| LogError x y z |] -> - LogError (mbLift x) (mbLift y) (mbLift z) - [nuMP| LogImpl x y z |] -> - LogImpl (mbLift x) (mbLift y) (mbLift z) - -data LogEntryID = LogEntryID - { leIdBlock :: Int - , leIdHeapster :: Int - } - deriving (Generic, Show) -instance ToJSON LogEntryID -instance NuMatching LogEntryID where - nuMatchingProof = unsafeMbTypeRepr -instance Liftable LogEntryID where - mbLift mb = case mbMatch mb of - [nuMP| LogEntryID x y |] -> LogEntryID (mbLift x) (mbLift y) - --- | A complete IDE info dump log, which is just a sequence of entries. Once --- the basics are working, we can enrich the information we log. -newtype IDELog = IDELog { - lmfEntries :: [LogEntry] -} deriving (Generic, Show) -instance ToJSON IDELog - - -class ExtractLogEntries a where - extractLogEntries :: a -> ExtractionM () - -instance (PermCheckExtC ext extExpr) - => ExtractLogEntries - (TypedEntry TransPhase ext blocks tops ret args ghosts) where - extractLogEntries te = do - let loc = mbLiftNamed $ fmap getFirstProgramLocTS (typedEntryBody te) - withLoc loc (mb'ExtractLogEntries (typedEntryBody te)) - let entryId = mkLogEntryID $ typedEntryID te - let callers = callerIDs $ typedEntryCallers te - (ppi, _, fname) <- ask - let loc' = snd (ppLoc loc) - let debugNames = _mbNames (typedEntryBody te) - let insertNames :: - RL.RAssign Name (x :: RList CrucibleType) -> - RL.RAssign StringF x -> - NameMap (StringF :: CrucibleType -> Type)-> - NameMap (StringF :: CrucibleType -> Type) - insertNames RL.MNil RL.MNil m = m - insertNames (ns RL.:>: n) (xs RL.:>: StringF name) m = - insertNames ns xs (NameMap.insert n (StringF name) m) - inputs = mbLift - $ flip nuMultiWithElim1 (typedEntryPermsIn te) - $ \ns body -> - let ppi' = ppi { ppExprNames = insertNames ns debugNames (ppExprNames ppi) } - f :: - (Pair StringF ValuePerm) x -> - Constant (String, String, Value) x - f (Pair (StringF name) vp) = Constant (name, permPrettyString ppi' vp, ppToJson ppi' vp) - in RL.toList (mapRAssign f (zipRAssign debugNames body)) - tell [LogEntry loc' entryId callers fname inputs] - -mkLogEntryID :: TypedEntryID blocks args -> LogEntryID -mkLogEntryID = uncurry LogEntryID . entryIDIndices - -callerIDs :: [Some (TypedCallSite phase blocks tops args ghosts)] -> [LogEntryID] -callerIDs = map $ \(Some tcs) -> case typedCallSiteID tcs of - TypedCallSiteID tei _ _ _ -> mkLogEntryID tei - -data Pair f g x = Pair (f x) (g x) - -zipRAssign :: RL.RAssign f x -> RL.RAssign g x -> RL.RAssign (Pair f g) x -zipRAssign RL.MNil RL.MNil = RL.MNil -zipRAssign (xs RL.:>: x) (ys RL.:>: y) = zipRAssign xs ys RL.:>: Pair x y - -instance ExtractLogEntries (TypedStmtSeq ext blocks tops ret ps_in) where - extractLogEntries (TypedImplStmt (AnnotPermImpl _str pimpl)) = - -- fmap (setErrorMsg str) <$> extractLogEntries pimpl - extractLogEntries pimpl - extractLogEntries (TypedConsStmt loc _ _ rest) = do - withLoc loc $ mb'ExtractLogEntries rest - extractLogEntries (TypedTermStmt _ _) = pure () - -instance ExtractLogEntries - (PermImpl (TypedStmtSeq ext blocks tops ret) ps_in) where - extractLogEntries (PermImpl_Step pi1 mbpis) = do - pi1Entries <- extractLogEntries pi1 - pisEntries <- extractLogEntries mbpis - return $ pi1Entries <> pisEntries - extractLogEntries (PermImpl_Done stmts) = extractLogEntries stmts - -instance ExtractLogEntries (PermImpl1 ps_in ps_outs) where - extractLogEntries (Impl1_Fail err) = - do (_, loc, fname) <- ask - emit (LogError (snd (ppLoc loc)) (ppError err) fname) - -- The error message is available further up the stack, so we just leave it - extractLogEntries impl = - do (ppi, loc, fname) <- ask - emit (LogImpl (snd (ppLoc loc)) (ppToJson ppi impl) fname) - -instance ExtractLogEntries - (MbPermImpls (TypedStmtSeq ext blocks tops ret) ps_outs) where - extractLogEntries (MbPermImpls_Cons ctx mbpis pis) = do - mbExtractLogEntries ctx pis - extractLogEntries mbpis - extractLogEntries MbPermImpls_Nil = pure () - -instance (PermCheckExtC ext extExpr) - => ExtractLogEntries (TypedCFG ext blocks ghosts inits gouts ret) where - extractLogEntries tcfg = extractLogEntries $ tpcfgBlockMap tcfg - -instance (PermCheckExtC ext extExpr) - => ExtractLogEntries (TypedBlockMap TransPhase ext blocks tops ret) where - extractLogEntries tbm = - sequence_ $ RL.mapToList extractLogEntries tbm - -instance (PermCheckExtC ext extExpr) - => ExtractLogEntries (TypedBlock TransPhase ext blocks tops ret args) where - extractLogEntries tb = - mapM_ (\(Some te) -> extractLogEntries te) $ _typedBlockEntries tb - -mbExtractLogEntries - :: ExtractLogEntries a => CruCtx ctx -> Mb (ctx :: RList CrucibleType) a -> ExtractionM () -mbExtractLogEntries ctx mb_a = - ReaderT $ \(ppi, loc, fname) -> - tell $ mbLift $ flip nuMultiWithElim1 mb_a $ \ns x -> - let ppi' = ppInfoAddTypedExprNames ctx ns ppi in - execWriter $ runReaderT (extractLogEntries x) (ppi', loc, fname) - -mb'ExtractLogEntries - :: ExtractLogEntries a => NamedMb (ctx :: RList CrucibleType) a -> ExtractionM () -mb'ExtractLogEntries mb_a = - ReaderT $ \(ppi, loc, fname) -> - tell $ mbLift $ flip nuMultiWithElim1 (_mbBinding mb_a) $ \ns x -> - let ppi' = ppInfoApplyAllocation ns (_mbNames mb_a) ppi in - execWriter $ runReaderT (extractLogEntries x) (ppi', loc, fname) - -typedStmtOutCtx :: TypedStmt ext rets ps_in ps_next -> CruCtx rets -typedStmtOutCtx = error "FIXME: write typedStmtOutCtx" - -withLoc :: ProgramLoc -> ExtractionM a -> ExtractionM a -withLoc loc = local (\(ppinfo, _, fname) -> (ppinfo, loc, fname)) - -setErrorMsg :: String -> LogEntry -> LogEntry -setErrorMsg msg le@LogError {} = le { lerrError = msg } -setErrorMsg msg le@LogImpl {} = - LogError { lerrError = msg - , lerrLocation = limplLocation le - , lerrFunctionName = limplFunctionName le} -setErrorMsg msg le@LogEntry {} = - LogError { lerrError = msg - , lerrLocation = leLocation le - , lerrFunctionName = leFunctionName le - } - -runWithLoc :: PPInfo -> [Some SomeTypedCFG] -> [LogEntry] -runWithLoc ppi = - concatMap (runWithLocHelper ppi) - where - runWithLocHelper :: PPInfo -> Some SomeTypedCFG -> [LogEntry] - runWithLocHelper ppi' sstcfg = case sstcfg of - Some (SomeTypedCFG _ _ tcfg) -> do - let env = (ppi', getFirstProgramLoc tcfg, getFunctionName tcfg) - execWriter (runReaderT (extractLogEntries tcfg) env) - -getFunctionName :: TypedCFG ext blocks ghosts inits gouts ret -> String -getFunctionName tcfg = case tpcfgHandle tcfg of - TypedFnHandle _ _ handle -> show $ handleName handle - -getFirstProgramLoc - :: PermCheckExtC ext extExpr - => TypedCFG ext blocks ghosts inits gouts ret -> ProgramLoc -getFirstProgramLoc tcfg = - case listToMaybe $ catMaybes $ - RL.mapToList getFirstProgramLocBM $ tpcfgBlockMap tcfg of - Just pl -> pl - _ -> error "Unable to get initial program location" - -getFirstProgramLocBM - :: PermCheckExtC ext extExpr - => TypedBlock TransPhase ext blocks tops ret ctx - -> Maybe ProgramLoc -getFirstProgramLocBM block = - listToMaybe $ mapMaybe helper (_typedBlockEntries block) - where - helper - :: PermCheckExtC ext extExpr - => Some (TypedEntry TransPhase ext blocks tops ret ctx) - -> Maybe ProgramLoc - helper ste = case ste of - Some TypedEntry { typedEntryBody = stmts } -> - Just $ mbLiftNamed $ fmap getFirstProgramLocTS stmts - --- | From the sequence, get the first program location we encounter, which --- should correspond to the permissions for the entry point we want to log -getFirstProgramLocTS :: PermCheckExtC ext extExpr - => TypedStmtSeq ext blocks tops ret ctx - -> ProgramLoc -getFirstProgramLocTS (TypedImplStmt (AnnotPermImpl _ pis)) = - getFirstProgramLocPI pis -getFirstProgramLocTS (TypedConsStmt loc _ _ _) = loc -getFirstProgramLocTS (TypedTermStmt loc _) = loc - -getFirstProgramLocPI - :: PermCheckExtC ext extExpr - => PermImpl (TypedStmtSeq ext blocks tops ret) ctx - -> ProgramLoc -getFirstProgramLocPI (PermImpl_Done stmts) = getFirstProgramLocTS stmts -getFirstProgramLocPI (PermImpl_Step _ mbps) = getFirstProgramLocMBPI mbps - -getFirstProgramLocMBPI - :: PermCheckExtC ext extExpr - => MbPermImpls (TypedStmtSeq ext blocks tops ret) ctx - -> ProgramLoc -getFirstProgramLocMBPI MbPermImpls_Nil = - error "Error finding program location for IDE log" -getFirstProgramLocMBPI (MbPermImpls_Cons _ _ pis) = - mbLift $ fmap getFirstProgramLocPI pis - --- | Print a `ProgramLoc` in a way that is useful for an IDE, i.e., machine --- readable -ppLoc :: ProgramLoc -> (String, String) -ppLoc pl = - let fnName = T.unpack $ functionName $ plFunction pl - locStr = ppPos $ plSourceLoc pl - - ppPos (SourcePos file line column) = - T.unpack file <> ":" <> show line <> ":" <> show column - ppPos (BinaryPos _ _) = "" - ppPos (OtherPos _) = "" - ppPos InternalPos = "" - in (fnName, locStr) diff --git a/heapster/src/Heapster/Implication.hs b/heapster/src/Heapster/Implication.hs deleted file mode 100644 index c60edea6c5..0000000000 --- a/heapster/src/Heapster/Implication.hs +++ /dev/null @@ -1,9619 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE BangPatterns #-} - -module Heapster.Implication where - -import Data.Maybe -import Data.List (delete, elemIndex, find, findIndex) -import Data.Functor.Compose -import Data.Reflection -import qualified Data.BitVector.Sized as BV -import GHC.TypeLits (KnownNat) -import Control.Lens hiding ((:>), ix) -import qualified Control.Applicative as App -import Control.Monad (forM_) -import Control.Monad.Extra (concatMapM) -import Control.Monad.State.Strict (MonadState(..), State, StateT, evalState, execStateT) -import Control.Monad.Trans.Class (MonadTrans(..)) - -import qualified Data.Type.RList as RL -import Data.Binding.Hobbits.MonadBind -import Data.Binding.Hobbits.NameMap (NameMap, NameAndElem(..)) -import qualified Data.Binding.Hobbits.NameMap as NameMap -import Data.Binding.Hobbits.NameSet (NameSet) -import qualified Data.Binding.Hobbits.NameSet as NameSet - -import Prettyprinter as PP - -import Data.Parameterized.BoolRepr -import Data.Parameterized.TraversableF - -import Lang.Crucible.Types -import Lang.Crucible.LLVM.DataLayout -import Lang.Crucible.LLVM.MemModel -import Lang.Crucible.CFG.Core -import Lang.Crucible.FunctionHandle -import SAWCore.Term.Functor (Ident) -import Lang.Crucible.LLVM.Bytes - -import Data.Binding.Hobbits - -import Heapster.Panic -import Heapster.CruUtil -import Heapster.PatternMatchUtil -import Heapster.Permissions -import Heapster.GenMonad - -import GHC.Stack -import Unsafe.Coerce -import Data.Functor.Constant (Constant(..)) -import Data.Functor.Product (Product(..)) - - - ----------------------------------------------------------------------- --- * Equality Proofs ----------------------------------------------------------------------- - --- | An equality permission @x:eq(e)@ read as an an equality @x=e@ or @e=x@, --- where the 'Bool' flag is 'True' for the former and 'False' for the latter -data EqPerm a = EqPerm (ExprVar a) (PermExpr a) Bool - --- | Get the LHS of the equation represented by an 'EqPerm' -eqPermLHS :: EqPerm a -> PermExpr a -eqPermLHS (EqPerm x _ True) = PExpr_Var x -eqPermLHS (EqPerm _ e False) = e - --- | Get the RHS of the equation represented by an 'EqPerm' -eqPermRHS :: EqPerm a -> PermExpr a -eqPermRHS (EqPerm _ e True) = e -eqPermRHS (EqPerm x _ False) = PExpr_Var x - --- | Get the variable out of an 'EqPerm' -eqPermVar :: EqPerm a -> ExprVar a -eqPermVar (EqPerm x _ _) = x - --- | Get the permission @eq(e)@ out of an 'EqPerm' -eqPermPerm :: EqPerm a -> ValuePerm a -eqPermPerm (EqPerm _ e _) = ValPerm_Eq e - --- | Get the variable and permission out of an 'EqPerm' -eqPermVarAndPerm :: EqPerm a -> VarAndPerm a -eqPermVarAndPerm (EqPerm x e _) = VarAndPerm x (ValPerm_Eq e) - --- | Apply symmetry to an 'EqPerm', changing an @e1=e2@ proof to @e2=e1@ -eqPermSym :: EqPerm a -> EqPerm a -eqPermSym (EqPerm x e flag) = EqPerm x e (not flag) - --- | A single step of an equality proof on some type @a@ is a sequence of @N@ --- 'EqPerms', each of which specifies a LHS and a RHS expression (one of which --- is a variable), along with a function @f@ from these @N@ expressions to an --- @a@. This represents a proof that @f es_lhs = f es_rhs@, where @es_lhs@ and --- @es_rhs@ are the LHS and RHS expressions, respectively, of the 'EqPerm's. -data EqProofStep ps a = EqProofStep (RAssign EqPerm ps) (PermExprs ps -> a) - --- | Get the left-hand side of an 'EqProofStep' -eqProofStepLHS :: EqProofStep ps a -> a -eqProofStepLHS (EqProofStep eq_perms f) = f (RL.map eqPermLHS eq_perms) - --- | Get the right-hand side of an 'EqProofStep' -eqProofStepRHS :: EqProofStep ps a -> a -eqProofStepRHS (EqProofStep eq_perms f) = f (RL.map eqPermRHS eq_perms) - --- | Get the equality permissions required by an 'EqProofStep' -eqProofStepPerms :: EqProofStep ps a -> DistPerms ps -eqProofStepPerms (EqProofStep eq_perms _) = RL.map eqPermVarAndPerm eq_perms - --- | Get the equalities required by an 'EqProofStep' -eqProofStepEqs :: EqProofStep ps a -> RAssign EqPerm ps -eqProofStepEqs (EqProofStep eq_perms _) = eq_perms - -instance Functor (EqProofStep ps) where - fmap f (EqProofStep eq_perms g) = EqProofStep eq_perms (f . g) - --- | Build a reflexive 'EqProofStep' that any object equals itself. The --- resulting proof uses no 'EqPerm's. This function along with --- 'eqProofStepLiftA2' forms a parameterized 'Applicative', where the @ps@ --- argument changes when we combine proofs but otherwise satisfies the --- 'Applicative' laws. -eqProofStepRefl :: a -> EqProofStep RNil a -eqProofStepRefl a = EqProofStep MNil (const a) - --- | Apply symmetry to a 'EqProofStep', changing an @e1=e2@ proof to @e2=e1@ -eqProofStepSym :: EqProofStep ps a -> EqProofStep ps a -eqProofStepSym (EqProofStep eq_perms f) = - EqProofStep (RL.map eqPermSym eq_perms) f - --- | Combine two 'EqProofStep's using a function, similar to the 'liftA2' method --- of 'Applicative'. The result uses the 'EqPerm's of both proofs. This function --- along with 'eqProofStepRefl' forms a parameterized 'Applicative', where the --- @ps@ argument changes when we combine proofs but otherwise satisfies the --- 'Applicative' laws. -eqProofStepLiftA2 :: (a -> b -> c) -> EqProofStep ps1 a -> EqProofStep ps2 b -> - EqProofStep (ps1 :++: ps2) c -eqProofStepLiftA2 f (EqProofStep eq_perms1 g1) (EqProofStep eq_perms2 g2) = - EqProofStep (RL.append eq_perms1 eq_perms2) $ \es -> - let (es1, es2) = RL.split eq_perms1 eq_perms2 es in - f (g1 es1) (g2 es2) - --- | Build an 'EqProofStep' for @(e1,...,en)=(x1,...,xn)@ from permissions --- @x1:eq(e1),...,xn:eq(en)@ -eqProofStepFromPermsRev :: RAssign ExprVar as -> PermExprs as -> - EqProofStep as (PermExprs as) -eqProofStepFromPermsRev xs es = - EqProofStep (RL.map2 (\x e -> EqPerm x e False) xs es) id - --- | A proof that two objects are equal, using 0 or more 'EqProofStep' steps -data EqProof ps a where - EqProofRefl :: a -> EqProof RNil a - EqProofCons :: EqProof ps1 a -> EqProofStep ps2 a -> - EqProof (ps1 :++: ps2) a - --- NOTE: this can be done but requires a lot of type-level equality proofs -{- --- | Construct an 'EqProof' by transitivity, checking that the RHS of the first --- proof equals the LHS of the second -eqProofTrans :: Eq a => EqProof ps1 a -> EqProof ps2 a -> - EqProof (ps1 :++: ps2) a -eqProofTrans eqp (EqProofRefl a) | eqProofRHS eqp == a = eqp --- FIXME: need to prove RNil :++: ps2 :~: ps2 ---eqProofTrans EqProofRefl eqp = eqp -eqProofTrans eqp1 eqp2 - | eqProofRHS eqp1 == eqProofLHS eqp2 - = EqProofTrans eqp1 eqp2 -eqProofTrans _ _ = error "eqProofTrans" --} - --- | Get the LHS of an 'EqProof' -eqProofLHS :: EqProof ps a -> a -eqProofLHS (EqProofRefl a) = a -eqProofLHS (EqProofCons eqp1 _) = eqProofLHS eqp1 - --- | Get the RHS of an 'EqProof' -eqProofRHS :: EqProof ps a -> a -eqProofRHS (EqProofRefl a) = a -eqProofRHS (EqProofCons _ eq_step) = eqProofStepRHS eq_step - --- | Get the permissions needed by an 'EqProof' -eqProofPerms :: EqProof ps a -> DistPerms ps -eqProofPerms (EqProofRefl _) = DistPermsNil -eqProofPerms (EqProofCons eqp eq_step) = - appendDistPerms (eqProofPerms eqp) (eqProofStepPerms eq_step) - --- | Build an 'EqProof' from a single 'EqProofStep' -eqProofFromStep :: EqProofStep ps a -> EqProof ps a -eqProofFromStep eq_step - | Refl <- RL.prependRNilEq (eqProofStepPerms eq_step) - = EqProofCons (EqProofRefl $ eqProofStepLHS eq_step) eq_step - --- | Build an 'EqProof' that @(e1,...,en)=(x1,...,xn)@ from permissions --- @x1:eq(e1),...,xn:eq(en)@ -eqProofFromPermsRev :: RAssign ExprVar as -> PermExprs as -> - EqProof as (PermExprs as) -eqProofFromPermsRev xs es = eqProofFromStep $ eqProofStepFromPermsRev xs es - -instance Functor (EqProof ps) where - fmap f (EqProofRefl a) = EqProofRefl $ f a - fmap f (EqProofCons eqp eq_step) = - EqProofCons (fmap f eqp) (fmap f eq_step) - --- | An equality proof using some unknown set of permissions -data SomeEqProof a where - SomeEqProofRefl :: a -> SomeEqProof a - SomeEqProofCons :: SomeEqProof a -> EqProofStep ps a -> SomeEqProof a - --- | Get the LHS of a 'SomeEqProof' -someEqProofLHS :: SomeEqProof a -> a -someEqProofLHS (SomeEqProofRefl a) = a -someEqProofLHS (SomeEqProofCons some_eqp _) = someEqProofLHS some_eqp - --- | Get the RHS of a 'SomeEqProof' -someEqProofRHS :: SomeEqProof a -> a -someEqProofRHS (SomeEqProofRefl a) = a -someEqProofRHS (SomeEqProofCons _ eq_step) = eqProofStepRHS eq_step - --- | Get all the equality permissions used by a 'SomeEqProof' -someEqProofEqs :: SomeEqProof a -> Some (RAssign EqPerm) -someEqProofEqs (SomeEqProofRefl _) = Some MNil -someEqProofEqs (SomeEqProofCons some_eqp eq_step) = - apSomeRAssign (Some $ eqProofStepEqs eq_step) (someEqProofEqs some_eqp) - --- | Get all the equality permissions used by a 'SomeEqProof' -someEqProofPerms :: SomeEqProof a -> Some DistPerms -someEqProofPerms (SomeEqProofRefl _) = Some MNil -someEqProofPerms (SomeEqProofCons some_eqp eq_step) - | Some ps <- someEqProofPerms some_eqp = - Some (RL.append ps $ eqProofStepPerms eq_step) - -someEqProofPP :: PermPretty a => PPInfo -> SomeEqProof a -> Doc ann -someEqProofPP i pf = - pretty "SomeEqProof:" - <+> permPretty i (someEqProofLHS pf) - <+> pretty "=" - <+> permPretty i (someEqProofRHS pf) - <+> line - <+> permPretty i (someEqProofPerms pf) - --- | Construct a 'SomeEqProof' for @x=e@ or @e=x@ using an @x:eq(e)@ permission, --- where the 'Bool' flag is 'True' for @x=e@ and 'False' for @e=x@ like 'EqPerm' -someEqProof1 :: ExprVar a -> PermExpr a -> Bool -> SomeEqProof (PermExpr a) -someEqProof1 x e flag = - let eq_step = EqProofStep (MNil :>: EqPerm x e flag) (\(_ :>: e') -> e') in - SomeEqProofCons (SomeEqProofRefl $ eqProofStepLHS eq_step) eq_step - --- | A 'SomeEqProof' for the identity @x = x &+ 0@ -someEqProofZeroOffset :: (1 <= w, KnownNat w) => ExprVar (LLVMPointerType w) -> - SomeEqProof (PermExpr (LLVMPointerType w)) -someEqProofZeroOffset x = - someEqProof1 x (PExpr_LLVMOffset x (zeroOfType (BVRepr knownNat))) True - --- | Apply symmetry to a 'SomeEqProof', changing an @e1=e2@ proof to @e2=e1@ -someEqProofSym :: SomeEqProof a -> SomeEqProof a -someEqProofSym eqp_top = - helper eqp_top (SomeEqProofRefl $ someEqProofRHS eqp_top) where - -- helper implements someEqProofSym using an accumulator - helper :: SomeEqProof a -> SomeEqProof a -> SomeEqProof a - helper (SomeEqProofRefl _) accum = accum - helper (SomeEqProofCons eqp step) accum = - helper eqp (SomeEqProofCons accum (eqProofStepSym step)) - --- | Construct a 'SomeEqProof' by transitivity -someEqProofTrans :: Eq a => SomeEqProof a -> SomeEqProof a -> SomeEqProof a -someEqProofTrans some_eqp1 some_eqp2 - | someEqProofRHS some_eqp1 == someEqProofLHS some_eqp2 = - someEqProofTrans' some_eqp1 some_eqp2 -someEqProofTrans _ _ = error "someEqProofTrans" - --- | Unchecked version of 'someEqProofTrans' -someEqProofTrans' :: SomeEqProof a -> SomeEqProof a -> SomeEqProof a -someEqProofTrans' some_eqp (SomeEqProofRefl _) = some_eqp -someEqProofTrans' some_eqp1 (SomeEqProofCons some_eqp2 eq_step) = - SomeEqProofCons (someEqProofTrans' some_eqp1 some_eqp2) eq_step - -instance Functor SomeEqProof where - fmap f (SomeEqProofRefl a) = SomeEqProofRefl $ f a - fmap f (SomeEqProofCons some_eqp eq_step) = - SomeEqProofCons (fmap f some_eqp) (fmap f eq_step) - --- NOTE: this is possible, but it requires a lot of type-level equality proofs -{- --- | A version of 'liftA2' for 'EqProof', which, like 'eqProofStepLiftA2', forms --- a parameterized 'Applicative' -eqProofLiftA2 :: (a -> b -> c) -> EqProof ps1 a -> EqProof ps2 b -> - EqProof (ps1 :++: ps2) c -eqProofLiftA2 f (EqProofRefl a) eqp - -- NOTE: this is to prove RNil :++: ps2 ~ ps2 - | Refl <- prependRNilEq (eqProofPerms eqp) = fmap (f a) eqp -eqProofLiftA2 f eqp (EqProofRefl b) = fmap (flip f b) eqp -eqProofLiftA2 f (EqProof1 eq_step1) (EqProof1 eq_step2) = - EqProof1 (eqProofStepLiftA2 f eq_step1 eq_step2) --} - -instance Applicative SomeEqProof where - pure = SomeEqProofRefl - liftA2 f (SomeEqProofRefl a) some_eqp = fmap (f a) some_eqp - liftA2 f some_eqp (SomeEqProofRefl b) = fmap (flip f b) some_eqp - liftA2 f (SomeEqProofCons eqp1 step1) (SomeEqProofCons eqp2 step2) = - SomeEqProofCons (App.liftA2 f eqp1 eqp2) (eqProofStepLiftA2 f step1 step2) - --- | An 'EqProofStep' with an existentially quantified list of permissions -data SomeEqProofStep a = forall ps. SomeEqProofStep (EqProofStep ps a) - --- | Build an 'EqProofStep' by finding each free variable @x@ in an object that --- has some equality permission @x:eq(e)@ in the supplied variable permission --- map and substituting @e@ for @x@ -eqProofStepFromSubst :: (AbstractVars a, FreeVars a, - Substable PermSubst a Identity) => NameMap ValuePerm -> - a -> SomeEqProofStep a -eqProofStepFromSubst var_ps a - | AbsObj vars cl_mb_a <- abstractFreeVars a - , eq_perms <- RL.map (\var -> case NameMap.lookup var var_ps of - Just (ValPerm_Eq e) -> EqPerm var e True - _ -> EqPerm var (PExpr_Var var) True) vars = - SomeEqProofStep $ - EqProofStep eq_perms (\es -> subst (substOfExprs es) (unClosed cl_mb_a)) - --- | Build a 'SomeEqProof' by finding each free variable @x@ in an object that --- has some equality permission @x:eq(e)@ in the supplied variable permission --- map and substituting @e@ for @x@ -someEqProofFromSubst :: (AbstractVars a, FreeVars a, - Substable PermSubst a Identity) => NameMap ValuePerm -> - a -> SomeEqProof a -someEqProofFromSubst var_ps a - | SomeEqProofStep eq_step <- eqProofStepFromSubst var_ps a = - SomeEqProofCons (SomeEqProofRefl a) eq_step - --- | A 'SomeEqProof' that has been converted to an 'EqProof' with explicit perms -data UnSomeEqProof a = forall ps. UnSomeEqProof (EqProof ps a) - --- | Convert a 'SomeEqProof' to an 'EqProof' -unSomeEqProof :: SomeEqProof a -> UnSomeEqProof a -unSomeEqProof (SomeEqProofRefl a) = UnSomeEqProof $ EqProofRefl a -unSomeEqProof (SomeEqProofCons some_eqp eq_step) - | UnSomeEqProof eqp <- unSomeEqProof some_eqp = - UnSomeEqProof $ EqProofCons eqp eq_step - - ----------------------------------------------------------------------- --- * Implication Errors ----------------------------------------------------------------------- - -data ImplError where - GeneralError :: Doc ann -> ImplError - NoFrameInScopeError :: ImplError - ArrayStepError :: ImplError - MuUnfoldError :: ImplError - FunctionPermissionError :: ImplError - PartialSubstitutionError :: String -> Doc ann -> ImplError - LifetimeError :: LifetimeErrorType -> ImplError - MemBlockError :: Doc ann -> ImplError - EqualityProofError :: Doc ann -> Doc ann -> ImplError - InsufficientVariablesError :: Doc ann -> ImplError - ExistentialError :: Doc ann -> Doc ann -> ImplError - ImplVariableError - :: Doc ann -> String - -> (Doc ann, ExprVar tp) -> (Doc ann, ValuePerm tp) -> CruCtx vars - -> DistPerms ps - -> ImplError - -data LifetimeErrorType where - EndLifetimeError :: LifetimeErrorType - ImplicationLifetimeError :: LifetimeErrorType - LifetimeCurrentError :: PP.Doc ann -> LifetimeErrorType - -$(concatMapM mkNuMatching - [ [t| ImplError |] - , [t| LifetimeErrorType |] - ]) - -instance Liftable LifetimeErrorType where - mbLift e = case mbMatch e of - [nuMP| EndLifetimeError |] -> EndLifetimeError - [nuMP| ImplicationLifetimeError |] -> ImplicationLifetimeError - [nuMP| LifetimeCurrentError doc |] -> LifetimeCurrentError $ mbLift doc - -instance SubstVar PermVarSubst m => - Substable PermVarSubst ImplError m where - genSubst s mb_impl = case mbMatch mb_impl of - [nuMP| GeneralError doc |] -> - return $ GeneralError $ mbLift doc - [nuMP| NoFrameInScopeError |] -> - return NoFrameInScopeError - [nuMP| ArrayStepError |] -> - return ArrayStepError - [nuMP| MuUnfoldError |] -> - return MuUnfoldError - [nuMP| FunctionPermissionError |] -> - return FunctionPermissionError - [nuMP| PartialSubstitutionError str doc |] -> - return $ PartialSubstitutionError (mbLift str) (mbLift doc) - [nuMP| LifetimeError le |] -> - return $ LifetimeError $ mbLift le - [nuMP| MemBlockError doc |] -> - return $ MemBlockError (mbLift doc) - [nuMP| EqualityProofError docl docr |] -> - return $ EqualityProofError (mbLift docl) (mbLift docr) - [nuMP| InsufficientVariablesError doc |] -> - return $ InsufficientVariablesError $ mbLift doc - [nuMP| ExistentialError doc1 doc2 |] -> - return $ ExistentialError (mbLift doc1) (mbLift doc2) - [nuMP| ImplVariableError doc f (xdoc, x) (pdoc, p) ctx mb_dp |] -> do - x' <- genSubst s x - p' <- genSubst s p - dp <- genSubst s mb_dp - return $ ImplVariableError (mbLift doc) (mbLift f) (mbLift xdoc, x') (mbLift pdoc, p') (mbLift ctx) dp - --- The reason this isn't just Show is to sort of future-proof things. For --- instance, we may want to dump a limited amount of information to stdout, but --- something more comprehensive to a log for an IDE. -class ErrorPretty a where - ppError :: a -> String - ----------------------------------------------------------------------- --- * Permission Implications ----------------------------------------------------------------------- - --- | A simple implication is an implication that does not introduce any --- variables or act on the 'varPermMap' part of a permission set. (Compare to --- the more general 'PermImpl'.) It has the form --- --- > P1 * ... * Pn -o P1' * ... * Pm' --- --- where the types of @P1@ through @Pn@ are given by the first type argument --- @ps_in@ and those of @P1'@ through @Pm'@ are given by the second, @ps_out@. --- --- To add a new @SimplImpl@ proof rule: --- 1. Add a constructor @SImpl_NewConstructor@ and documentation to this --- data structure --- 2. Implement cases for the helper functions @simplImplIn@, --- @simplImplOut@, and @genSubst@ for @SImpl_NewConstructor@ --- 3. Implement a wrapper @newConstructorM@ using @implSimplM@ to build up a --- proof using that constructor in the @ImplM@ monad --- 4. Implement the translation of the constructor by adding a case to --- `translateSimplImpl` in `SAWTranslation.hs`. -data SimplImpl ps_in ps_out where - -- | Drop a permission, i.e., forget about it: - -- - -- > x:p -o . - SImpl_Drop :: ExprVar a -> ValuePerm a -> SimplImpl (RNil :> a) RNil - - -- | Copy any copyable permission: - -- - -- > x:p -o x:p * x:p - SImpl_Copy :: ExprVar a -> ValuePerm a -> - SimplImpl (RNil :> a) (RNil :> a :> a) - - -- | Swap the top two permissions on the stack: - -- - -- > x:p1 * y:p2 -o y:p2 * x:p1 - SImpl_Swap :: ExprVar a -> ValuePerm a -> ExprVar b -> ValuePerm b -> - SimplImpl (RNil :> a :> b) (RNil :> b :> a) - - -- | Move permission @p@ that is on the stack below two lists @ps1@ and @ps2@ - -- towards the top of the stack by moving it between @ps1@ and @ps2@. That is, - -- change the stack - -- - -- > x:p, ps1, ps2 -o ps1, x:p, ps2 - SImpl_MoveUp :: DistPerms ps1 -> ExprVar a -> ValuePerm a -> DistPerms ps2 -> - SimplImpl (RNil :> a :++: ps1 :++: ps2) (ps1 :> a :++: ps2) - - -- | Move permission @p@ that is on the stack between two lists @ps1@ and - -- @ps2@ towards the bottom of the stack by moving it below both @ps1@ and - -- @ps2@. This inverts 'SImpl_MoveUp'. That is, change the stack - -- - -- > ps1, x:p, ps2 -o x:p, ps1, ps2 - SImpl_MoveDown :: DistPerms ps1 -> ExprVar a -> ValuePerm a -> DistPerms ps2 -> - SimplImpl (ps1 :> a :++: ps2) (RNil :> a :++: ps1 :++: ps2) - - -- | @SImpl_IntroOrL x p1 p2@ applies left disjunction introduction: - -- - -- > x:p1 -o x:(p1 \/ p2) - SImpl_IntroOrL :: ExprVar a -> ValuePerm a -> ValuePerm a -> - SimplImpl (RNil :> a) (RNil :> a) - - -- | @SImpl_IntroOrR x p1 p2 pf@ applies right disjunction introduction: - -- - -- > x:p2 -o x:(p1 \/ p2) - SImpl_IntroOrR :: ExprVar a -> ValuePerm a -> ValuePerm a -> - SimplImpl (RNil :> a) (RNil :> a) - - -- | @SImpl_IntroExists x e p@ applies existential introduction: - -- - -- > x:[e/z]p -o x:(exists z.p) - SImpl_IntroExists :: KnownRepr TypeRepr tp => ExprVar a -> PermExpr tp -> - Binding tp (ValuePerm a) -> - SimplImpl (RNil :> a) (RNil :> a) - - -- | Cast a proof of @y:p@ to one of @x:p@ using @x:eq(y)@: - -- - -- > x:eq(y) * y:p -o x:p - SImpl_Cast :: ExprVar a -> ExprVar a -> ValuePerm a -> - SimplImpl (RNil :> a :> a) (RNil :> a) - - -- | Cast a proof of @x:p@ to one of @x:p'@ using a proof that @p=p'@ along - -- with the equality permissions needed by that proof: - -- - -- > x:p, x1:eq(e1), ..., xn:eq(en) -o x:p', x1:eq(e1), ..., xn:eq(en) - SImpl_CastPerm :: ExprVar a -> EqProof ps (ValuePerm a) -> - SimplImpl (RNil :> a :++: ps) (RNil :> a :++: ps) - - -- | Introduce a proof that @x:eq(x)@: - -- - -- > . -o x:eq(x) - SImpl_IntroEqRefl :: ExprVar a -> SimplImpl RNil (RNil :> a) - - -- | Invert an @x:eq(y)@ permission into a @y:eq(x)@ permission: - -- - -- > x:eq(y) -o y:eq(x) - SImpl_InvertEq :: ExprVar a -> ExprVar a -> SimplImpl (RNil :> a) (RNil :> a) - - -- | Prove @x:eq(y)@ by proving equality permissions for both @x@ and @y@ to - -- the same expression, thereby implementing a form of transitivity of - -- equality where the second equality is inversted: - -- - -- > x:eq(e) * y:eq(e) -o x:eq(y) - SImpl_InvTransEq :: ExprVar a -> ExprVar a -> PermExpr a -> - SimplImpl (RNil :> a :> a) (RNil :> a) - - -- | For any unit-typed variable @x@ and unit-type expression @e@, prove - -- @x:eq(e)@ - -- - -- > (x:unit,e:unit) . -o x:eq(e) - SImpl_UnitEq :: ExprVar UnitType -> PermExpr UnitType -> - SimplImpl RNil (RNil :> UnitType) - - -- FIXME HERE: remove this in favor of SImpl_Copy - - -- | Copy an equality proof on the top of the stack: - -- - -- > x:eq(e) -o x:eq(e) * x:eq(e) - SImpl_CopyEq :: ExprVar a -> PermExpr a -> - SimplImpl (RNil :> a) (RNil :> a :> a) - - -- | Cast an @eq(llvmword(y))@ proof to an @eq(llvmword(e))@ proof using a - -- proof of @y:eq(e)@: - -- - -- > x:eq(llvmword(y)) * y:eq(e) -o x:eq(llvmword(e)) - SImpl_LLVMWordEq :: (1 <= w, KnownNat w) => ExprVar (LLVMPointerType w) -> - ExprVar (BVType w) -> PermExpr (BVType w) -> - SimplImpl (RNil :> LLVMPointerType w :> BVType w) - (RNil :> LLVMPointerType w) - - -- | The implication that @x@ is the same as @x &+ 0@ - -- - -- > . -o x:eq(x &+ 0) - SImpl_LLVMOffsetZeroEq :: (1 <= w, KnownNat w) => ExprVar (LLVMPointerType w) -> - SimplImpl RNil (RNil :> LLVMPointerType w) - - -- | Introduce an empty conjunction on @x@, i.e.: - -- - -- > . -o x:true - SImpl_IntroConj :: ExprVar a -> SimplImpl RNil (RNil :> a) - - -- | Extract the @i@th atomic permission out of a conjunct, putting it below - -- that conjunct on the stack: - -- - -- > x:(p0 * ... * p(n-1)) -o x:pi * x:(p0 * ... p(i-1) * p(i+1) ... * p(n-1)) - SImpl_ExtractConj :: ExprVar a -> [AtomicPerm a] -> Int -> - SimplImpl (RNil :> a) (RNil :> a :> a) - - -- | Copy the @i@th atomic permission out of a conjunct, assuming it is - -- copyable, putting it below that conjunct on the stack: - -- - -- > x:(p0 * ... * p (n-1)) -o x:pi * x:(p0 * ... * p(n-1)) - SImpl_CopyConj :: ExprVar a -> [AtomicPerm a] -> Int -> - SimplImpl (RNil :> a) (RNil :> a :> a) - - -- | 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 - -- @0@ and @n@ (the number of conjuncts), inclusive: - -- - -- > x:p * x:(p0 * ... * p(n-1)) - -- > -o x:(p0 * ... * p(i-1) * p * pi * ... * p(n-1)) - SImpl_InsertConj :: ExprVar a -> AtomicPerm a -> [AtomicPerm a] -> Int -> - SimplImpl (RNil :> a :> a) (RNil :> a) - - -- | Combine the top two conjunctive permissions on the stack: - -- - -- > x:(p1 * ... * pi) * x:(pi+1 * ... * pn) -o x:(p1 * ... * pn) - SImpl_AppendConjs :: ExprVar a -> [AtomicPerm a] -> [AtomicPerm a] -> - SimplImpl (RNil :> a :> a) (RNil :> a) - - -- | Split the conjunctive permissions on the top of the stack in two: - -- - -- > x:(p1 * ... * pn) -o x:(p1 * ... * pi) * x:(pi+1 * ... * pn) - SImpl_SplitConjs :: ExprVar a -> [AtomicPerm a] -> Int -> - SimplImpl (RNil :> a) (RNil :> a :> a) - - -- | Prove a struct permission of @true@ permissions on any struct: - -- - -- > -o x:struct(true, ..., true) - SImpl_IntroStructTrue :: - ExprVar (StructType ctx) -> RAssign Proxy (CtxToRList ctx) -> - SimplImpl RNil (RNil :> StructType ctx) - - -- | Prove a struct permission of equality permissions from an equality - -- permission to a struct: - -- - -- > x:eq(struct(e1, ..., en)) -o x:struct(eq(e1), ..., eq(en)) - SImpl_StructEqToPerm :: - ExprVar (StructType ctx) -> PermExprs (CtxToRList ctx) -> - SimplImpl (RNil :> StructType ctx) (RNil :> StructType ctx) - - -- | Prove an equality permission to a struct from a struct permission of - -- equality permissions: - -- - -- > x:struct(eq(e1), ..., eq(en)) -o x:eq(struct(e1, ..., en)) - SImpl_StructPermToEq :: - ExprVar (StructType ctx) -> PermExprs (CtxToRList ctx) -> - SimplImpl (RNil :> StructType ctx) (RNil :> StructType ctx) - - -- | Prove a permission @p@ on a struct field that is known to equal some - -- variable @y@ using a proof of @y:p@: - -- - -- > x:struct(ps, eq(y), ps'), y:p -o x:struct(ps,p,ps') - SImpl_IntroStructField :: - ExprVar (StructType ctx) -> RAssign ValuePerm (CtxToRList ctx) -> - Member (CtxToRList ctx) a -> ValuePerm a -> - SimplImpl (RNil :> StructType ctx :> a) (RNil :> StructType ctx) - - -- | Prove a function permission for a statically-known function (assuming - -- that the given entry is in the current function environment): - -- - -- > x:eq(handle) -o x:fun_perm - SImpl_ConstFunPerm :: - args ~ CtxToRList cargs => - ExprVar (FunctionHandleType cargs ret) -> FnHandle cargs ret -> - FunPerm ghosts (CtxToRList cargs) gouts ret -> Ident -> - SimplImpl (RNil :> FunctionHandleType cargs ret) - (RNil :> FunctionHandleType cargs ret) - - -- | Cast a proof of @x:eq(word(e1))@ to one of @x:eq(word(e2))@ using an - -- equality permission @e1=e2@ on top of the stack: - -- - -- > x:eq(word(e1)) * x:prop(e1=e2) -o x:eq(word(e2)) - SImpl_CastLLVMWord :: - (1 <= w, KnownNat w) => ExprVar (LLVMPointerType w) -> - PermExpr (BVType w) -> PermExpr (BVType w) -> - SimplImpl (RNil :> LLVMPointerType w :> LLVMPointerType w) - (RNil :> LLVMPointerType w) - - -- | Invert an @x:eq(y+off)@ proof into a @y:eq(x-off)@ proof: - -- - -- > x:eq(y+off) -o y:eq(x-off) - SImpl_InvertLLVMOffsetEq :: - (1 <= w, KnownNat w) => - ExprVar (LLVMPointerType w) -> PermExpr (BVType w) -> - ExprVar (LLVMPointerType w) -> - SimplImpl (RNil :> LLVMPointerType w) (RNil :> LLVMPointerType w) - - -- | Cast a proof of @y:eq(word(e))@ to one of @x:eq(word(e+off))@ using an - -- equality permission @x:eq(y+off)@ on top of the stack: - -- - -- > x:eq(y+off) * y:eq(word(e)) -o x:eq(word(e+off)) - SImpl_OffsetLLVMWord :: - (1 <= w, KnownNat w) => - ExprVar (LLVMPointerType w) -> PermExpr (BVType w) -> - PermExpr (BVType w) -> ExprVar (LLVMPointerType w) -> - SimplImpl (RNil :> LLVMPointerType w :> LLVMPointerType w) - (RNil :> LLVMPointerType w) - - -- | Cast a permission @y:p@ of LLVM type on the top of the stack to @x:(p - - -- off)@ using a proof of @x:eq(y+off)@ just below it on the stack: - -- - -- > x:eq(y+off) * y:p -o x:(p - off) - -- - -- FIXME: change this to work for arbitrary types with 'offsetPerm' - SImpl_CastLLVMPtr :: - (1 <= w, KnownNat w) => - ExprVar (LLVMPointerType w) -> ValuePerm (LLVMPointerType w) -> - PermExpr (BVType w) -> ExprVar (LLVMPointerType w) -> - SimplImpl (RNil :> LLVMPointerType w :> LLVMPointerType w) - (RNil :> LLVMPointerType w) - - -- | Cast a proof of @x:free(e1)@ to one of @x:free(e2)@ using an equality - -- permission @e1=e2@ on top of the stack: - -- - -- > x:free(e1) * x:prop(e1=e2) -o x:free(e2) - SImpl_CastLLVMFree :: - (1 <= w, KnownNat w) => ExprVar (LLVMPointerType w) -> - PermExpr (BVType w) -> PermExpr (BVType w) -> - SimplImpl (RNil :> LLVMPointerType w :> LLVMPointerType w) - (RNil :> LLVMPointerType w) - - -- | Cast the offset of a field permission from @off@ to @off'@ using an - -- equality permission @off=off'@ on the top of the stack: - -- - -- > x:ptr((rw,off) |-> p) * x:prop(off=off') -o x:ptr((rw,off') |-> p) - SImpl_CastLLVMFieldOffset :: - (1 <= w, KnownNat w, 1 <= sz, KnownNat sz) => - ExprVar (LLVMPointerType w) -> LLVMFieldPerm w sz -> PermExpr (BVType w) -> - SimplImpl (RNil :> LLVMPointerType w :> LLVMPointerType w) - (RNil :> LLVMPointerType w) - - -- | Combine proofs of @x:ptr((rw,off) |-> eq(y))@ and @y:p@ on the top of the - -- permission stack into a proof of @x:ptr((rw,off) |-> p)@, where the - -- supplied 'LLVMFieldPerm' gives the required output permission: - -- - -- > x:ptr((rw,off) |-> eq(y)) * y:p -o x:ptr((rw,off) |-> p) - SImpl_IntroLLVMFieldContents :: - (1 <= w, KnownNat w, 1 <= sz, KnownNat sz) => - ExprVar (LLVMPointerType w) -> ExprVar (LLVMPointerType sz) -> - LLVMFieldPerm w sz -> - SimplImpl (RNil :> LLVMPointerType w :> LLVMPointerType sz) - (RNil :> LLVMPointerType w) - - -- | Demote an LLVM field permission to read: - -- - -- > x:[ls]ptr((W,off) |-> p) -o [ls]x:ptr((R,off) |-> p) - SImpl_DemoteLLVMFieldRW :: - (1 <= w, KnownNat w, 1 <= sz, KnownNat sz) => - ExprVar (LLVMPointerType w) -> LLVMFieldPerm w sz -> - SimplImpl (RNil :> LLVMPointerType w) (RNil :> LLVMPointerType w) - - -- | Split an LLVM field permission with @true@ contents: - -- - -- > x:[l]ptr((rw,off,sz2) |-> true) - -- > -o [l]x:ptr((rw,off,sz1) |-> true) - -- > * [l]x:ptr((rw,off+sz1,sz2-sz1) |-> true) - SImpl_SplitLLVMTrueField :: - (1 <= w, KnownNat w, 1 <= sz1, KnownNat sz1, 1 <= sz2, KnownNat sz2, - 1 <= (sz2 - sz1), KnownNat (sz2 - sz1)) => - ExprVar (LLVMPointerType w) -> LLVMFieldPerm w sz2 -> NatRepr sz1 -> - NatRepr (sz2 - sz1) -> - SimplImpl (RNil :> LLVMPointerType w) - (RNil :> LLVMPointerType w :> LLVMPointerType w) - - -- | Truncate an LLVM field permission with @true@ contents: - -- - -- > x:[l]ptr((rw,off,sz2) |-> true) - -- > -o [l]x:ptr((rw,off,sz1) |-> true) - -- - SImpl_TruncateLLVMTrueField :: - (1 <= w, KnownNat w, 1 <= sz1, KnownNat sz1, 1 <= sz2, KnownNat sz2) => - ExprVar (LLVMPointerType w) -> LLVMFieldPerm w sz2 -> NatRepr sz1 -> - SimplImpl (RNil :> LLVMPointerType w) (RNil :> LLVMPointerType w) - - -- | Concatenate two LLVM field permissions with @true@ contents: - -- - -- > [l]x:ptr((rw,off,sz1) |-> true) * [l]x:ptr((rw,off+sz1,sz2) |-> true) - -- > -o x:[l]ptr((rw,off,sz1+sz2) |-> true) - SImpl_ConcatLLVMTrueFields :: - (1 <= w, KnownNat w, 1 <= sz1, KnownNat sz1, 1 <= sz2, KnownNat sz2, - 1 <= (sz1 + sz2), KnownNat (sz1 + sz2)) => - ExprVar (LLVMPointerType w) -> LLVMFieldPerm w sz1 -> NatRepr sz2 -> - SimplImpl (RNil :> LLVMPointerType w :> LLVMPointerType w) - (RNil :> LLVMPointerType w) - - -- | Demote an LLVM array permission to read modality: - -- - -- > 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=[l]array(rw,off2, * x:ar1=[l]array(rw,off1, - ExprVar (LLVMPointerType w) -> LLVMArrayPerm w -> - PermExpr (BVType w) -> PermExpr (BVType w) -> - SimplImpl (RNil :> LLVMPointerType w :> LLVMPointerType w) - (RNil :> LLVMPointerType w :> LLVMPointerType w) - - -- | 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=[l]array(rw,off1, * x:prop('llvmArrayContainsArray' ar1 ar2) - -- > -o x:ar2=[l]array(rw,off2, * x:[l]array(rw,off1, - 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:[l]array(rw,off2, * x:[l]array(rw,off1, -o x:[l]array(rw,off, - ExprVar (LLVMPointerType w) -> LLVMArrayPerm w -> LLVMArrayPerm w -> - SimplImpl (RNil :> LLVMPointerType w :> LLVMPointerType w) - (RNil :> LLVMPointerType w) - - -- | Append two array permissions, assuming one ends where the other begins - -- and that they have the same stride and fields: - -- - -- > 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 -> - SimplImpl (RNil :> LLVMPointerType w :> LLVMPointerType w) - (RNil :> LLVMPointerType w) - - -- | Rearrange the order of the borrows in an array permission: - -- - -- > 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) - - -- | Prove an empty array with length 0: - -- - -- > -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 whose borrows @bs@ cover the entire array using a - -- permission that instantiates at least one of its cells. This latter - -- permission ensures that the @x@ is a pointer, and is also used in the - -- translation to give a default value to the cells of the output array - -- permission: - -- - -- > x:[l2]memblock(rw,off1,stride,sh) - -- > -o x:[l2]memblock(rw,off1,stride,sh) - -- > * x:[l]array(rw,off, ExprVar (LLVMPointerType w) -> - LLVMBlockPerm w -> LLVMArrayPerm w -> - SimplImpl (RNil :> LLVMPointerType w) - (RNil :> LLVMPointerType w :> LLVMPointerType w) - - -- | Convert an array of byte-sized cells to a field of the same size with - -- @true@ contents: - -- - -- > 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) -> LLVMBlockPerm w -> - SimplImpl (RNil :> LLVMPointerType w) (RNil :> LLVMPointerType w) - - -- | 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:[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 -> PermExpr (BVType w) -> - SimplImpl (RNil :> LLVMPointerType w :> LLVMPointerType w) - (RNil :> LLVMPointerType w :> LLVMPointerType w) - - -- | 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:[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 -> PermExpr (BVType w) -> - SimplImpl (RNil :> LLVMPointerType w :> LLVMPointerType w) - (RNil :> LLVMPointerType w :> LLVMPointerType w) - - -- | Return the @i@th cell of an array permission, undoing a borrow: - -- - -- > 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 -> PermExpr (BVType w) -> - SimplImpl (RNil :> LLVMPointerType w :> LLVMPointerType w) - (RNil :> LLVMPointerType w) - - -- | Apply an implication to the cell shape of an array permission: - -- - -- > 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 -> - PermExpr (LLVMShapeType w) -> - Binding (LLVMPointerType w) (LocalPermImpl - (RNil :> LLVMPointerType w) - (RNil :> LLVMPointerType w)) -> - SimplImpl (RNil :> LLVMPointerType w) (RNil :> LLVMPointerType w) - - -- | Prove that @x@ is a pointer from a field permission: - -- - -- > x:ptr((rw,off) |-> p) -o x:is_llvmptr * x:ptr((rw,off) |-> p) - SImpl_LLVMFieldIsPtr :: - (1 <= w, KnownNat w, 1 <= sz, KnownNat sz) => - ExprVar (LLVMPointerType w) -> LLVMFieldPerm w sz -> - SimplImpl (RNil :> LLVMPointerType w) - (RNil :> LLVMPointerType w :> LLVMPointerType w) - - -- | Prove that @x@ is a pointer from a field permission: - -- - -- > x:array(...) -o x:is_llvmptr * x:array(...) - SImpl_LLVMArrayIsPtr :: - (1 <= w, KnownNat w) => - ExprVar (LLVMPointerType w) -> LLVMArrayPerm w -> - SimplImpl (RNil :> LLVMPointerType w) - (RNil :> LLVMPointerType w :> LLVMPointerType w) - - -- | Prove that @x@ is a pointer from a memblock permission: - -- - -- > x:[l]memblock(...) -o x:is_llvmptr * x:[l]memblock(...) - SImpl_LLVMBlockIsPtr :: - (1 <= w, KnownNat w) => - ExprVar (LLVMPointerType w) -> LLVMBlockPerm w -> - SimplImpl (RNil :> LLVMPointerType w) - (RNil :> LLVMPointerType w :> LLVMPointerType w) - - -- | Save a permission for later by splitting it into part that is in the - -- current lifetime and part that is saved in the lifetime for later: - -- - -- > x:F * l:[l2]lcurrent * l2:lowned[ls] (ps_in -o ps_out) - -- > -o x:F * l2:lowned[ls](ps_in, x:F -o ps_out, x:F) - -- - -- Note that this rule also supports @l=always@, in which case the - -- @l:[l2]lcurrent@ permission is replaced by @l2:true@ (as a hack, because it - -- has the same type) - SImpl_SplitLifetime :: - KnownRepr TypeRepr a => ExprVar a -> LifetimeFunctor args a -> - PermExprs args -> PermExpr LifetimeType -> ExprVar LifetimeType -> - [PermExpr LifetimeType] -> CruCtx ps_in -> CruCtx ps_out -> - ExprPerms ps_in -> ExprPerms ps_out -> - SimplImpl (RNil :> a :> LifetimeType :> LifetimeType) - (RNil :> a :> LifetimeType) - - -- | Subsume a smaller lifetime @l2@ inside a bigger lifetime @l1@, by adding - -- @l2@ to the lifetimes contained in the @lowned@ permission for @l@: - -- - -- > l1:lowned[ls] (ps_in -o ps_out) -o l1:lowned[l2,ls] (ps_in -o ps_out) - SImpl_SubsumeLifetime :: ExprVar LifetimeType -> [PermExpr LifetimeType] -> - CruCtx ps_in -> CruCtx ps_out -> - ExprPerms ps_in -> ExprPerms ps_out -> - PermExpr LifetimeType -> - SimplImpl (RNil :> LifetimeType) - (RNil :> LifetimeType) - - -- | Prove a lifetime @l@ is current during a lifetime @l2@ it contains: - -- - -- > l1:lowned[ls1,l2,ls2] (ps_in -o ps_out) - -- > -o l1:[l2]lcurrent * l1:lowned[ls1,l2,ls2] (ps_in -o ps_out) - SImpl_ContainedLifetimeCurrent :: ExprVar LifetimeType -> - [PermExpr LifetimeType] -> - CruCtx ps_in -> CruCtx ps_out -> - ExprPerms ps_in -> ExprPerms ps_out -> - PermExpr LifetimeType -> - SimplImpl (RNil :> LifetimeType) - (RNil :> LifetimeType :> LifetimeType) - - -- | Remove a finshed contained lifetime from an @lowned@ permission: - -- - -- > l1:lowned[ls1,l2,ls2] (ps_in -o ps_out) * l2:lfinished - -- > -o l1:lowned[ls1,ls2] (ps_in -o ps_out) - SImpl_RemoveContainedLifetime :: ExprVar LifetimeType -> - [PermExpr LifetimeType] -> - CruCtx ps_in -> CruCtx ps_out -> - ExprPerms ps_in -> ExprPerms ps_out -> - ExprVar LifetimeType -> - SimplImpl - (RNil :> LifetimeType :> LifetimeType) - (RNil :> LifetimeType) - - -- | Weaken a lifetime in a permission from some @l@ to some @l2@ that is - -- contained in @l@, i.e., such that @l@ is current during @l2@, assuming that - -- @F@ isa valid lifetime functor: - -- - -- > F * 'lcurrentPerm' l l2 -o F - SImpl_WeakenLifetime :: KnownRepr TypeRepr a => ExprVar a -> - LifetimeFunctor args a -> PermExprs args -> - PermExpr LifetimeType -> ExprVar LifetimeType -> - SimplImpl (RNil :> a :> LifetimeType) (RNil :> a) - - -- | Map the input and output permissions of a lifetime ownership permission - -- using local implications: - -- - -- > Ps1 * Ps_in' -o Ps_in Ps2 * Ps_out -o Ps_out' - -- > ---------------------------------------------------------------------- - -- > Ps1 * Ps2 * l:lowned [ls](Ps_in -o Ps_out) -o l:lowned[ls] (Ps_in' -o Ps_out') - SImpl_MapLifetime :: - ExprVar LifetimeType -> [PermExpr LifetimeType] -> - CruCtx ps_in -> CruCtx ps_out -> ExprPerms ps_in -> ExprPerms ps_out -> - CruCtx ps_in' -> CruCtx ps_out' -> ExprPerms ps_in' -> ExprPerms ps_out' -> - DistPerms ps1 -> DistPerms ps2 -> - LocalPermImpl (ps1 :++: ps_in') ps_in -> - LocalPermImpl (ps2 :++: ps_out) ps_out' -> - SimplImpl (ps1 :++: ps2 :> LifetimeType) (RNil :> LifetimeType) - - -- | End a lifetime, taking in its @lowned@ permission and all the permissions - -- required by the @lowned@ permission to end it, and returning all - -- permissions given back by the @lowned@ lifetime along with an @lfinished@ - -- permission asserting that @l@ has finished: - -- - -- > ps_in * l:lowned (ps_in -o ps_out) -o ps_out * l:lfinished - SImpl_EndLifetime :: ExprVar LifetimeType -> - CruCtx ps_in -> CruCtx ps_out -> - ExprPerms ps_in -> ExprPerms ps_out -> - SimplImpl (ps_in :> LifetimeType) - (ps_out :> LifetimeType) - - -- | Prove a simple @lowned(ps)@ permission from permissions @ps@ and an empty - -- @lowned@ permission by having @l@ borrow @ps@: - -- - -- > ps * l:lowned(empty -o empty) -o [l]ps * l:lowned(ps) - SImpl_IntroLOwnedSimple :: - ExprVar LifetimeType -> CruCtx ps -> ExprPerms ps -> - SimplImpl (ps :> LifetimeType) (ps :> LifetimeType) - - -- | Eliminate a simple @lowned(ps)@ permission into standard @lowned@ - -- permission @lowned([l](R)ps -o ps)@ it represents: - -- - -- > l:lowned(ps) -o l:lowned([l](R)ps -o ps) - SImpl_ElimLOwnedSimple :: - ExprVar LifetimeType -> CruCtx ps -> ExprPerms ps -> - SimplImpl (RNil :> LifetimeType) (RNil :> LifetimeType) - - -- | Reflexivity for @lcurrent@ proofs: - -- - -- > . -o l:lcurrent(l) - SImpl_LCurrentRefl :: ExprVar LifetimeType -> - SimplImpl RNil (RNil :> LifetimeType) - - -- | Transitively combine @lcurrent@ proofs: - -- - -- > l1:lcurrent(l2) * l2:lcurrent(l3) -o l1:lcurrent(l3) - SImpl_LCurrentTrans :: ExprVar LifetimeType -> ExprVar LifetimeType -> - PermExpr LifetimeType -> - SimplImpl (RNil :> LifetimeType :> LifetimeType) - (RNil :> LifetimeType) - - -- | Demote the modality of an LLVM block permission to read: - -- - -- > x:[l]memblock(rw,off,len,sh) -o x:[l]memblock(R,off,len,sh) - SImpl_DemoteLLVMBlockRW :: - (1 <= w, KnownNat w) => - ExprVar (LLVMPointerType w) -> LLVMBlockPerm w -> - SimplImpl (RNil :> LLVMPointerType w) (RNil :> LLVMPointerType w) - - -- | Prove an empty memblock permission of length 0: - -- - -- > -o x:memblock(rw,l,off,0,emptysh) - SImpl_IntroLLVMBlockEmpty :: - (1 <= w, KnownNat w) => ExprVar (LLVMPointerType w) -> LLVMBlockPerm w -> - SimplImpl RNil (RNil :> LLVMPointerType w) - - -- | Coerce an memblock permission to an empty memblock permission: - -- - -- > x:memblock(rw,l,off,len,sh) -o x:memblock(rw,l,off,len,emptysh) - SImpl_CoerceLLVMBlockEmpty :: - (1 <= w, KnownNat w) => ExprVar (LLVMPointerType w) -> LLVMBlockPerm w -> - SimplImpl (RNil :> LLVMPointerType w) (RNil :> LLVMPointerType w) - - -- | Eliminate any @memblock@ permission to an array of bytes: - -- - -- > x:memblock(rw,l,off,len,emptysh) - -- > -o x:[l]array(rw,off, ExprVar (LLVMPointerType w) -> LLVMBlockPerm w -> - SimplImpl (RNil :> LLVMPointerType w) (RNil :> LLVMPointerType w) - - -- | Add a tuple shape around the shape of a @memblock@ permission - -- - -- > x:memblock(rw,l,off,len,sh) -o x:memblock(rw,l,off,len,tuplesh(sh)) - SImpl_IntroLLVMBlockTuple :: - (1 <= w, KnownNat w) => ExprVar (LLVMPointerType w) -> LLVMBlockPerm w -> - SimplImpl (RNil :> LLVMPointerType w) (RNil :> LLVMPointerType w) - - -- | Eliminate a tuple shape in a @memblock@ permission - -- - -- > x:memblock(rw,l,off,len,tuplesh(sh)) -o x:memblock(rw,l,off,len,sh) - SImpl_ElimLLVMBlockTuple :: - (1 <= w, KnownNat w) => ExprVar (LLVMPointerType w) -> LLVMBlockPerm w -> - SimplImpl (RNil :> LLVMPointerType w) (RNil :> LLVMPointerType w) - - -- | Convert a memblock permission of shape @sh@ to one of shape @sh;emptysh@: - -- - -- > x:memblock(rw,l,off,len,sh) -o x:memblock(rw,l,off,len,sh;emptysh) - SImpl_IntroLLVMBlockSeqEmpty :: - (1 <= w, KnownNat w) => ExprVar (LLVMPointerType w) -> LLVMBlockPerm w -> - SimplImpl (RNil :> LLVMPointerType w) (RNil :> LLVMPointerType w) - - -- | Convert a memblock permission of shape @sh;emptysh@ to one of shape @sh@: - -- - -- > x:memblock(rw,l,off,len,sh;emptysh) -o x:memblock(rw,l,off,len,sh) - SImpl_ElimLLVMBlockSeqEmpty :: - (1 <= w, KnownNat w) => ExprVar (LLVMPointerType w) -> LLVMBlockPerm w -> - SimplImpl (RNil :> LLVMPointerType w) (RNil :> LLVMPointerType w) - - -- | Split a memblock permission of empty shape into one of a given length - -- @len1@ and another of the remaining length: - -- - -- > x:memblock(rw,l,off,len,emptysh) - -- > -o x:memblock(rw,l,off,len1,emptysh) - -- > * x:memblock(rw,l,off+len1,len - len1,emptysh) - SImpl_SplitLLVMBlockEmpty :: - (1 <= w, KnownNat w) => ExprVar (LLVMPointerType w) -> LLVMBlockPerm w -> - PermExpr (BVType w) -> - SimplImpl (RNil :> LLVMPointerType w) (RNil :> LLVMPointerType w) - - -- | Fold the body of a named shape in a @memblock@ permission: - -- - -- > x:memblock(rw,l,off,len,'unfoldNamedShape' nmsh args) - -- > -o x:memblock(rw,l,off,len,nmsh) - SImpl_IntroLLVMBlockNamed :: - (1 <= w, KnownNat w) => ExprVar (LLVMPointerType w) -> LLVMBlockPerm w -> - NamedShape 'True args w -> - SimplImpl (RNil :> LLVMPointerType w) (RNil :> LLVMPointerType w) - - -- | Unfold the body of a named shape in a @memblock@ permission: - -- - -- > x:memblock(rw,l,off,len,nmsh) - -- > -o x:memblock(rw,l,off,len,'unfoldNamedShape' nmsh args) - SImpl_ElimLLVMBlockNamed :: - (1 <= w, KnownNat w) => ExprVar (LLVMPointerType w) -> LLVMBlockPerm w -> - NamedShape 'True args w -> - SimplImpl (RNil :> LLVMPointerType w) (RNil :> LLVMPointerType w) - - -- | Add modalities to a named shape in a @memblock@ permission: - -- - -- > x:memblock(rw,l,off,len,nmsh) - -- > -o memblock(rw',l',off,len,[l](rw)nmsh) - SImpl_IntroLLVMBlockNamedMods :: - (1 <= w, KnownNat w) => ExprVar (LLVMPointerType w) -> LLVMBlockPerm w -> - SimplImpl (RNil :> LLVMPointerType w) (RNil :> LLVMPointerType w) - - -- | Eliminate modalities on a named shape in a @memblock@ permission: - -- - -- > x:memblock(rw,l,off,len,[l'](rw')nmsh) - -- > -o memblock(rw',l',off,len,nmsh) - SImpl_ElimLLVMBlockNamedMods :: - (1 <= w, KnownNat w) => ExprVar (LLVMPointerType w) -> LLVMBlockPerm w -> - SimplImpl (RNil :> LLVMPointerType w) (RNil :> LLVMPointerType w) - - -- | Prove an llvmblock permission of shape @sh@ from one of equality shape - -- @eqsh(len,y)@ and a shape permission on @y@: - -- - -- > x:memblock(rw,l,off,len,eqsh(len,y)), y:shape(sh) - -- > -o x:memblock(rw,l,off,len,sh) - SImpl_IntroLLVMBlockFromEq :: - (1 <= w, KnownNat w) => ExprVar (LLVMPointerType w) -> - LLVMBlockPerm w -> ExprVar (LLVMBlockType w) -> - SimplImpl (RNil :> LLVMPointerType w :> LLVMBlockType w) - (RNil :> LLVMPointerType w) - - -- | Prove an llvmblock permission of pointer shape from one of field shape - -- containing a pointer permission: - -- - -- > 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) -> 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]memblock(rw,off,w/8,fieldsh([l2]memblock(rw2,0,sh_len,sh))) - SImpl_ElimLLVMBlockPtr :: - (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,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 - -- - -- > 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 -> - SimplImpl (RNil :> LLVMPointerType w) (RNil :> LLVMPointerType w) - - -- | Prove a block of array shape from the corresponding array permission: - -- - -- > x:array(...) -o x:memblock(...) - SImpl_IntroLLVMBlockArray :: - (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, - -- assuming that the length of the block equals that of the array: - -- - -- > x:[l]memblock(rw,off,stride*len,arraysh( -o x:[l]array(rw,off, 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@, - -- where the supplied 'LLVMBlockPerm' gives @sh1@ and the supplied additional - -- arguments give @len2@ and @sh2@: - -- - -- > x:memblock(rw,l,off,len1,sh1) * memblock(rw,l,off+len1,len2,sh2) - -- > -o x:memblock(rw,l,off,len1+len2,sh1;sh2) - SImpl_IntroLLVMBlockSeq :: - (1 <= w, KnownNat w) => ExprVar (LLVMPointerType w) -> - LLVMBlockPerm w -> PermExpr (BVType w) -> PermExpr (LLVMShapeType w) -> - SimplImpl (RNil :> LLVMPointerType w :> LLVMPointerType w) - (RNil :> LLVMPointerType w) - - -- | Eliminate a block of shape @sh1;sh2@ to blocks of shape @sh1@ and @sh2@, - -- as long as we can compute the length of @sh1@, where the supplied - -- 'LLVMBlockPerm' gives @sh1@ and the additional argument gives @sh2@: - -- - -- > x:memblock(rw,l,off,len,sh1;sh2) - -- > -o x:memblock(rw,l,off,len(sh1),sh1) - -- > * memblock(rw,l,off+len(sh1),len-len(sh1),sh2) - SImpl_ElimLLVMBlockSeq :: - (1 <= w, KnownNat w) => ExprVar (LLVMPointerType w) -> - LLVMBlockPerm w -> PermExpr (LLVMShapeType w) -> - SimplImpl (RNil :> LLVMPointerType w) (RNil :> LLVMPointerType w) - - -- | Prove a block of shape @sh1 orsh sh2@ from a disjunction, where the - -- supplied 'LLVMBlockPerm' gives @sh1@ and the additional argument is @sh2@: - -- - -- > x:memblock(rw,l,off,len,sh1) or memblock(rw,l,off,len,sh2) - -- > -o x:memblock(rw,l,off,len,sh1 orsh sh2) - SImpl_IntroLLVMBlockOr :: - (1 <= w, KnownNat w) => ExprVar (LLVMPointerType w) -> - LLVMBlockPerm w -> PermExpr (LLVMShapeType w) -> - SimplImpl (RNil :> LLVMPointerType w) (RNil :> LLVMPointerType w) - - -- | Eliminate a block of shape @sh1 orsh (sh2 orsh (... orsh shn))@ to an - -- n-way disjunctive permission, where the shape of the supplied - -- 'LLVMBlockPerm' is ignored, and is replaced by the list of shapes, which - -- must be non-empty: - -- - -- > x:memblock(rw,l,off,len,sh1 orsh (... orsh shn)) - -- > -o x:memblock(rw,l,off,len,sh1) or (... or memblock(rw,l,off,len,shn)) - SImpl_ElimLLVMBlockOr :: - (1 <= w, KnownNat w) => ExprVar (LLVMPointerType w) -> - LLVMBlockPerm w -> [PermExpr (LLVMShapeType w)] -> - SimplImpl (RNil :> LLVMPointerType w) (RNil :> LLVMPointerType w) - - -- | Prove a block of shape @exsh z:A.sh@ from an existential: - -- - -- > x:exists z:A.memblock(rw,l,off,len,sh) - -- > -o x:memblock(rw,l,off,len,exsh z:A.sh) - SImpl_IntroLLVMBlockEx :: - (1 <= w, KnownNat w) => ExprVar (LLVMPointerType w) -> LLVMBlockPerm w -> - SimplImpl (RNil :> LLVMPointerType w) (RNil :> LLVMPointerType w) - - -- | Eliminate a block of shape @exsh z:A.sh@ from to existential: - -- - -- > x:memblock(rw,l,off,len,exsh z:A.sh) - -- > -o x:exists z:A.memblock(rw,l,off,len,sh) - SImpl_ElimLLVMBlockEx :: - (1 <= w, KnownNat w) => ExprVar (LLVMPointerType w) -> LLVMBlockPerm w -> - SimplImpl (RNil :> LLVMPointerType w) (RNil :> LLVMPointerType w) - - -- | Eliminate a block of shape @falsesh@ to @false@ - -- - -- > x:memblock(..., falsesh) -o x:false - SImpl_ElimLLVMBlockFalse :: - (1 <= w, KnownNat w) => ExprVar (LLVMPointerType w) -> LLVMBlockPerm w -> - SimplImpl (RNil :> LLVMPointerType w) (RNil :> LLVMPointerType w) - - -- | Fold a named permission (other than an opaque permission): - -- - -- > x:(unfold P args) -o x:P - SImpl_FoldNamed :: NameSortCanFold ns ~ 'True => - ExprVar a -> NamedPerm ns args a -> PermExprs args -> - PermOffset a -> SimplImpl (RNil :> a) (RNil :> a) - - -- | Unfold a named permission (other than an opaque permission): - -- - -- > x:P -o x:(unfold P args) - SImpl_UnfoldNamed :: NameSortCanFold ns ~ 'True => - ExprVar a -> NamedPerm ns args a -> PermExprs args -> - PermOffset a -> SimplImpl (RNil :> a) (RNil :> a) - - -- | Map a named permission that is conjoinable to a conjunction: - -- - -- > x:P -o x:ValPerm_Conj [P] - SImpl_NamedToConj :: NameSortIsConj ns ~ 'True => ExprVar a -> - NamedPermName ns args a -> PermExprs args -> - PermOffset a -> - SimplImpl (RNil :> a) (RNil :> a) - - -- | Map a conjuctive named permission to a named permission: - -- - -- > x:ValPerm_Conj [P] -o x:P - SImpl_NamedFromConj :: NameSortIsConj ns ~ 'True => ExprVar a -> - NamedPermName ns args a -> PermExprs args -> - PermOffset a -> SimplImpl (RNil :> a) (RNil :> a) - - -{- FIXME HERE: Write the rule for proving one recursive perm implies another - - -- | Apply an implication to the body of a least fixed-point permission: - -- - -- > y:p1 -o y:p2 - -- > ---------------------- - -- > x:mu X.p1 -o x:mu X.p2 - SImpl_Mu :: - ExprVar a -> Binding (ValuePerm a) (ValuePerm a) -> - Binding (ValuePerm a) (ValuePerm a) -> - Binding (ValuePerm a) (PermImpl ((:~:) (RNil :> a)) (RNil :> a)) -> - SimplImpl (RNil :> a) (RNil :> a) --} - - -- | Weaken an @always@ lifetime argument of a named permission: - -- - -- > x:P -o x:P - SImpl_NamedArgAlways :: ExprVar a -> NamedPermName ns args a -> - PermExprs args -> PermOffset a -> - Member args LifetimeType -> PermExpr LifetimeType -> - SimplImpl (RNil :> a) (RNil :> a) - - -- | Weaken a lifetime argument @l1@ of a named permission: - -- - -- > x:P * l1:[l2]lcurrent -o x:P - SImpl_NamedArgCurrent :: ExprVar a -> NamedPermName ns args a -> - PermExprs args -> PermOffset a -> - Member args LifetimeType -> PermExpr LifetimeType -> - SimplImpl (RNil :> a :> LifetimeType) (RNil :> a) - - -- | Weaken a 'Write' modality argument to any other modality: - -- - -- > x:P -o x:P - SImpl_NamedArgWrite :: ExprVar a -> NamedPermName ns args a -> - PermExprs args -> PermOffset a -> - Member args RWModalityType -> - PermExpr RWModalityType -> - SimplImpl (RNil :> a) (RNil :> a) - - -- | Weaken any modality argument to a 'Read' modality: - -- - -- > x:P -o x:P - SImpl_NamedArgRead :: ExprVar a -> NamedPermName ns args a -> - PermExprs args -> PermOffset a -> - Member args RWModalityType -> - SimplImpl (RNil :> a) (RNil :> a) - - -- | Implements transitivity of reachability permissions: - -- - -- > x:P, y:P -o x:P - SImpl_ReachabilityTrans :: - ExprVar a -> RecPerm b 'True (args :> a) a -> - PermExprs args -> PermOffset a -> ExprVar a -> PermExpr a -> - SimplImpl (RNil :> a :> a) (RNil :> a) - - -- | Two inconsistent equality permissions combine to an any: - -- - -- > x:eq(e1), x:eq(e2) -o x:any (when e1 /= e2) - SImpl_IntroAnyEqEq :: ExprVar a -> PermExpr a -> PermExpr a -> - SimplImpl (RNil :> a :> a) (RNil :> a) - - -- | Equality to a word along with a pointer permission combine to an any: - -- - -- > x:eq(llvmword(e)), x:p -o x:any (if p is a ptr, array, or block perm) - SImpl_IntroAnyWordPtr :: - (1 <= w, KnownNat w) => ExprVar (LLVMPointerType w) -> - PermExpr (BVType w) -> AtomicPerm (LLVMPointerType w) -> - SimplImpl (RNil :> LLVMPointerType w :> LLVMPointerType w) - (RNil :> LLVMPointerType w) - - -- | Eliminate an @any@ permission to an equality: - -- - -- > x:any -o x:eq(e) - SImpl_ElimAnyToEq :: ExprVar a -> PermExpr a -> - SimplImpl (RNil :> a) (RNil :> a) - - -- | Eliminate an @any@ permission to a pointer permission containing an @any@ - -- permission: - -- - -- > x:any -o x:[l]ptr((rw,off) |-> any) - SImpl_ElimAnyToPtr :: - (1 <= w, KnownNat w, 1 <= sz, KnownNat sz) => - ExprVar (LLVMPointerType w) -> LLVMFieldPerm w sz -> - SimplImpl (RNil :> LLVMPointerType w) (RNil :> LLVMPointerType w) - - --- | A single step of permission implication. These can have multiple, --- disjunctive conclusions, each of which can bind some number of variables, and --- can also move permissions between the primary permissions for each variable --- and the permission stack. The general form is: --- --- > x1::Px1 * ... * xl::Pl * P1 * ... * Pn --- > -o (zs1 . x1::Px1_1 * ... * xl::Pxl_1 * P1_1 * ... * P1_k1) \/ --- > ... \/ (zsm . x1::Px1_m * ... * xl::Pxl_m * Pm_1 * ... * Pm_km) --- --- where @zsi@ is a list of permission variables bound in the permissions @Pi_j@ --- and @xi::Pxi@ denotes the primary permission for variable @xi@. In the --- comments below, we often omit the primary variable permissions when they do --- not change. The types of @P1@ through @Pn@ are given by the first type --- argument @ps_in@ of this type, while those of the @zsi@ and the @Pi_j@ --- permissions are given by the @ps_outs@ argument. The latter is an 'RList' of --- the form --- --- > RNil :> (bs1, ps1) :> ... :> (bsm, psm) --- --- where each @bsi@ is itself an 'RList' of the types of the bound variables in --- @zsi@ and @psi@ is an 'RList' of the types of @Pi_1@ through @Pi_km@. --- --- To add a new @PermImpl1@ proof rule: --- 1. Add a constructor @Impl1_NewConstructor@ and documentation to this --- data structure --- 2. Implement cases for the helper functions @permImplStep@, --- @permImplSucceeds@, @applyImpl1@, and @genSubst@ for --- @Impl1_NewConstructor@ --- 3. Implement a wrapper @newConstructorM@ using @implApplyImpl1@ to build --- up a proof using that constructor in the @ImplM@ monad --- 4. Implement the translation of the constructor by adding a case to --- `translatePermImpl1` in `SAWTranslation.hs`. -data PermImpl1 ps_in ps_outs where - -- | Failure of a permission implication, along with a string explanation of - -- the failure, which is a proof of 0 disjuncts: - -- - -- > ps -o . - Impl1_Fail :: ImplError -> PermImpl1 ps RNil - - -- | Catch any failure in the first branch by calling the second, passing the - -- same input permissions to both branches: - -- - -- > ps -o ps \/ ps - -- - -- The 'String' gives debug info about why the algorithm inserted the catch. - Impl1_Catch :: String -> PermImpl1 ps (RNil :> '(RNil, ps) :> '(RNil, ps)) - - -- | Push the primary permission for variable @x@ onto the stack: - -- - -- > x::P * ps -o x::true * ps * x:P - Impl1_Push :: ExprVar a -> ValuePerm a -> - PermImpl1 ps (RNil :> '(RNil, ps :> a)) - - -- | Pop the a permission for variable @x@ back to the primary permission for - -- @x@, assuming the latter is the trivial permission @true@: - -- - -- > x::true * ps * x:P -o x::P * ps - Impl1_Pop :: ExprVar a -> ValuePerm a -> - PermImpl1 (ps :> a) (RNil :> '(RNil, ps)) - - -- | Eliminate a sequence of right-nested disjunctions: - -- - -- > ps * x:(p1 \/ (p2 \/ (... \/ pn))) - -- > -o (ps * x:p1) \/ ... \/ (ps * x:pn) - -- - -- The 'String' is contains the printed version of the @x:(p1 \/ ...)@ - -- permission that is being eliminated, for debug info. - Impl1_ElimOrs :: String -> ExprVar a -> OrList ps a disjs -> - PermImpl1 (ps :> a) disjs - - -- | Eliminate an existential on the top of the stack: - -- - -- > ps * x:(exists z.p) -o z. ps * x:p - Impl1_ElimExists :: KnownRepr TypeRepr tp => ExprVar a -> - Binding tp (ValuePerm a) -> - PermImpl1 (ps :> a) (RNil :> '(RNil :> tp, ps :> a)) - - -- | Eliminate a @false@ permission on the top of the stack, which is a - -- contradiction and so has no output disjuncts - -- - -- > ps * x:false -o . - Impl1_ElimFalse :: ExprVar a -> PermImpl1 (ps :> a) RNil - - -- | Apply a 'SimplImpl' - Impl1_Simpl :: SimplImpl ps_in ps_out -> Proxy ps -> - PermImpl1 (ps :++: ps_in) (RNil :> '(RNil, ps :++: ps_out)) - - -- | Let-bind a fresh variable @x@ to expression @e@, leaving an equality - -- permission on top of the stack: - -- - -- > ps -o x. ps * x:eq(e) - Impl1_LetBind :: TypeRepr tp -> PermExpr tp -> - PermImpl1 ps (RNil :> '(RNil :> tp, ps :> tp)) - - -- | Project out a field of a struct @x@ by binding a fresh variable @y@ for - -- its contents, and assign the permissions for that field to @y@, replacing - -- them with a proof that the field equals @y@: - -- - -- > x:struct(ps,p,ps') -o y. x:struct(ps, eq(y), ps'), y:p - Impl1_ElimStructField :: - ExprVar (StructType ctx) -> RAssign ValuePerm (CtxToRList ctx) -> - TypeRepr a -> Member (CtxToRList ctx) a -> - PermImpl1 (ps :> StructType ctx) (RNil :> '(RNil :> a, - ps :> StructType ctx :> a)) - - -- | Eliminate the contents of an LLVM field permission, binding a new - -- variable to hold those permissions and changing the contents of the field - -- permission to an equals permision for that variable: - -- - -- > x:ptr((rw,off) -> p) -o y. x:ptr((rw,off) -> eq(y)) * y:p - Impl1_ElimLLVMFieldContents :: - (1 <= w, KnownNat w, 1 <= sz, KnownNat sz) => - ExprVar (LLVMPointerType w) -> LLVMFieldPerm w sz -> - PermImpl1 (ps :> LLVMPointerType w) - (RNil :> '(RNil :> LLVMPointerType sz, - ps :> LLVMPointerType w :> LLVMPointerType sz)) - - -- | Eliminate an llvmblock permission of shape @sh@ to one of equality shape - -- @eqsh(y)@ and a shape permission on @y@ for a fresh variable @y@: - -- - -- > x:memblock(rw,l,off,len,sh) - -- > -o y. x:memblock(rw,l,off,len,eqsh(len,y)), - -- > y:shape('modalize'(rw,l,sh)) - Impl1_ElimLLVMBlockToEq :: - (1 <= w, KnownNat w) => ExprVar (LLVMPointerType w) -> LLVMBlockPerm w -> - PermImpl1 (ps :> LLVMPointerType w) - (RNil :> '(RNil :> LLVMBlockType w, - ps :> LLVMPointerType w :> LLVMBlockType w)) - - -- | Split an LLVM field permission that points to a word value, creating - -- fresh variables for the two portions of that word value: - -- - -- > x:[l]ptr((rw,off,sz2) |-> eq(llvmword(e))) - -- > -o y,z.[l]x:ptr((rw,off,sz1) |-> eq(llvmword(y))) - -- > * [l]x:ptr((rw,off+sz1/8,sz2-sz1) |-> eq(llvmword(z))) - -- > * y:p_y * z:p_z - -- - -- If @e@ is a known constant bitvector value @bv1++bv2@, then @p_y@ is - -- @eq(bv1)@ and @p_z@ is @eq(bv2)@, and otherwise these permissions are just - -- @true@. Note that the definition of @++@ depends on the current endianness. - Impl1_SplitLLVMWordField :: - (1 <= w, KnownNat w, 1 <= sz1, KnownNat sz1, 1 <= sz2, KnownNat sz2, - 1 <= (sz2 - sz1), KnownNat (sz2 - sz1)) => - ExprVar (LLVMPointerType w) -> LLVMFieldPerm w sz2 -> - NatRepr sz1 -> EndianForm -> - PermImpl1 (ps :> LLVMPointerType w) - (RNil :> '(RNil :> BVType sz1 :> BVType (sz2 - sz1), - ps :> LLVMPointerType w :> LLVMPointerType w :> - BVType sz1 :> BVType (sz2 - sz1))) - - -- | Truncate an LLVM field permission that points to a word value, creating a - -- fresh variable for the remaining portion of the word value: - -- - -- > x:[l]ptr((rw,off,sz2) |-> eq(llvmword(e))) - -- > -o y. [l]x:ptr((rw,off,sz1) |-> eq(llvmword(y))) * y:p_y - -- - -- If @e@ is a known constant bitvector value @bv1++bv2@, then @p_y@ is - -- @eq(bv1)@, and otherwise @p_y@ is just @true@. Note that the definition of - -- @++@ depends on the current endianness. - Impl1_TruncateLLVMWordField :: - (1 <= w, KnownNat w, 1 <= sz1, KnownNat sz1, 1 <= sz2, KnownNat sz2) => - ExprVar (LLVMPointerType w) -> LLVMFieldPerm w sz2 -> - NatRepr sz1 -> EndianForm -> - PermImpl1 (ps :> LLVMPointerType w) - (RNil :> '(RNil :> BVType sz1, ps :> LLVMPointerType w :> BVType sz1)) - - -- | Concatenate two LLVM field permissions that point to word values, - -- creating a fresh value for the concatenation of these word values: - -- - -- > [l]x:ptr((rw,off,sz1) |-> eq(llvmword(e1))) - -- > * [l]x:ptr((rw,off+sz1/2,sz2) |-> eq(llvmword(e2))) - -- > -o y. x:[l]ptr((rw,off,sz1+sz2) |-> eq(llvmword(y))) * y:p_y - -- - -- If @e1@ and @e2@ are known constant bitvector values @bv1@ and @bv2@, then - -- @p_y@ is @eq(bv1++bv2)@, and otherwise @p_y@ is just @true@. Note that the - -- definition of @++@ depends on the current endianness. - Impl1_ConcatLLVMWordFields :: - (1 <= w, KnownNat w, 1 <= sz1, KnownNat sz1, 1 <= sz2, KnownNat sz2, - 1 <= (sz1 + sz2), KnownNat (sz1 + sz2)) => - ExprVar (LLVMPointerType w) -> LLVMFieldPerm w sz1 -> - PermExpr (BVType sz2) -> EndianForm -> - PermImpl1 (ps :> LLVMPointerType w :> LLVMPointerType w) - (RNil :> '(RNil :> BVType (sz1 + sz2), - ps :> LLVMPointerType w :> BVType (sz1 + sz2))) - - -- | Begin a new lifetime: - -- - -- > . -o ret:lowned(empty -o empty) - Impl1_BeginLifetime :: - PermImpl1 ps (RNil :> '(RNil :> LifetimeType, ps :> LifetimeType)) - - -- | Try to prove a bitvector proposition, or fail (as in the 'Impl1_Fail' - -- rule) if this is not possible, where the 'String' is a pretty-printing of - -- the proposition (for ease of translation): - -- - -- > . -o prop(p) - Impl1_TryProveBVProp :: - (1 <= w, KnownNat w) => ExprVar (LLVMPointerType w) -> BVProp w -> - String -> PermImpl1 ps (RNil :> '(RNil, ps :> LLVMPointerType w)) - - --- | A single disjunct of type @a@ being eliminated, with permissions @ps@ on --- the stack below the disjunction -data OrListDisj (ps :: RList CrucibleType) a - (disj :: (RList CrucibleType, RList CrucibleType)) where - OrListDisj :: ValuePerm a -> OrListDisj ps a '(RNil, ps :> a) - --- | A sequence of disjuncts being eliminated, with permissions @ps@ on the --- stack below the disjunction -type OrList ps a = RAssign (OrListDisj ps a) - --- | A @'PermImpl' r ps@ is a proof tree of the judgment --- --- > Gamma | Pl * P |- (Gamma1 | Pl1 * P1) \/ ... \/ (Gamman | Pln * Pn) --- --- that contains an element of type @r@ at each leaf of the proof tree. Each --- disjunct on the right of the judgment corresponds to a different leaf in the --- tree, while each @Gammai@ denotes the variables that are bound on the path --- from the root to that leaf. The @ps@ argument captures the form of the --- \"distinguished\" left-hand side permissions @Pl@. --- --- FIXME: explain that @Pl@ is like a stack, and that intro rules apply to the --- top of the stack --- --- FIXME: it would be nice to have PermImpl r ps_out ps_in, where ps_out is --- guaranteed to be the stack shape at any Impl_Done, but this would make our --- generalized monad below more complicated... -data PermImpl r ps where - PermImpl_Done :: !(r ps) -> PermImpl r ps - PermImpl_Step :: !(PermImpl1 ps_in ps_outs) -> - !(MbPermImpls r ps_outs) -> - PermImpl r ps_in - --- | Helper type for 'PermImpl', that defines a collection of permission --- implications, one for each element of the @bs_pss@ type argument. Each of --- these elements are of the form @(bs,ps)@, where @ps@ determines the input --- permissions for that implication tree and @bs@ specifies an existential --- contexts of bound variables for that implication tree. -data MbPermImpls r bs_pss where - MbPermImpls_Nil :: MbPermImpls r RNil - MbPermImpls_Cons :: CruCtx bs -> - !(MbPermImpls r bs_pss) -> - !(Mb bs (PermImpl r ps)) -> - MbPermImpls r (bs_pss :> '(bs,ps)) - --- | A local implication, from an input to an output permission set -newtype LocalPermImpl ps_in ps_out = - LocalPermImpl (PermImpl (LocalImplRet ps_out) ps_in) - --- | The \"success\" condition of a 'LocalPermImpl', which essentially is just a --- type equality stating that the output permissions are as expected -newtype LocalImplRet ps ps' = LocalImplRet (ps :~: ps') - --- | The identity implication -idLocalPermImpl :: LocalPermImpl ps ps -idLocalPermImpl = LocalPermImpl $ PermImpl_Done $ LocalImplRet Refl - --- type IsLLVMPointerTypeList w ps = RAssign ((:~:) (LLVMPointerType w)) ps - --- Many of these types are mutually recursive. Moreover, Template Haskell --- declaration splices strictly separate top-level groups, so if we were to --- write each $(mkNuMatching [t| ... |]) splice individually, the splices --- involving mutually recursive types would not typecheck. As a result, we --- must put everything into a single splice so that it forms a single top-level --- group. -$(concatMapM mkNuMatching - [ [t| forall a. EqPerm a |] - , [t| forall ps a. NuMatching a => EqProofStep ps a |] - , [t| forall ps a. NuMatching a => EqProof ps a |] - , [t| forall ps_in ps_out. SimplImpl ps_in ps_out |] - , [t| forall ps_in ps_outs. PermImpl1 ps_in ps_outs |] - , [t| forall ps a disj. OrListDisj ps a disj |] - , [t| forall r bs_pss. NuMatchingAny1 r => MbPermImpls r bs_pss |] - , [t| forall r ps. NuMatchingAny1 r => PermImpl r ps |] - , [t| forall ps_in ps_out. LocalPermImpl ps_in ps_out |] - , [t| forall ps ps'. LocalImplRet ps ps' |] - ]) - --- | A splitting of an existential list of permissions into a prefix, a single --- variable plus permission, and then a suffix -data DistPermsSplit ps where - DistPermsSplit :: RAssign Proxy ps1 -> RAssign Proxy ps2 -> - DistPerms (ps1 :++: ps2) -> - ExprVar a -> ValuePerm a -> - DistPermsSplit (ps1 :> a :++: ps2) - -$(mkNuMatching [t| forall ps. DistPermsSplit ps |]) - --- FIXME: delete all of this? -{- --- | Compile-time flag for whether to prune failure branches in 'implCatchM' -pruneFailingBranches :: Bool -pruneFailingBranches = False - --- | Apply the 'PermImpl_Step' constructor to a 'PermImpl1' rule and its --- sub-proofs, performing the following simplifications (some of which are --- performed by the helper function 'permImplCatch'), where @unary impl@ --- represents any unary rule applied to the implication @impl@: --- --- > unary (fail msg) --> fail msg --- > unary (catch impl (fail msg)) --> catch (unary impl) (fail msg) --- > catch (fail msg1) (fail msg2) --> fail (msg1 ++ msg2) --- > catch (catch impl1 impl2) impl3 --> catch impl1 (catch impl2 impl3) --- > elim_or (fail msg1) (fail msg2) --> fail (msg1 ++ msg2) -permImplStep :: NuMatchingAny1 r => PermImpl1 ps_in ps_outs -> - MbPermImpls r ps_outs -> PermImpl r ps_in - --- No need to simplify a fail -permImplStep impl1@(Impl1_Fail _) mb_impls = PermImpl_Step impl1 mb_impls - --- Catch --> call the permImplCatch function -permImplStep Impl1_Catch ((MbPermImpls_Cons _ - (MbPermImpls_Cons _ _ mb_pimpl1) mb_pimpl2)) = - permImplCatch (elimEmptyMb mb_pimpl1) (elimEmptyMb mb_pimpl2) - --- Unary rules applied to failure --> failures --- --- NOTE: we write the cases all out explicitly in case we add a new Impl1 rule --- that does not work this way, since not simplifying is better than --- oversimplifying -permImplStep impl1@(Impl1_Push _ _) mb_impls = - permImplStepUnary impl1 mb_impls -permImplStep impl1@(Impl1_Pop _ _) mb_impls = - permImplStepUnary impl1 mb_impls -permImplStep impl1@(Impl1_ElimExists _ _) mb_impls = - permImplStepUnary impl1 mb_impls -permImplStep impl1@(Impl1_Simpl _ _) mb_impls = - permImplStepUnary impl1 mb_impls -permImplStep impl1@(Impl1_LetBind _ _) mb_impls = - permImplStepUnary impl1 mb_impls -permImplStep impl1@(Impl1_ElimStructField _ _ _ _) mb_impls = - permImplStepUnary impl1 mb_impls -permImplStep impl1@(Impl1_ElimLLVMFieldContents _ _) mb_impls = - permImplStepUnary impl1 mb_impls -permImplStep impl1@(Impl1_BeginLifetime) mb_impls = - permImplStepUnary impl1 mb_impls -permImplStep impl1@(Impl1_TryProveBVProp _ _ _) mb_impls = - permImplStepUnary impl1 mb_impls - --- An or elimination fails if both branches fail -permImplStep (Impl1_ElimOr _ _ _) (MbPermImpls_Cons _ - (MbPermImpls_Cons _ MbPermImpls_Nil - (matchMbImplFail -> Just msg1)) - (matchMbImplFail -> Just msg2)) = - PermImpl_Step (Impl1_Fail $ GeneralError $ pretty - (msg1 ++ "\n\n--------------------\n\n" ++ msg2)) - MbPermImpls_Nil - --- Default case: just apply PermImpl_Step -permImplStep impl1 mb_impls = PermImpl_Step impl1 mb_impls - - --- | Helper for 'permImplStep': apply the 'PermImpl_Step' constructor to a unary --- 'PermImpl1' rule and an implication that follows it, performing the necessary --- simplifications -permImplStepUnary :: NuMatchingAny1 r => - PermImpl1 ps_in (RNil :> '(bs, ps_out)) -> - MbPermImpls r (RNil :> '(bs, ps_out)) -> PermImpl r ps_in - --- If the continuation implication is a failure, percolate it up -permImplStepUnary _ (MbPermImpls_Cons _ _ (matchMbImplFail -> Just msg)) = - PermImpl_Step (Impl1_Fail $ GeneralError $ pretty msg) MbPermImpls_Nil - --- If the continuation implication is a catch with a failure on the right-hand --- side, percolate up the catch -{- FIXME: this exposes some weird performance bug! -permImplStepUnary impl1 (MbPermImpls_Cons MbPermImpls_Nil - (matchMbImplCatchFail -> Just (mb_impl, msg))) = - PermImpl_Step Impl1_Catch - (MbPermImpls_Cons - (MbPermImpls_Cons MbPermImpls_Nil $ - emptyMb $ PermImpl_Step impl1 $ - MbPermImpls_Cons MbPermImpls_Nil mb_impl) - (emptyMb $ PermImpl_Step (Impl1_Fail msg) MbPermImpls_Nil)) --} - --- Default case: just apply PermImpl_Step -permImplStepUnary impl1 mb_impls = PermImpl_Step impl1 mb_impls - --- | Pattern-match an implication inside a binding to see if it is just a --- failure, and if so, return the failure message, all without requiring a --- 'NuMatchingAny1' constraint on the @r@ variable -matchMbImplFail :: NuMatchingAny1 r => Mb ctx (PermImpl r ps) -> Maybe String -matchMbImplFail mb_impl = case mbMatch mb_impl of - [nuMP| PermImpl_Step (Impl1_Fail err) _ |] -> Just $ mbLift $ fmap ppError err - _ -> Nothing - --- | Pattern-matchin an implication inside a binding to see if it is a catch --- whose right-hand side is just a failure, all without requiring a --- 'NuMatchingAny1' constraint on the @r@ variable -matchMbImplCatchFail :: NuMatchingAny1 r => - Mb (ctx :: RList CrucibleType) (PermImpl r ps) -> - Maybe (Mb ctx (PermImpl r ps), String) -matchMbImplCatchFail mb_impl = case mbMatch mb_impl of - [nuMP| PermImpl_Step Impl1_Catch - (MbPermImpls_Cons _ (MbPermImpls_Cons _ _ mb_impl1) - mb_impl2) |] - | Just msg <- matchMbImplFail (mbCombine RL.typeCtxProxies mb_impl2) -> - Just (mbCombine RL.typeCtxProxies mb_impl1, msg) - _ -> Nothing - --- | Produce a branching proof tree that performs the first implication and, if --- that one fails, falls back on the second. If 'pruneFailingBranches' is set, --- failing branches are pruned; otherwise, catches are reorganized so that they --- are right-nested, and any failures are combined. -permImplCatch :: PermImpl r ps -> PermImpl r ps -> PermImpl r ps -permImplCatch (PermImpl_Step (Impl1_Fail _) _) pimpl - | pruneFailingBranches = pimpl -permImplCatch pimpl (PermImpl_Step (Impl1_Fail _) _) - | pruneFailingBranches = pimpl -permImplCatch (PermImpl_Step (Impl1_Fail str1) _) (PermImpl_Step - (Impl1_Fail str2) mb_impls) = - PermImpl_Step (Impl1_Fail $ GeneralError $ - pretty (ppError str1 ++ "\n\n--------------------\n\n" ++ ppError str2)) - mb_impls -permImplCatch pimpl1@(PermImpl_Step (Impl1_Fail _) _) pimpl2 = - permImplCatch pimpl2 pimpl1 -permImplCatch (PermImpl_Step Impl1_Catch - (MbPermImpls_Cons _ - (MbPermImpls_Cons _ _ mb_pimpl_1a) mb_pimpl_1b)) pimpl2 = - permImplCatch (elimEmptyMb mb_pimpl_1a) $ - permImplCatch (elimEmptyMb mb_pimpl_1b) pimpl2 -permImplCatch pimpl1 pimpl2 = - PermImpl_Step Impl1_Catch $ - MbPermImpls_Cons knownRepr (MbPermImpls_Cons knownRepr MbPermImpls_Nil $ emptyMb pimpl1) $ - emptyMb pimpl2 --} - - --- | Test if a 'PermImpl' \"succeeds\", meaning there is at least one non-failing --- branch. If it does succeed, return a heuristic number for how \"well\" it --- succeeds; e.g., rate a 'PermImpl' higher if all disjunctive branches succeed, --- that is, if both children of every 'Impl1_ElimOr' succeed. Return 0 if the --- 'PermImpl' does not succeed at all. -permImplSucceeds :: PermImpl r ps -> Int -permImplSucceeds (PermImpl_Done _) = 2 -permImplSucceeds (PermImpl_Step (Impl1_Fail _) _) = 0 -permImplSucceeds (PermImpl_Step (Impl1_Catch _) - (MbPermImpls_Cons _ (MbPermImpls_Cons _ _ mb_impl1) mb_impl2)) = - max (mbLift $ fmap permImplSucceeds mb_impl1) - (mbLift $ fmap permImplSucceeds mb_impl2) -permImplSucceeds (PermImpl_Step (Impl1_Push _ _) (MbPermImpls_Cons _ _ mb_impl)) = - mbLift $ fmap permImplSucceeds mb_impl -permImplSucceeds (PermImpl_Step (Impl1_Pop _ _) (MbPermImpls_Cons _ _ mb_impl)) = - mbLift $ fmap permImplSucceeds mb_impl -permImplSucceeds (PermImpl_Step (Impl1_ElimOrs _ _ _) mb_impls) = - mbImplsSucc mb_impls where - mbImplsSucc :: MbPermImpls r ps_outs -> Int - mbImplsSucc MbPermImpls_Nil = 0 - mbImplsSucc (MbPermImpls_Cons _ mb_impls' mb_impl) = - max (mbImplsSucc mb_impls') (mbLift $ fmap permImplSucceeds mb_impl) -{- -permImplSucceeds (PermImpl_Step (Impl1_ElimOr _ _ _) - (MbPermImpls_Cons _ (MbPermImpls_Cons _ _ mb_impl1) mb_impl2)) = - max (mbLift (fmap permImplSucceeds mb_impl1)) - (mbLift (fmap permImplSucceeds mb_impl2)) --} -permImplSucceeds (PermImpl_Step (Impl1_ElimExists _ _) - (MbPermImpls_Cons _ _ mb_impl)) = - mbLift $ fmap permImplSucceeds mb_impl -permImplSucceeds (PermImpl_Step (Impl1_ElimFalse _) _) = 2 -permImplSucceeds (PermImpl_Step (Impl1_Simpl _ _) - (MbPermImpls_Cons _ _ mb_impl)) = - mbLift $ fmap permImplSucceeds mb_impl -permImplSucceeds (PermImpl_Step (Impl1_LetBind _ _) - (MbPermImpls_Cons _ _ mb_impl)) = - mbLift $ fmap permImplSucceeds mb_impl -permImplSucceeds (PermImpl_Step (Impl1_ElimStructField _ _ _ _) - (MbPermImpls_Cons _ _ mb_impl)) = - mbLift $ fmap permImplSucceeds mb_impl -permImplSucceeds (PermImpl_Step (Impl1_ElimLLVMFieldContents _ _) - (MbPermImpls_Cons _ _ mb_impl)) = - mbLift $ fmap permImplSucceeds mb_impl -permImplSucceeds (PermImpl_Step (Impl1_ElimLLVMBlockToEq _ _) - (MbPermImpls_Cons _ _ mb_impl)) = - mbLift $ fmap permImplSucceeds mb_impl -permImplSucceeds (PermImpl_Step (Impl1_SplitLLVMWordField _ _ _ _) - (MbPermImpls_Cons _ _ mb_impl)) = - mbLift $ fmap permImplSucceeds mb_impl -permImplSucceeds (PermImpl_Step (Impl1_TruncateLLVMWordField _ _ _ _) - (MbPermImpls_Cons _ _ mb_impl)) = - mbLift $ fmap permImplSucceeds mb_impl -permImplSucceeds (PermImpl_Step (Impl1_ConcatLLVMWordFields _ _ _ _) - (MbPermImpls_Cons _ _ mb_impl)) = - mbLift $ fmap permImplSucceeds mb_impl -permImplSucceeds (PermImpl_Step Impl1_BeginLifetime - (MbPermImpls_Cons _ _ mb_impl)) = - mbLift $ fmap permImplSucceeds mb_impl -permImplSucceeds (PermImpl_Step (Impl1_TryProveBVProp _ _ _) - (MbPermImpls_Cons _ _ mb_impl)) = - mbLift $ fmap permImplSucceeds mb_impl - --- | Test if a 'PermImpl' fails, meaning 'permImplSucceeds' returns 0 -permImplFails :: PermImpl r ps -> Bool -permImplFails = (== 0) . permImplSucceeds - - --- FIXME: no longer needed...? --- traversePermImpl :: forall m ps r1 r2. --- MonadStrongBind m => (forall ps'. r1 ps' -> m (r2 ps')) -> --- PermImpl r1 ps -> m (PermImpl r2 ps) --- traversePermImpl f (PermImpl_Done r) = PermImpl_Done <$> f r --- traversePermImpl f (PermImpl_Step impl1 mb_perm_impls) = --- PermImpl_Step impl1 <$> helper mb_perm_impls --- where --- helper :: MbPermImpls r1 bs_pss -> m (MbPermImpls r2 bs_pss) --- helper MbPermImpls_Nil = return MbPermImpls_Nil --- helper (MbPermImpls_Cons _ mb_impls mb_impl) = --- do mb_impls' <- helper mb_impls --- mb_impl' <- strongMbM (fmap (traversePermImpl f) mb_impl) --- return (MbPermImpls_Cons _ mb_impls' mb_impl') - --- | Assert a condition and print an error message if it fails --- --- FIXME: put this somewhere more meaningful... -permAssert :: Bool -> String -> a -> a -permAssert True _ a = a -permAssert False str _ = error str - --- | Compute the input permissions of a 'SimplImpl' implication -simplImplIn :: SimplImpl ps_in ps_out -> DistPerms ps_in -simplImplIn (SImpl_Drop x p) = distPerms1 x p -simplImplIn (SImpl_Copy x p) = - permAssert (permIsCopyable p) - "simplImplIn: SImpl_Copy: permission is not copyable!" $ - distPerms1 x p -simplImplIn (SImpl_Swap x p1 y p2) = distPerms2 x p1 y p2 -simplImplIn (SImpl_MoveUp ps1 x p ps2) = - appendDistPerms (distPerms1 x p) $ appendDistPerms ps1 ps2 -simplImplIn (SImpl_MoveDown ps1 x p ps2) = - appendDistPerms (DistPermsCons ps1 x p) ps2 -simplImplIn (SImpl_IntroOrL x p1 _) = distPerms1 x p1 -simplImplIn (SImpl_IntroOrR x _ p2) = distPerms1 x p2 -simplImplIn (SImpl_IntroExists x e p) = - distPerms1 x (subst (singletonSubst e) p) -simplImplIn (SImpl_Cast x y p) = distPerms2 x (ValPerm_Eq $ PExpr_Var y) y p -simplImplIn (SImpl_CastPerm x eqp) = - appendDistPerms (distPerms1 x (eqProofLHS eqp)) (eqProofPerms eqp) -simplImplIn (SImpl_IntroEqRefl _) = DistPermsNil -simplImplIn (SImpl_InvertEq x y) = distPerms1 x (ValPerm_Eq $ PExpr_Var y) -simplImplIn (SImpl_InvTransEq x y e) = - distPerms2 x (ValPerm_Eq e) y (ValPerm_Eq e) -simplImplIn (SImpl_UnitEq _ _) = DistPermsNil -simplImplIn (SImpl_CopyEq x e) = distPerms1 x (ValPerm_Eq e) -simplImplIn (SImpl_LLVMWordEq x y e) = - distPerms2 x (ValPerm_Eq (PExpr_LLVMWord (PExpr_Var y))) y (ValPerm_Eq e) -simplImplIn (SImpl_LLVMOffsetZeroEq _) = DistPermsNil -simplImplIn (SImpl_IntroConj _) = DistPermsNil -simplImplIn (SImpl_ExtractConj x ps _) = distPerms1 x (ValPerm_Conj ps) -simplImplIn (SImpl_CopyConj x ps _) = distPerms1 x (ValPerm_Conj ps) -simplImplIn (SImpl_InsertConj x p ps _) = - distPerms2 x (ValPerm_Conj [p]) x (ValPerm_Conj ps) -simplImplIn (SImpl_AppendConjs x ps1 ps2) = - distPerms2 x (ValPerm_Conj ps1) x (ValPerm_Conj ps2) -simplImplIn (SImpl_SplitConjs x ps _) = - distPerms1 x (ValPerm_Conj ps) -simplImplIn (SImpl_IntroStructTrue _ _) = DistPermsNil -simplImplIn (SImpl_StructEqToPerm x exprs) = - distPerms1 x (ValPerm_Eq $ PExpr_Struct exprs) -simplImplIn (SImpl_StructPermToEq x exprs) = - distPerms1 x (ValPerm_Conj1 $ Perm_Struct $ - RL.map ValPerm_Eq $ exprsToRAssign exprs) -simplImplIn (SImpl_IntroStructField x ps memb p) = - case RL.get memb ps of - ValPerm_Eq (PExpr_Var y) -> - distPerms2 x (ValPerm_Conj1 $ Perm_Struct ps) y p - _ -> error "simplImplIn: SImpl_IntroStructField: field does not have an equality permission to a variable" -simplImplIn (SImpl_ConstFunPerm x h _ _) = - distPerms1 x (ValPerm_Eq $ PExpr_Fun h) -simplImplIn (SImpl_CastLLVMWord x e1 e2) = - distPerms2 x (ValPerm_Eq $ PExpr_LLVMWord e1) - x (ValPerm_Conj [Perm_BVProp $ BVProp_Eq e1 e2]) -simplImplIn (SImpl_InvertLLVMOffsetEq x off y) = - distPerms1 x $ ValPerm_Eq $ PExpr_LLVMOffset y off -simplImplIn (SImpl_OffsetLLVMWord y e off x) = - distPerms2 x (ValPerm_Eq $ PExpr_LLVMOffset y off) - y (ValPerm_Eq (PExpr_LLVMWord e)) -simplImplIn (SImpl_CastLLVMPtr y p off x) = - distPerms2 x (ValPerm_Eq $ PExpr_LLVMOffset y off) y p -simplImplIn (SImpl_CastLLVMFree x e1 e2) = - distPerms2 x (ValPerm_Conj [Perm_LLVMFree e1]) - x (ValPerm_Conj [Perm_BVProp $ BVProp_Eq e1 e2]) -simplImplIn (SImpl_CastLLVMFieldOffset x fld off') = - distPerms2 x (ValPerm_Conj [Perm_LLVMField fld]) - x (ValPerm_Conj [Perm_BVProp $ BVProp_Eq (llvmFieldOffset fld) off']) -simplImplIn (SImpl_IntroLLVMFieldContents x y fld) = - distPerms2 x (ValPerm_Conj [Perm_LLVMField $ - fld { llvmFieldContents = - ValPerm_Eq (PExpr_Var y)}]) - y (llvmFieldContents fld) -simplImplIn (SImpl_DemoteLLVMFieldRW x fld) = - distPerms1 x (ValPerm_Conj [Perm_LLVMField fld]) -simplImplIn (SImpl_SplitLLVMTrueField x fp _ _) = - case llvmFieldContents fp of - ValPerm_True -> distPerms1 x $ ValPerm_LLVMField fp - _ -> error "simplImplIn: SImpl_SplitLLVMTrueField: malformed field permission" -simplImplIn (SImpl_TruncateLLVMTrueField x fp _) = - case llvmFieldContents fp of - ValPerm_True -> distPerms1 x $ ValPerm_LLVMField fp - _ -> error "simplImplIn: SImpl_TruncateLLVMTrueField: malformed field permission" -simplImplIn (SImpl_ConcatLLVMTrueFields x fp1 sz2) = - case llvmFieldContents fp1 of - ValPerm_True -> - distPerms2 x (ValPerm_LLVMField fp1) x (ValPerm_LLVMField $ - llvmFieldAddOffsetInt - (llvmFieldSetTrue fp1 sz2) - (intValue (natRepr fp1) `div` 8)) - _ -> error "simplImplIn: SImpl_ConcatLLVMTrueFields: malformed field permission" -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 $ - llvmMakeSubArray ap off len) - else - error "simplImplIn: SImpl_LLVMArrayCopy: array permission not copyable or not a sub-array" -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 $ - llvmMakeSubArray ap off len) - else - error "simplImplIn: SImpl_LLVMArrayBorrow: array permission not a sub-array" -simplImplIn (SImpl_LLVMArrayReturn x ap ret_ap) = - if isJust (llvmArrayIsOffsetArray ap ret_ap) && - elem (llvmSubArrayBorrow ap ret_ap) (llvmArrayBorrows ap) then - distPerms2 x (ValPerm_Conj [Perm_LLVMArray ret_ap]) - x (ValPerm_Conj [Perm_LLVMArray ap]) - else - error ("simplImplIn: SImpl_LLVMArrayReturn: array not being borrowed or not a sub-array:\n" ++ - renderDoc ( - permPretty emptyPPInfo (ap, ret_ap) - ) - ) - -simplImplIn (SImpl_LLVMArrayAppend x ap1 ap2) = - case llvmArrayIsOffsetArray ap1 ap2 of - Just len1 - | bvEq len1 (llvmArrayLen ap1) - , 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" - -simplImplIn (SImpl_LLVMArrayRearrange x ap bs) = - if llvmArrayBorrowsPermuteTo ap bs then - distPerms1 x (ValPerm_Conj1 $ Perm_LLVMArray ap) - else - error "simplImplIn: SImpl_LLVMArrayRearrange: malformed output borrows list" - -simplImplIn (SImpl_LLVMArrayToField x ap _) = - distPerms1 x (ValPerm_Conj1 $ Perm_LLVMArray ap) - -simplImplIn (SImpl_LLVMArrayEmpty _ ap) = - if bvIsZero (llvmArrayLen ap) then DistPermsNil else - error "simplImplIn: SImpl_LLVMArrayEmpty: malformed empty array permission" -simplImplIn (SImpl_LLVMArrayBorrowed x bp ap) = - if llvmArrayIsBorrowed ap && llvmBlockShape bp == llvmArrayCellShape ap then - distPerms1 x (ValPerm_Conj1 $ Perm_LLVMBlock bp) - else - error "simplImplIn: SImpl_LLVMArrayBorrowed: array permission not completely borrowed or of the wrong shape" -simplImplIn (SImpl_LLVMArrayFromBlock x bp) = - distPerms1 x $ ValPerm_LLVMBlock bp - -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 - error "simplImplIn: SImpl_LLVMArrayCellCopy: array is not copyable" - -simplImplIn (SImpl_LLVMArrayCellBorrow x ap cell) = - distPerms2 x (ValPerm_Conj [Perm_LLVMArray ap]) - x (ValPerm_Conj $ map Perm_BVProp $ llvmArrayCellInArray ap cell) - -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_LLVMArrayCellReturn: index not being borrowed" - -simplImplIn (SImpl_LLVMArrayContents x ap _ _) = - distPerms1 x (ValPerm_Conj [Perm_LLVMArray ap]) -simplImplIn (SImpl_LLVMFieldIsPtr x fp) = - distPerms1 x (ValPerm_Conj [Perm_LLVMField fp]) -simplImplIn (SImpl_LLVMArrayIsPtr x ap) = - distPerms1 x (ValPerm_Conj [Perm_LLVMArray ap]) -simplImplIn (SImpl_LLVMBlockIsPtr x bp) = - distPerms1 x (ValPerm_Conj [Perm_LLVMBlock bp]) -simplImplIn (SImpl_SplitLifetime x f args l l2 sub_ls tps_in tps_out ps_in ps_out) = - -- If l=always then the second permission is l2:true - let (l',l'_p) = lcurrentPerm l l2 in - distPerms3 x (ltFuncApply f args l) l' l'_p - l2 (ValPerm_LOwned sub_ls tps_in tps_out ps_in ps_out) -simplImplIn (SImpl_SubsumeLifetime l ls tps_in tps_out ps_in ps_out _) = - distPerms1 l (ValPerm_LOwned ls tps_in tps_out ps_in ps_out) -simplImplIn (SImpl_ContainedLifetimeCurrent l ls tps_in tps_out ps_in ps_out l2) = - if elem l2 ls then - distPerms1 l (ValPerm_LOwned ls tps_in tps_out ps_in ps_out) - else - error ("simplImplIn: SImpl_ContainedLifetimeCurrent: " ++ - "lifetime not in contained lifetimes") -simplImplIn (SImpl_RemoveContainedLifetime l ls tps_in tps_out ps_in ps_out l2) = - if elem (PExpr_Var l2) ls then - distPerms2 l (ValPerm_LOwned ls tps_in tps_out ps_in ps_out) l2 ValPerm_LFinished - else - error ("simplImplIn: SImpl_RemoveContainedLifetime: " ++ - "lifetime not in contained lifetimes") -simplImplIn (SImpl_WeakenLifetime x f args l l2) = - let (l',l'_p) = lcurrentPerm l l2 in - distPerms2 x (ltFuncApply f args l) l' l'_p -simplImplIn (SImpl_MapLifetime l ls tps_in tps_out ps_in ps_out _ _ _ _ ps1 ps2 _ _) = - RL.append ps1 $ DistPermsCons ps2 l $ - ValPerm_LOwned ls tps_in tps_out ps_in ps_out -simplImplIn (SImpl_EndLifetime l tps_in tps_out ps_in ps_out) = - case exprPermsToDistPerms ps_in of - Just perms_in -> - DistPermsCons perms_in l $ ValPerm_LOwned [] tps_in tps_out ps_in ps_out - Nothing -> - error "simplImplIn: SImpl_EndLifetime: non-variables in input permissions" -simplImplIn (SImpl_IntroLOwnedSimple l _ lops) = - case exprPermsToDistPerms lops of - Just dps -> DistPermsCons dps l (ValPerm_LOwned [] CruCtxNil CruCtxNil MNil MNil) - Nothing -> - error "simplImplIn: SImpl_IntroLOwnedSimple: malformed permissions list" -simplImplIn (SImpl_ElimLOwnedSimple l tps lops) = - distPerms1 l (ValPerm_LOwnedSimple tps lops) -simplImplIn (SImpl_LCurrentRefl _) = DistPermsNil -simplImplIn (SImpl_LCurrentTrans l1 l2 l3) = - distPerms2 l1 (ValPerm_LCurrent $ PExpr_Var l2) l2 (ValPerm_LCurrent l3) -simplImplIn (SImpl_IntroLLVMBlockEmpty _ _) = DistPermsNil -simplImplIn (SImpl_DemoteLLVMBlockRW x bp) = - distPerms1 x $ ValPerm_LLVMBlock bp -simplImplIn (SImpl_CoerceLLVMBlockEmpty x bp) = - distPerms1 x (ValPerm_Conj1 $ Perm_LLVMBlock bp) -simplImplIn (SImpl_ElimLLVMBlockToBytes x bp) = - distPerms1 x (ValPerm_Conj1 $ Perm_LLVMBlock bp) -simplImplIn (SImpl_IntroLLVMBlockTuple x bp) = - distPerms1 x (ValPerm_Conj1 $ Perm_LLVMBlock bp) -simplImplIn (SImpl_ElimLLVMBlockTuple x bp) = - distPerms1 x (ValPerm_Conj1 $ Perm_LLVMBlock $ - bp { llvmBlockShape = PExpr_TupShape (llvmBlockShape bp) }) -simplImplIn (SImpl_IntroLLVMBlockSeqEmpty x bp) = - distPerms1 x (ValPerm_Conj1 $ Perm_LLVMBlock bp) -simplImplIn (SImpl_ElimLLVMBlockSeqEmpty x bp) = - distPerms1 x (ValPerm_Conj1 $ Perm_LLVMBlock $ - bp { llvmBlockShape = - PExpr_SeqShape (llvmBlockShape bp) PExpr_EmptyShape }) -simplImplIn (SImpl_SplitLLVMBlockEmpty x bp len1) = - if llvmBlockShape bp == PExpr_EmptyShape && bvLt len1 (llvmBlockLen bp) then - distPerms1 x (ValPerm_LLVMBlock bp) - else - error "simplImplIn: SImpl_SplitLLVMBlockEmpty: length too long!" -simplImplIn (SImpl_IntroLLVMBlockNamed x bp nmsh) = - case llvmBlockShape bp of - PExpr_NamedShape rw l nmsh' args - | Just (Refl,Refl) <- namedShapeEq nmsh nmsh' - , Just sh' <- unfoldModalizeNamedShape rw l nmsh args -> - distPerms1 x (ValPerm_LLVMBlock $ bp { llvmBlockShape = sh' }) - _ -> error "simplImplIn: SImpl_IntroLLVMBlockNamed: unexpected block shape" -simplImplIn (SImpl_ElimLLVMBlockNamed x bp _) = - distPerms1 x $ ValPerm_LLVMBlock bp -simplImplIn (SImpl_IntroLLVMBlockNamedMods x bp) = - case llvmBlockShape bp of - PExpr_NamedShape maybe_rw maybe_l nmsh args - | rw <- fromMaybe (llvmBlockRW bp) maybe_rw - , l <- fromMaybe (llvmBlockLifetime bp) maybe_l -> - distPerms1 x $ ValPerm_LLVMBlock $ - bp { llvmBlockRW = rw, llvmBlockLifetime = l, - llvmBlockShape = PExpr_NamedShape Nothing Nothing nmsh args } - _ -> error "simplImplIn: SImpl_IntroLLVMBlockNamedMods: malformed input permission" -simplImplIn (SImpl_ElimLLVMBlockNamedMods x bp) = - distPerms1 x $ ValPerm_LLVMBlock bp -simplImplIn (SImpl_IntroLLVMBlockFromEq x bp y) = - distPerms2 x (ValPerm_Conj1 $ Perm_LLVMBlock $ - bp { llvmBlockShape = - PExpr_EqShape (llvmBlockLen bp) $ PExpr_Var y }) - y (ValPerm_Conj1 $ Perm_LLVMBlockShape $ llvmBlockShape bp) -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) = - distPerms1 x (ValPerm_Conj1 $ Perm_LLVMBlock $ llvmFieldPermToBlock fp) -simplImplIn (SImpl_IntroLLVMBlockArray x ap) = - distPerms1 x (ValPerm_Conj1 $ Perm_LLVMArray ap) -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) - x (ValPerm_Conj1 $ Perm_LLVMBlock $ - bp1 { llvmBlockOffset = bvAdd (llvmBlockOffset bp1) (llvmBlockLen bp1), - llvmBlockLen = len2, llvmBlockShape = sh2 }) -simplImplIn (SImpl_ElimLLVMBlockSeq x bp sh2) = - distPerms1 x (ValPerm_Conj1 $ Perm_LLVMBlock $ - bp { llvmBlockShape = PExpr_SeqShape (llvmBlockShape bp) sh2 }) -simplImplIn (SImpl_IntroLLVMBlockOr x bp1 sh2) = - distPerms1 x (ValPerm_Or - (ValPerm_Conj1 $ Perm_LLVMBlock bp1) - (ValPerm_Conj1 $ Perm_LLVMBlock $ bp1 { llvmBlockShape = sh2 })) -simplImplIn (SImpl_ElimLLVMBlockOr x bp shs) = - distPerms1 x (ValPerm_Conj1 $ Perm_LLVMBlock $ - bp { llvmBlockShape = foldr1 PExpr_OrShape shs }) -simplImplIn (SImpl_IntroLLVMBlockEx x bp) = - case llvmBlockShape bp of - PExpr_ExShape mb_sh -> - distPerms1 x (ValPerm_Exists $ - flip fmap mb_sh $ \sh -> - ValPerm_LLVMBlock (bp { llvmBlockShape = sh })) - _ -> - error "simplImplIn: SImpl_IntroLLVMBlockEx: non-existential shape" -simplImplIn (SImpl_ElimLLVMBlockEx x bp) = - distPerms1 x (ValPerm_LLVMBlock bp) -simplImplIn (SImpl_ElimLLVMBlockFalse x bp) = - distPerms1 x (ValPerm_LLVMBlock bp) -simplImplIn (SImpl_FoldNamed x np args off) = - distPerms1 x (unfoldPerm np args off) -simplImplIn (SImpl_UnfoldNamed x np args off) = - distPerms1 x (ValPerm_Named (namedPermName np) args off) -simplImplIn (SImpl_NamedToConj x npn args off) = - distPerms1 x (ValPerm_Named npn args off) -simplImplIn (SImpl_NamedFromConj x npn args off) = - distPerms1 x (ValPerm_Conj1 $ Perm_NamedConj npn args off) --- simplImplIn (SImpl_Mu x p1 _ _) = distPerms1 x (ValPerm_Mu p1) -simplImplIn (SImpl_NamedArgAlways x npn args off memb _) = - case nthPermExpr args memb of - PExpr_Always -> distPerms1 x (ValPerm_Named npn args off) - _ -> error "simplImplIn: SImplNamedArgAlways: non-always argument!" -simplImplIn (SImpl_NamedArgCurrent x npn args off memb l2) = - case nthPermExpr args memb of - PExpr_Var l1 -> - distPerms2 x (ValPerm_Named npn args off) l1 (ValPerm_LCurrent l2) - _ -> error "simplImplIn: SImplNamedArgCurrent: non-variable argument!" -simplImplIn (SImpl_NamedArgWrite x npn args off memb _) = - case nthPermExpr args memb of - PExpr_RWModality Write -> - distPerms1 x (ValPerm_Named npn args off) - _ -> error "simplImplIn: SImplNamedArgWrite: non-Write argument!" -simplImplIn (SImpl_NamedArgRead x npn args off _) = - distPerms1 x (ValPerm_Named npn args off) -simplImplIn (SImpl_ReachabilityTrans x rp args off y e) = - let npn = recPermName rp in - distPerms2 x (ValPerm_Named npn (PExprs_Cons args (PExpr_Var y)) off) - y (ValPerm_Named npn (PExprs_Cons args e) off) -simplImplIn (SImpl_IntroAnyEqEq x e1 e2) = - if exprsUnequal e1 e2 then - distPerms2 x (ValPerm_Eq e1) x (ValPerm_Eq e2) - else - error "simplImplIn: SImpl_IntroAnyEqEq: expressions not unequal" -simplImplIn (SImpl_IntroAnyWordPtr x e p) = - if isLLVMPointerPerm p then - distPerms2 x (ValPerm_Eq $ PExpr_LLVMWord e) x (ValPerm_Conj1 p) - else - error "simplImplIn: SImpl_IntroAnyWordPtr: expressions not unequal" -simplImplIn (SImpl_ElimAnyToEq x _) = - distPerms1 x ValPerm_Any -simplImplIn (SImpl_ElimAnyToPtr x _) = distPerms1 x ValPerm_Any - --- | Compute the output permissions of a 'SimplImpl' implication -simplImplOut :: SimplImpl ps_in ps_out -> DistPerms ps_out -simplImplOut (SImpl_Drop _ _) = DistPermsNil -simplImplOut (SImpl_Copy x p) = - if permIsCopyable p then distPerms2 x p x p else - error "simplImplOut: SImpl_Copy: permission is not copyable!" -simplImplOut (SImpl_Swap x p1 y p2) = distPerms2 y p2 x p1 -simplImplOut (SImpl_MoveUp ps1 x p ps2) = - appendDistPerms (DistPermsCons ps1 x p) ps2 -simplImplOut (SImpl_MoveDown ps1 x p ps2) = - appendDistPerms (distPerms1 x p) $ appendDistPerms ps1 ps2 -simplImplOut (SImpl_IntroOrL x p1 p2) = distPerms1 x (ValPerm_Or p1 p2) -simplImplOut (SImpl_IntroOrR x p1 p2) = distPerms1 x (ValPerm_Or p1 p2) -simplImplOut (SImpl_IntroExists x _ p) = distPerms1 x (ValPerm_Exists p) -simplImplOut (SImpl_Cast x _ p) = distPerms1 x p -simplImplOut (SImpl_CastPerm x eqp) = - appendDistPerms (distPerms1 x (eqProofRHS eqp)) (eqProofPerms eqp) -simplImplOut (SImpl_IntroEqRefl x) = distPerms1 x (ValPerm_Eq $ PExpr_Var x) -simplImplOut (SImpl_InvertEq x y) = distPerms1 y (ValPerm_Eq $ PExpr_Var x) -simplImplOut (SImpl_InvTransEq x y _) = distPerms1 x (ValPerm_Eq $ PExpr_Var y) -simplImplOut (SImpl_UnitEq x e) = distPerms1 x (ValPerm_Eq e) -simplImplOut (SImpl_CopyEq x e) = distPerms2 x (ValPerm_Eq e) x (ValPerm_Eq e) -simplImplOut (SImpl_LLVMWordEq x _ e) = - distPerms1 x (ValPerm_Eq (PExpr_LLVMWord e)) -simplImplOut (SImpl_LLVMOffsetZeroEq x) = - distPerms1 x (ValPerm_Eq (PExpr_LLVMOffset x (zeroOfType (BVRepr knownNat)))) -simplImplOut (SImpl_IntroConj x) = distPerms1 x ValPerm_True -simplImplOut (SImpl_ExtractConj x ps i) = - if i < length ps then - distPerms2 x (ValPerm_Conj [ps !! i]) - x (ValPerm_Conj (take i ps ++ drop (i+1) ps)) - else - error "simplImplOut: SImpl_ExtractConj: index out of bounds" -simplImplOut (SImpl_CopyConj x ps i) = - if i < length ps && atomicPermIsCopyable (ps !! i) then - distPerms2 x (ValPerm_Conj [ps !! i]) x (ValPerm_Conj ps) - else - if i >= length ps then - error "simplImplOut: SImpl_CopyConj: index out of bounds" - else - error "simplImplOut: SImpl_CopyConj: permission not copyable" -simplImplOut (SImpl_InsertConj x p ps i) = - distPerms1 x (ValPerm_Conj (take i ps ++ p : drop i ps)) -simplImplOut (SImpl_AppendConjs x ps1 ps2) = - distPerms1 x (ValPerm_Conj (ps1 ++ ps2)) -simplImplOut (SImpl_SplitConjs x ps i) = - distPerms2 x (ValPerm_Conj (take i ps)) x (ValPerm_Conj (drop i ps)) -simplImplOut (SImpl_IntroStructTrue x fs) = - distPerms1 x (ValPerm_Conj1 $ Perm_Struct $ trueValuePerms fs) -simplImplOut (SImpl_StructEqToPerm x exprs) = - distPerms1 x (ValPerm_Conj1 $ Perm_Struct $ - RL.map ValPerm_Eq $ exprsToRAssign exprs) -simplImplOut (SImpl_StructPermToEq x exprs) = - distPerms1 x (ValPerm_Eq $ PExpr_Struct exprs) -simplImplOut (SImpl_IntroStructField x ps memb p) = - distPerms1 x (ValPerm_Conj1 $ Perm_Struct $ RL.set memb p ps) -simplImplOut (SImpl_ConstFunPerm x _ fun_perm _) = - distPerms1 x (ValPerm_Conj1 $ Perm_Fun fun_perm) -simplImplOut (SImpl_CastLLVMWord x _ e2) = - distPerms1 x (ValPerm_Eq $ PExpr_LLVMWord e2) -simplImplOut (SImpl_InvertLLVMOffsetEq x off y) = - distPerms1 y $ ValPerm_Eq $ PExpr_LLVMOffset x $ bvNegate off -simplImplOut (SImpl_OffsetLLVMWord _ e off x) = - distPerms1 x (ValPerm_Eq $ PExpr_LLVMWord $ bvAdd e off) -simplImplOut (SImpl_CastLLVMPtr _ p off x) = - distPerms1 x (offsetLLVMPerm (bvNegate off) p) -simplImplOut (SImpl_CastLLVMFree x _ e2) = - distPerms1 x (ValPerm_Conj [Perm_LLVMFree e2]) -simplImplOut (SImpl_CastLLVMFieldOffset x fld off') = - distPerms1 x (ValPerm_Conj [Perm_LLVMField $ fld { llvmFieldOffset = off' }]) -simplImplOut (SImpl_IntroLLVMFieldContents x _ fld) = - distPerms1 x (ValPerm_Conj [Perm_LLVMField fld]) -simplImplOut (SImpl_DemoteLLVMFieldRW x fld) = - distPerms1 x (ValPerm_Conj [Perm_LLVMField $ - fld { llvmFieldRW = PExpr_Read }]) -simplImplOut (SImpl_SplitLLVMTrueField x fp sz1 sz2m1) = - case llvmFieldContents fp of - ValPerm_True -> - distPerms2 x (ValPerm_LLVMField $ llvmFieldSetTrue fp sz1) - x (ValPerm_LLVMField $ - llvmFieldAddOffsetInt (llvmFieldSetTrue fp sz2m1) - (intValue (natRepr sz1) `div` 8)) - _ -> error "simplImplOut: SImpl_SplitLLVMTrueField: malformed field permission" -simplImplOut (SImpl_TruncateLLVMTrueField x fp sz1) = - case llvmFieldContents fp of - ValPerm_True - | intValue sz1 < intValue (llvmFieldSize fp) -> - distPerms1 x (ValPerm_LLVMField $ llvmFieldSetTrue fp sz1) - _ -> error "simplImplOut: SImpl_TruncateLLVMTrueField: malformed field permission" -simplImplOut (SImpl_ConcatLLVMTrueFields x fp1 sz2) = - case llvmFieldContents fp1 of - ValPerm_True -> - distPerms1 x (ValPerm_LLVMField $ - llvmFieldSetTrue fp1 (addNat (llvmFieldSize fp1) sz2)) - _ -> error "simplImplOut: SImpl_ConcatLLVMTrueFields: malformed field permission" -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 $ 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 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]) - else - error "simplImplOut: SImpl_LLVMArrayBorrow: array permission not a sub-array" - -simplImplOut (SImpl_LLVMArrayReturn x ap ret_ap) = - if isJust (llvmArrayIsOffsetArray ap ret_ap) && - elem (llvmSubArrayBorrow ap ret_ap) (llvmArrayBorrows ap) then - distPerms1 x - (ValPerm_Conj [Perm_LLVMArray $ - llvmArrayRemBorrow (llvmSubArrayBorrow ap ret_ap) $ - llvmArrayAddArrayBorrows ap ret_ap]) - else - error "simplImplOut: SImpl_LLVMArrayReturn: array not being borrowed or not a sub-array" - -simplImplOut (SImpl_LLVMArrayAppend x ap1 ap2) = - case llvmArrayIsOffsetArray ap1 ap2 of - Just len1 - | bvEq len1 (llvmArrayLen ap1) - , llvmArrayCellShape ap1 == llvmArrayCellShape ap2 - , ap1' <- ap1 { llvmArrayLen = - bvAdd (llvmArrayLen ap1) (llvmArrayLen ap2) } -> - distPerms1 x $ ValPerm_Conj1 $ Perm_LLVMArray $ - llvmArrayAddArrayBorrows ap1' ap2 - _ -> error "simplImplOut: SImpl_LLVMArrayAppend: arrays cannot be appended" - -simplImplOut (SImpl_LLVMArrayRearrange x ap bs) = - if llvmArrayBorrowsPermuteTo ap bs then - distPerms1 x (ValPerm_Conj1 $ Perm_LLVMArray $ ap { llvmArrayBorrows = bs }) - else - error "simplImplOut: SImpl_LLVMArrayRearrange: malformed output borrows list" - -simplImplOut (SImpl_LLVMArrayToField x ap sz) = - case llvmArrayToField sz ap of - Just fp -> distPerms1 x (ValPerm_Conj1 $ Perm_LLVMField fp) - Nothing -> - error "simplImplOut: SImpl_LLVMArrayToField: malformed array permission" - -simplImplOut (SImpl_LLVMArrayEmpty x ap) = - if bvIsZero (llvmArrayLen ap) then - distPerms1 x (ValPerm_Conj1 $ Perm_LLVMArray ap) - else - error "simplImplOut: SImpl_LLVMArrayEmpty: malformed empty array permission" - -simplImplOut (SImpl_LLVMArrayBorrowed x bp ap) = - if bvIsZero (llvmArrayLen ap) then - error "simplImplOut: SImpl_LLVMArrayBorrowed: malformed borrowed array permission" - else - distPerms2 - x (ValPerm_Conj1 $ Perm_LLVMArray ap) - x (ValPerm_Conj1 $ Perm_LLVMBlock bp) - -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 - error "simplImplOut: SImpl_LLVMArrayCellCopy: array is not copyable" - -simplImplOut (SImpl_LLVMArrayCellBorrow x ap cell) = - distPerms2 x (ValPerm_LLVMBlock $ llvmArrayCellPerm ap cell) - x (ValPerm_LLVMArray $ llvmArrayAddBorrow (FieldBorrow cell) 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_LLVMArrayCellReturn: index not being borrowed" - -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) - x (ValPerm_Conj [Perm_LLVMField fp]) -simplImplOut (SImpl_LLVMArrayIsPtr x ap) = - distPerms2 x (ValPerm_Conj1 Perm_IsLLVMPtr) - x (ValPerm_Conj [Perm_LLVMArray ap]) -simplImplOut (SImpl_LLVMBlockIsPtr x bp) = - distPerms2 x (ValPerm_Conj1 Perm_IsLLVMPtr) - x (ValPerm_Conj [Perm_LLVMBlock bp]) -simplImplOut (SImpl_SplitLifetime x f args l l2 sub_ls tps_in tps_out ps_in ps_out) = - distPerms2 x (ltFuncApply f args $ PExpr_Var l2) - l2 (ValPerm_LOwned sub_ls - (CruCtxCons tps_in $ exprType x) - (CruCtxCons tps_out $ exprType x) - (ps_in :>: ExprAndPerm (PExpr_Var x) (ltFuncMinApply f (PExpr_Var l2))) - (ps_out :>: ExprAndPerm (PExpr_Var x) (ltFuncApply f args l))) -simplImplOut (SImpl_SubsumeLifetime l ls tps_in tps_out ps_in ps_out l2) = - distPerms1 l (ValPerm_LOwned (l2:ls) tps_in tps_out ps_in ps_out) -simplImplOut (SImpl_ContainedLifetimeCurrent l ls tps_in tps_out ps_in ps_out l2) = - if elem l2 ls then - distPerms2 l (ValPerm_LCurrent l2) - l (ValPerm_LOwned ls tps_in tps_out ps_in ps_out) - else - error ("simplImplOut: SImpl_ContainedLifetimeCurrent: " ++ - "lifetime not in contained lifetimes") -simplImplOut (SImpl_RemoveContainedLifetime l ls tps_in tps_out ps_in ps_out l2) = - if elem (PExpr_Var l2) ls then - distPerms1 l (ValPerm_LOwned (delete (PExpr_Var l2) ls) - tps_in tps_out ps_in ps_out) - else - error ("simplImplOut: SImpl_RemoveContainedLifetime: " ++ - "lifetime not in contained lifetimes") -simplImplOut (SImpl_WeakenLifetime x f args _ l2) = - distPerms1 x (ltFuncApply f args $ PExpr_Var l2) -simplImplOut (SImpl_MapLifetime l ls _ _ _ _ tps_in' tps_out' ps_in' ps_out' _ _ _ _) = - distPerms1 l $ ValPerm_LOwned ls tps_in' tps_out' ps_in' ps_out' -simplImplOut (SImpl_EndLifetime l _ _ _ ps_out) = - case exprPermsToDistPerms ps_out of - Just perms_out -> - DistPermsCons perms_out l ValPerm_LFinished - _ -> error "simplImplOut: SImpl_EndLifetime: non-variable in output permissions" -simplImplOut (SImpl_IntroLOwnedSimple l tps lops) = - case modalize Nothing (Just (PExpr_Var l)) lops >>= exprPermsToDistPerms of - Just dps -> DistPermsCons dps l $ ValPerm_LOwnedSimple tps lops - Nothing -> - error "simplImplOut: SImpl_IntroLOwnedSimple: non-variables in permission list" -simplImplOut (SImpl_ElimLOwnedSimple l tps lops) = - case lownedPermsSimpleIn l lops of - Just lops' -> distPerms1 l (ValPerm_LOwned [] tps tps lops' lops) - Nothing -> - error "simplImplOut: SImpl_ElimLOwnedSimple: could not modalize permission list" -simplImplOut (SImpl_LCurrentRefl l) = - distPerms1 l (ValPerm_LCurrent $ PExpr_Var l) -simplImplOut (SImpl_LCurrentTrans l1 _ l3) = - distPerms1 l1 (ValPerm_LCurrent l3) -simplImplOut (SImpl_DemoteLLVMBlockRW x bp) = - distPerms1 x $ ValPerm_LLVMBlock (bp { llvmBlockRW = PExpr_Read }) -simplImplOut (SImpl_IntroLLVMBlockEmpty x bp) = - case llvmBlockShape bp of - PExpr_EmptyShape -> distPerms1 x $ ValPerm_Conj1 $ Perm_LLVMBlock bp - _ -> error "simplImplOut: SImpl_IntroLLVMBlockEmpty: malformed permission" -simplImplOut (SImpl_CoerceLLVMBlockEmpty x bp) = - distPerms1 x (ValPerm_Conj1 $ Perm_LLVMBlock $ - bp { llvmBlockShape = PExpr_EmptyShape }) -simplImplOut (SImpl_ElimLLVMBlockToBytes x (LLVMBlockPerm {..})) = - distPerms1 x (llvmByteArrayPerm llvmBlockOffset llvmBlockLen - llvmBlockRW llvmBlockLifetime) -simplImplOut (SImpl_IntroLLVMBlockTuple x bp) = - distPerms1 x (ValPerm_Conj1 $ Perm_LLVMBlock $ - bp { llvmBlockShape = PExpr_TupShape (llvmBlockShape bp) }) -simplImplOut (SImpl_ElimLLVMBlockTuple x bp) = - distPerms1 x (ValPerm_Conj1 $ Perm_LLVMBlock bp) -simplImplOut (SImpl_IntroLLVMBlockSeqEmpty x bp) = - distPerms1 x (ValPerm_Conj1 $ Perm_LLVMBlock $ - bp { llvmBlockShape = - PExpr_SeqShape (llvmBlockShape bp) PExpr_EmptyShape }) -simplImplOut (SImpl_ElimLLVMBlockSeqEmpty x bp) = - distPerms1 x (ValPerm_Conj1 $ Perm_LLVMBlock bp) -simplImplOut (SImpl_SplitLLVMBlockEmpty x bp len1) = - if llvmBlockShape bp == PExpr_EmptyShape && bvLt len1 (llvmBlockLen bp) then - distPerms1 x (ValPerm_Conj - [Perm_LLVMBlock (bp { llvmBlockLen = len1 }), - Perm_LLVMBlock - (bp { llvmBlockOffset = bvAdd (llvmBlockOffset bp) len1, - llvmBlockLen = bvSub (llvmBlockLen bp) len1 })]) - else - error "simplImplOut: SImpl_SplitLLVMBlockEmpty: length too long!" -simplImplOut (SImpl_IntroLLVMBlockNamed x bp _) = - distPerms1 x $ ValPerm_LLVMBlock bp -simplImplOut (SImpl_ElimLLVMBlockNamed x bp nmsh) = - case llvmBlockShape bp of - PExpr_NamedShape rw l nmsh' args - | Just (Refl,Refl) <- namedShapeEq nmsh nmsh' - , Just sh' <- unfoldModalizeNamedShape rw l nmsh args -> - distPerms1 x (ValPerm_LLVMBlock $ bp { llvmBlockShape = sh' }) - _ -> error "simplImplOut: SImpl_ElimLLVMBlockNamed: unexpected block shape" -simplImplOut (SImpl_IntroLLVMBlockNamedMods x bp) = - distPerms1 x $ ValPerm_LLVMBlock bp -simplImplOut (SImpl_ElimLLVMBlockNamedMods x bp) = - case llvmBlockShape bp of - PExpr_NamedShape maybe_rw maybe_l nmsh args - | rw <- fromMaybe (llvmBlockRW bp) maybe_rw - , l <- fromMaybe (llvmBlockLifetime bp) maybe_l -> - distPerms1 x $ ValPerm_LLVMBlock $ - bp { llvmBlockRW = rw, llvmBlockLifetime = l, - llvmBlockShape = PExpr_NamedShape Nothing Nothing nmsh args } - _ -> error "simplImplOut: SImpl_ElimLLVMBlockNamedMods: malformed input permission" -simplImplOut (SImpl_IntroLLVMBlockFromEq x bp _) = - distPerms1 x (ValPerm_Conj1 $ Perm_LLVMBlock bp) -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) = - 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 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, - llvmBlockShape = PExpr_SeqShape (llvmBlockShape bp1) sh2 }) -simplImplOut (SImpl_ElimLLVMBlockSeq x bp sh2) = - case llvmShapeLength (llvmBlockShape bp) of - Just len1 -> - distPerms1 - x (ValPerm_Conj - [Perm_LLVMBlock (bp { llvmBlockLen = len1 }), - Perm_LLVMBlock $ - bp { llvmBlockOffset = bvAdd (llvmBlockOffset bp) len1, - llvmBlockLen = bvSub (llvmBlockLen bp) len1, - llvmBlockShape = sh2 }]) - Nothing -> - error "simplImplOut: SImpl_ElimLLVMBlockSeq" -simplImplOut (SImpl_IntroLLVMBlockOr x bp1 sh2) = - let sh1 = llvmBlockShape bp1 in - distPerms1 x (ValPerm_Conj1 $ Perm_LLVMBlock $ - bp1 { llvmBlockShape = PExpr_OrShape sh1 sh2 }) -simplImplOut (SImpl_ElimLLVMBlockOr x bp shs) = - distPerms1 x $ - foldr1 ValPerm_Or $ - map (\sh -> ValPerm_Conj1 $ Perm_LLVMBlock $ bp { llvmBlockShape = sh }) shs -simplImplOut (SImpl_IntroLLVMBlockEx x bp) = - distPerms1 x (ValPerm_LLVMBlock bp) -simplImplOut (SImpl_ElimLLVMBlockEx x bp) = - case llvmBlockShape bp of - PExpr_ExShape mb_sh -> - distPerms1 x (ValPerm_Exists $ - flip fmap mb_sh $ \sh -> - ValPerm_LLVMBlock (bp { llvmBlockShape = sh })) - _ -> - error "simplImplOut: SImpl_ElimLLVMBlockEx: non-existential shape" -simplImplOut (SImpl_ElimLLVMBlockFalse x bp) = - case llvmBlockShape bp of - PExpr_FalseShape -> - distPerms1 x ValPerm_False - _ -> error "simplImplOut: SImpl_ElimLLVMBlockFalse: non-false shape" -simplImplOut (SImpl_FoldNamed x np args off) = - distPerms1 x (ValPerm_Named (namedPermName np) args off) -simplImplOut (SImpl_UnfoldNamed x np args off) = - distPerms1 x (unfoldPerm np args off) -simplImplOut (SImpl_NamedToConj x npn args off) = - distPerms1 x (ValPerm_Conj1 $ Perm_NamedConj npn args off) -simplImplOut (SImpl_NamedFromConj x npn args off) = - distPerms1 x (ValPerm_Named npn args off) --- simplImplOut (SImpl_Mu x _ p2 _) = distPerms1 x (ValPerm_Mu p2) -simplImplOut (SImpl_NamedArgAlways x npn args off memb l) = - distPerms1 x (ValPerm_Named npn (setNthPermExpr args memb l) off) -simplImplOut (SImpl_NamedArgCurrent x npn args off memb l2) = - distPerms1 x (ValPerm_Named npn (setNthPermExpr args memb l2) off) -simplImplOut (SImpl_NamedArgWrite x npn args off memb rw) = - distPerms1 x (ValPerm_Named npn (setNthPermExpr args memb rw) off) -simplImplOut (SImpl_NamedArgRead x npn args off memb) = - distPerms1 x (ValPerm_Named npn - (setNthPermExpr args memb (PExpr_RWModality Read)) - off) -simplImplOut (SImpl_ReachabilityTrans x rp args off _ e) = - distPerms1 x (ValPerm_Named (recPermName rp) (PExprs_Cons args e) off) -simplImplOut (SImpl_IntroAnyEqEq x _ _) = distPerms1 x ValPerm_Any -simplImplOut (SImpl_IntroAnyWordPtr x _ _) = distPerms1 x ValPerm_Any -simplImplOut (SImpl_ElimAnyToEq x e) = distPerms1 x (ValPerm_Eq e) -simplImplOut (SImpl_ElimAnyToPtr x fp) = - if llvmFieldContents fp == ValPerm_Any then - distPerms1 x (ValPerm_LLVMField fp) - else - error "simplImplOut: SImpl_ElimAnyToPtr: non-any contents" - --- | Compute the input permissions of a 'SimplImpl' implication in a binding -mbSimplImplIn :: Mb ctx (SimplImpl ps_in ps_out) -> Mb ctx (DistPerms ps_in) -mbSimplImplIn = mbMapCl $(mkClosed [| simplImplIn |]) - --- | Compute the output permissions of a 'SimplImpl' implication in a binding -mbSimplImplOut :: Mb ctx (SimplImpl ps_in ps_out) -> Mb ctx (DistPerms ps_out) -mbSimplImplOut = mbMapCl $(mkClosed [| simplImplOut |]) - --- | Apply a 'SimplImpl' implication to the permissions on the top of a --- permission set stack, checking that they equal the 'simplImplIn' of the --- 'SimplImpl' and then replacing them with its 'simplImplOut' -applySimplImpl :: HasCallStack => PPInfo -> Proxy ps -> - SimplImpl ps_in ps_out -> PermSet (ps :++: ps_in) -> - PermSet (ps :++: ps_out) -applySimplImpl pp_info prx simpl = - modifyDistPerms $ \all_ps -> - let (ps, ps_in) = - splitDistPerms prx (distPermsToProxies $ simplImplIn simpl) all_ps in - if ps_in == simplImplIn simpl then - appendDistPerms ps (simplImplOut simpl) - else - error $ renderDoc $ - vsep [pretty "applySimplImpl: incorrect input permissions", - pretty "expected: " <> permPretty pp_info (simplImplIn simpl), - pretty "actual: " <> permPretty pp_info ps_in] - --- | A sequence of permission sets inside name-bindings -data MbPermSets bs_pss where - MbPermSets_Nil :: MbPermSets RNil - MbPermSets_Cons :: MbPermSets bs_pss -> CruCtx bs -> Mb bs (PermSet ps) -> - MbPermSets (bs_pss :> '(bs,ps)) - --- | Helper for building a one-element 'MbPermSets' sequence -mbPermSets1 :: KnownRepr CruCtx bs => - Mb bs (PermSet ps) -> MbPermSets (RNil :> '(bs,ps)) -mbPermSets1 = MbPermSets_Cons MbPermSets_Nil knownRepr - --- | Helper for building a two-element 'MbPermSets' sequence -mbPermSets2 :: (KnownRepr CruCtx bs1, KnownRepr CruCtx bs2) => - Mb bs1 (PermSet ps1) -> Mb bs2 (PermSet ps2) -> - MbPermSets (RNil :> '(bs1,ps1) :> '(bs2,ps2)) -mbPermSets2 ps1 ps2 = - MbPermSets_Cons (MbPermSets_Cons MbPermSets_Nil knownRepr ps1) knownRepr ps2 - --- | Extract the permission in an or elimination disjunct -orListDisjPerm :: OrListDisj ps a disj -> ValuePerm a -orListDisjPerm (OrListDisj p) = p - --- | Extract the disjuncts of an or elimination list -orListDisjs :: OrList ps a disjs -> [ValuePerm a] -orListDisjs = RL.mapToList orListDisjPerm - --- | Extract the disjuncts of an or elimination list in a binding -mbOrListDisjs :: Mb ctx (OrList ps a disjs) -> [Mb ctx (ValuePerm a)] -mbOrListDisjs = mbList . mbMapCl $(mkClosed [| orListDisjs |]) - --- | Compute the permission eliminated by an 'OrList' -orListPerm :: OrList ps a disjs -> ValuePerm a -orListPerm MNil = error "orListPerm: empty disjunct list!" -orListPerm or_list = foldr1 ValPerm_Or $ orListDisjs or_list - --- | Compute the permission-in-binding eliminated by an 'OrList' in a binding -mbOrListPerm :: Mb ctx (OrList ps a disj) -> Mb ctx (ValuePerm a) -mbOrListPerm = mbMapCl $(mkClosed [| orListPerm |]) - --- | Build an 'MbPermSets' -orListMbPermSets :: PermSet (ps :> a) -> ExprVar a -> OrList ps a disjs -> - MbPermSets disjs -orListMbPermSets _ _ MNil = MbPermSets_Nil -orListMbPermSets ps x (or_list :>: OrListDisj p) = - MbPermSets_Cons (orListMbPermSets ps x or_list) CruCtxNil $ - emptyMb $ set (topDistPerm x) p ps - --- | If we have an 'MbPermImpls' list associated with a multi-way or --- elimination, extract out the list of 'PermImpl's it carries -orListPermImpls :: OrList ps a disjs -> MbPermImpls r disjs -> - [PermImpl r (ps :> a)] -orListPermImpls MNil MbPermImpls_Nil = [] -orListPermImpls (or_list :>: OrListDisj _) (MbPermImpls_Cons - _ mb_impls mb_impl) = - orListPermImpls or_list mb_impls ++ [elimEmptyMb mb_impl] - --- | Extract the 'PermImpl's-in-bindings from an 'MbPermImpls'-in-binding --- associated with a multi-way or elimination -mbOrListPermImpls :: NuMatchingAny1 r => Mb ctx (OrList ps a disjs) -> - Mb ctx (MbPermImpls r disjs) -> - [Mb ctx (PermImpl r (ps :> a))] -mbOrListPermImpls (mbMatch -> - [nuMP| MNil |]) (mbMatch -> [nuMP| MbPermImpls_Nil |]) = [] -mbOrListPermImpls - (mbMatch -> [nuMP| mb_or_list :>: OrListDisj _ |]) - (mbMatch -> [nuMP| MbPermImpls_Cons _ mb_impls mb_impl |]) - = mbOrListPermImpls mb_or_list mb_impls ++ [mbMapCl - $(mkClosed [| elimEmptyMb |]) - mb_impl] - --- | Apply a single permission implication step to a permission set -applyImpl1 :: HasCallStack => PPInfo -> PermImpl1 ps_in ps_outs -> - PermSet ps_in -> MbPermSets ps_outs -applyImpl1 _ (Impl1_Fail _) _ = MbPermSets_Nil -applyImpl1 _ (Impl1_Catch _) ps = mbPermSets2 (emptyMb ps) (emptyMb ps) -applyImpl1 pp_info (Impl1_Push x p) ps = - if ps ^. varPerm x == p then - mbPermSets1 $ emptyMb $ pushPerm x p $ set (varPerm x) ValPerm_True ps - else - error $ renderDoc (pretty "applyImpl1: Impl1_Push" <+> - permPretty pp_info x <+> colon <> softline <> - pretty "expected:" <+> permPretty pp_info p <> softline <> - pretty "found:" <+> - permPretty pp_info (ps ^. varPerm x)) -applyImpl1 pp_info (Impl1_Pop x p) ps = - if ps ^. topDistPerm x == p && ps ^. varPerm x == ValPerm_True then - mbPermSets1 $ emptyMb $ fst $ popPerm x $ set (varPerm x) p ps - else - if ps ^. varPerm x == ValPerm_True then - error $ renderDoc $ - vsep [pretty "applyImpl1: Impl1_Pop: unexpected permissions on top of the stack", - pretty "expected: " <> permPretty pp_info p, - pretty "actual: " <> permPretty pp_info (ps ^. topDistPerm x)] - else - error $ renderDoc $ - vsep [pretty "applyImpl1: Impl1_Pop: non-empty permissions for variable" - <+> permPretty pp_info x <> pretty ":", - permPretty pp_info (ps ^. varPerm x)] -applyImpl1 _ (Impl1_ElimOrs _ x or_list) ps = - if ps ^. topDistPerm x == orListPerm or_list then - orListMbPermSets ps x or_list - else - error "applyImpl1: Impl1_ElimOrs: unexpected permission" -applyImpl1 _ (Impl1_ElimExists x p_body) ps = - if ps ^. topDistPerm x == ValPerm_Exists p_body then - mbPermSets1 (fmap (\p -> set (topDistPerm x) p ps) p_body) - else - error "applyImpl1: Impl1_ElimExists: unexpected permission" -applyImpl1 _ (Impl1_ElimFalse x) ps = - if ps ^. topDistPerm x == ValPerm_False then - MbPermSets_Nil - else - error "applyImpl1: Impl1_ElimFalse: unexpected permission" -applyImpl1 pp_info (Impl1_Simpl simpl prx) ps = - mbPermSets1 $ emptyMb $ applySimplImpl pp_info prx simpl ps -applyImpl1 _ (Impl1_LetBind tp e) ps = - MbPermSets_Cons MbPermSets_Nil (CruCtxCons CruCtxNil tp) $ - nu $ \x -> pushPerm x (ValPerm_Eq e) ps -applyImpl1 _ (Impl1_ElimStructField x ps' tp memb) ps = - if ps ^. topDistPerm x == ValPerm_Conj [Perm_Struct ps'] then - (MbPermSets_Cons MbPermSets_Nil (singletonCruCtx tp) $ nu $ \y -> - pushPerm y (RL.get memb ps') $ - set (topDistPerm x) (ValPerm_Conj1 $ Perm_Struct $ - RL.set memb (ValPerm_Eq $ PExpr_Var y) ps') - ps) - else - error "applyImpl1: Impl1_ElimStructField: unexpected permission" -applyImpl1 _ (Impl1_ElimLLVMFieldContents x fp) ps = - if ps ^. topDistPerm x == ValPerm_Conj [Perm_LLVMField fp] then - (mbPermSets1 $ nu $ \y -> - pushPerm y (llvmFieldContents fp) $ - set (topDistPerm x) (ValPerm_Conj [Perm_LLVMField $ - fp { llvmFieldContents = - ValPerm_Eq (PExpr_Var y) }]) - ps) - else - error "applyImpl1: Impl1_ElimLLVMFieldContents: unexpected permission" -applyImpl1 _ (Impl1_ElimLLVMBlockToEq x bp) ps = - if ps ^. topDistPerm x == ValPerm_Conj1 (Perm_LLVMBlock bp) then - (mbPermSets1 $ nu $ \y -> - pushPerm y (ValPerm_Conj1 $ Perm_LLVMBlockShape $ - modalizeBlockShape bp) $ - set (topDistPerm x) (ValPerm_Conj1 $ Perm_LLVMBlock $ - bp { llvmBlockShape = - PExpr_EqShape (llvmBlockLen bp) (PExpr_Var y) }) - ps) - else - error "applyImpl1: Impl1_ElimLLVMBlockToEq: unexpected permission" -applyImpl1 _ (Impl1_SplitLLVMWordField x fp sz1 endianness) ps = - if ps ^. topDistPerm x == ValPerm_LLVMField fp && - intValue sz1 `mod` 8 == 0 then - mbPermSets1 $ nuMultiWithElim1 - (\(_ :>: y :>: z) vps_out -> - flip modifyDistPerms ps $ \(dps :>: _) -> - RL.append dps $ RL.map2 VarAndPerm (MNil :>: x :>: x :>: y :>: z) vps_out) $ - impl1SplitLLVMWordFieldOutPerms fp sz1 endianness - else - error "applyImpl1: Impl1_SplitLLVMWordField: unexpected input permissions" -applyImpl1 _ (Impl1_TruncateLLVMWordField x fp sz1 endianness) ps = - if ps ^. topDistPerm x == ValPerm_LLVMField fp then - mbPermSets1 $ nuWithElim1 - (\y vps_out -> - flip modifyDistPerms ps $ \(dps :>: _) -> - RL.append dps $ RL.map2 VarAndPerm (MNil :>: x :>: y) vps_out) $ - impl1TruncateLLVMWordFieldOutPerms fp sz1 endianness - else - error "applyImpl1: Impl1_TruncateLLVMWordField: unexpected input permissions" -applyImpl1 _ (Impl1_ConcatLLVMWordFields x fp1 e2 endianness) ps = - if ps ^. distPerm (Member_Step Member_Base) x == ValPerm_LLVMField fp1 && - ps ^. topDistPerm x == (ValPerm_LLVMField $ - llvmFieldAddOffsetInt - (llvmFieldSetEqWord fp1 e2) - (intValue (natRepr fp1) `div` 8)) && - intValue (natRepr fp1) `mod` 8 == 0 then - mbPermSets1 $ nuWithElim1 - (\y vps_out -> - flip modifyDistPerms ps $ \(dps :>: _ :>: _) -> - RL.append dps $ RL.map2 VarAndPerm (MNil :>: x :>: y) vps_out) $ - impl1ConcatLLVMWordFieldsOutPerms fp1 e2 endianness - else - error "applyImpl1: Impl1_ConcatLLVMWordField: unexpected input permissions" -applyImpl1 _ Impl1_BeginLifetime ps = - mbPermSets1 $ nu $ \l -> - pushPerm l (ValPerm_LOwned [] CruCtxNil CruCtxNil MNil MNil) ps -applyImpl1 _ (Impl1_TryProveBVProp x prop _) ps = - mbPermSets1 $ emptyMb $ - pushPerm x (ValPerm_Conj [Perm_BVProp prop]) ps - - --- | Helper function to compute the output permissions of the --- 'Impl1_SplitLLVMWordField' rule -impl1SplitLLVMWordFieldOutPerms :: - (1 <= w, KnownNat w, 1 <= sz1, KnownNat sz1, 1 <= sz2, KnownNat sz2, - 1 <= (sz2 - sz1), KnownNat (sz2 - sz1)) => - LLVMFieldPerm w sz2 -> NatRepr sz1 -> EndianForm -> - Mb (RNil :> BVType sz1 :> BVType (sz2 - sz1)) - (ValuePerms (RNil :> LLVMPointerType w :> LLVMPointerType w :> - BVType sz1 :> BVType (sz2 - sz1))) -impl1SplitLLVMWordFieldOutPerms fp sz1 endianness = - nuMulti RL.typeCtxProxies $ \(MNil :>: y :>: z) -> - let (p_y,p_z) = - case llvmFieldContents fp of - ValPerm_Eq (PExpr_LLVMWord (bvMatchConst -> Just bv)) - | Just (bv1,bv2) <- bvSplit endianness sz1 bv -> - (ValPerm_Eq (bvBV bv1), ValPerm_Eq (bvBV bv2)) - ValPerm_Eq (PExpr_LLVMWord _) -> - (ValPerm_True, ValPerm_True) - _ -> - error ("applyImpl1: Impl1_SplitLLVMWordField: " - ++ "malformed input permission") in - MNil :>: ValPerm_LLVMField (llvmFieldSetEqWordVar fp y) :>: - ValPerm_LLVMField (llvmFieldAddOffsetInt - (llvmFieldSetEqWordVar fp z) - (intValue sz1 `div` 8)) :>: p_y :>: p_z - --- | Helper function to compute the output permissions of the --- 'Impl1_TruncateLLVMWordField' rule -impl1TruncateLLVMWordFieldOutPerms :: - (1 <= w, KnownNat w, 1 <= sz1, KnownNat sz1, 1 <= sz2, KnownNat sz2) => - LLVMFieldPerm w sz2 -> NatRepr sz1 -> EndianForm -> - Mb (RNil :> BVType sz1) (ValuePerms (RNil :> LLVMPointerType w :> BVType sz1)) -impl1TruncateLLVMWordFieldOutPerms fp sz1 endianness = - nu $ \y -> - let p_y = - case llvmFieldContents fp of - ValPerm_Eq (PExpr_LLVMWord (bvMatchConst -> Just bv)) - | Just (bv1,_) <- bvSplit endianness sz1 bv -> - ValPerm_Eq (bvBV bv1) - ValPerm_Eq (PExpr_LLVMWord _) -> ValPerm_True - _ -> - error ("applyImpl1: Impl1_TruncateLLVMWordField: " - ++ "malformed input permission") in - MNil :>: ValPerm_LLVMField (llvmFieldSetEqWordVar fp y) :>: p_y - - --- | Helper function to compute the output permissions of the --- 'Impl1_ConcatLLVMWordFields' rule -impl1ConcatLLVMWordFieldsOutPerms :: - (1 <= w, KnownNat w, 1 <= sz1, KnownNat sz1, 1 <= sz2, KnownNat sz2, - 1 <= (sz1 + sz2), KnownNat (sz1 + sz2)) => - LLVMFieldPerm w sz1 -> PermExpr (BVType sz2) -> EndianForm -> - Mb (RNil :> BVType (sz1 + sz2)) (ValuePerms (RNil :> LLVMPointerType w :> - BVType (sz1 + sz2))) -impl1ConcatLLVMWordFieldsOutPerms fp1 e2 endianness = - nu $ \y -> - let p_y = - case (llvmFieldContents fp1, bvMatchConst e2) of - (ValPerm_Eq (PExpr_LLVMWord - (bvMatchConst -> Just bv1)), Just bv2) -> - ValPerm_Eq $ bvBV (bvConcat endianness bv1 bv2) - (ValPerm_Eq (PExpr_LLVMWord _), _) -> ValPerm_True - _ -> - error ("applyImpl1: Impl1_ConcatLLVMWordField: " - ++ "malformed input permission") in - MNil :>: ValPerm_LLVMField (llvmFieldSetEqWordVar fp1 y) :>: p_y - - -instance SubstVar PermVarSubst m => Substable PermVarSubst (EqPerm a) m where - genSubst s (mbMatch -> [nuMP| EqPerm x e b |]) = - EqPerm <$> genSubst s x <*> genSubst s e <*> return (mbLift b) - -instance SubstVar PermVarSubst m => Substable1 PermVarSubst EqPerm m where - genSubst1 = genSubst - --- NOTE: PermVarSubst is always associated with the Identity monad because of --- the functional dependency of SubstVar; this is necessary to substitute inside --- the function used in EqProofStep -instance (NuMatching a, Substable PermVarSubst a Identity) => - Substable PermVarSubst (EqProofStep ps a) Identity where - genSubst s (mbMatch -> [nuMP| EqProofStep eq_perms f |]) = - Identity $ EqProofStep (runIdentity $ genSubst s eq_perms) $ \es -> - runIdentity $ genSubst s $ fmap ($ es) f - -instance (NuMatching a, Substable PermVarSubst a Identity) => - Substable PermVarSubst (EqProof ps a) Identity where - genSubst s eqp = case mbMatch eqp of - [nuMP| EqProofRefl a |] -> - EqProofRefl <$> genSubst s a - [nuMP| EqProofCons eqp' eq_step |] -> - EqProofCons <$> genSubst s eqp' <*> genSubst s eq_step - -instance m ~ Identity => - Substable PermVarSubst (SimplImpl ps_in ps_out) m where - genSubst s mb_impl = case mbMatch mb_impl of - [nuMP| SImpl_Drop x p |] -> - SImpl_Drop <$> genSubst s x <*> genSubst s p - [nuMP| SImpl_Copy x p |] -> - SImpl_Copy <$> genSubst s x <*> genSubst s p - [nuMP| SImpl_Swap x p1 y p2 |] -> - SImpl_Swap <$> genSubst s x <*> genSubst s p1 <*> genSubst s y <*> genSubst s p2 - [nuMP| SImpl_MoveUp ps1 x p ps2 |] -> - SImpl_MoveUp <$> genSubst s ps1 <*> genSubst s x <*> - genSubst s p <*> genSubst s ps2 - [nuMP| SImpl_MoveDown ps1 x p ps2 |] -> - SImpl_MoveDown <$> genSubst s ps1 <*> genSubst s x <*> - genSubst s p <*> genSubst s ps2 - [nuMP| SImpl_IntroOrL x p1 p2 |] -> - SImpl_IntroOrL <$> genSubst s x <*> genSubst s p1 <*> genSubst s p2 - [nuMP| SImpl_IntroOrR x p1 p2 |] -> - SImpl_IntroOrR <$> genSubst s x <*> genSubst s p1 <*> genSubst s p2 - [nuMP| SImpl_IntroExists x e p |] -> - SImpl_IntroExists <$> genSubst s x <*> genSubst s e <*> genSubst s p - [nuMP| SImpl_Cast x y p |] -> - SImpl_Cast <$> genSubst s x <*> genSubst s y <*> genSubst s p - [nuMP| SImpl_CastPerm x eqp |] -> - SImpl_CastPerm <$> genSubst s x <*> return (runIdentity $ genSubst s eqp) - [nuMP| SImpl_IntroEqRefl x |] -> - SImpl_IntroEqRefl <$> genSubst s x - [nuMP| SImpl_InvertEq x y |] -> - SImpl_InvertEq <$> genSubst s x <*> genSubst s y - [nuMP| SImpl_InvTransEq x y e |] -> - SImpl_InvTransEq <$> genSubst s x <*> genSubst s y <*> genSubst s e - [nuMP| SImpl_UnitEq x e |] -> - SImpl_UnitEq <$> genSubst s x <*> genSubst s e - [nuMP| SImpl_CopyEq x e |] -> - SImpl_CopyEq <$> genSubst s x <*> genSubst s e - [nuMP| SImpl_LLVMWordEq x y e |] -> - SImpl_LLVMWordEq <$> genSubst s x <*> genSubst s y <*> genSubst s e - [nuMP| SImpl_LLVMOffsetZeroEq x |] -> - SImpl_LLVMOffsetZeroEq <$> genSubst s x - [nuMP| SImpl_IntroConj x |] -> - SImpl_IntroConj <$> genSubst s x - [nuMP| SImpl_ExtractConj x ps i |] -> - SImpl_ExtractConj <$> genSubst s x <*> genSubst s ps <*> return (mbLift i) - [nuMP| SImpl_CopyConj x ps i |] -> - SImpl_CopyConj <$> genSubst s x <*> genSubst s ps <*> return (mbLift i) - [nuMP| SImpl_InsertConj x p ps i |] -> - SImpl_InsertConj <$> genSubst s x <*> genSubst s p <*> - genSubst s ps <*> return (mbLift i) - [nuMP| SImpl_AppendConjs x ps1 ps2 |] -> - SImpl_AppendConjs <$> genSubst s x <*> genSubst s ps1 <*> genSubst s ps2 - [nuMP| SImpl_SplitConjs x ps i |] -> - SImpl_SplitConjs <$> genSubst s x <*> genSubst s ps <*> return (mbLift i) - [nuMP| SImpl_IntroStructTrue x fs |] -> - SImpl_IntroStructTrue <$> genSubst s x <*> return (mbLift fs) - [nuMP| SImpl_StructEqToPerm x exprs |] -> - SImpl_StructEqToPerm <$> genSubst s x <*> genSubst s exprs - [nuMP| SImpl_StructPermToEq x exprs |] -> - SImpl_StructPermToEq <$> genSubst s x <*> genSubst s exprs - [nuMP| SImpl_IntroStructField x ps memb p |] -> - SImpl_IntroStructField <$> genSubst s x <*> genSubst s ps - <*> genSubst s memb <*> genSubst s p - [nuMP| SImpl_ConstFunPerm x h fun_perm ident |] -> - SImpl_ConstFunPerm <$> genSubst s x <*> return (mbLift h) <*> - genSubst s fun_perm <*> return (mbLift ident) - [nuMP| SImpl_CastLLVMWord x e1 e2 |] -> - SImpl_CastLLVMWord <$> genSubst s x <*> genSubst s e1 <*> genSubst s e2 - [nuMP| SImpl_InvertLLVMOffsetEq x off y |] -> - SImpl_InvertLLVMOffsetEq <$> genSubst s x <*> genSubst s off <*> genSubst s y - [nuMP| SImpl_OffsetLLVMWord y e off x |] -> - SImpl_OffsetLLVMWord <$> genSubst s y <*> genSubst s e <*> - genSubst s off <*> genSubst s x - [nuMP| SImpl_CastLLVMPtr y p off x |] -> - SImpl_CastLLVMPtr <$> genSubst s y <*> genSubst s p <*> - genSubst s off <*> genSubst s x - [nuMP| SImpl_CastLLVMFree x e1 e2 |] -> - SImpl_CastLLVMFree <$> genSubst s x <*> genSubst s e1 <*> genSubst s e2 - [nuMP| SImpl_CastLLVMFieldOffset x fld off' |] -> - SImpl_CastLLVMFieldOffset <$> genSubst s x <*> genSubst s fld <*> - genSubst s off' - [nuMP| SImpl_IntroLLVMFieldContents x y fld |] -> - SImpl_IntroLLVMFieldContents <$> genSubst s x <*> genSubst s y <*> - genSubst s fld - [nuMP| SImpl_DemoteLLVMFieldRW x fld |] -> - SImpl_DemoteLLVMFieldRW <$> genSubst s x <*> genSubst s fld - [nuMP| SImpl_SplitLLVMTrueField x fp sz1 sz2m1 |] -> - SImpl_SplitLLVMTrueField <$> genSubst s x <*> genSubst s fp <*> - return (mbLift sz1) <*> return (mbLift sz2m1) - [nuMP| SImpl_TruncateLLVMTrueField x fp sz1 |] -> - SImpl_TruncateLLVMTrueField <$> genSubst s x <*> genSubst s fp <*> - return (mbLift sz1) - [nuMP| SImpl_ConcatLLVMTrueFields x fp1 sz2 |] -> - SImpl_ConcatLLVMTrueFields <$> genSubst s x <*> genSubst s fp1 <*> - return (mbLift sz2) - [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 |] -> - SImpl_LLVMArrayAppend <$> genSubst s x <*> genSubst s ap1 <*> genSubst s ap2 - [nuMP| SImpl_LLVMArrayRearrange x ap bs |] -> - SImpl_LLVMArrayRearrange <$> genSubst s x <*> genSubst s ap <*> genSubst s bs - [nuMP| SImpl_LLVMArrayToField x ap sz |] -> - SImpl_LLVMArrayToField <$> genSubst s x <*> genSubst s ap - <*> return (mbLift sz) - [nuMP| SImpl_LLVMArrayEmpty x ap |] -> - SImpl_LLVMArrayEmpty <$> genSubst s x <*> genSubst s ap - [nuMP| SImpl_LLVMArrayFromBlock x bp |] -> - SImpl_LLVMArrayFromBlock <$> genSubst s x <*> genSubst s bp - [nuMP| SImpl_LLVMArrayBorrowed x bp ap |] -> - SImpl_LLVMArrayBorrowed <$> genSubst s x <*> genSubst s bp <*> genSubst s ap - [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 sh <*> genSubst s mb_mb_impl - [nuMP| SImpl_LLVMFieldIsPtr x fp |] -> - SImpl_LLVMFieldIsPtr <$> genSubst s x <*> genSubst s fp - [nuMP| SImpl_LLVMArrayIsPtr x ap |] -> - SImpl_LLVMArrayIsPtr <$> genSubst s x <*> genSubst s ap - [nuMP| SImpl_LLVMBlockIsPtr x bp |] -> - SImpl_LLVMBlockIsPtr <$> genSubst s x <*> genSubst s bp - [nuMP| SImpl_SplitLifetime x f args l l2 sub_ls tps_in tps_out ps_in ps_out |] -> - SImpl_SplitLifetime <$> genSubst s x <*> genSubst s f <*> genSubst s args - <*> genSubst s l <*> genSubst s l2 - <*> genSubst s sub_ls - <*> genSubst s tps_in <*> genSubst s tps_out - <*> genSubst s ps_in <*> genSubst s ps_out - [nuMP| SImpl_SubsumeLifetime l ls tps_in tps_out ps_in ps_out l2 |] -> - SImpl_SubsumeLifetime <$> genSubst s l <*> genSubst s ls - <*> genSubst s tps_in <*> genSubst s tps_out - <*> genSubst s ps_in <*> genSubst s ps_out - <*> genSubst s l2 - [nuMP| SImpl_ContainedLifetimeCurrent l ls tps_in tps_out ps_in ps_out l2 |] -> - SImpl_ContainedLifetimeCurrent <$> genSubst s l <*> genSubst s ls - <*> genSubst s tps_in <*> genSubst s tps_out - <*> genSubst s ps_in <*> genSubst s ps_out - <*> genSubst s l2 - [nuMP| SImpl_RemoveContainedLifetime l ls tps_in tps_out ps_in ps_out l2 |] -> - SImpl_RemoveContainedLifetime <$> genSubst s l <*> genSubst s ls - <*> genSubst s tps_in <*> genSubst s tps_out - <*> genSubst s ps_in <*> genSubst s ps_out - <*> genSubst s l2 - [nuMP| SImpl_WeakenLifetime x f args l l2 |] -> - SImpl_WeakenLifetime <$> genSubst s x <*> genSubst s f <*> genSubst s args - <*> genSubst s l <*> genSubst s l2 - [nuMP| SImpl_MapLifetime l ls tps_in tps_out ps_in ps_out - tps_in' tps_out' ps_in' ps_out' - ps1 ps2 impl1 impl2 |] -> - SImpl_MapLifetime <$> genSubst s l <*> genSubst s ls - <*> genSubst s tps_in <*> genSubst s tps_out - <*> genSubst s ps_in <*> genSubst s ps_out - <*> genSubst s tps_in' <*> genSubst s tps_out' - <*> genSubst s ps_in' <*> genSubst s ps_out' - <*> genSubst s ps1 <*> genSubst s ps2 - <*> genSubst s impl1 <*> genSubst s impl2 - [nuMP| SImpl_EndLifetime l tps_in tps_out ps_in ps_out |] -> - SImpl_EndLifetime <$> genSubst s l - <*> genSubst s tps_in <*> genSubst s tps_out - <*> genSubst s ps_in <*> genSubst s ps_out - [nuMP| SImpl_IntroLOwnedSimple l tps lops |] -> - SImpl_IntroLOwnedSimple <$> genSubst s l - <*> genSubst s tps <*> genSubst s lops - [nuMP| SImpl_ElimLOwnedSimple l tps lops |] -> - SImpl_ElimLOwnedSimple <$> genSubst s l - <*> genSubst s tps <*> genSubst s lops - [nuMP| SImpl_LCurrentRefl l |] -> - SImpl_LCurrentRefl <$> genSubst s l - [nuMP| SImpl_LCurrentTrans l1 l2 l3 |] -> - SImpl_LCurrentTrans <$> genSubst s l1 <*> genSubst s l2 <*> genSubst s l3 - [nuMP| SImpl_DemoteLLVMBlockRW x bp |] -> - SImpl_DemoteLLVMBlockRW <$> genSubst s x <*> genSubst s bp - [nuMP| SImpl_IntroLLVMBlockEmpty x bp |] -> - SImpl_IntroLLVMBlockEmpty <$> genSubst s x <*> genSubst s bp - [nuMP| SImpl_CoerceLLVMBlockEmpty x bp |] -> - SImpl_CoerceLLVMBlockEmpty <$> genSubst s x <*> genSubst s bp - [nuMP| SImpl_ElimLLVMBlockToBytes x bp |] -> - SImpl_ElimLLVMBlockToBytes <$> genSubst s x <*> genSubst s bp - [nuMP| SImpl_IntroLLVMBlockTuple x bp |] -> - SImpl_IntroLLVMBlockTuple <$> genSubst s x <*> genSubst s bp - [nuMP| SImpl_ElimLLVMBlockTuple x bp |] -> - SImpl_ElimLLVMBlockTuple <$> genSubst s x <*> genSubst s bp - [nuMP| SImpl_IntroLLVMBlockSeqEmpty x bp |] -> - SImpl_IntroLLVMBlockSeqEmpty <$> genSubst s x <*> genSubst s bp - [nuMP| SImpl_ElimLLVMBlockSeqEmpty x bp |] -> - SImpl_ElimLLVMBlockSeqEmpty <$> genSubst s x <*> genSubst s bp - [nuMP| SImpl_SplitLLVMBlockEmpty x bp len1 |] -> - SImpl_SplitLLVMBlockEmpty <$> genSubst s x <*> genSubst s bp - <*> genSubst s len1 - [nuMP| SImpl_IntroLLVMBlockNamed x bp nmsh |] -> - SImpl_IntroLLVMBlockNamed <$> genSubst s x <*> genSubst s bp - <*> genSubst s nmsh - [nuMP| SImpl_ElimLLVMBlockNamed x bp nmsh |] -> - SImpl_ElimLLVMBlockNamed <$> genSubst s x <*> genSubst s bp - <*> genSubst s nmsh - [nuMP| SImpl_IntroLLVMBlockNamedMods x bp |] -> - SImpl_IntroLLVMBlockNamedMods <$> genSubst s x <*> genSubst s bp - [nuMP| SImpl_ElimLLVMBlockNamedMods x bp |] -> - SImpl_ElimLLVMBlockNamedMods <$> genSubst s x <*> genSubst s bp - [nuMP| SImpl_IntroLLVMBlockFromEq x bp y |] -> - SImpl_IntroLLVMBlockFromEq <$> genSubst s x <*> genSubst s bp - <*> genSubst s y - [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 |] -> - SImpl_ElimLLVMBlockField <$> genSubst s x <*> genSubst s fp - [nuMP| SImpl_IntroLLVMBlockArray x fp |] -> - SImpl_IntroLLVMBlockArray <$> 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 - [nuMP| SImpl_ElimLLVMBlockSeq x bp1 sh2 |] -> - SImpl_ElimLLVMBlockSeq <$> genSubst s x <*> genSubst s bp1 - <*> genSubst s sh2 - [nuMP| SImpl_IntroLLVMBlockOr x bp1 sh2 |] -> - SImpl_IntroLLVMBlockOr <$> genSubst s x <*> genSubst s bp1 - <*> genSubst s sh2 - [nuMP| SImpl_ElimLLVMBlockOr x bp shs |] -> - SImpl_ElimLLVMBlockOr <$> genSubst s x <*> genSubst s bp <*> genSubst s shs - [nuMP| SImpl_IntroLLVMBlockEx x bp |] -> - SImpl_IntroLLVMBlockEx <$> genSubst s x <*> genSubst s bp - [nuMP| SImpl_ElimLLVMBlockEx x bp |] -> - SImpl_ElimLLVMBlockEx <$> genSubst s x <*> genSubst s bp - [nuMP| SImpl_ElimLLVMBlockFalse x bp |] -> - SImpl_ElimLLVMBlockFalse <$> genSubst s x <*> genSubst s bp - [nuMP| SImpl_FoldNamed x np args off |] -> - SImpl_FoldNamed <$> genSubst s x <*> genSubst s np <*> genSubst s args - <*> genSubst s off - [nuMP| SImpl_UnfoldNamed x np args off |] -> - SImpl_UnfoldNamed <$> genSubst s x <*> genSubst s np <*> genSubst s args - <*> genSubst s off - [nuMP| SImpl_NamedToConj x npn args off |] -> - SImpl_NamedToConj <$> genSubst s x <*> genSubst s npn <*> genSubst s args - <*> genSubst s off - [nuMP| SImpl_NamedFromConj x npn args off |] -> - SImpl_NamedFromConj <$> genSubst s x <*> genSubst s npn <*> genSubst s args - <*> genSubst s off - [nuMP| SImpl_NamedArgAlways x npn args off memb l |] -> - SImpl_NamedArgAlways <$> genSubst s x <*> genSubst s npn <*> - genSubst s args <*> genSubst s off <*> - genSubst s memb <*> genSubst s l - [nuMP| SImpl_NamedArgCurrent x npn args off memb l2 |] -> - SImpl_NamedArgCurrent <$> genSubst s x <*> genSubst s npn <*> - genSubst s args <*> genSubst s off <*> - genSubst s memb <*> genSubst s l2 - [nuMP| SImpl_NamedArgWrite x npn args off memb rw |] -> - SImpl_NamedArgWrite <$> genSubst s x <*> genSubst s npn <*> - genSubst s args <*> genSubst s off <*> - genSubst s memb <*> genSubst s rw - [nuMP| SImpl_NamedArgRead x npn args off memb |] -> - SImpl_NamedArgRead <$> genSubst s x <*> genSubst s npn <*> - genSubst s args <*> genSubst s off <*> - genSubst s memb - [nuMP| SImpl_ReachabilityTrans x rp args off y e |] -> - SImpl_ReachabilityTrans <$> genSubst s x <*> genSubst s rp <*> - genSubst s args <*> genSubst s off <*> - genSubst s y <*> genSubst s e - [nuMP| SImpl_IntroAnyEqEq x e1 e2 |] -> - SImpl_IntroAnyEqEq <$> genSubst s x <*> genSubst s e1 <*> genSubst s e2 - [nuMP| SImpl_IntroAnyWordPtr x e p |] -> - SImpl_IntroAnyWordPtr <$> genSubst s x <*> genSubst s e <*> genSubst s p - [nuMP| SImpl_ElimAnyToEq x e |] -> - SImpl_ElimAnyToEq <$> genSubst s x <*> genSubst s e - [nuMP| SImpl_ElimAnyToPtr x fp |] -> - SImpl_ElimAnyToPtr <$> genSubst s x <*> genSubst s fp - -instance m ~ Identity => - Substable PermVarSubst (PermImpl1 ps_in ps_out) m where - genSubst s mb_impl = case mbMatch mb_impl of - [nuMP| Impl1_Fail err |] -> Impl1_Fail <$> genSubst s err - [nuMP| Impl1_Catch str |] -> return $ Impl1_Catch $ mbLift str - [nuMP| Impl1_Push x p |] -> - Impl1_Push <$> genSubst s x <*> genSubst s p - [nuMP| Impl1_Pop x p |] -> - Impl1_Pop <$> genSubst s x <*> genSubst s p - [nuMP| Impl1_ElimOrs str x or_list |] -> - Impl1_ElimOrs (mbLift str) <$> genSubst s x <*> genSubst s or_list - [nuMP| Impl1_ElimExists x p_body |] -> - Impl1_ElimExists <$> genSubst s x <*> genSubst s p_body - [nuMP| Impl1_ElimFalse x |] -> - Impl1_ElimFalse <$> genSubst s x - [nuMP| Impl1_Simpl simpl prx |] -> - Impl1_Simpl <$> genSubst s simpl <*> return (mbLift prx) - [nuMP| Impl1_LetBind tp e |] -> - Impl1_LetBind (mbLift tp) <$> genSubst s e - [nuMP| Impl1_ElimStructField x ps tp memb |] -> - Impl1_ElimStructField <$> genSubst s x <*> genSubst s ps - <*> return (mbLift tp) <*> genSubst s memb - [nuMP| Impl1_ElimLLVMFieldContents x fp |] -> - Impl1_ElimLLVMFieldContents <$> genSubst s x <*> genSubst s fp - [nuMP| Impl1_ElimLLVMBlockToEq x bp |] -> - Impl1_ElimLLVMBlockToEq <$> genSubst s x <*> genSubst s bp - [nuMP| Impl1_SplitLLVMWordField x fp2 sz1 endianness |] -> - Impl1_SplitLLVMWordField <$> genSubst s x <*> genSubst s fp2 <*> - return (mbLift sz1) <*> return (mbLift endianness) - [nuMP| Impl1_TruncateLLVMWordField x fp2 sz1 endianness |] -> - Impl1_TruncateLLVMWordField <$> genSubst s x <*> genSubst s fp2 <*> - return (mbLift sz1) <*> return (mbLift endianness) - [nuMP| Impl1_ConcatLLVMWordFields x fp1 e2 endianness |] -> - Impl1_ConcatLLVMWordFields <$> genSubst s x <*> genSubst s fp1 <*> - genSubst s e2 <*> return (mbLift endianness) - [nuMP| Impl1_BeginLifetime |] -> return Impl1_BeginLifetime - [nuMP| Impl1_TryProveBVProp x prop prop_str |] -> - Impl1_TryProveBVProp <$> genSubst s x <*> genSubst s prop <*> - return (mbLift prop_str) - -instance (NuMatchingAny1 r, m ~ Identity, - Substable1 PermVarSubst r m) => - Substable PermVarSubst (PermImpl r ps) m where - genSubst s mb_impl = case mbMatch mb_impl of - [nuMP| PermImpl_Done r |] -> PermImpl_Done <$> genSubst1 s r - [nuMP| PermImpl_Step impl1 mb_impls |] -> - PermImpl_Step <$> genSubst s impl1 <*> genSubst s mb_impls - -instance (NuMatchingAny1 r, m ~ Identity, - Substable1 PermVarSubst r m) => - Substable PermVarSubst (MbPermImpls r bs_pss) m where - genSubst s mb_impls = case mbMatch mb_impls of - [nuMP| MbPermImpls_Nil |] -> return MbPermImpls_Nil - [nuMP| MbPermImpls_Cons mpx mb_impl mb_impls' |] -> - let px = mbLift mpx in - MbPermImpls_Cons px <$> genSubst s mb_impl <*> genSubstMb (cruCtxProxies px) s mb_impls' - -instance SubstVar s m => Substable s (OrListDisj ps a disj) m where - genSubst s (mbMatch -> [nuMP| OrListDisj mb_p |]) = - OrListDisj <$> genSubst s mb_p - -instance SubstVar s m => Substable1 s (OrListDisj ps a) m where - genSubst1 = genSubst - -instance m ~ Identity => - Substable PermVarSubst (LocalPermImpl ps_in ps_out) m where - genSubst s (mbMatch -> [nuMP| LocalPermImpl impl |]) = - LocalPermImpl <$> genSubst s impl - -instance SubstVar s m => Substable s (LocalImplRet ps ps') m where - genSubst _ (mbMatch -> [nuMP| LocalImplRet Refl |]) = return $ LocalImplRet Refl - -instance SubstVar s m => Substable1 s (LocalImplRet ps) m where - genSubst1 _ (mbMatch -> [nuMP| LocalImplRet Refl |]) = return $ LocalImplRet Refl - - ----------------------------------------------------------------------- --- * Permission Implication Monad ----------------------------------------------------------------------- - --- FIXME: instead of having a separate PPInfo and name type map, we should maybe --- combine all the local context into one type...? - -data ImplState vars ps = - ImplState { _implStatePerms :: PermSet ps, - -- ^ The current primary permissions and permissions stack - _implStateVars :: CruCtx vars, - -- ^ The types of all evars in scope - _implStatePSubst :: PartialSubst vars, - -- ^ The partial instantiation of evars in scope - _implStatePVarSubst :: RAssign (Compose Maybe ExprVar) vars, - -- ^ The partial instantiation of evars to fresh variables; used - -- by 'proveVarsImplVarEVars' and when evars need have permissions - -- proved on them - _implStateRecRecurseFlag :: RecurseFlag, - -- ^ Whether we are recursing under a recursive permission, either - -- on the left hand or the right hand side - _implStatePermEnv :: PermEnv, - -- ^ The current permission environment - _implStatePPInfo :: PPInfo, - -- ^ Pretty-printing for all variables in scope - _implStateNameTypes :: NameMap TypeRepr, - -- ^ Types of all the variables in scope - _implStateUnitVar :: Maybe (ExprVar UnitType), - -- ^ A global unit variable that all other unit variables will be - -- equal to - _implStateEndianness :: EndianForm, - -- ^ The endianness of the current architecture - _implStateFailPrefix :: String, - -- ^ A prefix string to prepend to any failure messages - _implStateDebugLevel :: DebugLevel - -- ^ Whether tracing is turned on or not - } -makeLenses ''ImplState - -mkImplState :: CruCtx vars -> PermSet ps -> PermEnv -> - PPInfo -> String -> DebugLevel -> - NameMap TypeRepr -> Maybe (ExprVar UnitType) -> - EndianForm -> ImplState vars ps -mkImplState vars perms env info fail_prefix dlevel nameTypes u endianness = - ImplState { - _implStateVars = vars, - _implStatePerms = perms, - _implStatePSubst = emptyPSubst $ cruCtxProxies vars, - _implStatePVarSubst = RL.map (const $ Compose Nothing) (cruCtxProxies vars), - _implStateRecRecurseFlag = RecNone, - _implStatePermEnv = env, - _implStatePPInfo = info, - _implStateNameTypes = nameTypes, - _implStateUnitVar = u, - _implStateEndianness = endianness, - _implStateFailPrefix = fail_prefix, - _implStateDebugLevel = dlevel - } - -extImplState :: TypeRepr tp -> ImplState vars ps -> - ImplState (vars :> tp) ps -extImplState tp s = - s { _implStateVars = CruCtxCons (_implStateVars s) tp, - _implStatePSubst = extPSubst (_implStatePSubst s), - _implStatePVarSubst = (_implStatePVarSubst s) :>: Compose Nothing } - -unextImplState :: ImplState (vars :> a) ps -> ImplState vars ps -unextImplState s = - s { _implStateVars = unextCruCtx (_implStateVars s), - _implStatePSubst = unextPSubst (_implStatePSubst s), - _implStatePVarSubst = RL.tail (_implStatePVarSubst s) } - - --- | The implication monad is a state-continuation monad that uses 'ImplState' -type ImplM vars s r ps_out ps_in = - GenStateContT - (ImplState vars ps_out) (PermImpl r ps_out) - (ImplState vars ps_in ) (PermImpl r ps_in ) - (State (Closed s)) - --- | Run an 'ImplM' computation by passing it a @vars@ context, a starting --- permission set, top-level state, and a continuation to consume the output -runImplM :: - NuMatchingAny1 r => - CruCtx vars {- ^ existential variables and their types -} -> - PermSet ps_in -> - PermEnv {- ^ permission environment -} -> - PPInfo {- ^ pretty-printer settings -} -> - String {- ^ fail prefix -} -> - DebugLevel {- ^ debug level -} -> - NameMap TypeRepr {- ^ name types -} -> - Maybe (ExprVar UnitType) {- ^ optional global unit var -} -> - EndianForm {- ^ endianness -} -> - ImplM vars s r ps_out ps_in a -> - ((a, ImplState vars ps_out) -> State (Closed s) (r ps_out)) -> - State (Closed s) (PermImpl r ps_in) -runImplM vars perms env ppInfo fail_prefix dlevel nameTypes unitVar endianness m k = - runGenStateContT - -- instantiate all unit evars to the global unit variable (with - -- 'handleUnitEVars') before running m - (handleUnitEVars >>> m) - (mkImplState vars perms env ppInfo fail_prefix dlevel nameTypes unitVar endianness) - (\s a -> PermImpl_Done <$> k (a, s)) - - - --- | Run an 'ImplM' computation that returns a 'PermImpl', by inserting that --- 'PermImpl' inside of the larger 'PermImpl' that is built up by the 'ImplM' --- computation. -runImplImplM :: NuMatchingAny1 r => - CruCtx vars -> PermSet ps_in -> PermEnv -> PPInfo -> - String -> DebugLevel -> NameMap TypeRepr -> - Maybe (ExprVar UnitType) -> EndianForm -> - ImplM vars s r ps_out ps_in (PermImpl r ps_out) -> - State (Closed s) (PermImpl r ps_in) -runImplImplM vars perms env ppInfo fail_prefix dlevel nameTypes u endianness m = - runGenStateContT - -- instantiate all unit evars to the global unit variable (with - -- 'handleUnitEVars') before running m - (handleUnitEVars >>> m) - (mkImplState vars perms env ppInfo fail_prefix dlevel nameTypes u endianness) - (\_ -> pure) - --- | 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 -embedImplM :: NuMatchingAny1 r' => - DistPerms ps_in -> - ImplM RNil s r' ps_out ps_in (r' ps_out) -> - ImplM vars s r ps ps (PermImpl r' ps_in) -embedImplM ps_in m = - get >>= \s -> - lift $ - runImplM CruCtxNil (distPermSet ps_in) - (view implStatePermEnv s) (view implStatePPInfo s) - (view implStateFailPrefix s) (view implStateDebugLevel s) - (view implStateNameTypes s) (view implStateUnitVar s) - (view implStateEndianness s) m (pure . fst) - --- | 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 :: KnownRepr CruCtx ctx => NuMatchingAny1 r' => - 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 $ 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) (view implStateUnitVar s) - (view implStateEndianness 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 --- @reset@ operation of delimited continuations. --- --- FIXME: figure out a more general @reset@ combinator... -localImplM :: - ImplM vars s r ps_out ps_in (PermImpl r ps_out) -> - ImplM vars s r ps_in ps_in (PermImpl r ps_in) -localImplM m = - do st <- get - lift (runGenStateContT m st (\_ -> pure)) - --- | Look up the type of an existential variable -getExVarType :: Member vars tp -> ImplM vars s r ps ps (TypeRepr tp) -getExVarType memb = - do varTypes <- use implStateVars - pure (cruCtxLookup varTypes memb) - --- | Look up the current partial substitution -getPSubst :: ImplM vars s r ps ps (PartialSubst vars) -getPSubst = use implStatePSubst - --- | Get phantom arguments for the current existential variables -getVarProxies :: ImplM vars s r ps ps (RAssign Proxy vars) -getVarProxies = uses implStateVars cruCtxProxies - --- | Add a multi-binding for the current existential variables around a value --- (that does not use those variables) -mbVarsM :: a -> ImplM vars s r ps ps (Mb vars a) -mbVarsM a = - do px <- getVarProxies - pure (mbPure px a) - --- | Build a multi-binding for the current existential variables using a --- function that expects a substitution of these new variables for old copies of --- those variables -mbSubstM :: ((forall a. Substable PermVarSubst a Identity => - Mb vars a -> a) -> b) -> - ImplM vars s r ps ps (Mb vars b) -mbSubstM f = - do vars <- getVarProxies - return (nuMulti vars $ \ns -> - f (varSubst $ permVarSubstOfNames ns)) - --- | Apply the current partial substitution to an expression, failing if the --- partial substitution is not complete enough. The supplied 'String' is the --- calling function, used for error reporting in the failure. -partialSubstForceM :: (NuMatchingAny1 r, PermPretty a, - Substable PartialSubst a Maybe) => - Mb vars a -> String -> ImplM vars s r ps ps a -partialSubstForceM mb_e caller = - do psubst <- getPSubst - use implStatePPInfo >>>= \ppinfo -> - case partialSubst psubst mb_e of - Just e -> pure e - Nothing -> - implFailM $ PartialSubstitutionError caller (permPretty ppinfo mb_e) - --- | Modify the current partial substitution -modifyPSubst :: (PartialSubst vars -> PartialSubst vars) -> - ImplM vars s r ps ps () -modifyPSubst f = implStatePSubst %= f - --- | Set the value for an existential variable in the current substitution, --- raising an error if it is already set -setVarM :: Member vars a -> PermExpr a -> ImplM vars s r ps ps () -setVarM memb e = - do vars <- getVarProxies - _ <- implTraceM (\i -> pretty "Setting" <+> - permPretty i (nuMulti vars $ \ns -> RL.get memb ns) <+> - pretty "=" <+> permPretty i e) - modifyPSubst (psubstSet memb e) - --- | Set the value for an existential variable to the zero of its type if it has --- not yet been set -zeroUnsetVarM :: Member vars (a :: CrucibleType) -> ImplM vars s r ps ps () -zeroUnsetVarM memb = - do tp <- RL.get memb <$> cruCtxToTypes <$> use implStateVars - setVarM memb (zeroOfType tp) - --- | Get a free variable that is provably equal to the value of an existential --- variable, let-binding a fresh variable if the evar is instantiated with a --- non-variable expression. It is an error if the evar has no instantiation in --- the current partial substitution. -getVarVarM :: NuMatchingAny1 r => Member vars a -> - ImplM vars s r ps ps (ExprVar a) -getVarVarM memb = - getPSubst >>>= \psubst -> - use implStatePVarSubst >>>= \pvsubst -> - case (RL.get memb pvsubst, psubstLookup psubst memb) of - (Compose (Just n), Just _) -> pure n - (Compose (Just n), Nothing) -> - setVarM memb (PExpr_Var n) >>> pure n - (_, Just e) -> - getExVarType memb >>>= \tp -> - implLetBindVar tp e >>>= \n -> - implStatePVarSubst %= RL.set memb (Compose (Just n)) >>> - pure n - _ -> error "getVarVarM" - - --- | Run an implication computation with one more existential variable, --- returning the optional expression it was bound to in the current partial --- substitution when it is done -withExtVarsM' :: NuMatchingAny1 r => - TypeRepr tp -> ImplM (vars :> tp) s r ps1 ps2 a -> - ImplM vars s r ps1 ps2 (a, PermExpr tp) -withExtVarsM' tp m = - -- Add a new existential to the 'ImplState' - gmodify (extImplState tp) >>> - -- If the new existential has type unit, instantiate it to the global unit - handleUnitEVar Member_Base >>> - -- Run the computation - m >>>= \a -> - getPSubst >>>= \psubst -> - -- Remove the existential after it has been instantiated - gmodify unextImplState >>> - pure (a, case psubstLookup psubst Member_Base of - Just e -> e - Nothing -> zeroOfType tp) - --- | Run an implication computation with one more existential variable, --- returning the optional expression it was bound to in the current partial --- substitution when it is done -withExtVarsM :: KnownRepr TypeRepr tp => - NuMatchingAny1 r => - ImplM (vars :> tp) s r ps1 ps2 a -> - ImplM vars s r ps1 ps2 (a, PermExpr tp) -withExtVarsM = withExtVarsM' knownRepr - --- | Run an implication computation with an additional context of existential --- variables -withExtVarsMultiM :: NuMatchingAny1 r => - CruCtx vars' -> - ImplM (vars :++: vars') s r ps1 ps2 a -> - ImplM vars s r ps1 ps2 a -withExtVarsMultiM CruCtxNil m = m -withExtVarsMultiM (CruCtxCons ctx tp) m = - withExtVarsMultiM ctx (withExtVarsM' tp m >>>= \(a,_) -> return a) - --- | Perform either the first, second, or both computations with an 'implCatchM' --- between, depending on the recursion flag. The 'String' names the function --- that is calling 'implCatchM', while the @p@ argument states what we are --- trying to prove; both of these are used for debug tracing. -implRecFlagCaseM :: NuMatchingAny1 r => PermPretty p => String -> p -> - ImplM vars s r ps_out ps_in a -> - ImplM vars s r ps_out ps_in a -> - ImplM vars s r ps_out ps_in a -implRecFlagCaseM f p m1 m2 = - use implStateRecRecurseFlag >>>= \case - RecLeft -> m1 - RecRight -> m2 - RecNone -> implCatchM f p m1 m2 - --- | Set the recursive permission recursion flag to indicate recursion on the --- right, or fail if we are already recursing on the left -implSetRecRecurseRightM :: NuMatchingAny1 r => ImplM vars s r ps ps () -implSetRecRecurseRightM = - use implStateRecRecurseFlag >>= \case - RecLeft -> implFailM MuUnfoldError - _ -> implStateRecRecurseFlag .= RecRight - --- | Set the recursive recursion flag to indicate recursion on the left, or fail --- if we are already recursing on the right -implSetRecRecurseLeftM :: NuMatchingAny1 r => ImplM vars s r ps ps () -implSetRecRecurseLeftM = - use implStateRecRecurseFlag >>= \case - RecRight -> - implFailM MuUnfoldError - _ -> implStateRecRecurseFlag .= RecLeft - --- | Look up the 'NamedPerm' structure for a named permssion -implLookupNamedPerm :: NamedPermName ns args a -> - ImplM vars s r ps ps (NamedPerm ns args a) -implLookupNamedPerm npn = - (view implStatePermEnv <$> get) >>>= \env -> - case lookupNamedPerm env npn of - Just np -> pure np - Nothing -> error ("Named permission " ++ namedPermNameName npn - ++ " not defined!") - --- | Get the current 'PermSet' -getPerms :: ImplM vars s r ps ps (PermSet ps) -getPerms = use implStatePerms - --- | Look up the current permission for a given variable -getPerm :: ExprVar a -> ImplM vars s r ps ps (ValuePerm a) -getPerm x = use (implStatePerms . varPerm x) - --- | 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) -getDistPerms = use (implStatePerms . distPerms) - --- | Get ghost arguments to represent the current stack at the type level -getDistPermsProxies :: ImplM vars s r ps ps (RAssign Proxy ps) -getDistPermsProxies = rlToProxies <$> getDistPerms - --- | Get the top permission in the stack -getTopDistPerm :: ExprVar a -> ImplM vars s r (ps :> a) (ps :> a) (ValuePerm a) -getTopDistPerm x = use (implStatePerms . topDistPerm x) - --- | Get the top permission in the stack, which is expected to be a conjuction, --- and return its conjuncts. If it is not a conjunction, raise an 'error', using --- the supplied 'String' as the caller in the error message. -getTopDistConj :: HasCallStack => - String -> ExprVar a -> - ImplM vars s r (ps :> a) (ps :> a) [AtomicPerm a] -getTopDistConj caller x = - use (implStatePerms . topDistPerm x) >>>= \case - ValPerm_Conj ps -> return ps - _ -> error (caller ++ ": unexpected non-conjunctive permission") - --- | Get a sequence of the top @N@ permissions on the stack -getTopDistPerms :: prx1 ps1 -> RAssign prx2 ps2 -> - ImplM vars s r (ps1 :++: ps2) (ps1 :++: ps2) (DistPerms ps2) -getTopDistPerms ps1 ps2 = snd <$> RL.split ps1 ps2 <$> getDistPerms - --- | Find all @lowned@ permissions held in in the variable permissions -implFindLOwnedPerms :: ImplM vars s r ps ps [(ExprVar LifetimeType, - ValuePerm LifetimeType)] -implFindLOwnedPerms = - mapMaybe (\case NameAndElem l p@(ValPerm_LOwned _ _ _ _ _) -> Just (l,p) - NameAndElem l p@(ValPerm_LOwnedSimple _ _) -> Just (l,p) - _ -> Nothing) <$> - NameMap.assocs <$> view varPermMap <$> getPerms - --- | Find all lifetimes contained in a lifetime @l@, including itself -containedLifetimes :: ExprVar LifetimeType -> - ImplM vars s r ps ps [ExprVar LifetimeType] -containedLifetimes orig_l = execStateT (helper $ PExpr_Var orig_l) [] where - helper :: PermExpr LifetimeType -> - StateT [ExprVar LifetimeType] (ImplM vars s r ps ps) () - helper PExpr_Always = return () - helper (PExpr_Var l) = - do prevs <- get - if elem l prevs then return () else - put (l : prevs) >> - (lift $ getPerm l) >>= \case - ValPerm_Conj ps -> - forM_ ps $ \case - Perm_LCurrent l' -> helper l' - Perm_LOwned ls _ _ _ _ -> mapM_ helper ls - _ -> return () - _ -> return () - --- | Instantiate the current @implStateUnitVar@ with the given @ExprVar@ of type --- @UnitType@ -setUnitImplM :: Maybe (ExprVar UnitType) -> ImplM vars s r ps ps () -setUnitImplM e = do st <- get - put st{ _implStateUnitVar = e } - -getUnitImplM :: ImplM vars s r ps ps (Maybe (ExprVar UnitType)) -getUnitImplM = do st <- get - return $ _implStateUnitVar st - --- | If the global unit varaible is not yet set, generate a fresh name and set --- it -ensureUnitImplM :: NuMatchingAny1 r => - ImplM vars s r ps ps (ExprVar UnitType) -ensureUnitImplM = - getUnitImplM >>>= \maybe_u -> - case maybe_u of - Nothing -> implIntroUnitVar >>>= \n -> - setUnitImplM (Just n) >>> - pure n - Just u -> pure u - --- | Look up the type of a free variable -implGetVarType :: Name a -> ImplM vars s r ps ps (TypeRepr a) -implGetVarType n = - do varTypes <- use implStateNameTypes - case NameMap.lookup n varTypes of - Just tp -> pure tp - Nothing -> - implTraceM (\i -> pretty "Could not find type for variable:" <+> - permPretty i n) >>> - error "implGetVarType" - --- | Look up the types of a list of free variables -implGetVarTypes :: RAssign Name a -> ImplM vars s r ps ps (CruCtx a) -implGetVarTypes MNil = pure CruCtxNil -implGetVarTypes (xs :>: x) = - CruCtxCons <$> implGetVarTypes xs <*> implGetVarType x - --- | Find the first variable of a specific type -implFindVarOfType :: TypeRepr a -> ImplM vars s r ps ps (Maybe (Name a)) -implFindVarOfType tp = - do varTypes <- use implStateNameTypes - pure (foldr (\(NameAndElem n tp') rest -> - case testEquality tp tp' of - Just Refl -> return n - Nothing -> rest) Nothing - (NameMap.assocs varTypes)) - --- | Remember the types associated with a list of 'Name's, and also ensure those --- names have permissions -implSetNameTypes :: NuMatchingAny1 r => - RAssign Name ctx -> CruCtx ctx -> ImplM vars s r ps ps () -implSetNameTypes MNil _ = pure () -implSetNameTypes (ns :>: n) (CruCtxCons tps tp) = - do implStateNameTypes %= NameMap.insert n tp - implStatePerms %= initVarPerm n - handleUnitVar tp n - implSetNameTypes ns tps - --- | TODO: Move this in to Hobbits -nameMapFind - :: (forall tp. f tp -> Bool) - -> NameMap f - -> Maybe (Some (Product Name f)) -nameMapFind predicate nm = - case find (\(NameAndElem _ f) -> predicate f) $ NameMap.assocs nm of - Just (NameAndElem name f) -> Just $ Some $ Pair name f - Nothing -> Nothing - --- | Traverse a permissions to determine whether it refers to a particular variable. -permContainsVar :: ExprVar a -> ValuePerm b -> Bool -permContainsVar x p = NameSet.member x (freeVars p) - --- | Build a 'DistPerms' sequence of a permission @y1:p1@ we currently hold such --- that @p1@ contains @x@, a permission @y2:p2@ we currently hold such that @p2@ --- contains @p1@, etc. --- --- FIXME: what is the purpose of this? Don't we want all permissions recursively --- containing @x@? -findPermsContainingVar :: ExprVar tp -> ImplM vars s r ps ps (Some DistPerms) -findPermsContainingVar x = - getPerms >>>= \perms -> - case nameMapFind (permContainsVar x) (view varPermMap perms) of - Just (Some (Pair y p)) -> findPermsContainingVar y >>>= \(Some dps) -> - return $ Some $ DistPermsCons dps y p - Nothing -> return $ Some DistPermsNil - --- | When adding a new existential unit-typed variable, instantiate it with the --- underlying global unit if available; if not, update the global unit variable --- with a fresh variable -handleUnitEVar :: forall (a :: CrucibleType) vars s r ps. - NuMatchingAny1 r => - Member vars a -> ImplM vars s r ps ps () --- Note: this only works in ImplM monad, not necessarily in TypedCrucible -handleUnitEVar mem = - use implStateVars >>>= \vars -> - case cruCtxLookup vars mem of - UnitRepr -> -- get the global unit variable - ensureUnitImplM >>>= \u -> - -- add the binding mem |-> u to implStatePSubst - -- will fail if mem already is instantiated in implStatePSubst - modifyPSubst (psubstSet mem (PExpr_Var u)) - _ -> -- non-unit variables - pure () - --- | Call handleUnitEVar on every existential variable in @vars@. Note that this --- will fail if called more than once on overlapping sets of @vars@. -handleUnitEVars :: forall vars s r ps. - NuMatchingAny1 r => - ImplM vars s r ps ps () --- look up current cructx, then call handleUnitEVar for each member proof --- RL.members (CruCtxProxies vars) -handleUnitEVars = - use implStateVars >>>= \vars -> - let mems :: RAssign (Member vars) vars - -- get the memberships of all variables - mems = RL.members (cruCtxProxies vars) - -- call handleUnitEVar on each variable - in RL.foldr handleUnitEVarM (pure ()) mems - where - handleUnitEVarM :: forall (a :: CrucibleType). - Member vars a -> - ImplM vars s r ps ps () -> - ImplM vars s r ps ps () - handleUnitEVarM mem m = handleUnitEVar mem >>> m - --- | When adding a new universal unit-typed variable, unify with the underlying --- global unit if available, and if not, update the global unit variable with --- the variable provided -handleUnitVar :: NuMatchingAny1 r => - TypeRepr a -> ExprVar a -> ImplM vars s r ps ps () -handleUnitVar UnitRepr n = - -- When introducing a new unit-typed variable, check whether we have a global - -- unit variable in the current @ImplState@ - getUnitImplM >>= \u -> case u of - Nothing -> - -- If not, initialize the state with the current variable - setUnitImplM (Just n) - Just x | x == n -> - -- If n is equal to the global unit, do nothing - pure () - Just x -> - -- Otherwise, add a permission @n:eq(x)@, and then pop it off the stack - unitEqM n (PExpr_Var x) >>> - implPopM n (ValPerm_Eq (PExpr_Var x)) >>> - pure () -handleUnitVar _ _ = pure () - --- | Unify the unit variables already added to the state NameMap -handleUnitVars :: forall (tps :: RList CrucibleType) - vars r s ps. - NuMatchingAny1 r => - RAssign Name tps -> - ImplM vars s r ps ps () -handleUnitVars ns = use implStateNameTypes >>>= \nameMap -> - handleUnitVars' nameMap ns - -handleUnitVars' :: forall (tps :: RList CrucibleType) - vars r s ps. - NuMatchingAny1 r => - NameMap TypeRepr -> - RAssign Name tps -> - ImplM vars s r ps ps () -handleUnitVars' _ MNil = pure () -handleUnitVars' nameMap (ns :>: n) = - case NameMap.lookup n nameMap of - Nothing -> error "handleUnitVars: variable not added to nameMap" - Just tp -> handleUnitVar tp n >>> - handleUnitVars' nameMap ns - - ----------------------------------------------------------------------- --- * The Permission Implication Rules as Monadic Operations ----------------------------------------------------------------------- - -type family Fst (p :: (k1,k2)) :: k1 where Fst '(x,_) = x -type family Snd (p :: (k1,k2)) :: k2 where Snd '(_,y) = y - --- | An 'ImplM' continuation for a permission implication rule -newtype Impl1Cont vars s r ps_r a bs_ps = - Impl1Cont (RAssign Name (Fst bs_ps) -> ImplM vars s r ps_r (Snd bs_ps) a) - --- | Apply a permission implication rule, with the given continuations in the --- possible disjunctive branches of the result -implApplyImpl1 :: HasCallStack => NuMatchingAny1 r => PermImpl1 ps_in ps_outs -> - RAssign (Impl1Cont vars s r ps_r a) ps_outs -> - ImplM vars s r ps_r ps_in a -implApplyImpl1 impl1 mb_ms = - use implStatePerms >>>= \perms -> - use implStatePPInfo >>>= \pp_info -> - gmapRet (PermImpl_Step impl1 <$>) >>> - helper (applyImpl1 pp_info impl1 perms) mb_ms - where - helper :: NuMatchingAny1 r => - MbPermSets ps_outs -> - RAssign (Impl1Cont vars s r ps_r a) ps_outs -> - GenStateContT - (ImplState vars ps_r) (PermImpl r ps_r) - (ImplState vars ps_in) (MbPermImpls r ps_outs) - (State (Closed s)) a - helper MbPermSets_Nil _ = gabortM (return MbPermImpls_Nil) - helper (MbPermSets_Cons mbperms ctx mbperm) (args :>: Impl1Cont f) = - gparallel (\m1 m2 -> MbPermImpls_Cons ctx <$> m1 <*> m2) - (helper mbperms args) - (gopenBinding strongMbM mbperm >>>= \(ns, perms') -> - gmodify (set implStatePerms perms' . - over implStatePPInfo (ppInfoAddTypedExprNames ctx ns)) >>> - implSetNameTypes ns ctx >>> - f ns) - --- | Emit debugging output using the current 'PPInfo' if the 'implStateDebugLevel' --- is at least the supplied debug level -implDebugM :: DebugLevel -> (PPInfo -> PP.Doc ann) -> - ImplM vars s r ps ps String -implDebugM reqlvl f = - do dlevel <- use implStateDebugLevel - doc <- uses implStatePPInfo f - let str = renderDoc doc - debugTrace reqlvl dlevel str (return str) - --- | Pretty-print an object using the current pretty-printing info -implPrettyM :: NuMatchingAny1 r => PermPretty p => p -> - ImplM vars s r ps ps (PP.Doc ann) -implPrettyM p = uses implStatePPInfo $ \pp_info -> permPretty pp_info p - --- | Emit debugging output using the current 'PPInfo' if the 'implStateDebugLevel' --- is at least 'traceDebugLevel' -implTraceM :: (PPInfo -> PP.Doc ann) -> ImplM vars s r ps ps String -implTraceM = implDebugM traceDebugLevel - --- | Emit debugging output using the current 'PPInfo' if the 'implStateDebugLevel' --- is at least 'verboseDebugLevel' -implVerbTraceM :: (PPInfo -> PP.Doc ann) -> ImplM vars s r ps ps String -implVerbTraceM = implDebugM verboseDebugLevel - --- | Run an 'ImplM' computation with the debug level set to 'noDebugLevel' -implWithoutTracingM :: ImplM vars s r ps_out ps_in a -> - ImplM vars s r ps_out ps_in a -implWithoutTracingM m = - use implStateDebugLevel >>>= \saved -> - (implStateDebugLevel .= noDebugLevel) >>> - m >>>= \a -> - (implStateDebugLevel .= saved) >> - pure a - --- | Pretty print an implication @x:p -o (vars).p'@ -ppImpl :: PPInfo -> ExprVar tp -> ValuePerm tp -> - Mb (vars :: RList CrucibleType) (ValuePerm tp) -> PP.Doc ann -ppImpl i x p mb_p = - sep [PP.group (permPretty i x <> PP.colon <> PP.align (permPretty i p)), - PP.pretty "-o", - PP.group (PP.align (permPretty i mb_p))] - --- | Produce a branching proof tree that performs the first implication and, if --- that one fails, falls back on the second. The supplied 'String' says what --- proof-search function is performing the catch, while the @p@ argument says --- what we are trying to prove; both of these are for debugging purposes, and --- are used in the debug trace. -implCatchM :: NuMatchingAny1 r => PermPretty p => String -> p -> - ImplM vars s r ps1 ps2 a -> ImplM vars s r ps1 ps2 a -> - ImplM vars s r ps1 ps2 a -implCatchM f p m1 m2 = - implTraceM (\i -> pretty ("Catch in " ++ f ++ " for proving:") - <> line <> permPretty i p) >>>= \catch_str -> - implApplyImpl1 - (Impl1_Catch catch_str) - (MNil - :>: Impl1Cont (const $ - implTraceM (\i -> pretty ("Case 1 of catch in " ++ f - ++ " for proving:") - <> line <> permPretty i p) >>> - m1) - :>: Impl1Cont (const $ - implTraceM (\i -> pretty ("Case 2 of catch in " ++ f - ++ " for proving:") - <> line <> permPretty i p) >>> - m2)) - --- | \"Push\" all of the permissions in the permission set for a variable, which --- should be equal to the supplied permission, after deleting those permissions --- from the input permission set. This is like a simple \"proof\" of @x:p@. -implPushM :: HasCallStack => NuMatchingAny1 r => ExprVar a -> ValuePerm a -> - ImplM vars s r (ps :> a) ps () -implPushM x p = - implVerbTraceM (\i -> - sep [pretty "implPushM" <+> - permPretty i x <> colon <> permPretty i p]) >>> - implApplyImpl1 (Impl1_Push x p) (MNil :>: Impl1Cont (const $ pure ())) - --- | Call 'implPushM' for multiple @x:p@ permissions -implPushMultiM :: HasCallStack => NuMatchingAny1 r => - DistPerms ps -> ImplM vars s r ps RNil () -implPushMultiM DistPermsNil = pure () -implPushMultiM (DistPermsCons ps x p) = - implPushMultiM ps >>> implPushM x p - --- | For each permission @x:p@ in a list of permissions, either prove @x:eq(x)@ --- by reflexivity if @p=eq(x)@ or push @x:p@ if @x@ has permissions @p@ -implPushOrReflMultiM :: HasCallStack => NuMatchingAny1 r => DistPerms ps -> - ImplM vars s r ps RNil () -implPushOrReflMultiM DistPermsNil = pure () -implPushOrReflMultiM (DistPermsCons ps x (ValPerm_Eq (PExpr_Var x'))) - | x == x' = implPushOrReflMultiM ps >>> introEqReflM x -implPushOrReflMultiM (DistPermsCons ps x p) = - implPushOrReflMultiM ps >>> implPushM x p - --- | Pop a permission from the top of the stack back to the primary permission --- for a variable, assuming that the primary permission for that variable is --- empty, i.e., is the @true@ permission -implPopM :: HasCallStack => NuMatchingAny1 r => ExprVar a -> ValuePerm a -> - ImplM vars s r ps (ps :> a) () -implPopM x p = - implVerbTraceM (\i -> - sep [pretty "implPopM" <+> - permPretty i x <> colon <> permPretty i p]) >>> - implApplyImpl1 (Impl1_Pop x p) (MNil :>: Impl1Cont (const $ pure ())) - --- | Pattern-match a permission as a sequence of 1 or more disjuncts -matchOrList :: ValuePerm a -> Maybe (Some (OrList ps a)) -matchOrList p_top@(ValPerm_Or _ _) = Just (helper MNil p_top) where - helper :: OrList ps a disjs -> ValuePerm a -> Some (OrList ps a) - helper or_list (ValPerm_Or p1 p2) = - helper (or_list :>: OrListDisj p1) p2 - helper or_list p = Some (or_list :>: OrListDisj p) -matchOrList _ = Nothing - --- | Eliminate a right-nested disjunction @x:(p1 \/ (p2 \/ (... \/ pn)))@, --- building proof trees that proceed with all the @pi@ -implElimOrsM :: NuMatchingAny1 r => ExprVar a -> ValuePerm a -> - ImplM vars s r (ps :> a) (ps :> a) () -implElimOrsM x p@(matchOrList -> Just (Some or_list)) = - implTraceM (\pp_info -> pretty "Eliminating or:" <+> - permPretty pp_info (ColonPair x p)) >>>= \xp_pp -> - implApplyImpl1 (Impl1_ElimOrs xp_pp x or_list) - (RL.map (\(OrListDisj _) -> Impl1Cont (const $ pure ())) or_list) -implElimOrsM _ _ = error "implElimOrsM: malformed input permission" - --- | Eliminate an existential permission @x:(exists (y:tp).p)@ in the current --- permission set -implElimExistsM :: (NuMatchingAny1 r, KnownRepr TypeRepr tp) => - ExprVar a -> Binding tp (ValuePerm a) -> - ImplM vars s r (ps :> a) (ps :> a) () -implElimExistsM x p = - implApplyImpl1 (Impl1_ElimExists x p) - (MNil :>: Impl1Cont (const $ pure ())) - --- | Eliminate a false permission in the current permission set -implElimFalseM :: NuMatchingAny1 r => ExprVar a -> - ImplM vars s r ps_any (ps :> a) () -implElimFalseM x = - implApplyImpl1 (Impl1_ElimFalse x) MNil - --- | Apply a simple implication rule to the top permissions on the stack -implSimplM :: HasCallStack => NuMatchingAny1 r => Proxy ps -> - SimplImpl ps_in ps_out -> - ImplM vars s r (ps :++: ps_out) (ps :++: ps_in) () -implSimplM prx simpl = - implApplyImpl1 (Impl1_Simpl simpl prx) - (MNil :>: Impl1Cont (const $ pure ())) - --- | Bind a new variable @x@ that is set to the supplied expression @e@ and has --- permissions @eq(e)@, returning @x@ -implLetBindVar :: NuMatchingAny1 r => TypeRepr tp -> PermExpr tp -> - ImplM vars s r ps ps (Name tp) --- NOTE: we explicitly do *not* want to re-use an existing variable, for the --- case where we need distinct bound variables, i.e., for proveVarsImplVarEVars --- --- implLetBindVar _ (PExpr_Var x) = greturn x -implLetBindVar tp e = - implApplyImpl1 (Impl1_LetBind tp e) - (MNil :>: Impl1Cont (\(_ :>: n) -> pure n)) >>>= \n -> - recombinePerm n (ValPerm_Eq e) >>> - pure n - --- | Bind a sequence of variables with 'implLetBindVar' -implLetBindVars :: NuMatchingAny1 r => CruCtx tps -> PermExprs tps -> - ImplM vars s r ps ps (RAssign ExprVar tps) -implLetBindVars CruCtxNil MNil = pure MNil -implLetBindVars (CruCtxCons tps tp) (es :>: e) = - (:>:) <$> implLetBindVars tps es <*> implLetBindVar tp e - --- | Introduce a new univerally-quantified variable @x@ of unit type. --- --- ps -o x. ps -implIntroUnitVar :: NuMatchingAny1 r => - ImplM vars s r ps ps (Name UnitType) -implIntroUnitVar = - -- Note that unlike @implLetbindVar@, this function does *not* bind @x@ to a - -- value @e@. Instead, we have almost the same operations as 'implLetBindVar' - -- but instead of calling 'recombinePerm', we instead call - -- 'implLetBindVarDropEq', which drops the residual equality permission - let e = PExpr_Unit in - implApplyImpl1 (Impl1_LetBind UnitRepr e) - (MNil :>: Impl1Cont (\(_ :>: n) -> pure n)) >>>= \n -> - -- Drop the n:eq(unit) permission - implDropM n (ValPerm_Eq e) >>> - pure n - - --- | Freshen up a sequence of names by replacing any duplicate names in the list --- with fresh, let-bound variables -implFreshenNames :: NuMatchingAny1 r => RAssign ExprVar tps -> - ImplM vars s r ps ps (RAssign ExprVar tps) -implFreshenNames ns = - fmap fst $ rlMapMWithAccum - (\prevs n -> - if NameSet.member n prevs then - (implGetVarType n >>>= \tp -> implLetBindVar tp (PExpr_Var n) >>>= \n' -> - return (n', prevs)) - else return (n, NameSet.insert n prevs)) - NameSet.empty ns - --- | Project out a field of a struct @x@ by binding a fresh variable @y@ for its --- contents, and assign the permissions for that field to @y@, replacing them --- with a proof that the field equals @y@, popping the permissions for @y@ and --- returning the variable @y@. If the given struct field already has permissions --- @eq(y)@ for some @y@, just return that @y@. -implElimStructField :: - NuMatchingAny1 r => ExprVar (StructType ctx) -> - RAssign ValuePerm (CtxToRList ctx) -> Member (CtxToRList ctx) a -> - ImplM vars s r (ps :> StructType ctx) (ps :> StructType ctx) (ExprVar a) -implElimStructField _ ps memb - | ValPerm_Eq (PExpr_Var y) <- RL.get memb ps = pure y -implElimStructField x ps memb = - implGetVarType x >>>= \(StructRepr tps) -> - let tp = RL.get memb (assignToRList tps) in - implApplyImpl1 (Impl1_ElimStructField x ps tp memb) - (MNil :>: Impl1Cont (\(_ :>: n) -> pure n)) >>>= \y -> - recombinePerm y (RL.get memb ps) >>> - pure y - --- | Apply 'implElimStructField' to a sequence of fields in a struct permission, --- to get out a sequence of variables for the corrsponding fields of that struct -implElimStructFields :: - NuMatchingAny1 r => ExprVar (StructType ctx) -> - RAssign ValuePerm (CtxToRList ctx) -> RAssign (Member (CtxToRList ctx)) fs -> - ImplM vars s r (ps :> StructType ctx) (ps :> StructType ctx) (RAssign ExprVar fs) -implElimStructFields _ _ MNil = pure MNil -implElimStructFields x ps (membs :>: memb) = - implElimStructField x ps memb >>>= \y -> - implElimStructFields x (RL.set memb (ValPerm_Eq $ - PExpr_Var y) ps) membs >>>= \ys -> - pure (ys :>: y) - --- | Apply 'implElimStructField' to all fields in a struct permission, to get --- out a sequence of variables for the fields of that struct -implElimStructAllFields :: - NuMatchingAny1 r => ExprVar (StructType ctx) -> - RAssign ValuePerm (CtxToRList ctx) -> - ImplM vars s r (ps :> StructType ctx) (ps :> StructType ctx) - (RAssign Name (CtxToRList ctx)) -implElimStructAllFields x ps = implElimStructFields x ps (RL.members ps) - --- | Prove a struct permission @struct(p1,...,pn)@ from a struct permission --- (described by the second argument) where some subset of the field permissions --- are equality permissions to variables along with proofs that the variables --- have the required permissions -implIntroStructFields :: - NuMatchingAny1 r => ExprVar (StructType ctx) -> - RAssign ValuePerm (CtxToRList ctx) -> RAssign (Member (CtxToRList ctx)) fs -> - ImplM vars s r (ps :> StructType ctx) (ps :++: fs :> StructType ctx) () -implIntroStructFields _ _ MNil = pure () -implIntroStructFields x ps (membs :>: memb) - | ValPerm_Eq (PExpr_Var y) <- RL.get memb ps = - (distPermsHeadPerm <$> distPermsSnoc <$> getDistPerms) >>>= \y_p -> - implSwapM y y_p x (ValPerm_Conj1 $ Perm_Struct ps) >>> - implSimplM Proxy (SImpl_IntroStructField x ps memb y_p) >>> - implIntroStructFields x (RL.set memb y_p ps) membs -implIntroStructFields _ _ _ = - error "implIntroStructFields: malformed input permission" - --- | Prove a struct permission @struct(p1,...,pn)@ from a struct permission --- @struct(eq(y1),...,eq(yn))@ on top of the stack of equality permissions to --- variables along with proofs below it on the stack that each variable @yi@ has --- the corresponding permission @pi@ -implIntroStructAllFields :: - NuMatchingAny1 r => ExprVar (StructType ctx) -> - ImplM vars s r (ps :> StructType ctx) (ps :++: CtxToRList ctx - :> StructType ctx) () -implIntroStructAllFields x = - getTopDistPerm x >>>= \case - (ValPerm_Conj1 (Perm_Struct ps)) -> - implIntroStructFields x ps (RL.members ps) - _ -> error "implIntroStructAllFields: malformed input permission" - --- | Eliminate a permission @x:ptr((rw,off) |-> p)@ into permissions --- @x:ptr((rw,off) |-> eq(y))@ and @y:p@ for a fresh variable @y@, returning the --- fresh variable @y@ and popping the @y@ permissions off the stack. If @p@ --- already has the form @eq(y)@, then just return @y@. -implElimLLVMFieldContentsM :: - (NuMatchingAny1 r, 1 <= w, KnownNat w, 1 <= sz, KnownNat sz) => - ExprVar (LLVMPointerType w) -> LLVMFieldPerm w sz -> - ImplM vars s r (ps :> LLVMPointerType w) (ps :> LLVMPointerType w) - (ExprVar (LLVMPointerType sz)) -implElimLLVMFieldContentsM _ fp - | ValPerm_Eq (PExpr_Var y) <- llvmFieldContents fp - = pure y -implElimLLVMFieldContentsM x fp = - implApplyImpl1 (Impl1_ElimLLVMFieldContents x fp) - (MNil :>: Impl1Cont (\(_ :>: n) -> pure n)) >>>= \y -> - recombinePerm y (llvmFieldContents fp) >>> - pure y - --- | Prove a reachability permission @x:P@ from a proof of @x:eq(e)@ on --- the top of the stack -implReachabilityReflM :: - NuMatchingAny1 r => - ExprVar a -> NamedPermName (RecursiveSort b 'True) args a -> - PermExprs args -> PermOffset a -> - ImplM vars s r (ps :> a) (ps :> a) () -implReachabilityReflM x npn all_args off - | NameReachConstr <- namedPermNameReachConstr npn - , PExprs_Cons args e <- all_args = - implLookupNamedPerm npn >>>= \np -> - case unfoldPerm np (PExprs_Cons args e) off of - ValPerm_Or p1 p2 - | p1 == ValPerm_Eq e -> - introOrLM x p1 p2 >>> - implFoldNamedM x npn (PExprs_Cons args e) off - _ -> error "implReachabilityReflM: unexpected form of unfolded permission" - --- | Prove a reachability permission @x:P@ from proofs of --- @x:P@ and @y:P@ on the top of the stack -implReachabilityTransM :: - NuMatchingAny1 r => - ExprVar a -> NamedPermName (RecursiveSort b 'True) args a -> - PermExprs args -> PermOffset a -> ExprVar a -> - ImplM vars s r (ps :> a) (ps :> a :> a) () -implReachabilityTransM x npn all_args off y - | NameReachConstr <- namedPermNameReachConstr npn - , PExprs_Cons args e <- all_args = - implLookupNamedPerm npn >>>= \(NamedPerm_Rec rp) -> - implSimplM Proxy (SImpl_ReachabilityTrans x rp args off y e) - --- | Eliminate a @memblock@ permission with arbitrary shape @sh@, which cannot --- have any free variables outside of pointer shapes, to have equality shape --- @eqsh(y)@ for a variable @y@, assuming that permission is on the top of the --- stack, and return the variable @y@. If @sh@ is already of this form, just --- return the variable without doing any elimination. -implElimLLVMBlockToEq :: - (NuMatchingAny1 r, 1 <= w, KnownNat w) => ExprVar (LLVMPointerType w) -> - LLVMBlockPerm w -> - ImplM vars s r (ps :> LLVMPointerType w) (ps :> LLVMPointerType w) - (ExprVar (LLVMBlockType w)) -implElimLLVMBlockToEq _ (LLVMBlockPerm - { llvmBlockShape = PExpr_EqShape _ (PExpr_Var y)}) = - pure y -implElimLLVMBlockToEq x bp = - implApplyImpl1 (Impl1_ElimLLVMBlockToEq x bp) - (MNil :>: Impl1Cont (\(_ :>: n) -> pure n)) >>>= \y -> - recombinePerm y (ValPerm_Conj1 $ Perm_LLVMBlockShape $ modalizeBlockShape bp) >>> - pure y - --- | Try to prove a proposition about bitvectors dynamically, failing as in --- 'implFailM if the proposition does not hold -implTryProveBVProp :: (1 <= w, KnownNat w, NuMatchingAny1 r) => - ExprVar (LLVMPointerType w) -> BVProp w -> - ImplM vars s r (ps :> LLVMPointerType w) ps () -implTryProveBVProp x p = - use implStatePPInfo >>>= \i -> - let str = renderDoc (permPretty i p) in - implApplyImpl1 (Impl1_TryProveBVProp x p str) - (MNil :>: Impl1Cont (const $ pure ())) - --- | Try to prove a sequence of propositions using 'implTryProveBVProp' -implTryProveBVProps :: (1 <= w, KnownNat w, NuMatchingAny1 r) => - ExprVar (LLVMPointerType w) -> [BVProp w] -> - ImplM vars s r (ps :> LLVMPointerType w) ps () -implTryProveBVProps x [] = introConjM x -implTryProveBVProps x (prop:props) = - implTryProveBVProp x prop >>> - implTryProveBVProps x props >>> - implInsertConjM x (Perm_BVProp prop) (map Perm_BVProp props) 0 - --- | Drop a permission from the top of the stack -implDropM :: HasCallStack => NuMatchingAny1 r => ExprVar a -> ValuePerm a -> - ImplM vars s r ps (ps :> a) () -implDropM x p = implSimplM Proxy (SImpl_Drop x p) - --- | Drop zero or more permissions from the top of the stack -implDropMultiM :: HasCallStack => NuMatchingAny1 r => DistPerms ps' -> - ImplM vars s r ps (ps :++: ps') () -implDropMultiM MNil = return () -implDropMultiM (ps :>: VarAndPerm x p) = implDropM x p >>> implDropMultiM ps - --- | Copy a permission on the top of the stack, assuming it is copyable -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 :: 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 -- NOTE: must be implPopM and - -- not recombinePerm - --- | Swap the top two permissions on the top of the stack -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) - --- | Move permission @p@ that is on the stack below two lists @ps1@ and @ps2@ --- towards the top of the stack by moving it between @ps1@ and @ps2@. That is, --- change the stack --- --- > perms, p, p1_1, ..., p1_n, p2_1, ..., p2_m --- --- to --- --- > perms, p1_1, ..., p1_n, p, p2_1, ..., p2_m -implMoveUpM :: - NuMatchingAny1 r => - prx ps -> RAssign f ps1 -> ExprVar a -> RAssign f ps2 -> - ImplM vars s r (ps :++: ps1 :> a :++: ps2) (ps :> a :++: ps1 :++: ps2) () -implMoveUpM (ps :: prx ps) ps1 (x :: ExprVar a) ps2 = - -- FIXME: this is gross! Find a better way to do all this! - getDistPerms >>>= \perms -> - let (perms0x, perms12) = - splitDistPerms (Proxy :: Proxy (ps :> a)) (RL.append ps1 ps2) perms - (perms1, perms2) = splitDistPerms ps1 ps2 perms12 in - case (perms0x, RL.appendRNilConsEq ps x (RL.append ps1 ps2)) of - (DistPermsCons _perms0 x' p, Refl) - | Just Refl <- testEquality x x' -> - implSimplM (Proxy :: Proxy ps) (SImpl_MoveUp perms1 x p perms2) - (DistPermsCons _ _x' _, _) -> error "implMoveUpM: unexpected variable" - -reflU :: () :~: () -reflU = Refl - --- | Same as 'implMoveUpM' except the type lists are associated differently -implMoveUpM' :: - NuMatchingAny1 r => - prx ps -> RAssign f ps1 -> ExprVar a -> RAssign f ps2 -> - ImplM vars s r ((ps :++: ps1) :++: (RNil :> a :++: ps2)) - ((ps :> a :++: ps1) :++: ps2) () -implMoveUpM' (ps :: prx ps) (ps1 :: RAssign f ps1) (x :: ExprVar a) - (ps2 :: RAssign f ps2) - -- FIXME: build these proofs instead of just coercing them - | Refl <- unsafeCoerce reflU :: - ((ps :++: ps1) :++: (RNil :> a :++: ps2)) :~: (ps :++: ps1 :> a :++: ps2) - , Refl <- (unsafeCoerce reflU) :: - ((ps :> a :++: ps1) :++: ps2) :~: (ps :> a :++: ps1 :++: ps2) = - implMoveUpM ps ps1 x ps2 - --- | Move permission @p@ that is on the stack between two lists @ps1@ and @ps2@ --- towards the bottom of the stack by moving it below both @ps1@ and @ps2@. That --- is, change the stack --- --- > perms, p1_1, ..., p1_n, p, p2_1, ..., p2_m --- --- to --- --- > perms, p, p1_1, ..., p1_n, p2_1, ..., p2_m -implMoveDownM :: - NuMatchingAny1 r => - prx ps -> RAssign f (ps1 :> a) -> ExprVar a -> RAssign f ps2 -> - ImplM vars s r (ps :> a :++: ps1 :++: ps2) (ps :++: ps1 :> a :++: ps2) () -implMoveDownM (ps :: prx ps) ps1x (x :: ExprVar a) ps2 = - -- FIXME: this is gross! Find a better way to do all this! - getDistPerms >>>= \perms -> - let (_, perms1x2) = splitDistPerms ps (RL.append ps1x ps2) perms - (perms1x, perms2) = splitDistPerms ps1x ps2 perms1x2 in - case (perms1x, RL.appendRNilConsEq ps (RL.head ps1x) (RL.append - (RL.tail ps1x) ps2)) of - (DistPermsCons perms1 x' p, Refl) - | Just Refl <- testEquality x x' -> - implSimplM (Proxy :: Proxy ps) (SImpl_MoveDown perms1 x p perms2) - _ -> error "implMoveDownM: unexpected variable" - --- | Same as 'implMoveDownM' except the type lists are associated differently -implMoveDownM' :: - NuMatchingAny1 r => - prx ps -> RAssign f (ps1 :> a) -> ExprVar a -> RAssign f ps2 -> - ImplM vars s r ((ps :> a :++: ps1) :++: ps2) - ((ps :++: ps1) :++: (RNil :> a :++: ps2)) () -implMoveDownM' (ps :: prx ps) (ps1x :: RAssign f (ps1 :> a)) (x :: ExprVar a) - (ps2 :: RAssign f ps2) - -- FIXME: build these proofs instead of just coercing them - | Refl <- unsafeCoerce reflU :: - ((ps :> a :++: ps1) :++: ps2) :~: (ps :> a :++: ps1 :++: ps2) - , Refl <- unsafeCoerce reflU :: - ((ps :++: ps1) :++: (RNil :> a :++: ps2)) :~: (ps :++: ps1 :> a :++: ps2) - = implMoveDownM ps ps1x x ps2 - --- | Eliminate disjunctives and existentials on the top of the stack and return --- the resulting permission -elimOrsExistsM :: NuMatchingAny1 r => ExprVar a -> - ImplM vars s r (ps :> a) (ps :> a) (ValuePerm a) -elimOrsExistsM x = - getTopDistPerm x >>= \case - p@(ValPerm_Or _ _) -> implElimOrsM x p >>> elimOrsExistsM x - ValPerm_Exists mb_p -> - implElimExistsM x mb_p >>> elimOrsExistsM x - p -> pure p - --- | Eliminate disjunctives, existentials, recusive permissions, and --- defined permissions on the top of the stack -elimOrsExistsNamesM :: NuMatchingAny1 r => ExprVar a -> - ImplM vars s r (ps :> a) (ps :> a) (ValuePerm a) -elimOrsExistsNamesM x = - getTopDistPerm x >>= \case - p@(ValPerm_Or _ _) -> implElimOrsM x p >>> elimOrsExistsNamesM x - ValPerm_Exists mb_p -> - implElimExistsM x mb_p >>> elimOrsExistsNamesM x - ValPerm_Named npn args off - | TrueRepr <- nameCanFoldRepr npn -> - implUnfoldNamedM x npn args off >>> elimOrsExistsNamesM x - ValPerm_Named npn args off - | TrueRepr <- nameIsConjRepr npn -> - implNamedToConjM x npn args off >>> getTopDistPerm x - p -> pure p - --- | Eliminate any disjunctions, existentials, recursive permissions, or defined --- permissions for a variable and then return the resulting \"simple\" permission -getSimpleVarPerm :: NuMatchingAny1 r => ExprVar a -> - ImplM vars s r ps ps (ValuePerm a) -getSimpleVarPerm x = - getPerm x >>= \p_init -> - implPushM x p_init >>> - elimOrsExistsNamesM x >>>= \p -> - implPopM x p >>> pure p - --- | Eliminate any disjunctions, existentials, recursive permissions, or defined --- permissions for a variable to try to get an equality permission --- @eq(e)@. Return @e@ if this is successful. -getVarEqPerm :: NuMatchingAny1 r => ExprVar a -> - ImplM vars s r ps ps (Maybe (PermExpr a)) -getVarEqPerm x = - getPerm x >>= \p_init -> - implPushM x p_init >>> - elimOrsExistsNamesM x >>>= - \case - p@(ValPerm_Eq e) -> implPopM x p >>> pure (Just e) - ValPerm_Conj [Perm_Struct ps] -> - implElimStructAllFields x ps >>>= \ys -> - implSimplM Proxy (SImpl_StructPermToEq x $ namesToExprs ys) >>> - implPopM x (ValPerm_Eq $ PExpr_Struct $ namesToExprs ys) >>> - pure (Just $ PExpr_Struct $ namesToExprs ys) - p -> implPopM x p >>> pure Nothing - --- | Eliminate any disjunctions, existentials, recursive permissions, or defined --- permissions for any variables in the supplied expression and substitute any --- equality permissions for those variables. Also eta-expand any struct --- variables to a struct of variables using 'implElimStructAllFields'. -getEqualsExpr :: NuMatchingAny1 r => PermExpr a -> - ImplM vars s r ps ps (PermExpr a) -getEqualsExpr e@(PExpr_Var x) = - getVarEqPerm x >>= \case Just e' -> getEqualsExpr e' - Nothing -> pure e -getEqualsExpr (PExpr_BV factors off) = - foldr bvAdd (PExpr_BV [] off) <$> - mapM (\(BVFactor (BV.BV i) x) -> - bvMult i <$> getEqualsExpr (PExpr_Var x)) factors -getEqualsExpr (PExpr_LLVMWord e) = - PExpr_LLVMWord <$> getEqualsExpr e -getEqualsExpr (PExpr_LLVMOffset x off) = - addLLVMOffset <$> getEqualsExpr (PExpr_Var x) <*> getEqualsExpr off -getEqualsExpr e = pure e - - --- | Introduce a proof of @x:eq(x)@ onto the top of the stack -introEqReflM :: NuMatchingAny1 r => ExprVar a -> ImplM vars s r (ps :> a) ps () -introEqReflM x = implSimplM Proxy (SImpl_IntroEqRefl x) - --- | Invert a proof of @x:eq(y)@ on the top of the stack to one of @y:eq(x)@ -invertEqM :: NuMatchingAny1 r => ExprVar a -> ExprVar a -> - ImplM vars s r (ps :> a) (ps :> a) () -invertEqM x y = implSimplM Proxy (SImpl_InvertEq x y) - --- | Prove @x:eq(y)@ by proving equality permissions for both @x@ and @y@ to the --- same expression, thereby implementing a form of transitivity of equality --- where the second equality is inversted: -invTransEqM :: NuMatchingAny1 r => ExprVar a -> ExprVar a -> PermExpr a -> - ImplM vars s r (ps :> a) (ps :> a :> a) () -invTransEqM x y e = implSimplM Proxy (SImpl_InvTransEq x y e) - - --- | For a unit variable @x@ and a unit-typed epxression @e@, prove @x:eq(e)@ -unitEqM :: NuMatchingAny1 r => ExprVar UnitType -> PermExpr UnitType -> - ImplM vars s r (ps :> UnitType) ps () -unitEqM x e = implSimplM Proxy (SImpl_UnitEq x e) - - --- | Copy an @x:eq(e)@ permission on the top of the stack -introEqCopyM :: NuMatchingAny1 r => ExprVar a -> PermExpr a -> - ImplM vars s r (ps :> a :> a) (ps :> a) () -introEqCopyM x e = implSimplM Proxy (SImpl_CopyEq x e) - --- | Cast an @eq(llvmword(y))@ proof to an @eq(llvmword(e))@ proof using a --- proof of @y:eq(e)@ -llvmWordEqM :: (1 <= w, KnownNat w, NuMatchingAny1 r) => - ExprVar (LLVMPointerType w) -> - ExprVar (BVType w) -> PermExpr (BVType w) -> - ImplM vars s r (ps :> LLVMPointerType w) - (ps :> LLVMPointerType w :> BVType w) () -llvmWordEqM x y e = implSimplM Proxy (SImpl_LLVMWordEq x y e) - --- | Cast a @y:p@ perm on the top of the stack to an @x:p@ perm using an --- @x:eq(y)@ just below it on the stack -introCastM :: NuMatchingAny1 r => ExprVar a -> ExprVar a -> ValuePerm a -> - ImplM vars s r (ps :> a) (ps :> a :> a) () -introCastM x y p = implSimplM Proxy (SImpl_Cast x y p) - --- | Prove a sequence of equality permissions @x1:eq(e1),...,xn:eq(en)@, where --- each is proved either by reflexivity, if it is of the form @x:eq(x)@, or by --- copying an equality permission already held by the variable in quesiton, if --- it is not. It is an error if any of the supplied perms are not equality --- perms, or if any @xi@ does not have permission @eq(ei)@ in the current --- permission set for @ei@ not equal to @xi@. -implProveEqPerms :: NuMatchingAny1 r => HasCallStack => DistPerms ps' -> - ImplM vars s r (ps :++: (RNil :> a :++: ps')) (ps :> a) () -implProveEqPerms DistPermsNil = pure () -implProveEqPerms (DistPermsCons ps' x (ValPerm_Eq (PExpr_Var y))) - | x == y - = implProveEqPerms ps' >>> introEqReflM x -implProveEqPerms (DistPermsCons ps' x (ValPerm_Eq (PExpr_LLVMOffset y off))) - | x == y, bvMatchConstInt off == Just 0 - = implProveEqPerms ps' >>> implSimplM Proxy (SImpl_LLVMOffsetZeroEq x) -implProveEqPerms (DistPermsCons ps' x p@(ValPerm_Eq _)) = - implProveEqPerms ps' >>> implPushCopyM x p -implProveEqPerms _ = error "implProveEqPerms: non-equality permission" - --- | Cast a proof of @x:p@ to one of @x:p'@ using a proof that @p=p'@ -implCastPermM :: HasCallStack => NuMatchingAny1 r => - Proxy ps -> ExprVar a -> SomeEqProof (ValuePerm a) -> - ImplM vars s r (ps :> a) (ps :> a) () -implCastPermM ps x some_eqp - | UnSomeEqProof eqp <- unSomeEqProof some_eqp - , Refl <- RL.appendAssoc ps (MNil :>: eqProofLHS eqp) (eqProofPerms eqp) = - implProveEqPerms (eqProofPerms eqp) >>> - implSimplM ps (SImpl_CastPerm x eqp) >>> - implDropMultiM (eqProofPerms eqp) - -distPermsProxy :: DistPerms ps -> Proxy ps -distPermsProxy _ = Proxy - --- | Cast a permission somewhere in the stack using an equality proof -implCastStackElemM :: HasCallStack => NuMatchingAny1 r => Member ps a -> - EqProof ps' (ValuePerm a) -> - ImplM vars s r (ps :++: ps') (ps :++: ps') () -implCastStackElemM memb eqp = - let ps' = eqProofPerms eqp in - getDistPerms >>>= \all_perms -> - let ps = fst $ RL.split Proxy ps' all_perms in - case RL.memberSplitAt ps memb of - RL.SplitAtMemberRet ps0 px@(VarAndPerm x _) ps1 -> - implMoveUpM' ps0 ps1 x ps' >>> - implSimplM (distPermsProxy $ RL.append ps0 ps1) (SImpl_CastPerm x eqp) >>> - implMoveDownM' ps0 (ps1 :>: px) x ps' - --- | Cast all of the permissions on the stack using 'implCastPermM' -implCastStackM :: HasCallStack => NuMatchingAny1 r => - EqProof ps' (ValuePerms ps) -> - ImplM vars s r ps (ps :++: ps') () -implCastStackM eqp = - RL.foldr (\memb m -> - implCastStackElemM memb (fmap (RL.get memb) eqp) >>> m) - (implDropMultiM (eqProofPerms eqp)) - (RL.members $ eqProofLHS eqp) - --- | Introduce a proof of @x:true@ onto the top of the stack, which is the same --- as an empty conjunction -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 :: 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 :: 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 :: 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 :: 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 :: 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 >>> - implSwapM x (ValPerm_Conj $ take i ps) x (ValPerm_Conj $ drop i ps) - --- | Copy the @i@th atomic permission in the conjunct on the top of the stack, --- 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 :: 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 :: 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 :: 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 - implCopyConjM x ps i >>> - implPopM x (ValPerm_Conj ps) - else - implExtractConjM x ps i >>> - implPopM x (ValPerm_Conj $ deleteNth i ps) - --- | 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 :: 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 :: 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) - --- | 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 :: HasCallStack => NuMatchingAny1 r => ExprVar a -> - AtomicPerm a -> [AtomicPerm a] -> Int -> - ImplM vars s r (ps :> a) (ps :> a :> a) () -implSwapInsertConjM x p ps i = - implSwapM x (ValPerm_Conj ps) x (ValPerm_Conj1 p) >>> - implInsertConjM x p ps i - --- | Apply the left or-introduction rule to the top of the permission stack, --- changing it from @x:p1@ to @x:(p1 \/ p2)@ -introOrLM :: NuMatchingAny1 r => ExprVar a -> ValuePerm a -> ValuePerm a -> - ImplM vars s r (ps :> a) (ps :> a) () -introOrLM x p1 p2 = implSimplM Proxy (SImpl_IntroOrL x p1 p2) - --- | Apply the right or-introduction rule to the top of the permission stack, --- changing it from @x:p2@ to @x:(p1 \/ p2)@ -introOrRM :: NuMatchingAny1 r => ExprVar a -> ValuePerm a -> ValuePerm a -> - ImplM vars s r (ps :> a) (ps :> a) () -introOrRM x p1 p2 = implSimplM Proxy (SImpl_IntroOrR x p1 p2) - --- | Apply existential introduction to the top of the permission stack, changing --- it from @[e/x]p@ to @exists (x:tp).p@ --- --- FIXME: is there some way we could \"type-check\" this, to ensure that the --- permission on the top of the stack really equals @[e/x]p@? -introExistsM :: (KnownRepr TypeRepr tp, NuMatchingAny1 r) => - ExprVar a -> PermExpr tp -> Binding tp (ValuePerm a) -> - ImplM vars s r (ps :> a) (ps :> a) () -introExistsM x e p_body = implSimplM Proxy (SImpl_IntroExists x e p_body) - --- | Cast a proof of @x:eq(LLVMWord(e1))@ to @x:eq(LLVMWord(e2))@ on the top of --- the stack -castLLVMWordEqM :: - (1 <= w, KnownNat w, NuMatchingAny1 r) => - ExprVar (LLVMPointerType w) -> PermExpr (BVType w) -> PermExpr (BVType w) -> - ImplM vars s r (ps :> LLVMPointerType w) (ps :> LLVMPointerType w) () -castLLVMWordEqM x e1 e2 = - implTryProveBVProp x (BVProp_Eq e1 e2) >>> - implSimplM Proxy (SImpl_CastLLVMWord x e1 e2) - --- | Cast a @y:p@ on the top of the stack to @x:(p - off)@ using a --- proof of @x:eq(y+off)@ just below it on the stack -castLLVMPtrM :: (1 <= w, KnownNat w, NuMatchingAny1 r) => - ExprVar (LLVMPointerType w) -> - ValuePerm (LLVMPointerType w) -> PermExpr (BVType w) -> - ExprVar (LLVMPointerType w) -> - ImplM vars s r (ps :> LLVMPointerType w) - (ps :> LLVMPointerType w :> LLVMPointerType w) () -castLLVMPtrM y p off x = implSimplM Proxy (SImpl_CastLLVMPtr y p off x) - --- | Cast a @y:eq(word(e))@ on the top of the stack to @x:eq(word(e+off))@ using --- a proof of @x:eq(y+off)@ just below it on the stack -offsetLLVMWordM :: (1 <= w, KnownNat w, NuMatchingAny1 r) => - ExprVar (LLVMPointerType w) -> - PermExpr (BVType w) -> PermExpr (BVType w) -> - ExprVar (LLVMPointerType w) -> - ImplM vars s r (ps :> LLVMPointerType w) - (ps :> LLVMPointerType w :> LLVMPointerType w) () -offsetLLVMWordM y e off x = implSimplM Proxy (SImpl_OffsetLLVMWord y e off x) - --- | Cast a proof of @x:free(e1)@ on the top of the stack to one of @x:free(e2)@ --- by first proving that @e1=e2@ -castLLVMFreeM :: (1 <= w, KnownNat w, NuMatchingAny1 r) => - ExprVar (LLVMPointerType w) -> - PermExpr (BVType w) -> PermExpr (BVType w) -> - ImplM vars s r (ps :> LLVMPointerType w) - (ps :> LLVMPointerType w) () -castLLVMFreeM x e1 e2 = - implTryProveBVProp x (BVProp_Eq e1 e2) >>> - implSimplM Proxy (SImpl_CastLLVMFree x e1 e2) - --- | Fold a named permission (other than an opaque permission) -implFoldNamedM :: (NameSortCanFold ns ~ 'True, NuMatchingAny1 r) => ExprVar a -> - NamedPermName ns args a -> PermExprs args -> PermOffset a -> - ImplM vars s r (ps :> a) (ps :> a) () -implFoldNamedM x npn args off = - do np <- implLookupNamedPerm npn - implSimplM Proxy (SImpl_FoldNamed x np args off) - --- | Unfold a named permission (other than an opaque permission), returning the --- unfolding -implUnfoldNamedM :: (NameSortCanFold ns ~ 'True, NuMatchingAny1 r) => - ExprVar a -> NamedPermName ns args a -> - PermExprs args -> PermOffset a -> - ImplM vars s r (ps :> a) (ps :> a) (ValuePerm a) -implUnfoldNamedM x npn args off = - do np <- implLookupNamedPerm npn - implSimplM Proxy (SImpl_UnfoldNamed x np args off) - pure (unfoldPerm np args off) - --- | Map a named permission that is conjoinable to a conjunction -implNamedToConjM :: (NameSortIsConj ns ~ 'True, NuMatchingAny1 r) => - ExprVar a -> NamedPermName ns args a -> - PermExprs args -> PermOffset a -> - ImplM vars s r (ps :> a) (ps :> a) () -implNamedToConjM x npn args off = - implSimplM Proxy (SImpl_NamedToConj x npn args off) - --- | Map a conjuctive named permission to a named permission -implNamedFromConjM :: (NameSortIsConj ns ~ 'True, NuMatchingAny1 r) => - ExprVar a -> NamedPermName ns args a -> PermExprs args -> - PermOffset a -> ImplM vars s r (ps :> a) (ps :> a) () -implNamedFromConjM x npn args off = - implSimplM Proxy (SImpl_NamedFromConj x npn args off) - --- | Begin a fresh lifetime, returning the lifetime that was created and popping --- its @lowned@ permission off of the stack -implBeginLifetimeM :: NuMatchingAny1 r => - ImplM vars s r ps ps (ExprVar LifetimeType) -implBeginLifetimeM = - implApplyImpl1 Impl1_BeginLifetime - (MNil :>: Impl1Cont (\(_ :>: n) -> pure n)) >>>= \l -> - recombinePerm l (ValPerm_LOwned [] CruCtxNil CruCtxNil MNil MNil) >>> - implTraceM (\i -> pretty "Beginning lifetime:" <+> permPretty i l) >>> - pure l - --- | End a lifetime, assuming the top of the stack is of the form --- --- > ps, ps_in, l:lowned(ps_in -o ps_out) --- --- Remove @l@ from any other @lowned@ permissions held by other variables. --- Recombine all the returned permissions @ps_out@ and @l:lfinished@ returned by --- ending @l@, leaving just @ps@ on the stack. -implEndLifetimeM :: NuMatchingAny1 r => Proxy ps -> ExprVar LifetimeType -> - CruCtx ps_in -> CruCtx ps_out -> - ExprPerms ps_in -> ExprPerms ps_out -> - ImplM vars s r ps (ps :++: ps_in :> LifetimeType) () -implEndLifetimeM ps l tps_in tps_out ps_in ps_out - | Just dps_out <- exprPermsToDistPerms ps_out - , isJust (exprPermsToDistPerms ps_in) = - implSimplM ps (SImpl_EndLifetime l tps_in tps_out ps_in ps_out) >>> - implTraceM (\i -> pretty "Ending lifetime:" <+> permPretty i l) >>> - implDropLifetimePermsM l >>> - recombinePermsPartial ps (DistPermsCons dps_out l ValPerm_LFinished) -implEndLifetimeM _ _ _ _ _ _ = implFailM (LifetimeError EndLifetimeError) - --- | Drop any permissions of the form @x:[l]p@ in the primary permissions for --- @x@, which are supplied as an argument -implDropLifetimeConjsM :: NuMatchingAny1 r => ExprVar LifetimeType -> - ExprVar a -> [AtomicPerm a] -> - ImplM vars s r ps ps () -implDropLifetimeConjsM l x ps - | Just i <- findIndex (\p -> atomicPermLifetime p == Just (PExpr_Var l)) ps = - implPushM x (ValPerm_Conj ps) >>> - implExtractSwapConjM x ps i >>> - implDropM x (ValPerm_Conj1 (ps!!i)) >>> - let ps' = deleteNth i ps in - recombinePerm x (ValPerm_Conj ps') >>> - implDropLifetimeConjsM l x ps' -implDropLifetimeConjsM _ _ _ = return () - --- | Find all primary permissions of the form @x:[l]p@ and drop them, assuming --- that we have just ended lifetime @l@ -implDropLifetimePermsM :: NuMatchingAny1 r => ExprVar LifetimeType -> - ImplM vars s r ps ps () -implDropLifetimePermsM l = - (NameMap.assocs <$> view varPermMap <$> getPerms) >>>= \vars_and_perms -> - forM_ vars_and_perms $ \case - NameAndElem x (ValPerm_Conj ps) -> - implDropLifetimeConjsM l x ps - _ -> return () - --- | Save a permission for later by splitting it into part that is in the --- current lifetime and part that is saved in the lifetime for later. Assume --- permissions --- --- > x:F * l:[l2]lcurrent * l2:lowned ps --- --- are on the top of the stack, and return @x:F@ on top of the stack, --- popping the new @lowned@ permission on @l2@ -implSplitLifetimeM :: (KnownRepr TypeRepr a, NuMatchingAny1 r) => - ExprVar a -> LifetimeFunctor args a -> - PermExprs args -> PermExpr LifetimeType -> - ExprVar LifetimeType -> [PermExpr LifetimeType] -> - CruCtx ps_in -> CruCtx ps_out -> - ExprPerms ps_in -> ExprPerms ps_out -> - ImplM vars s r (ps :> a) - (ps :> a :> LifetimeType :> LifetimeType) () -implSplitLifetimeM x f args l l2 sub_ls tps_in tps_out ps_in ps_out = - implTraceM (\i -> - sep [pretty "Splitting lifetime to" <+> permPretty i l2 <> colon, - permPretty i x <> colon <> - permPretty i (ltFuncMinApply f l)]) >>> - implSimplM Proxy (SImpl_SplitLifetime x f args l l2 - sub_ls tps_in tps_out ps_in ps_out) >>> - getTopDistPerm l2 >>>= recombinePerm l2 - - --- | Subsume a smaller lifetime @l2@ inside a bigger lifetime @l1@, by adding --- @l2@ to the lifetimes contained in the @lowned@ permission for @l@. Assume --- the top of the stack is @l1:lowned[ls] (ps_in1 -o ps_out1)@, and replace that --- permission with @l1:lowned[l2,ls] (ps_in1 -o ps_out1)@. -implSubsumeLifetimeM :: NuMatchingAny1 r => ExprVar LifetimeType -> - [PermExpr LifetimeType] -> - CruCtx ps_in -> CruCtx ps_out -> - ExprPerms ps_in -> ExprPerms ps_out -> - PermExpr LifetimeType -> - ImplM vars s r (ps :> LifetimeType) - (ps :> LifetimeType) () -implSubsumeLifetimeM l ls tps_in tps_out ps_in ps_out l2 = - implSimplM Proxy (SImpl_SubsumeLifetime l ls tps_in tps_out ps_in ps_out l2) - - --- | Prove a lifetime @l@ is current during a lifetime @l2@ it contains, --- assuming the permission --- --- > l1:lowned[ls1,l2,ls2] (ps_in -o ps_out) --- --- is on top of the stack, and replacing it with @l1:[l2]lcurrent@. -implContainedLifetimeCurrentM :: NuMatchingAny1 r => ExprVar LifetimeType -> - [PermExpr LifetimeType] -> - CruCtx ps_in -> CruCtx ps_out -> - ExprPerms ps_in -> ExprPerms ps_out -> - PermExpr LifetimeType -> - ImplM vars s r (ps :> LifetimeType) - (ps :> LifetimeType) () -implContainedLifetimeCurrentM l ls tps_in tps_out ps_in ps_out l2 = - implSimplM Proxy (SImpl_ContainedLifetimeCurrent - l ls tps_in tps_out ps_in ps_out l2) >>> - recombinePerm l (ValPerm_LOwned ls tps_in tps_out ps_in ps_out) - - --- | Remove a finshed contained lifetime from an @lowned@ permission. Assume the --- permissions --- --- > l1:lowned[ls] (ps_in -o ps_out) * l2:lfinished --- --- are on top of the stack where @l2@ is in @ls@, and remove @l2@ from the --- contained lifetimes @ls@ of @l1@, popping the resulting @lowned@ permission --- on @l1@ off of the stack. -implRemoveContainedLifetimeM :: NuMatchingAny1 r => ExprVar LifetimeType -> - [PermExpr LifetimeType] -> - CruCtx ps_in -> CruCtx ps_out -> - ExprPerms ps_in -> ExprPerms ps_out -> - ExprVar LifetimeType -> - ImplM vars s r ps - (ps :> LifetimeType :> LifetimeType) () -implRemoveContainedLifetimeM l ls tps_in tps_out ps_in ps_out l2 = - implSimplM Proxy (SImpl_RemoveContainedLifetime - l ls tps_in tps_out ps_in ps_out l2) >>> - recombinePerm l (ValPerm_LOwned (delete (PExpr_Var l2) ls) - tps_in tps_out ps_in ps_out) - --- | Find all equality permissions @eq(e)@ contained in a permission we --- currently hold on @x@, and return all of the free variables of @e@ along with --- their contained eq vars -getContainedEqVars :: ExprVar a -> ImplM vars s r ps ps (NameSet CrucibleType) -getContainedEqVars x = getContainedEqVarsExcept (NameSet.singleton x) x - --- | Find all equality permissions @eq(e)@ contained in a permission we --- currently hold on @x@, and return all of the free variables of @e@ not in the --- supplied set, along with their contained eq vars -getContainedEqVarsExcept :: NameSet CrucibleType -> ExprVar a -> - ImplM vars s r ps ps (NameSet CrucibleType) -getContainedEqVarsExcept excl x = - getPerm x >>>= \p -> - let p_eq_vars = containedEqVars p - new_excl = NameSet.union excl p_eq_vars - new_vars = NameSet.difference p_eq_vars excl in - NameSet.unions <$> (new_vars :) <$> - mapM (\(NameSet.SomeName y) -> - getContainedEqVarsExcept new_excl y) (NameSet.toList new_vars) - --- | Find all lifetimes that we currently own which could, if ended, help prove --- the specified permissions, and return them with their @lowned@ permissions, --- in a topological order, where child lifetimes come before their parents. -lifetimesThatCouldProve :: NuMatchingAny1 r => Mb vars (DistPerms ps') -> - ImplM vars s r ps ps [ExprVar LifetimeType] -lifetimesThatCouldProve mb_ps = - do varTypes <- use implStateVars - -- Cast all lowneds we currently hold using any equality perms we hold - (unzip -> (ls, ps)) <- implFindLOwnedPerms - ps' <- substEqs ps - let ls_ps' = zip ls ps' - -- Convert mb_ps to ExprPerms so we can cast them as well; DistPerms can't - -- be cast because casting substitutes expressions for variables, and - -- DistPerms are pairs of a variable with a permission - mb_ps' <- - give (cruCtxProxies varTypes) $ - substEqs (mbDistPermsToExprPerms mb_ps) - -- For all permissions x:p in mb_ps that we need to prove, find all the - -- variables y such that an eq(e) permission with y in the free variables - -- of e is contained in a permission we currently hold on x - containedVars <- - NameSet.unions <$> - mapM (\(NameSet.SomeName n) -> - getContainedEqVars n) (mbExprPermsVarsList mb_ps') - -- Make sure we don't end any lifetimes that we still need in mb_ps - let needed_ls = lownedsInMbExprPerms mb_ps' - -- Find any lifetime in ps' not in needed_ls that could prove a permission - -- we need in mb_ps' - return $ map fst $ sortLOwnedPerms $ flip mapMaybe ls_ps' $ \case - (l, p@(ValPerm_LOwned _ _ _ _ ps_out)) - | notElem l needed_ls - , lownedPermsCouldProve varTypes ps_out mb_ps' || - not (NameSet.null $ - NameSet.intersection containedVars $ - exprPermsVarsSet ps_out) -> - Just (l,p) - (l, p@(ValPerm_LOwnedSimple _ ps_out)) - | notElem l needed_ls - , lownedPermsCouldProve varTypes ps_out mb_ps' || - not (NameSet.null $ - NameSet.intersection containedVars $ - exprPermsVarsSet ps_out) -> Just (l,p) - _ -> Nothing - --- | Combine proofs of @x:ptr(pps,(off,spl) |-> eq(y))@ and @y:p@ on the top of --- the permission stack into a proof of @x:ptr(pps,(off,spl |-> p))@ -introLLVMFieldContentsM :: - (1 <= w, KnownNat w, 1 <= sz, KnownNat sz, NuMatchingAny1 r) => - ExprVar (LLVMPointerType w) -> ExprVar (LLVMPointerType sz) -> - LLVMFieldPerm w sz -> - ImplM vars s r (ps :> LLVMPointerType w) (ps :> LLVMPointerType w :> - LLVMPointerType sz) () -introLLVMFieldContentsM x y fp = - implSimplM Proxy (SImpl_IntroLLVMFieldContents x y fp) - --- | Coerce the contents of a field permission on top of the stack to @true@ -implLLVMFieldSetTrue :: - (NuMatchingAny1 r, 1 <= w, KnownNat w, 1 <= sz, KnownNat sz) => - ExprVar (LLVMPointerType w) -> LLVMFieldPerm w sz -> - ImplM vars s r (ps :> LLVMPointerType w) (ps :> LLVMPointerType w) () -implLLVMFieldSetTrue x fp = - implElimLLVMFieldContentsM x fp >>>= \y -> - introConjM y >>> - let fp_true = llvmFieldSetTrue fp fp in - introLLVMFieldContentsM x y fp_true - --- | Start with a pointer permission on top of the stack and try to coerce it to --- a pointer permission whose contents are of the form @(eq(llvmword(e)))@. If --- successful, return @e@, otherwise coerce to a field with @true@ contents and --- return 'Nothing'. -implLLVMFieldTryProveWordEq :: - (NuMatchingAny1 r, 1 <= w, KnownNat w, 1 <= sz, KnownNat sz) => - ExprVar (LLVMPointerType w) -> LLVMFieldPerm w sz -> - ImplM vars s r (ps :> LLVMPointerType w) (ps :> LLVMPointerType w) - (Maybe (PermExpr (BVType sz))) -implLLVMFieldTryProveWordEq x fp = - implElimLLVMFieldContentsM x fp >>>= \y -> getPerm y >>>= \p -> - implPushM y p >>> implMaybeCopyPopM y p >>> elimOrsExistsNamesM y >>>= \case - ValPerm_Eq e -> - substEqsWithProof e >>>= \eqp -> - case someEqProofRHS eqp of - PExpr_LLVMWord e' -> - implCastPermM Proxy y (fmap ValPerm_Eq eqp) >>> - let fp' = llvmFieldSetEqWord fp e' in - introLLVMFieldContentsM x y fp' >>> - return (Just e') - _ -> - implDropM y p >>> implLLVMFieldSetTrue x (llvmFieldSetEqVar fp y) >>> - return Nothing - p' -> - implDropM y p' >>> implLLVMFieldSetTrue x (llvmFieldSetEqVar fp y) >>> - return Nothing - --- | Like 'implLLVMFieldTryeProveWordEq' but for two field permissions in the --- top two slots on the stack -implLLVMFieldTryProveWordEq2 :: - (NuMatchingAny1 r, 1 <= w, KnownNat w, 1 <= sz1, KnownNat sz1, - 1 <= sz2, KnownNat sz2) => - ExprVar (LLVMPointerType w) -> LLVMFieldPerm w sz1 -> LLVMFieldPerm w sz2 -> - ImplM vars s r (ps :> LLVMPointerType w :> LLVMPointerType w) - (ps :> LLVMPointerType w :> LLVMPointerType w) - (Maybe (PermExpr (BVType sz1), PermExpr (BVType sz2))) -implLLVMFieldTryProveWordEq2 x fp1 fp2 = - implLLVMFieldTryProveWordEq x fp2 >>>= \case - Nothing -> - let fp2_true = llvmFieldSetTrue fp2 fp2 in - implSwapM x (ValPerm_LLVMField fp1) x (ValPerm_LLVMField fp2_true) >>> - implLLVMFieldSetTrue x fp1 >>> - let fp1_true = llvmFieldSetTrue fp1 fp1 in - implSwapM x (ValPerm_LLVMField fp2_true) x (ValPerm_LLVMField fp1_true) >>> - return Nothing - Just e2 -> - let fp2' = llvmFieldSetEqWord fp2 e2 in - implSwapM x (ValPerm_LLVMField fp1) x (ValPerm_LLVMField fp2') >>> - implLLVMFieldTryProveWordEq x fp1 >>>= \case - Nothing -> - let fp1_true = llvmFieldSetTrue fp1 fp1 in - implSwapM x (ValPerm_LLVMField fp2') x (ValPerm_LLVMField fp1_true) >>> - implLLVMFieldSetTrue x fp2' >>> - return Nothing - Just e1 -> - let fp1' = llvmFieldSetEqWord fp1 e1 in - implSwapM x (ValPerm_LLVMField fp2') x (ValPerm_LLVMField fp1') >>> - return (Just (e1, e2)) - --- | Attempt to split a pointer permission @ptr((rw,off,sz) |-> p)@ on top of --- the stack into two permissions of the form @ptr((rw,off,8*len) |-> p1)@ and --- @ptr((rw,off+len,sz-(8*len)) |-> p2)@, that is, into one field of size @len@ --- bytes and one field of the remaining size. If @p@ can be coerced to an --- equality permission @eq(llvmword(bv))@ for a known constant bitvector @bv@, --- then @p1@ and @p2@ are equalities to the split of @bv@ into known smaller --- bitvectors, and otherwise they are both @true@. -implLLVMFieldSplit :: - (NuMatchingAny1 r, 1 <= w, KnownNat w, 1 <= sz, KnownNat sz) => - ExprVar (LLVMPointerType w) -> LLVMFieldPerm w sz -> Integer -> - ImplM vars s r (ps :> LLVMPointerType w :> LLVMPointerType w) - (ps :> LLVMPointerType w) - (AtomicPerm (LLVMPointerType w), AtomicPerm (LLVMPointerType w)) -implLLVMFieldSplit x fp sz_bytes - | Just (Some sz) <- someNat (sz_bytes * 8) - , Just fp_m_sz <- subNat' (llvmFieldSize fp) sz - , Left LeqProof <- decideLeq sz (llvmFieldSize fp) - , Left LeqProof <- decideLeq (knownNat @1) sz - , Left LeqProof <- decideLeq (knownNat @1) fp_m_sz = - withKnownNat sz $ withKnownNat fp_m_sz $ - use implStateEndianness >>>= \endianness -> - implLLVMFieldTryProveWordEq x fp >>>= \case - Just e -> - implApplyImpl1 - (Impl1_SplitLLVMWordField x (llvmFieldSetEqWord fp e) sz endianness) - (MNil :>: Impl1Cont (const $ return ())) >>> - getDistPerms >>>= - \case - (_ :>: VarAndPerm _ (ValPerm_Conj1 p1) :>: - VarAndPerm _ (ValPerm_Conj1 p2) :>: - VarAndPerm y p_y :>: VarAndPerm z p_z) -> - recombinePerm z p_z >>> recombinePerm y p_y >>> return (p1,p2) - _ -> error "implLLVMFieldSplit: unexpected permission stack" - Nothing -> - implSimplM Proxy (SImpl_SplitLLVMTrueField x - (llvmFieldSetTrue fp fp) sz fp_m_sz) >>> - return (Perm_LLVMField (llvmFieldSetTrue fp sz), - Perm_LLVMField (llvmFieldAddOffsetInt - (llvmFieldSetTrue fp fp_m_sz) - sz_bytes)) -implLLVMFieldSplit _ _ _ = - error "implLLVMFieldSplit: malformed input permissions" - --- | Attempt to truncate a pointer permission @ptr((rw,off,sz) |-> p)@ on top of --- the stack into a permission of the form @ptr((rw,off,sz') |-> p')@ for @sz'@ --- smaller than @sz@. If @p@ can be coerced to an equality permission --- @eq(llvmword(bv))@ for a known constant bitvector @bv@, then @p'@ is an --- equality to the truncation of @bv@. If @p@ can be coerced to an equality --- permission @eq(llvmword(e))@ to some non-constant @e@, @p'@ is an equality to --- a fresh bitvector variable. Otherwise @p'@ is just @true@. -implLLVMFieldTruncate :: - (NuMatchingAny1 r, 1 <= w, KnownNat w, 1 <= sz, KnownNat sz) => - ExprVar (LLVMPointerType w) -> LLVMFieldPerm w sz -> NatRepr sz' -> - ImplM vars s r (ps :> LLVMPointerType w) - (ps :> LLVMPointerType w) - (AtomicPerm (LLVMPointerType w)) -implLLVMFieldTruncate x fp sz' - | Left LeqProof <- decideLeq sz' (llvmFieldSize fp) - , Left LeqProof <- decideLeq (knownNat @1) sz' = - withKnownNat sz' $ - use implStateEndianness >>>= \endianness -> - implLLVMFieldTryProveWordEq x fp >>>= \case - Just e -> - implApplyImpl1 - (Impl1_TruncateLLVMWordField x (llvmFieldSetEqWord fp e) sz' endianness) - (MNil :>: Impl1Cont (const $ return ())) >>> - getDistPerms >>>= - \case - (_ :>: VarAndPerm _ (ValPerm_Conj1 p) :>: VarAndPerm y p_y) -> - recombinePerm y p_y >>> return p - _ -> error "implLLVMFieldTruncate: unexpected permission stack" - Nothing -> - implSimplM Proxy (SImpl_TruncateLLVMTrueField x - (llvmFieldSetTrue fp fp) sz') >>> - return (Perm_LLVMField (llvmFieldSetTrue fp sz')) -implLLVMFieldTruncate _ _ _ = - error "implLLVMFieldTruncate: malformed input permissions" - --- | Concatentate two pointer permissions @ptr((rw,off,sz1) |-> p1)@ and --- @ptr((rw,off+sz1/8,sz2) |-> p2)@ into a single pointer permission of the form --- @ptr((rw,off,sz1+sz2) |-> p)@. If @p1@ and @p2@ are both equality permissions --- @eq(llvmword(bv))@ for known constant bitvectors, then the output contents --- permission @p@ is an equality to the concatenated of these bitvectors. If --- @p1@ and @p2@ are both equality permissions to bitvector expressions (at --- least one of which is non-constant), then @p@ is an equality to a fresh --- variable. Otherwise @p@ is just @true@. -implLLVMFieldConcat :: - (NuMatchingAny1 r, 1 <= w, KnownNat w, 1 <= sz1, KnownNat sz1, - 1 <= sz2, KnownNat sz2) => - ExprVar (LLVMPointerType w) -> LLVMFieldPerm w sz1 -> LLVMFieldPerm w sz2 -> - ImplM vars s r (ps :> LLVMPointerType w) - (ps :> LLVMPointerType w :> LLVMPointerType w) - () -implLLVMFieldConcat x fp1 fp2 - | LeqProof <- leqAddPos fp1 fp2 = - withKnownNat (addNat (natRepr fp1) (natRepr fp2)) $ - use implStateEndianness >>>= \endianness -> - implLLVMFieldTryProveWordEq2 x fp1 fp2 >>>= \case - Just (e1, e2) -> - implApplyImpl1 - (Impl1_ConcatLLVMWordFields x (llvmFieldSetEqWord fp1 e1) e2 endianness) - (MNil :>: Impl1Cont (const $ return ())) >>> - getDistPerms >>>= \(_ :>: VarAndPerm y p_y) -> - recombinePerm y p_y - Nothing -> - implSimplM Proxy (SImpl_ConcatLLVMTrueFields x - (llvmFieldSetTrue fp1 fp1) - (llvmFieldSize fp2)) - --- | 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 '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. -implLLVMArrayCellBorrow :: - (1 <= w, KnownNat w, NuMatchingAny1 r) => - ExprVar (LLVMPointerType w) -> LLVMArrayPerm w -> PermExpr (BVType w) -> - ImplM vars s r (ps :> LLVMPointerType w :> LLVMPointerType w) - (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 'llvmArrayCellInArray') -implLLVMArrayCellCopy :: - (1 <= w, KnownNat w, NuMatchingAny1 r) => - ExprVar (LLVMPointerType w) -> LLVMArrayPerm w -> PermExpr (BVType w) -> - ImplM vars s r (ps :> LLVMPointerType w - :> LLVMPointerType w) (ps :> LLVMPointerType w) () -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 -> 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) () -implLLVMArrayCellReturn x ap cell = - implSimplM Proxy (SImpl_LLVMArrayCellReturn x ap cell) - --- | 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 -> - PermExpr (BVType w) -> PermExpr (BVType w) -> - ImplM vars s r (ps :> LLVMPointerType w :> LLVMPointerType w) - (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 off len) >>> - return (llvmArrayAddBorrow (llvmSubArrayBorrow ap sub_ap) $ - llvmArrayRemArrayBorrows ap sub_ap) - --- | 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 -> - PermExpr (BVType w) -> PermExpr (BVType w) -> - ImplM vars s r (ps :> LLVMPointerType w :> LLVMPointerType w) - (ps :> LLVMPointerType w) () -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 --- the array it was borrowed from is on top of the stack. Return the new array --- permission after the return that is now on the top of the stack. -implLLVMArrayReturn :: - (1 <= w, KnownNat w, NuMatchingAny1 r) => - ExprVar (LLVMPointerType w) -> LLVMArrayPerm w -> LLVMArrayPerm w -> - ImplM vars s r (ps :> LLVMPointerType w) - (ps :> LLVMPointerType w :> LLVMPointerType w) - (LLVMArrayPerm w) -implLLVMArrayReturn x ap ret_ap = - implSimplM Proxy (SImpl_LLVMArrayReturn x ap ret_ap) >>> - pure (llvmArrayRemBorrow (llvmSubArrayBorrow ap ret_ap) $ - llvmArrayAddArrayBorrows ap ret_ap) - --- | 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 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 --- by 'permForLLVMArrayBorrow', is just below it -implLLVMArrayReturnBorrow :: - (1 <= w, KnownNat w, NuMatchingAny1 r) => - ExprVar (LLVMPointerType w) -> LLVMArrayPerm w -> LLVMArrayBorrow w -> - ImplM vars s r (ps :> LLVMPointerType w) (ps :> LLVMPointerType w - :> LLVMPointerType w) () -implLLVMArrayReturnBorrow x ap (FieldBorrow cell) = - implLLVMArrayCellReturn x ap cell -implLLVMArrayReturnBorrow x ap b@(RangeBorrow _) - | ValPerm_Conj1 (Perm_LLVMArray ap_ret) <- permForLLVMArrayBorrow ap b = - implLLVMArrayReturn x ap ap_ret >>> - pure () -implLLVMArrayReturnBorrow _ _ _ = error "implLLVMArrayReturnBorrow" - - --- | Append to array permissions, assuming one ends where the other begins and --- that they have the same stride and fields -implLLVMArrayAppend :: - (1 <= w, KnownNat w, NuMatchingAny1 r) => - ExprVar (LLVMPointerType w) -> LLVMArrayPerm w -> LLVMArrayPerm w -> - ImplM vars s r (ps :> LLVMPointerType w) (ps :> LLVMPointerType w - :> LLVMPointerType w) () -implLLVMArrayAppend x ap1 ap2 = - implSimplM Proxy (SImpl_LLVMArrayAppend x ap1 ap2) - - --- | Rearrange the order of the borrows in the input array permission to match --- the given list, assuming the two have the same elements -implLLVMArrayRearrange :: - (1 <= w, KnownNat w, NuMatchingAny1 r) => - ExprVar (LLVMPointerType w) -> LLVMArrayPerm w -> [LLVMArrayBorrow w] -> - ImplM vars s r (ps :> LLVMPointerType w) (ps :> LLVMPointerType w) () -implLLVMArrayRearrange x ap bs = - implSimplM Proxy (SImpl_LLVMArrayRearrange x ap bs) - --- | Prove an empty array with length 0 -implLLVMArrayEmpty :: - (1 <= w, KnownNat w, NuMatchingAny1 r) => - ExprVar (LLVMPointerType w) -> LLVMArrayPerm w -> - ImplM vars s r (ps :> LLVMPointerType w) ps () -implLLVMArrayEmpty x ap = implSimplM Proxy (SImpl_LLVMArrayEmpty x ap) - --- | Prove an array permission whose borrows cover the array using a permission --- that instantiates at least one of its cells -implLLVMArrayBorrowed :: - (1 <= w, KnownNat w, NuMatchingAny1 r) => - ExprVar (LLVMPointerType w) -> LLVMBlockPerm w -> LLVMArrayPerm w -> - ImplM vars s r (ps :> LLVMPointerType w :> LLVMPointerType w) (ps :> LLVMPointerType w) () -implLLVMArrayBorrowed x blk ap = - implSimplM Proxy (SImpl_LLVMArrayBorrowed x blk ap) - --- | Prove the @memblock@ permission returned by @'llvmAtomicPermToBlock' p@ --- from a proof of @p@ on top of the stack, assuming it returned one -implIntroLLVMBlock :: (1 <= w, KnownNat w, NuMatchingAny1 r) => - ExprVar (LLVMPointerType w) -> - AtomicPerm (LLVMPointerType w) -> - ImplM vars s r (ps :> LLVMPointerType w) - (ps :> LLVMPointerType w) () -implIntroLLVMBlock x (Perm_LLVMField fp) = - implSimplM Proxy (SImpl_IntroLLVMBlockField x fp) -implIntroLLVMBlock x p@(Perm_LLVMArray ap) - | isJust (llvmAtomicPermToBlock p) = - implSimplM Proxy (SImpl_IntroLLVMBlockArray x ap) -implIntroLLVMBlock _ (Perm_LLVMBlock _bp) = pure () -implIntroLLVMBlock _ _ = error "implIntroLLVMBlock: malformed permission" - --- | Prove a @memblock@ permission with a foldable named shape from its --- unfolding, assuming that unfolding is on the top of the stack -implIntroLLVMBlockNamed :: (1 <= w, KnownNat w, NuMatchingAny1 r) => - ExprVar (LLVMPointerType w) -> LLVMBlockPerm w -> - ImplM vars s r (ps :> LLVMPointerType w) - (ps :> LLVMPointerType w) () -implIntroLLVMBlockNamed x bp - | PExpr_NamedShape _ _ nmsh _ <- llvmBlockShape bp - , TrueRepr <- namedShapeCanUnfoldRepr nmsh = - implSimplM Proxy (SImpl_IntroLLVMBlockNamed x bp nmsh) -implIntroLLVMBlockNamed _ _ = - error "implIntroLLVMBlockNamed: malformed permission" - - --- | Eliminate a @memblock@ permission on the top of the stack, if possible, --- otherwise fail. Specifically, this means to perform one step of @memblock@ --- elimination, depening on the shape of the @memblock@ permission. -implElimLLVMBlock :: (1 <= w, KnownNat w, NuMatchingAny1 r) => - ExprVar (LLVMPointerType w) -> LLVMBlockPerm w -> - ImplM vars s r (ps :> LLVMPointerType w) - (ps :> LLVMPointerType w) () - --- Eliminate the empty shape to an array of bytes -implElimLLVMBlock x bp@(LLVMBlockPerm { llvmBlockShape = PExpr_EmptyShape }) = - implSimplM Proxy (SImpl_ElimLLVMBlockToBytes x bp) - --- If the \"natural\" length of the shape of a memblock permission is smaller than --- its actual length, sequence with the empty shape and then eliminate -implElimLLVMBlock x bp - | Just sh_len <- llvmShapeLength $ llvmBlockShape bp - , bvLt sh_len $ llvmBlockLen bp = - implSimplM Proxy (SImpl_IntroLLVMBlockSeqEmpty x bp) >>> - implSimplM Proxy (SImpl_ElimLLVMBlockSeq x bp PExpr_EmptyShape) - --- Eliminate modalities on named shapes -implElimLLVMBlock x bp@(LLVMBlockPerm { llvmBlockShape = - PExpr_NamedShape rw l _ _ }) - | isJust rw || isJust l - = implSimplM Proxy (SImpl_ElimLLVMBlockNamedMods x bp) - --- Unfold defined or recursive named shapes -implElimLLVMBlock x bp@(LLVMBlockPerm { llvmBlockShape = - PExpr_NamedShape rw l nmsh args }) - | TrueRepr <- namedShapeCanUnfoldRepr nmsh - , isJust (unfoldModalizeNamedShape rw l nmsh args) = - (if namedShapeIsRecursive nmsh - then implSetRecRecurseLeftM else pure ()) >>> - implSimplM Proxy (SImpl_ElimLLVMBlockNamed x bp nmsh) - --- For shape eqsh(len,y), prove y:block(sh) for some sh and then apply --- SImpl_IntroLLVMBlockFromEq -implElimLLVMBlock x bp@(LLVMBlockPerm { llvmBlockShape = - PExpr_EqShape len (PExpr_Var y) }) - | bvEq len (llvmBlockLen bp) = - mbVarsM () >>>= \mb_unit -> - withExtVarsM (proveVarImplInt y $ mbCombine RL.typeCtxProxies $ - flip mbConst mb_unit $ - nu $ \sh -> ValPerm_Conj1 $ - Perm_LLVMBlockShape $ PExpr_Var sh) >>>= \(_, sh) -> - let bp' = bp { llvmBlockShape = sh } in - 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 _ _ _ }) - | isJust (llvmBlockPtrShapeUnfold bp) = - implSimplM Proxy (SImpl_ElimLLVMBlockPtr x bp) - --- For a field shape, eliminate to a field permission -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 _ _ _ }) = - --- For a tuple shape, eliminate the tuple -implElimLLVMBlock x bp@(LLVMBlockPerm { llvmBlockShape = PExpr_TupShape sh }) = - implSimplM Proxy (SImpl_ElimLLVMBlockTuple x (bp { llvmBlockShape = sh })) - --- 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 --- to a memblock permission of shape sh1 -implElimLLVMBlock x bp@(LLVMBlockPerm { llvmBlockShape = - PExpr_SeqShape sh PExpr_EmptyShape }) - | Just len <- llvmShapeLength sh - , bvEq len (llvmBlockLen bp) = - implSimplM Proxy (SImpl_ElimLLVMBlockSeqEmpty x - (bp { llvmBlockShape = sh })) - --- Otherwise, for a sequence shape sh1;sh2, eliminate to two memblock --- permissions, of shapes sh1 and sh2 -implElimLLVMBlock x bp@(LLVMBlockPerm { llvmBlockShape = - PExpr_SeqShape sh1 sh2 }) - | isJust $ llvmShapeLength sh1 = - implSimplM Proxy (SImpl_ElimLLVMBlockSeq - x (bp { llvmBlockShape = sh1 }) sh2) - --- For an or shape, eliminate to a disjunctive permisison -implElimLLVMBlock x bp@(LLVMBlockPerm { llvmBlockShape = - PExpr_OrShape sh1 (matchOrShapes -> shs) }) = - implSimplM Proxy (SImpl_ElimLLVMBlockOr x bp (sh1:shs)) - --- For an existential shape, eliminate to an existential permisison -implElimLLVMBlock x bp@(LLVMBlockPerm { llvmBlockShape = - PExpr_ExShape _mb_sh }) = - implSimplM Proxy (SImpl_ElimLLVMBlockEx x bp) - -implElimLLVMBlock x bp@(LLVMBlockPerm { llvmBlockShape = - PExpr_FalseShape }) = - implSimplM Proxy (SImpl_ElimLLVMBlockFalse x bp) - --- If none of the above cases matched, we cannot eliminate, so fail -implElimLLVMBlock _ bp = - use implStatePPInfo >>>= \ppinfo -> - implFailM $ MemBlockError $ permPretty ppinfo (Perm_LLVMBlock bp) - --- | Destruct a shape @sh1 orsh (sh2 orsh (... orsh shn))@ that is a --- right-nested disjunctive shape into the list @[sh1,...,shn]@ of disjuncts -matchOrShapes :: PermExpr (LLVMShapeType w) -> [PermExpr (LLVMShapeType w)] -matchOrShapes (PExpr_OrShape sh1 (matchOrShapes -> shs)) = sh1 : shs -matchOrShapes sh = [sh] - --- | Assume the top of the stack contains @x:ps@, which are all the permissions --- 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 eliminated, --- then fail. -implElimPopIthLLVMBlock :: (1 <= w, KnownNat w, NuMatchingAny1 r) => - ExprVar (LLVMPointerType w) -> - [AtomicPerm (LLVMPointerType w)] -> Int -> - ImplM vars s r ps (ps :> LLVMPointerType w) () -implElimPopIthLLVMBlock x ps i - | Perm_LLVMBlock bp <- ps!!i = - implExtractConjM x ps i >>> recombinePerm x (ValPerm_Conj $ deleteNth i ps) >>> - implElimLLVMBlock x bp >>> getTopDistPerm x >>>= \p' -> recombinePerm x p' -implElimPopIthLLVMBlock _ _ _ = error "implElimPopIthLLVMBlock: malformed inputs" - - --- | Assume the top of the stack contains @x:p1*...*pn@, which are all the --- permissions for @x@. Extract the @i@th conjuct @pi@, which should be a --- @memblock@ permission. Eliminate that @memblock@ permission using --- 'implElimLLVMBlock' if possible to atomic permissions @x:q1*...*qm@, and --- append the resulting atomic permissions @qi@ to the top of the stack, leaving --- --- > x:ps1 * ... * pi-1 * pi+1 * ... * pn * q1 * ... * qm --- --- on top of the stack. Return the list of atomic permissions that are now on --- top of the stack. If the @memblock@ permission @pi@ cannot be elimnated, then --- fail. -implElimAppendIthLLVMBlock :: (1 <= w, KnownNat w, NuMatchingAny1 r) => - ExprVar (LLVMPointerType w) -> - [AtomicPerm (LLVMPointerType w)] -> Int -> - ImplM vars s r (ps :> LLVMPointerType w) - (ps :> LLVMPointerType w) - [AtomicPerm (LLVMPointerType w)] -implElimAppendIthLLVMBlock x ps i - | Perm_LLVMBlock bp <- ps!!i = - implExtractSwapConjM x ps i >>> implElimLLVMBlock x bp >>> - elimOrsExistsM x >>>= \case - (ValPerm_Conj ps') -> - implAppendConjsM x (deleteNth i ps) ps' >>> return (deleteNth i ps ++ ps') - _ -> error ("implElimAppendIthLLVMBlock: unexpected non-conjunctive perm " - ++ "returned by implElimLLVMBlock") -implElimAppendIthLLVMBlock _ _ _ = - error "implElimAppendIthLLVMBlock: malformed inputs" - - --- | Return the indices in a list of permissions for all of those that could be --- used to prove a permission containing the specified offset. Field and block --- permissions can only be used if they definitely (in the sense of --- 'bvPropHolds') contain the offset, while the 'Bool' flag indicates whether --- array permissions are allowed to only possibly contain (in the sense of --- 'bvPropCouldHold') the offset. -permIndicesForProvingOffset :: (1 <= w, KnownNat w) => - [AtomicPerm (LLVMPointerType w)] -> Bool -> - PermExpr (BVType w) -> [Int] --- Special case: if we have an any permission, return just it -permIndicesForProvingOffset ps _ _ - | Just i <- findIndex (== Perm_Any) ps = [i] -permIndicesForProvingOffset ps imprecise_p off = - let ixs_holdss = flip findMaybeIndices ps $ \p -> - case llvmPermContainsOffset off p of - Just (_, holds) | holds || imprecise_p -> Just holds - -- Just _ | llvmPermContainsArray p && imprecise_p -> Just False - _ -> Nothing in - case find (\(_,holds) -> holds) ixs_holdss of - Just (i,_) -> [i] - Nothing -> map fst ixs_holdss - --- | 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 permIndicesForProvingOffset 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 "implGetLLVMPermForOffset" (ColonPair x mb_p)) $ - 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) => - ExprVar (LLVMPointerType w) -> LLVMBlockPerm w -> - [PermExpr (LLVMShapeType w)] -> Int -> - ImplM vars s r (ps :> LLVMPointerType w) - (ps :> LLVMPointerType w) () --- Special case: if we take the or of a single shape, it is that shape itself, --- so we don't need to do anything -implIntroOrShapeMultiM _x _bp [_sh] 0 = return () -implIntroOrShapeMultiM x bp (sh1 : shs) 0 = - let sh2 = foldr1 PExpr_OrShape shs in - introOrLM x - (ValPerm_LLVMBlock $ bp { llvmBlockShape = sh1 }) - (ValPerm_LLVMBlock $ bp { llvmBlockShape = sh2 }) >>> - implSimplM Proxy (SImpl_IntroLLVMBlockOr - x (bp { llvmBlockShape = sh1 }) sh2) -implIntroOrShapeMultiM x bp (sh1 : shs) i = - implIntroOrShapeMultiM x bp shs (i-1) >>> - let sh2 = foldr1 PExpr_OrShape shs in - introOrRM x - (ValPerm_LLVMBlock $ bp { llvmBlockShape = sh1 }) - (ValPerm_LLVMBlock $ bp { llvmBlockShape = sh2 }) >>> - implSimplM Proxy (SImpl_IntroLLVMBlockOr - x (bp { llvmBlockShape = sh1 }) sh2) -implIntroOrShapeMultiM _ _ _ _ = error "implIntroOrShapeMultiM" - - ----------------------------------------------------------------------- --- * Support for Proving Lifetimes Are Current ----------------------------------------------------------------------- - --- | Build a 'LifetimeCurrentPerms' to prove that a lifetime @l@ is current in --- the current permission set, failing if this is not possible -getLifetimeCurrentPerms :: NuMatchingAny1 r => PermExpr LifetimeType -> - ImplM vars s r ps ps (Some LifetimeCurrentPerms) -getLifetimeCurrentPerms PExpr_Always = pure $ Some AlwaysCurrentPerms -getLifetimeCurrentPerms (PExpr_Var l) = - getPerm l >>= \case - ValPerm_LOwned ls tps_in tps_out ps_in ps_out -> - pure $ Some $ LOwnedCurrentPerms l ls tps_in tps_out ps_in ps_out - ValPerm_LOwnedSimple tps ps -> - pure $ Some $ LOwnedSimpleCurrentPerms l tps ps - ValPerm_LCurrent l' -> - getLifetimeCurrentPerms l' >>= \some_cur_perms -> - case some_cur_perms of - Some cur_perms -> pure $ Some $ CurrentTransPerms cur_perms l - _ -> - use implStatePPInfo >>>= \ppinfo -> - implFailM $ LifetimeError (LifetimeCurrentError $ permPretty ppinfo l) - --- | Prove the permissions represented by a 'LifetimeCurrentPerms' -proveLifetimeCurrent :: NuMatchingAny1 r => LifetimeCurrentPerms ps_l -> - ImplM vars s r (ps :++: ps_l) ps () -proveLifetimeCurrent AlwaysCurrentPerms = pure () -proveLifetimeCurrent (LOwnedCurrentPerms l ls tps_in tps_out ps_in ps_out) = - implPushM l (ValPerm_LOwned ls tps_in tps_out ps_in ps_out) -proveLifetimeCurrent (LOwnedSimpleCurrentPerms l tps ps) = - implPushM l (ValPerm_LOwnedSimple tps ps) -proveLifetimeCurrent (CurrentTransPerms cur_perms l) = - proveLifetimeCurrent cur_perms >>> - let l' = lifetimeCurrentPermsLifetime cur_perms - p_l_cur = ValPerm_LCurrent l' in - implPushCopyM l p_l_cur - - ----------------------------------------------------------------------- --- * Recombining Permissions ----------------------------------------------------------------------- - --- | Simplify an equality permission @x:eq(e)@ that we assume is on the top of --- the stack by substituting any equality permissions on variables in @e@, --- returning the resulting expression -simplEqPerm :: HasCallStack => NuMatchingAny1 r => ExprVar a -> PermExpr a -> - ImplM vars s r (as :> a) (as :> a) (PermExpr a) -simplEqPerm x e@(PExpr_Var y) = - getPerm y >>= \case - p@(ValPerm_Eq e') -> implPushCopyM y p >>> introCastM x y p >>> pure e' - _ -> pure e -simplEqPerm x e@(PExpr_LLVMOffset y off) = - getPerm y >>= \case - p@(ValPerm_Eq e') -> - implPushCopyM y p >>> castLLVMPtrM y p off x >>> pure (addLLVMOffset e' off) - _ -> pure e -simplEqPerm _ e = pure e - --- | Recombine the permission @x:p@ on top of the stack back into the existing --- permission for @x@ -recombinePerm :: HasCallStack => NuMatchingAny1 r => ExprVar a -> ValuePerm a -> - ImplM vars s r as (as :> a) () -recombinePerm x p = getPerm x >>>= \x_p -> recombinePermExpl x x_p p - --- | Recombine the permission @x:p@ on top of the stack back into the existing --- permission @x_p@ for @x@, where @x_p@ is given explicitly as the first --- permission argument and @p@ is the second -recombinePermExpl :: HasCallStack => NuMatchingAny1 r => ExprVar a -> ValuePerm a -> - ValuePerm a -> ImplM vars s r as (as :> a) () -recombinePermExpl x x_p p = - implVerbTraceM (\i -> - sep [pretty "recombinePerm" <+> - permPretty i x <> colon <> permPretty i x_p, - pretty "<-" <+> permPretty i p]) >>> - recombinePerm' x x_p p - --- | This is the implementation of 'recombinePermExpl'; see the documentation --- for that function for details -recombinePerm' :: HasCallStack => NuMatchingAny1 r => - ExprVar a -> ValuePerm a -> ValuePerm a -> - ImplM vars s r as (as :> a) () -recombinePerm' x _ p@ValPerm_True = implDropM x p -recombinePerm' x _ ValPerm_False = implElimFalseM x -recombinePerm' x _ p@(ValPerm_Eq (PExpr_Var y)) | y == x = implDropM x p -recombinePerm' x ValPerm_True (ValPerm_Eq e) = - simplEqPerm x e >>>= \e' -> implPopM x (ValPerm_Eq e') -recombinePerm' x x_p (ValPerm_LOwnedSimple tps lops) = - case lownedPermsSimpleIn x lops of - Just ps_simple -> - -- If p is a simple lowned permission, eliminate it - -- FIXME: do we want to do this? If not, we need more subtle rules for proving - -- simple lowned permissions, and probably widening support for it too... - implSimplM Proxy (SImpl_ElimLOwnedSimple x tps lops) >>> - recombinePerm' x x_p (ValPerm_LOwned [] tps tps ps_simple lops) - Nothing -> - error "recombinePerm: cannot compute input permissions for simple lowned permission" -recombinePerm' x ValPerm_True p = implPopM x p -recombinePerm' x (ValPerm_Eq (PExpr_Var y)) _ - | y == x = error "recombinePerm: variable x has permission eq(x)!" -recombinePerm' x (ValPerm_Eq e1) p@(ValPerm_Eq e2) - | e1 == e2 = implDropM x p -recombinePerm' x x_p@(ValPerm_Eq (PExpr_Var y)) p = - implPushCopyM x x_p >>> - invertEqM x y >>> implSwapM x p y (ValPerm_Eq (PExpr_Var x)) >>> - introCastM y x p >>> getPerm y >>>= \y_p -> recombinePermExpl y y_p p -recombinePerm' x x_p@(ValPerm_Eq (PExpr_LLVMOffset y off)) p = - implPushCopyM x x_p >>> - implSimplM Proxy (SImpl_InvertLLVMOffsetEq x off y) >>> - implSwapM x p y (ValPerm_Eq (PExpr_LLVMOffset x (bvNegate off))) >>> - castLLVMPtrM x p (bvNegate off) y >>> - getPerm y >>>= \y_p -> - recombinePermExpl y y_p (offsetLLVMPerm off p) -recombinePerm' x _p p'@(ValPerm_Eq PExpr_Unit) = - -- When trying to combine a permission x:eq(()), just drop this permission - implDropM x p' -recombinePerm' x (ValPerm_Eq e1) (ValPerm_Eq e2) - | exprsUnequal e1 e2 = - implPushM x (ValPerm_Eq e1) >>> - implSimplM Proxy (SImpl_IntroAnyEqEq x e2 e1) >>> - implPopM x ValPerm_Any -recombinePerm' x (ValPerm_Conj ps) (ValPerm_Eq (PExpr_LLVMWord e)) - | Just i <- findIndex isLLVMPointerPerm ps = - implPushM x (ValPerm_Conj ps) >>> implGetConjM x ps i >>>= \ps' -> - implPopM x (ValPerm_Conj ps') >>> - implSimplM Proxy (SImpl_IntroAnyWordPtr x e (ps!!i)) >>> - recombinePerm x ValPerm_Any -recombinePerm' x p p'@(ValPerm_Eq _) = - -- NOTE: we could handle this by swapping the stack with the variable perm and - -- calling recombinePerm again, but this could potentially create permission - -- equality cycles with, e.g., x:eq(y) * y:eq(x). So instead we just drop the - -- new equality permission. - implTraceM (\i -> - pretty "recombinePerm: unexpected equality permission being recombined" <> softline <> - permPretty i x <+> colon <+> permPretty i p <+> - pretty "<-" <+> permPretty i p') >>> - implDropM x p' -recombinePerm' x x_p (ValPerm_Or _ _) = - elimOrsExistsM x >>>= \p' -> recombinePermExpl x x_p p' -recombinePerm' x x_p (ValPerm_Exists _) = - elimOrsExistsM x >>>= \p' -> recombinePermExpl x x_p p' -recombinePerm' x x_p@(ValPerm_Or _ _) p = - implPushM x x_p >>> elimOrsExistsM x >>>= \x_p' -> - implPopM x x_p' >>> recombinePermExpl x x_p' p -recombinePerm' x x_p@(ValPerm_Exists _) p = - implPushM x x_p >>> elimOrsExistsM x >>>= \x_p' -> - implPopM x x_p' >>> recombinePermExpl x x_p' p -recombinePerm' x (ValPerm_Conj x_ps) (ValPerm_Conj (p:ps)) = - implExtractConjM x (p:ps) 0 >>> - implSwapM x (ValPerm_Conj1 p) x (ValPerm_Conj ps) >>> - recombinePermConj x x_ps p >>> - recombinePerm x (ValPerm_Conj ps) -recombinePerm' x x_p (ValPerm_Named npn args off) - -- When recombining a conjuctive named permission, turn it into a conjunction - -- and recombine it - | TrueRepr <- nameIsConjRepr npn = - implNamedToConjM x npn args off >>> - recombinePermExpl x x_p (ValPerm_Conj1 $ Perm_NamedConj npn args off) -recombinePerm' x x_p (ValPerm_Named npn args off) - -- When recombining a non-conjuctive but unfoldable named permission, unfold - -- it and recombine it - | TrueRepr <- nameCanFoldRepr npn = - implUnfoldNamedM x npn args off >>>= \p' -> - recombinePermExpl x x_p p' -recombinePerm' x x_p@(ValPerm_Named npn args off) p - -- When recombining into a conjuctive named permission, turn it into a - -- conjunction and recombine it - | TrueRepr <- nameIsConjRepr npn = - implPushM x x_p >>> implNamedToConjM x npn args off >>> - let x_p' = ValPerm_Conj1 $ Perm_NamedConj npn args off in - implPopM x x_p' >>> recombinePermExpl x x_p' p -recombinePerm' x x_p@(ValPerm_Named npn args off) p - -- When recombining into a non-conjuctive but unfoldable named permission, unfold - -- it and recombine it - | TrueRepr <- nameCanFoldRepr npn = - implPushM x x_p >>> implUnfoldNamedM x npn args off >>>= \x_p' -> - implPopM x x_p' >>> recombinePermExpl x x_p' p -recombinePerm' x _ p = implDropM x p - --- | Recombine a single conjuct @x:p@ on top of the stack back into the existing --- conjuctive permission @x_p1 * ... * x_pn@ for @x@, returning the resulting --- permission conjucts for @x@ -recombinePermConj :: HasCallStack => NuMatchingAny1 r => ExprVar a -> [AtomicPerm a] -> - AtomicPerm a -> ImplM vars s r as (as :> a) () - --- If p is a field permission whose range is a subset of that of a permission we --- already hold, drop it -recombinePermConj x x_ps (Perm_LLVMField fp) - | any (llvmAtomicPermContainsRange $ llvmFieldRange fp) x_ps = - implDropM x $ ValPerm_LLVMField fp - --- FIXME: if p is a field permission whose range overlaps with but is not wholly --- contained in a permission we already hold, split it and recombine parts of it - --- If p is an array read permission whose offsets match an existing array --- permission, drop it -recombinePermConj x x_ps p@(Perm_LLVMArray ap) - | Just _ <- - find (\case Perm_LLVMArray ap' -> - bvEq (llvmArrayOffset ap') (llvmArrayOffset ap) && - bvEq (llvmArrayLen ap') (llvmArrayLen ap) - _ -> False) x_ps - , PExpr_Read <- llvmArrayRW ap = - implDropM x (ValPerm_Conj1 p) - --- If p is an is_llvmptr permission and x_ps already contains one, drop it -recombinePermConj x x_ps p@Perm_IsLLVMPtr - | elem Perm_IsLLVMPtr x_ps = - implDropM x (ValPerm_Conj1 p) - --- NOTE: we do not return a field that was borrowed from an array, 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, which --- make it a stronger permission than the cell permission in the array - --- If p is an array that was borrowed from some other array, return it -recombinePermConj x x_ps (Perm_LLVMArray ap) - | (ap_bigger,i):_ <- - flip mapMaybe (zip x_ps [0::Int ..]) - (\case (Perm_LLVMArray ap', i) - | isJust (llvmArrayIsOffsetArray ap' ap) && - elem (llvmSubArrayBorrow ap' ap) (llvmArrayBorrows ap') && - llvmArrayStride ap' == llvmArrayStride ap && - llvmArrayCellShape ap' == llvmArrayCellShape ap -> - return (ap', i) - _ -> Nothing) = - implPushM x (ValPerm_Conj x_ps) >>> implExtractConjM x x_ps i >>> - let x_ps' = deleteNth i x_ps in - implPopM x (ValPerm_Conj x_ps') >>> - implLLVMArrayReturn x ap_bigger ap >>>= \ap_bigger' -> - recombinePermConj x x_ps' (Perm_LLVMArray ap_bigger') - --- If p is a memblock permission whose range is a subset of that of a permission --- we already hold, drop it -recombinePermConj x x_ps (Perm_LLVMBlock bp) - | any (llvmAtomicPermContainsRange $ llvmBlockRange bp) x_ps = - implDropM x $ ValPerm_LLVMBlock bp - --- If p is a memblock permission whose range overlaps with but is not wholly --- contained in a permission we already hold, eliminate it and recombine --- --- FIXME: if the elimination fails, this shouldn't fail, it should just --- recombine without eliminating, so we should special case those shapes where --- the elimination will fail -{- -recombinePermConj x x_ps (Perm_LLVMBlock bp) - | any (llvmAtomicPermOverlapsRange $ llvmBlockRange bp) x_ps = - implElimLLVMBlock x bp >>> - getTopDistPerm x >>>= \p -> - recombinePerm x p --} - --- If p is a memblock permission on the false shape, eliminate the block to --- a false permission (and eliminate the false permission itself) -recombinePermConj x _ (Perm_LLVMBlock bp) - | PExpr_FalseShape <- llvmBlockShape bp - = implElimLLVMBlock x bp >>> implElimFalseM x - --- Default case: insert p at the end of the x_ps -recombinePermConj x x_ps p = - implPushM x (ValPerm_Conj x_ps) >>> - implInsertConjM x p x_ps (length x_ps) >>> - implPopM x (ValPerm_Conj (x_ps ++ [p])) - - --- | Recombine the permissions on the stack back into the permission set -recombinePerms :: HasCallStack => NuMatchingAny1 r => DistPerms ps -> ImplM vars s r RNil ps () -recombinePerms DistPermsNil = pure () -recombinePerms (DistPermsCons ps' x p) = - recombinePerm x p >>> recombinePerms ps' - --- | Recombine some of the permissions on the stack back into the permission set -recombinePermsPartial :: HasCallStack => NuMatchingAny1 r => f ps -> DistPerms ps' -> - ImplM vars s r ps (ps :++: ps') () -recombinePermsPartial _ DistPermsNil = pure () -recombinePermsPartial ps (DistPermsCons ps' x p) = - recombinePerm x p >>> recombinePermsPartial ps ps' - --- | Recombine some of the permissions on the stack back into the permission --- set, but in reverse order -recombinePermsRevPartial :: HasCallStack => NuMatchingAny1 r => RAssign Proxy ps1 -> DistPerms ps2 -> - ImplM vars s r ps1 (ps1 :++: ps2) () -recombinePermsRevPartial _ DistPermsNil = return () -recombinePermsRevPartial ps1 ps2@(DistPermsCons ps2' x p) = - implMoveDownM ps1 (rlToProxies ps2) x MNil >>> - recombinePermsRevPartial (ps1 :>: Proxy) ps2' >>> - recombinePerm x p - --- | Recombine the permissions on the stack back into the permission set, but in --- reverse order -recombinePermsRev :: HasCallStack => NuMatchingAny1 r => DistPerms ps -> - ImplM vars s r RNil ps () -recombinePermsRev ps - | Refl <- RL.prependRNilEq ps = recombinePermsRevPartial MNil ps - --- | Recombine the permissions for a 'LifetimeCurrentPerms' list -recombineLifetimeCurrentPerms :: HasCallStack => NuMatchingAny1 r => - LifetimeCurrentPerms ps_l -> - ImplM vars s r ps (ps :++: ps_l) () -recombineLifetimeCurrentPerms AlwaysCurrentPerms = pure () -recombineLifetimeCurrentPerms (LOwnedCurrentPerms l ls tps_in tps_out ps_in ps_out) = - recombinePermExpl l ValPerm_True (ValPerm_LOwned ls tps_in tps_out ps_in ps_out) -recombineLifetimeCurrentPerms (LOwnedSimpleCurrentPerms l tps ps) = - recombinePermExpl l ValPerm_True (ValPerm_LOwnedSimple tps ps) -recombineLifetimeCurrentPerms (CurrentTransPerms cur_perms l) = - implDropM l (ValPerm_LCurrent $ lifetimeCurrentPermsLifetime cur_perms) >>> - recombineLifetimeCurrentPerms cur_perms - - ----------------------------------------------------------------------- --- * Proving Equalities ----------------------------------------------------------------------- - --- | Typeclass for the generic function that tries to extend the current partial --- substitution to unify an expression with an expression pattern and returns a --- proof of the equality on success -class ProveEq a where - proveEq :: NuMatchingAny1 r => a -> Mb vars a -> - ImplM vars s r ps ps (SomeEqProof a) - -instance (Eq a, Eq b, ProveEq a, ProveEq b, NuMatching a, NuMatching b, - Substable PermSubst a Identity, - Substable PermSubst b Identity) => ProveEq (a,b) where - proveEq (a,b) mb_ab = - do eqp1 <- proveEq a (mbFst mb_ab) - eqp2 <- proveEq b (mbSnd mb_ab) - pure ((,) <$> eqp1 <*> eqp2) - -instance (Eq a, Eq b, Eq c, ProveEq a, ProveEq b, ProveEq c, - NuMatching a, NuMatching b, NuMatching c, - Substable PermSubst a Identity, - Substable PermSubst b Identity, - Substable PermSubst c Identity) => ProveEq (a,b,c) where - proveEq (a,b,c) mb_abc = - do eqp1 <- proveEq a (mbFst3 mb_abc) - eqp2 <- proveEq b (mbSnd3 mb_abc) - eqp3 <- proveEq c (mbThd3 mb_abc) - pure ((,,) <$> eqp1 <*> eqp2 <*> eqp3) - -instance ProveEq (PermExpr a) where - proveEq e mb_e = - do psubst <- getPSubst - proveEqH psubst e mb_e - -instance ProveEq (LLVMFramePerm w) where - proveEq [] [nuP| [] |] = pure $ SomeEqProofRefl [] - proveEq ((e,i):fperms) [nuP| ((mb_e,mb_i)):mb_fperms |] - | mbLift mb_i == i = - do eqp1 <- proveEq e mb_e - eqp2 <- proveEq fperms mb_fperms - pure (App.liftA2 (\x y -> (x,i):y) eqp1 eqp2) - proveEq perms mb = - use implStatePPInfo >>>= \ppinfo -> - implFailM $ EqualityProofError - (permPretty ppinfo perms) - (permPretty ppinfo mb) - -instance ProveEq (LLVMBlockPerm w) where - proveEq bp mb_bp = - do eqp_rw <- proveEq (llvmBlockRW bp) (mbLLVMBlockRW mb_bp) - eqp_l <- proveEq (llvmBlockLifetime bp) (mbLLVMBlockLifetime mb_bp) - eqp_off <- proveEq (llvmBlockOffset bp) (mbLLVMBlockOffset mb_bp) - eqp_len <- proveEq (llvmBlockLen bp) (mbLLVMBlockLen mb_bp) - eqp_sh <- proveEq (llvmBlockShape bp) (mbLLVMBlockShape mb_bp) - pure (LLVMBlockPerm <$> - eqp_rw <*> eqp_l <*> eqp_off <*> eqp_len <*> eqp_sh) - - --- | Substitute any equality permissions for the variables in an expression, --- returning a proof that the input expression equals the output. Unlike --- 'getEqualsExpr', this does not eliminate any permissions, because it is used --- by 'proveEq' to instantiate existential variables, and we do not want to have --- to eliminate perms just to set @z=e@. --- --- FIXME: maybe 'getEqualsExpr' should also not eliminate permissions? -substEqsWithProof :: (AbstractVars a, FreeVars a, - Substable PermSubst a Identity, NuMatchingAny1 r) => - a -> ImplM vars s r ps ps (SomeEqProof a) -substEqsWithProof a = - do var_ps <- use (implStatePerms . varPermMap) - pure (someEqProofFromSubst var_ps a) - --- | Substitute any equality permissions for the variables in an expression --- using 'substEqsWithProof', but just return the result expression and not the --- proof -substEqs :: (AbstractVars a, FreeVars a, - Substable PermSubst a Identity, NuMatchingAny1 r) => - a -> ImplM vars s r ps ps a -substEqs a = someEqProofRHS <$> substEqsWithProof a - --- | The main work horse for 'proveEq' on expressions -proveEqH :: forall vars a s r ps. NuMatchingAny1 r => HasCallStack => - PartialSubst vars -> PermExpr a -> - Mb vars (PermExpr a) -> - ImplM vars s r ps ps (SomeEqProof (PermExpr a)) -proveEqH psubst e mb_e = case (e, mbMatch mb_e) of - - -- If the RHS is an unset variable z, simplify e using any available equality - -- proofs to some e' and set z=e' - (_, [nuMP| PExpr_Var z |]) - | Left memb <- mbNameBoundP z - , Nothing <- psubstLookup psubst memb -> - -- implTraceM (\i -> pretty "proveEqH (unset var):" <+> permPretty i e) >>> - substEqsWithProof e >>= \eqp -> - setVarM memb (someEqProofRHS eqp) >>> pure eqp - - -- If the RHS is an unset variable z plus an offset o, simplify e using any - -- available equality proofs to some e' and set z equal to e' minus o - (_, [nuMP| PExpr_LLVMOffset z mb_off |]) - | Left memb <- mbNameBoundP z - , Nothing <- psubstLookup psubst memb - , Just off <- partialSubst psubst mb_off -> - -- implTraceM (\i -> pretty "proveEqH (unset var + offset):" <+> permPretty i e) >>> - substEqsWithProof e >>= \eqp -> - setVarM memb (someEqProofRHS eqp `addLLVMOffset` bvNegate off) >>> pure eqp - - -- If the RHS is a set variable, substitute for it and recurse - (_, [nuMP| PExpr_Var z |]) - | Left memb <- mbNameBoundP z - , Just e' <- psubstLookup psubst memb -> - -- implTraceM (\i -> pretty "proveEqH (set var):" <+> permPretty i e) >>> - proveEqH psubst e (mbConst e' z) - - -- If the RHS = LHS, do a proof by reflexivity - _ | Just e' <- partialSubst psubst mb_e - , e == e' -> - -- implTraceM (\i -> pretty "proveEqH (reflexivity):" <+> permPretty i e) >>> - pure (SomeEqProofRefl e) - - -- To prove x=y, try to see if either side has an eq permission, if necessary by - -- eliminating compound permissions, and proceed by transitivity if possible - (PExpr_Var x, [nuMP| PExpr_Var mb_y |]) - | Right y <- mbNameBoundP mb_y -> - -- implTraceM (\i -> pretty "proveEqH (left eq):" <+> permPretty i e) >>> - getPerm x >>= \x_p -> - getPerm y >>= \y_p -> - case (x_p, y_p) of - (ValPerm_Eq e', _) -> - -- If we have x:eq(e'), prove e' = y and apply transitivity - proveEq e' mb_e >>= \some_eqp -> - pure $ someEqProofTrans (someEqProof1 x e' True) some_eqp - (_, ValPerm_Eq e') -> - -- If we have y:eq(e'), prove x = e' and apply transitivity - proveEq e (mbConst e' mb_e) >>= \some_eqp -> - pure $ someEqProofTrans some_eqp (someEqProof1 y e' False) - (_, _) -> - -- If we have no equality perms, eliminate perms on x and y to see if we - -- can get one; if so, recurse, and otherwise, raise an error - getVarEqPerm x >>= \case - Just _ -> proveEqH psubst e mb_e - Nothing -> getVarEqPerm y >>= \case - Just _ -> proveEqH psubst e mb_e - Nothing -> - use implStatePPInfo >>>= \ppinfo -> - implFailM $ EqualityProofError - (permPretty ppinfo e) - (permPretty ppinfo mb_e) - - -- To prove @x &+ o = e@, we subtract @o@ from the RHS and recurse - (PExpr_LLVMOffset x off, _) -> - -- implTraceM (\i -> pretty "proveEqH (offsetL):" <+> permPretty i e) >>> - proveEq (PExpr_Var x) (fmap (`addLLVMOffset` bvNegate off) mb_e) >>= \some_eqp -> - pure $ fmap (`addLLVMOffset` off) some_eqp - - -- To prove @x = x &+ o@, we prove that @0 = o@ and combine it with the fact - -- that @x = x &+ 0@ ('someEqProofZeroOffset') using transitivity - (PExpr_Var x, [nuMP| PExpr_LLVMOffset mb_y mb_off |]) - | Right y <- mbNameBoundP mb_y - , x == y -> - -- implTraceM (\i -> pretty "proveEqH (offsetR):" <+> permPretty i e) >>> - proveEq (zeroOfType (BVRepr knownNat)) mb_off >>= \some_eqp -> - pure $ someEqProofTrans (someEqProofZeroOffset y) - (fmap (PExpr_LLVMOffset y) some_eqp) - - -- To prove x=e, try to see if x:eq(e') and proceed by transitivity - (PExpr_Var x, _) -> - -- implTraceM (\i -> pretty "proveEqH (x=e):" <+> - -- permPretty i x <+> pretty "=" <+> permPretty i mb_e) >>> - getVarEqPerm x >>= \case - Just e' -> - proveEq e' mb_e >>= \eqp2 -> - pure (someEqProofTrans (someEqProof1 x e' True) eqp2) - Nothing -> - use implStatePPInfo >>>= \ppinfo -> - implFailM $ EqualityProofError - (permPretty ppinfo e) - (permPretty ppinfo mb_e) - - -- To prove e=x, try to see if x:eq(e') and proceed by transitivity - (_, [nuMP| PExpr_Var z |]) - | Right x <- mbNameBoundP z -> - -- implTraceM (\i -> pretty "proveEqH (e=x):" <+> - -- permPretty i e <+> pretty "=" <+> permPretty i x) >>> - getVarEqPerm x >>= \case - Just e' -> - proveEq e (mbConst e' mb_e) >>= \eqp -> - pure (someEqProofTrans eqp (someEqProof1 x e' False)) - Nothing -> - use implStatePPInfo >>>= \ppinfo -> - implFailM $ EqualityProofError - (permPretty ppinfo e) - (permPretty ppinfo mb_e) - - -- FIXME: if proving word(e1)=word(e2) for ground e2, we could add an assertion - -- that e1=e2 using a BVProp_Eq - - -- Prove word(e1) = word(e2) by proving e1=e2 - (PExpr_LLVMWord e', [nuMP| PExpr_LLVMWord mb_e' |]) -> - -- implTraceM (\i -> pretty "proveEqH (word):" <+> permPretty i e) >>> - fmap PExpr_LLVMWord <$> proveEqH psubst e' mb_e' - - -- Prove e = L_1*y_1 + ... + L_k*y_k + N*z + M where z is an unset variable, - -- each y_i is either a set variable with value e_i or an unbound variable - -- with e_i = y_i, and e - (L_1*e_1 + ... + L_k*e_k + M) is divisible by N, - -- by setting z = (e - (L_1*e_1 + ... + L_k*e_k + M))/N - (_, [nuMP| PExpr_BV mb_factors (BV.BV mb_m) |]) - | Just (n, memb, e_factors) <- getUnsetBVFactor psubst mb_factors - , e' <- bvSub e (bvAdd e_factors (bvInt $ mbLift mb_m)) - , bvIsZero (bvMod e' n) -> - -- implTraceM (\i -> pretty "proveEqH (bv):" <+> permPretty i e) >>> - setVarM memb (bvDiv e' n) >>> pure (SomeEqProofRefl e) - - -- FIXME: add cases to prove struct(es1)=struct(es2) - - -- Otherwise give up! - _ -> use implStatePPInfo >>>= \ppinfo -> - implFailM $ EqualityProofError - (permPretty ppinfo e) - (permPretty ppinfo mb_e) - - --- | Build a proof on the top of the stack that @x:eq(e)@ -proveVarEq :: NuMatchingAny1 r => ExprVar a -> Mb vars (PermExpr a) -> - ImplM vars s r (ps :> a) ps () -proveVarEq x mb_e = - getPerm x >>>= \case - p@(ValPerm_Conj ps) - | Just i <- findIndex (== Perm_Any) ps -> - implPushM x p >>> implCopyConjM x ps i >>> implPopM x p >>> - -- Zero out all bound variables in mb_e that have not yet been set - mapM_ (\(Some memb) -> zeroUnsetVarM memb) (boundVars mb_e) >>> - partialSubstForceM mb_e "proveVarEq" >>>= \e -> - implSimplM Proxy (SImpl_ElimAnyToEq x e) - _ -> - proveEq (PExpr_Var x) mb_e >>>= \some_eqp -> - introEqReflM x >>> implCastPermM Proxy x (fmap ValPerm_Eq some_eqp) - --- | Build proofs that @x1:eq(e1),...,xn:eq(en)@ on top of the stack -proveVarsEq :: NuMatchingAny1 r => RAssign ExprVar as -> - Mb vars (RAssign PermExpr as) -> - ImplM vars s r (ps :++: as) ps () -proveVarsEq MNil _ = return () -proveVarsEq (xs' :>: x) es = - let [nuMP| es' :>: mb_e |] = mbMatch es in - proveVarsEq xs' es' >>> proveVarEq x mb_e - --- | Prove that @e1=e2@ using 'proveEq' and then cast permission @x:(f e1)@, --- which is on top of the stack, to @x:(f e2)@ -proveEqCast :: (ProveEq a, NuMatchingAny1 r) => ExprVar b -> - (a -> ValuePerm b) -> a -> Mb vars a -> - ImplM vars s r (ps :> b) (ps :> b) () -proveEqCast x f e mb_e = - do some_eqp <- proveEq e mb_e - implCastPermM Proxy x (fmap f some_eqp) - - ----------------------------------------------------------------------- --- * 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) (PermExpr LifetimeType) -proveVarLifetimeFunctor x f args l mb_l = - do psubst <- getPSubst - proveVarLifetimeFunctor' x f args l mb_l psubst - --- | The main workhorse for 'proveVarLifetimeFunctor' -proveVarLifetimeFunctor' :: - (KnownRepr TypeRepr a, NuMatchingAny1 r) => - ExprVar a -> LifetimeFunctor args a -> PermExprs args -> - PermExpr LifetimeType -> Mb vars (PermExpr LifetimeType) -> - PartialSubst vars -> - 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 >>> return l - - -- If mb_l is a set evar, substitute for it and recurse - [nuMP| PExpr_Var mb_z |] - | Left memb <- mbNameBoundP mb_z - , Just l2 <- psubstLookup psubst memb -> - proveVarLifetimeFunctor' x f args l (mbConst l2 mb_z) psubst - - -- If mb_l==l, we are done - _ | mbLift $ fmap (== l) mb_l -> - return l - - -- If mb_l is a free variable l2 /= l, we need to split or weaken the lifetime - [nuMP| PExpr_Var mb_z |] - | Right l2 <- mbNameBoundP mb_z -> - getPerm l2 >>= \case - - -- If we have l2:lowned ps, prove l:[l2]lcurrent * l2:lowned ps' for - -- some ps' and then split the lifetime of x. Note that, in proving - -- l:[l2]lcurrent, we can change the lowned permission for l2, - -- specifically if we subsume l1 into l2. - ValPerm_LOwned _ _ _ _ _ -> - let (l',l'_p) = lcurrentPerm l l2 in - proveVarImplInt l' (mbConst l'_p mb_z) >>> - getPerm l2 >>>= \case - l2_p@(ValPerm_LOwned sub_ls tps_in tps_out ps_in ps_out) -> - implPushM l2 l2_p >>> - implSplitLifetimeM x f args l l2 sub_ls tps_in tps_out ps_in ps_out >>> - return (PExpr_Var l2) - _ -> error ("proveVarLifetimeFunctor: unexpected error: " - ++ "l2 lost its lowned perms") - - -- Otherwise, prove l:[l2]lcurrent and weaken the lifetime - _ -> - let (l',l'_p) = lcurrentPerm l l2 in - proveVarImplInt l' (mbConst l'_p mb_z) >>> - 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 - _ -> - implFailVarM "proveVarLifetimeFunctor" x (ltFuncApply f args l) - (fmap (ltFuncApply f args) mb_l) - - ----------------------------------------------------------------------- --- * Solving for Permission List Implications ----------------------------------------------------------------------- - --- | A permission that needs to be proved for an implication -data NeededPerm a - -- | An equality permission that is needed - = NeededEq (EqPerm a) - -- | A block or struct permission for a range - | NeededRange (ExprVar a) (MbRangeForType a) - -instance PermPretty (NeededPerm a) where - permPrettyM (NeededEq eq_perm) = - do x_pp <- permPrettyM (eqPermVar eq_perm) - p_pp <- permPrettyM (eqPermPerm eq_perm) - return (x_pp <> colon <> p_pp) - permPrettyM (NeededRange x rng) = - do x_pp <- permPrettyM x - rng_pp <- permPrettyM rng - return (x_pp <> colon <> pretty "range" <> parens (rng_pp)) - -instance PermPrettyF NeededPerm where - permPrettyMF = permPrettyM - --- | A sequence of permissions in bindings that need to be proved -type NeededPerms = Some (RAssign NeededPerm) - --- | Convert a sequence of 'EqPerm's to a 'NeededPerms' -eqPermsToNeededPerms :: Some (RAssign EqPerm) -> NeededPerms -eqPermsToNeededPerms = fmapF (RL.map NeededEq) - --- | Convert a sequence of 'MbRangeForType's to a 'NeededPerms' -neededPermsForRanges :: ExprVar a -> [MbRangeForType a] -> NeededPerms -neededPermsForRanges x rngs = - concatSomeRAssign $ map (\rng -> Some (MNil :>: NeededRange x rng)) rngs - --- | No permissions needed -neededPerms0 :: NeededPerms -neededPerms0 = Some MNil - --- | A permission in some context of existential variables extending @vars@ -data SomeMbPerm vars a where - SomeMbPerm :: CruCtx vars' -> - Mb (vars :++: vars') (ValuePerm a) -> - SomeMbPerm vars a - --- | Convert an 'MbRangeForType' to a corresponding permission-in-binding -someMbPermForRange :: RAssign Proxy vars -> MbRangeForType a -> - SomeMbPerm vars a -someMbPermForRange vars (MbRangeForLLVMType vars' mb_rw mb_l mb_rng) = - SomeMbPerm (CruCtxCons vars' knownRepr) $ - mbCombine (cruCtxProxies vars' :>: Proxy) $ nuMulti vars $ const $ - mbCombine (MNil :>: Proxy) $ - mbMap3 (\rw l rng -> nu $ \sh -> - ValPerm_LLVMBlock $ - LLVMBlockPerm { llvmBlockRW = rw, - llvmBlockLifetime = l, - llvmBlockOffset = bvRangeOffset rng, - llvmBlockLen = bvRangeLength rng, - llvmBlockShape = PExpr_Var sh }) - mb_rw mb_l mb_rng - --- | Prove a 'SomeMbPerm' -proveSomeMbPerm :: NuMatchingAny1 r => ExprVar a -> SomeMbPerm vars a -> - ImplM vars s r (ps :> a) ps () -proveSomeMbPerm x (SomeMbPerm ctx mb_p) = - withExtVarsMultiM ctx $ proveVarImplInt x mb_p - --- | Prove the permission represented by a 'NeededPerm', returning zero or more --- auxiliary permissions that are also needed -proveNeededPerm :: NuMatchingAny1 r => RAssign Proxy vars -> NeededPerm a -> - ImplM vars s r (ps :> a) ps (Some DistPerms) -proveNeededPerm _ (NeededEq eq_perm) = - mbVarsM (eqPermPerm eq_perm) >>>= \mb_p -> - proveVarImplInt (eqPermVar eq_perm) mb_p >>> - return (Some MNil) -proveNeededPerm vars (NeededRange x rng@(MbRangeForLLVMType _ _ _ _)) = - proveSomeMbPerm x (someMbPermForRange vars rng) >>> - getTopDistPerm x >>>= \case - (ValPerm_LLVMBlock bp) -> - case NameSet.toRAssign (findEqVarFieldsInShape (llvmBlockShape bp)) of - NameSet.SomeRAssign ns -> - Some <$> traverseRAssign (\n -> VarAndPerm n <$> getPerm n) ns - _ -> error "proveNeededPerm: expected block permission" - --- | Prove the permissions represented by a sequence of 'NeededPerms', returning --- zero or more auxiliary permissions that are also needed -proveNeededPerms :: NuMatchingAny1 r => RAssign Proxy vars -> - RAssign NeededPerm ps' -> - ImplM vars s r (ps :++: ps') ps (Some DistPerms) -proveNeededPerms _ MNil = return (Some MNil) -proveNeededPerms vars (ps :>: p) = - proveNeededPerms vars ps >>>= \auxs1 -> - proveNeededPerm vars p >>>= \auxs2 -> - return (apSomeRAssign auxs1 auxs2) - --- | Call 'proveNeededPerms' and then reassociate the resulting stack -proveNeededPermsAssoc :: - NuMatchingAny1 r => RAssign Proxy vars -> - prx ps -> prx1 ps1 -> RAssign NeededPerm ps2 -> - ImplM vars s r (ps :++: (ps1 :++: ps2)) (ps :++: ps1) (Some DistPerms) -proveNeededPermsAssoc vars ps ps1 ps2 - | Refl <- RL.appendAssoc ps ps1 ps2 - = proveNeededPerms vars ps2 - --- | If the second argument is an unset variable, set it to the first, otherwise --- do nothing -tryUnifyVars :: PermExpr a -> Mb vars (PermExpr a) -> ImplM vars s r ps ps () -tryUnifyVars x mb_x = case mbMatch mb_x of - [nuMP| PExpr_Var mb_x' |] - | Left memb <- mbNameBoundP mb_x' -> - do psubst <- getPSubst - case psubstLookup psubst memb of - Nothing -> setVarM memb x - _ -> pure () - _ -> pure () - --- | Get the ranges of offsets covered by the current permissions on an --- expression, eliminating permissions if necessary -getExprRanges :: NuMatchingAny1 r => TypeRepr a -> PermExpr a -> - ImplM vars s r ps ps [MbRangeForType a] -getExprRanges tp (asVar -> Just x) = - getSimpleVarPerm x >>>= \case - p@(ValPerm_Conj _) -> return $ getOffsets p - ValPerm_Eq e -> getExprRanges tp e - _ -> return [] -getExprRanges tp (asVarOffset -> Just (x,off)) = - map (offsetMbRangeForType $ negatePermOffset off) <$> - getExprRanges tp (PExpr_Var x) -getExprRanges _ _ = pure [] - --- | The second stage of 'solveForPermListImpl', after equality permissions have --- been substituted into the 'ExprPerms' -solveForPermListImplH :: NuMatchingAny1 r => RAssign Proxy vars -> - ExprPerms ps_l -> CruCtx ps_r -> ExprPerms ps_r -> - ImplM vars s r ps ps NeededPerms --- If the RHS is empty, we are done -solveForPermListImplH _ _ _ MNil = - pure neededPerms0 - --- If the RHS is a varible x, get all the offsets mentioned in RHS permissions --- for x, subtract any ranges on the LHS for x, and then return block --- permisisons for any of the remaining ranges that are currently held for x --- --- FIXME: mbRangeFTsDelete always treats evars on the left and right as distinct --- fresh expressions, whereas RHS evars could be instantiated to expressions, --- even LHS evars. This means that this implementaiton of solveForPermListImpl --- will require more permissions from the current primary permissions on a --- variable than strictly needed when the RHS covers an existentially-quantified --- range of offsets -solveForPermListImplH vars ps_l (CruCtxCons tps_r' tp_r) (ps_r' :>: e_and_p) - | Just (VarAndPerm x p) <- exprPermVarAndPerm e_and_p - , lhs_ps <- exprPermsForVar x ps_l - , lhs_rngs <- concatMap getOffsets lhs_ps - , rhs_rngs <- getOffsets p - , needed_rngs <- mbRangeFTsDelete rhs_rngs lhs_rngs = - getExprRanges tp_r (PExpr_Var x) >>>= \expr_rngs -> - let res_rngs = mbRangeFTsSubsetTo needed_rngs expr_rngs in - implVerbTraceM - (\i -> pretty "solveForPermListImplH" <+> - permPretty i x <> colon <> line <> pretty " " <> - align (sep [pretty "RHS:" <+> permPretty i p, - pretty "LHS:" <+> permPretty i lhs_ps, - pretty "Needed ranges:" <+> permPretty i needed_rngs, - pretty "Held ranges:" <+> permPretty i expr_rngs, - pretty "Result ranges:" <+> permPretty i res_rngs])) - >>>= \_ -> - apSomeRAssign (neededPermsForRanges x res_rngs) <$> - solveForPermListImplH vars ps_l tps_r' ps_r' - --- If the RHS is not a variable, ignore it and keep going -solveForPermListImplH vars ps_l (CruCtxCons tps_r' _) (ps_r' :>: _) = - solveForPermListImplH vars ps_l tps_r' ps_r' - --- | Determine what additional permissions from the current set of variable --- permissions, if any, would be needed to prove one list of permissions implies --- another. This is just a \"best guess\", so just do nothing and return if --- nothing can be done. --- --- At a high level, this algorithm currently works as follows. It starts by --- substituting any equality permissions in the current permission set, --- returning those equalities as needed permissions. Next, it finds all LLVM --- pointer offsets and ranges of offsets for any LLVM variable @x@ that are --- mentioned on the right and subtracts those for the same variable that are --- mentioned on the left. It then returns ranges for any of these remaining --- offsets that are held as permissions in the current permission set. The --- intuition is that these offsets are the ones that are important to the right- --- or left-hand sides, but we don't know exactly how the proof will go, so we --- only pick those offsets that can actually be satisfied by the current --- permission set without failing. -solveForPermListImpl :: NuMatchingAny1 r => ExprPerms ps_l -> - CruCtx ps_r -> Mb vars (ExprPerms ps_r) -> - ImplM vars s r ps ps NeededPerms -solveForPermListImpl ps_l tps_r mb_ps_r = - let prxs = mbToProxy mb_ps_r in - -- FIXME HERE: eliminate struct variables - substEqsWithProof ps_l >>>= \eqp_l -> - (psubstProxies <$> getPSubst) >>>= \vars -> - partialSubstForceM mb_ps_r "solveForPermListImpl" >>>= \ps_r -> - give prxs (substEqsWithProof ps_r) >>>= \eqp_r -> - let neededs1 = eqPermsToNeededPerms $ someEqProofEqs eqp_l - neededs2 = eqPermsToNeededPerms $ someEqProofEqs eqp_r - neededs = apSomeRAssign neededs1 neededs2 - ps_l' = someEqProofRHS eqp_l - ps_r' = someEqProofRHS eqp_r in - apSomeRAssign neededs <$> solveForPermListImplH vars ps_l' tps_r ps_r' - - ----------------------------------------------------------------------- --- * Proving Field Permissions ----------------------------------------------------------------------- - --- | 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)] -> - PermExpr (BVType w) -> Mb vars (LLVMFieldPerm w sz) -> - ImplM vars s r (ps :> LLVMPointerType w) (ps :> LLVMPointerType w) () - -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) -> AtomicPerm (LLVMPointerType w) -> - PermExpr (BVType w) -> Mb vars (LLVMFieldPerm w sz) -> - ImplM vars s r (ps :> LLVMPointerType w) (ps :> LLVMPointerType w) () - -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) -> 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'') - (mbLLVMFieldLifetime 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''') >>>= \rw' -> - - -- Step 5: duplicate the field permission if it is copyable, and then return - let fp'''' = fp''' { llvmFieldRW = rw' } in - (if atomicPermIsCopyable (Perm_LLVMField fp'''') then - implCopyM x (ValPerm_LLVMField fp'''') >>> - recombinePerm x (ValPerm_LLVMField fp'''') - else return ()) >>> - return () - --- If we have a field permission with the correct offset that is bigger than the --- size of the desired field permission rounded up to the nearest byte, split --- the field permission we have and recurse -proveVarLLVMFieldH2 x (Perm_LLVMField fp) off mb_fp - | bvEq (llvmFieldOffset fp) off - , sz <- mbLLVMFieldSize mb_fp - , sz_bytes <- (intValue sz + 7) `div` 8 - , sz_bytes < llvmFieldSizeBytes fp = - implLLVMFieldSplit x fp sz_bytes >>>= \(p1, p2) -> - recombinePerm x (ValPerm_Conj1 p2) >>> - proveVarLLVMFieldH x p1 off mb_fp - --- If we have a field permission with the correct offset that is bigger than the --- desired field permission but did not match the previous case, then the --- desired field is some uneven number of bits smaller than the field we have, --- so all we can do is truncate the field we have -proveVarLLVMFieldH2 x (Perm_LLVMField fp) off mb_fp - | bvEq (llvmFieldOffset fp) off - , sz <- mbLLVMFieldSize mb_fp - , intValue sz < intValue (llvmFieldSize fp) = - implLLVMFieldTruncate x fp sz >>>= \p -> - proveVarLLVMFieldH x p off mb_fp - --- If we have a field permission with the correct offset that is smaller than --- the desired field permission, split the desired field permission into two, --- recursively prove the first of these from fp, prove the second with some --- other permissions, and then concatenate the results -proveVarLLVMFieldH2 x (Perm_LLVMField fp) off mb_fp - | bvEq (llvmFieldOffset fp) off - , sz <- llvmFieldSize fp - , mb_sz <- mbLLVMFieldSize mb_fp - , Just (sz' :: NatRepr sz') <- subNat' mb_sz sz -- sz + sz' = mb_sz - , Left leq' <- decideLeq (knownNat @1) sz' - , intValue sz `mod` 8 == 0 - , sz_bytes <- intValue sz `div` 8 = - - -- First, eliminate fp to point to a variable y, and prove mb_fp with - -- contents (and size) set to y - implElimLLVMFieldContentsM x fp >>>= \y -> - let fp' = fp { llvmFieldContents = ValPerm_Eq (PExpr_Var y) } in - let mb_fp1 = fmap (flip llvmFieldSetContents - (ValPerm_Eq (PExpr_Var y))) mb_fp in - proveVarLLVMFieldH x (Perm_LLVMField fp') off mb_fp1 >>> - getTopDistPerm x >>>= \p_top1 -> - - -- Next, prove the rest of mb_fp, at offset off+sz_bytes and with contents - -- equal to some variable z - withKnownNat sz' $ withLeqProof leq' $ - let mb_fp2 = - mbCombine (MNil :>: (Proxy :: Proxy (LLVMPointerType sz'))) $ - fmap (\fp_rhs -> nu $ \(z :: Name (LLVMPointerType sz')) -> - fp_rhs { llvmFieldOffset = bvAdd off (bvInt sz_bytes), - llvmFieldContents = ValPerm_Eq (PExpr_Var z) }) - mb_fp in - withExtVarsM (proveVarImplInt x $ mbValPerm_LLVMField mb_fp2) >>> - getTopDistPerm x >>>= \p_top2 -> - - -- Finally, combine these two pieces of mb_fp into a single permission, and - -- use this permission to prove the one we needed to begin with - case (p_top1, p_top2) of - (ValPerm_LLVMField fp1, ValPerm_LLVMField fp2) -> - implLLVMFieldConcat x fp1 fp2 >>> - getTopDistPerm x >>>= \case - (ValPerm_LLVMField fp_concat) -> - proveVarLLVMFieldH x (Perm_LLVMField fp_concat) off mb_fp - _ -> error "proveVarLLVMFieldH2: expected field permission" - _ -> error "proveVarLLVMFieldH2: expected field permissions" - --- If we have a field permission that contains the correct offset but doesn't --- start at it, then split it and recurse -proveVarLLVMFieldH2 x (Perm_LLVMField fp) off mb_fp - | not $ bvEq (llvmFieldOffset fp) off - , bvInRange off (llvmFieldRange fp) - , Just split_off <- bvMatchConstInt (bvSub off $ llvmFieldOffset fp) = - implLLVMFieldSplit x fp split_off >>>= \(p1, p2) -> - implSwapM x (ValPerm_Conj1 p1) x (ValPerm_Conj1 p2) >>> - recombinePerm x (ValPerm_Conj1 p1) >>> - proveVarLLVMFieldH x p2 off mb_fp - --- 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 = [] } - , Just fp <- llvmArrayToField sz sub_ap = - mbVarsM sub_ap >>>= \mb_sub_ap -> - proveVarLLVMArray x [Perm_LLVMArray ap] mb_sub_ap >>> - implSimplM Proxy (SImpl_LLVMArrayToField x sub_ap sz) >>> - proveVarLLVMFieldH x (Perm_LLVMField fp) off mb_fp - --- If we have an any permission, eliminate it to a field and recurse -proveVarLLVMFieldH2 x Perm_Any off (mb_fp :: Mb vars (LLVMFieldPerm w sz)) = - getPSubst >>>= \psubst -> - let l = fromMaybe PExpr_Always (partialSubst psubst $ - mbLLVMFieldLifetime mb_fp) - rw = fromMaybe PExpr_Write $ partialSubst psubst $ mbLLVMFieldRW mb_fp - p = ValPerm_Any :: ValuePerm (LLVMPointerType sz) - fp = LLVMFieldPerm rw l off p in - implCopyM x ValPerm_Any >>> recombinePerm x ValPerm_Any >>> - implSimplM Proxy (SImpl_ElimAnyToPtr x fp) >>> - proveVarLLVMFieldH x (Perm_LLVMField fp) off 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: look over this stuff and make sure there isn't something useful in --- here before removing it... -{- --- | Search for a permission that _could_ prove a block at an offset in the --- given range -findSomeBlock :: forall w. (1 <= w, KnownNat w) => - [AtomicPerm (LLVMPointerType w)] -> BVRange w -> - Maybe (LLVMBlockPerm w) -findSomeBlock ps range = msum (couldProve <$> ps) - where - couldProve :: AtomicPerm (LLVMPointerType w) -> Maybe (LLVMBlockPerm w) - couldProve p = - case p of - Perm_LLVMArray (llvmArrayToBlocks -> Just (bp:_)) - | bvCouldBeInRange (llvmBlockOffset bp) range -> Just bp - (llvmAtomicPermToBlock -> Just bp) - | bvCouldBeInRange (llvmBlockOffset bp) range -> Just bp - _ -> Nothing - --- | Given a list ps of permissions, find the subseqeuences of ps --- that could cover the given array permission. Also returns the permissions --- corresponding to the given ranges. -gatherRangesForArray :: - forall w. - (1 <= w, KnownNat w) => - [AtomicPerm (LLVMPointerType w)] -> - LLVMArrayPerm w -> - [[(Maybe (AtomicPerm (LLVMPointerType w)), LLVMArrayBorrow w)]] -gatherRangesForArray lhs rhs = - collectRanges False (llvmArrayOffset rhs) (lhs_ranges ++ rhs_ranges) - where - -- This is what we have to work with: - lhs_not_borrows = filterBorrowedPermissions lhs - -- For each possible lhs permission, calculate the corresponding borrow - lhs_ranges = [ (Just p, b) | p <- lhs_not_borrows - , b <- maybeToList (permToLLVMArrayBorrow rhs p) ] - -- We don't need to worry about covering the bits of the rhs that are borrowed - rhs_ranges = [ (Nothing, b) | b <- llvmArrayBorrows rhs ] - -- This is the extent of the rhs array permission - rhs_off_bytes = bvAdd (llvmArrayOffset rhs) (llvmArrayLengthBytes rhs) - - -- check if the given offset is covered by the given borrow/range. - -- the first parameter controls whether the start of the range must - -- be equal to the given offset, or merely fall in the range - rangeForOffset prec off (_, b) = - if prec then bvEq off (bvRangeOffset range) else bvPropCouldHold prop - where - range = llvmArrayAbsBorrowRange rhs b - prop = bvPropInRange off range - - -- Build the possible sequences of permissions that cover the rhs. - -- The Bool flag allows the first permission to _maybe_ cover the first offset, - -- (it is set to True, i.e. the permission 'must' cover the desired offset, - -- in recursive calls) - collectRanges :: - Bool -> - PermExpr (BVType w) -> - [(Maybe (AtomicPerm (LLVMPointerType w)), LLVMArrayBorrow w)] -> - [[(Maybe (AtomicPerm (LLVMPointerType w)), LLVMArrayBorrow w)]] - collectRanges prec off0 ranges - | bvLeq rhs_off_bytes off0 = [[]] - | otherwise = - [ h:rest | h@(_, b) <- filter (rangeForOffset prec off0) ranges, - let r = llvmArrayAbsBorrowRange rhs b, - let next_offset = bvRangeOffset r `bvAdd` bvRangeLength r, - rest <- collectRanges True next_offset (filter (/= h) ranges) ] - --- | Given atomic permissions @lhs@ and array permission @rhs@, construct a new --- array permission that covers @rhs@, but is entirely borrowed. Each borrow of --- the new permission corresponds to some permission in @lhs@ OR a borrow that --- already exists in @rhs@. --- --- Also returns the AtomicPerms corresponding to the borrows in the returned --- array perm. -borrowedLLVMArrayForArray :: - forall w. - (1 <= w, KnownNat w) => - [AtomicPerm (LLVMPointerType w)] -> - LLVMArrayPerm w -> - Maybe ([AtomicPerm (LLVMPointerType w)], LLVMArrayPerm w) -borrowedLLVMArrayForArray lhs rhs = - case gatherRangesForArray lhs rhs of - -- NOTE: This only returns the first such sequence - (unzip -> (ps, bs)):_ - | not (null rs) - , Just n <- len' -> - Just (catMaybes ps, rhs { llvmArrayBorrows = bs' - , llvmArrayLen = n - , llvmArrayOffset = o' - }) - where - rs = llvmArrayAbsBorrowRange rhs <$> bs - (r', rs') = expectLengthAtLeastOne rs - - bs' = chopBorrows [] bs (llvmArrayBorrows rhs) ++ llvmArrayBorrows rhs - o' = bvRangeOffset r' - v = bvRangeOffset rs' `bvAdd` bvRangeLength rs' - len' = matchLLVMArrayCell rhs v - _ -> Nothing - - where - overlapsWith b = or . fmap (not . bvPropCouldHold) . llvmArrayBorrowsDisjoint b - - -- We need to chop up any ranges that overlap with borrows on the rhs - chopBorrows bs_skip bs_lhs bs_rhs - | Just bi <- findIndex (`notElem` bs_rhs) bs_lhs - , Just b_rhs <- find (overlapsWith (bs_lhs!!bi)) bs_rhs - = let b = bs_lhs!!bi - b_rhs_off = llvmArrayBorrowCells b_rhs - bs_lhs' = llvmArrayBorrowRangeDelete b b_rhs_off ++ deleteNth bi bs_lhs - in chopBorrows bs_skip bs_lhs' bs_rhs - | Just bi <- findIndex (`notElem` bs_rhs) bs_lhs - = chopBorrows ((bs_lhs!!bi):bs_skip) (deleteNth bi bs_lhs) bs_rhs - | otherwise - = bs_skip ++ bs_lhs --} - - --- | 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) -> - [AtomicPerm (LLVMPointerType w)] -> Mb vars (LLVMArrayPerm w) -> - ImplM vars s r (ps :> LLVMPointerType w) (ps :> LLVMPointerType w) () - -proveVarLLVMArray x 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 mb_ap)])) >>> - getPSubst >>>= \psubst -> - proveVarLLVMArrayH x psubst ps mb_ap - --- | The main implementation of 'proveVarLLVMArray'. At a high level, the --- algorithm chooses one of the ways that an array permission can be proved, --- which are: --- --- 1. From an array permission with the same offset and length; --- --- 2. By borrowing or copying a portion of a larger array permission; --- --- 3. By constructing a fully borrowed array using 'SImpl_LLVMArrayBorrowed'; or --- --- 4. By eliminating a @memblock@ permission with array shape. --- --- NOTE: these \"ways\" do *not* line up with the cases of the function, labeled --- as \"case 1\", \"case 2\", etc. outputs in the code below. --- --- To determine which way to use, the algorithm searches for a permission --- currently held on the left that is either an array permission with exactly --- the required offset and length or that includes them in its range, or is a --- block permission that that includes the required offset and length in its --- range. Currently, there are no rules for changing the stride of an array, so --- arrays with different strides are not considered. If no such permission is --- found on the left, then a fully borrowed array permission is created, where --- the borrows are calculated to either line up with the ranges of permissions --- we already hold on the left, so they can be returned, or to be in the desired --- output permission, so we do not have to return them. --- --- In all of these ways, an array permission with the required offset and --- length is either found on the left or created, and all ways then reduce to --- way 1. At this point, the algorithm equalizes the borrows, meaning that it --- returns any borrows on the left that are not on the right (where the right is --- the desired output permission) and borrows any borrows on the right that are --- not on the left. It then adjusts the read/write and lifetime modalities and --- coerces the cell permissions if necessary. These steps are performed by the --- helper function 'proveVarLLVMArray_FromArray'. -proveVarLLVMArrayH :: - (1 <= w, KnownNat w, NuMatchingAny1 r) => ExprVar (LLVMPointerType w) -> - PartialSubst vars -> [AtomicPerm (LLVMPointerType w)] -> - Mb vars (LLVMArrayPerm w) -> - ImplM vars s r (ps :> LLVMPointerType w) (ps :> LLVMPointerType w) () - --- 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 = - recombinePerm x (ValPerm_Conj ps) >>> - partialSubstForceM mb_ap "proveVarLLVMArray: incomplete psubst" >>>= \ap -> - implLLVMArrayEmpty x ap - --- If we have a single array permission that covers the RHS, then we are using --- way 1 or 2, so either use that or borrow or copy a portion of it and proceed --- to proveVarLLVMArray_FromArray -proveVarLLVMArrayH x psubst ps mb_ap - | Just off <- partialSubst psubst $ mbLLVMArrayOffset mb_ap - , Just len <- partialSubst psubst $ mbLLVMArrayLen mb_ap - , Just lenBytes <- partialSubst psubst $ mbLLVMArrayLenBytes mb_ap - , stride <- mbLLVMArrayStride mb_ap - , Just bs <- partialSubst psubst $ mbLLVMArrayBorrows mb_ap - , Just i <- findIndex (suitableAP off lenBytes stride bs) ps - , Perm_LLVMArray ap_lhs <- ps!!i = - implVerbTraceM (\info -> pretty "proveVarLLVMArrayH case 1: using" <+> - permPretty info ap_lhs) >>> - implGetConjM x ps i >>>= \ps' -> - recombinePerm x (ValPerm_Conj ps') >>> - - partialSubstForceM (mbLLVMArrayBorrows mb_ap) - "proveVarLLVMArrayH: incomplete array borrows" >>> - - if bvEq off (llvmArrayOffset ap_lhs) && bvEq len (llvmArrayLen ap_lhs) then - proveVarLLVMArray_FromArray x ap_lhs len bs mb_ap - else - implLLVMArrayGet x ap_lhs off len >>>= \ap_lhs' -> - recombinePerm x (ValPerm_LLVMArray ap_lhs') >>> - proveVarLLVMArray_FromArray x (llvmMakeSubArray ap_lhs off len) len bs mb_ap - where - -- Test if an atomic permission is a "suitable" array permission for the - -- given offset, length, stride, and borrows, meaning that it has the - -- given stride, could contain the given offset and length, and either - -- has exactly the given borrows or at least does not have all of the - -- given offset and length borrowed - suitableAP :: - (1 <= w, KnownNat w) => - PermExpr (BVType w) -> PermExpr (BVType w) -> Bytes -> - [LLVMArrayBorrow w] -> AtomicPerm (LLVMPointerType w) -> Bool - suitableAP off len stride bs (Perm_LLVMArray ap) = - -- Test that the strides are equal - llvmArrayStride ap == stride && - -- Test if this permission *could* cover the desired off/len - all bvPropCouldHold (bvPropRangeSubset (BVRange off len) - (llvmArrayAbsOffsets ap)) && - -- Test that either the sets of borrows are equal ... - ((all (flip elem bs) (llvmArrayBorrows ap) && - all (flip elem (llvmArrayBorrows ap)) bs) || - -- ...or the range [off,len) is not fully borrowed - not (llvmArrayRangeIsBorrowed ap (BVRange off len))) - suitableAP _ _ _ _ _ = False - --- Check if there is a block that contains the required offset and length, in --- which case eliminate it, allowing us to either satisfy way 4 (eliminate a --- memblock to an array), or to generate a set of permissions that can contain --- array and/or pointer permissions that can be used to satisfy one of ways 1-3 --- when we recurse -proveVarLLVMArrayH x psubst ps mb_ap - | Just rng <- partialSubst psubst $ mbLLVMArrayRange mb_ap - , Just i <- findIndex (\p -> isLLVMBlockPerm p && - llvmAtomicPermCouldContainRange rng p) ps = - implVerbTraceM (\info -> pretty "proveVarLLVMArrayH case 2: eliminating" <+> - permPretty info (ps!!i)) >>> - implElimAppendIthLLVMBlock x ps i >>>= \ps' -> - proveVarLLVMArray x ps' mb_ap - --- This case prepares us to hit case 4 below, which needs the modalities of --- mb_ap to be determined; this is done by finding an arbitrary permission on --- the left that overlaps with a non-borrowed portion of mb_ap and using it to --- instantiate the modalities -proveVarLLVMArrayH x psubst ps mb_ap - | Just off <- partialSubst psubst $ mbLLVMArrayOffset mb_ap - , Just lenBytes <- partialSubst psubst $ mbLLVMArrayLenBytes mb_ap - , not (isJust $ partialSubst psubst $ mbLLVMArrayRW mb_ap) || - not (isJust $ partialSubst psubst $ mbLLVMArrayLifetime mb_ap) - , Just p <- find (llvmAtomicPermCouldOverlapRange (BVRange off lenBytes)) ps - , Just rw <- atomicPermModality p - , Just l <- atomicPermLifetime p = - implVerbTraceM (\_ -> pretty "proveVarLLVMArrayH case 3 (unifying vars)") >>> - tryUnifyVars rw (mbLLVMArrayRW mb_ap) >>> - tryUnifyVars l (mbLLVMArrayLifetime mb_ap) >>> - proveVarLLVMArray x ps mb_ap - --- If none of the above match, try and build a completely borrowed array whose --- borrows are made up of either borrows in the desired output permission mb_ap --- or are ranges on permissions that we already hold on the left, which is way 3 --- for building an array permission -proveVarLLVMArrayH x psubst ps mb_ap - | Just ap <- partialSubst psubst mb_ap - , len <- llvmArrayLen ap - , lhs_cells@(lhs_cell_rng:_) <- concatMap (permCells ap) ps - , rhs_cells <- map llvmArrayBorrowCells (llvmArrayBorrows ap) - , Just cells <- gatherCoveringRanges (llvmArrayCells ap) (rhs_cells ++ - lhs_cells) - , bs <- map cellRangeToBorrow cells - , ap_borrowed <- ap { llvmArrayBorrows = bs } - , cell_bp <- blockForCell ap (bvRangeOffset lhs_cell_rng) = - implVerbTraceM (\i -> hang 2 $ - sep [pretty "proveVarLLVMArrayH case 4", - pretty "cell ranges = " <> permPretty i cells, - pretty "bp = " <> permPretty i cell_bp]) >>> - mbVarsM cell_bp >>>= \mb_cell_bp -> - proveVarLLVMBlock x ps mb_cell_bp >>> - implLLVMArrayBorrowed x cell_bp ap_borrowed >>> - recombinePerm x (ValPerm_Conj1 (Perm_LLVMBlock cell_bp)) >>> - proveVarLLVMArray_FromArray x ap_borrowed len (llvmArrayBorrows ap) mb_ap - where - -- Comupte the range of array cells in ap that an atomic permission - -- corresponds to, if any, as long as it is not wholly borrowed - permCells :: (1 <= w, KnownNat w) => LLVMArrayPerm w -> - AtomicPerm (LLVMPointerType w) -> [BVRange w] - permCells ap p = mapMaybe (llvmArrayAbsOffsetsToCells ap) (permOffsets p) - - -- Compute the range of offsets in an atomic permission, if any, using the - -- whole range of an array permission iff it is not fully borrowed - permOffsets :: (1 <= w, KnownNat w) => AtomicPerm (LLVMPointerType w) -> - [BVRange w] - permOffsets (Perm_LLVMArray ap) = - bvRangesDelete (llvmArrayRange ap) $ - map (llvmArrayAbsBorrowRange ap) (llvmArrayBorrows ap) - permOffsets p = maybeToList $ llvmAtomicPermRange p - - -- Convert a range to a borrow - cellRangeToBorrow :: (1 <= w, KnownNat w) => BVRange w -> LLVMArrayBorrow w - cellRangeToBorrow (BVRange cell (bvMatchConstInt -> Just 1)) = - FieldBorrow cell - cellRangeToBorrow rng = RangeBorrow rng - - -- Create a block permission for a cell in an array - blockForCell :: (1 <= w, KnownNat w) => LLVMArrayPerm w -> - PermExpr (BVType w) -> LLVMBlockPerm w - blockForCell ap cell = - LLVMBlockPerm { llvmBlockRW = llvmArrayRW ap, - llvmBlockLifetime = llvmArrayLifetime ap, - llvmBlockOffset = llvmArrayCellToAbsOffset ap cell, - llvmBlockLen = bvInt (toInteger $ llvmArrayStride ap), - llvmBlockShape = llvmArrayCellShape ap } - --- If we get here, then there is no covering of the offsets needed for mb_ap, so --- there is no possible way we could prove mb_ap, and thus we fail -proveVarLLVMArrayH x _ ps mb_ap = - implFailVarM "proveVarLLVMArrayH" x (ValPerm_Conj ps) - (mbValPerm_LLVMArray mb_ap) - - --- | Prove an array permission @mb_ap@ using the array permission @ap_lhs@ on --- top of the stack, assuming that @ap_lhs@ has the same offset and stride as --- @ap@ and that @ap@ has length and borrows given by the supplied arguments. -proveVarLLVMArray_FromArray :: - (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) () - -proveVarLLVMArray_FromArray x ap_lhs len bs mb_ap = - implTraceM (\info -> - pretty "proveVarLLVMArray_FromArray:" <+> - permPretty info x <> colon <> - align (sep [permPretty info (ValPerm_LLVMArray ap_lhs), - pretty "-o", - PP.group (permPretty info mb_ap), - pretty "bs = " <> permPretty info bs])) >>> - proveVarLLVMArray_FromArrayH x ap_lhs len bs mb_ap - --- | The implementation of 'proveVarLLVMArray_FromArray' -proveVarLLVMArray_FromArrayH :: - (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) () - --- If there is a borrow in ap_lhs that is not in ap, return it to ap_lhs --- --- FIXME: when an array is returned to ap_lhs, this code requires all of it to --- be returned, with no borrows, even though it could be that some portion of --- that borrow is borrowed in mb_ap. E.g., if ap_lhs has the range [0,8) --- borrowed while mb_ap only needs to have [2,3) borrowed, this code will first --- return all of [0,8) and then borrow [2,3), while the array return rule allows --- all of [0,8) except [2,3) to be returned as one step. -proveVarLLVMArray_FromArrayH x ap_lhs len bs mb_ap - | Just b <- find (flip notElem bs) (llvmArrayBorrows ap_lhs) = - - -- Prove the borrowed perm - let p = permForLLVMArrayBorrow ap_lhs b in - mbVarsM p >>>= \mb_p -> - implTraceM (\info -> - hang 2 $ - sep [pretty "Proving borrowed permission...", - permPretty info p, - pretty "For borrow:" <+> permPretty info b, - pretty "From array:" <+> permPretty info ap_lhs]) >>> - proveVarImplInt x mb_p >>> - implSwapM x (ValPerm_Conj1 $ Perm_LLVMArray ap_lhs) x p >>> - - -- Return the borrowed perm to ap_lhs to get ap - implLLVMArrayReturnBorrow x ap_lhs b >>> - - -- Continue proving mb_ap with the updated ap_lhs - let ap_lhs' = llvmArrayRemBorrow b ap_lhs in - proveVarLLVMArray_FromArray x ap_lhs' len bs mb_ap - --- 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_FromArrayH x ap_lhs len bs mb_ap - | Just b <- find (flip notElem (llvmArrayBorrows ap_lhs)) bs = - - -- Borrow the permission if that is possible; this will fail if ap has a - -- borrow that is not actually in its range - implLLVMArrayBorrowBorrow x ap_lhs b >>>= \p -> - recombinePerm x p >>> - - -- Continue proving mb_ap with the updated ap_lhs - let ap_lhs' = llvmArrayAddBorrow b ap_lhs in - proveVarLLVMArray_FromArray x ap_lhs' len bs mb_ap - - --- 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_FromArrayH 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''' -> - -- Finally, rearrange the borrows of ap_lhs to match bs - implLLVMArrayRearrange x ap_lhs''' bs - ----------------------------------------------------------------------- --- * Proving Named Permission Arguments ----------------------------------------------------------------------- - --- | Prove @P |- P@ by weakening the arguments in @args1@ and --- substituting for free variablers in @args2@ until the arguments are --- equal. The weakening steps include: --- --- * Replacing 'Write' arguments with 'Read'; --- --- * Replacing a bigger lifetime @l1@ with a smaller one @l2@, defined by the --- existence of a @l2:[l1]lcurrent@; --- --- * Replacing all lifetime arguments with a single @lowned@ lifetime @l@, by --- splitting the lifetime of the input permission --- --- FIXME: currently this does not do the lifetime splitting step -proveNamedArgs :: NuMatchingAny1 r => ExprVar a -> - NamedPermName ns args a -> PermExprs args -> - PermOffset a -> Mb vars (PermExprs args) -> - ImplM vars s r (ps :> a) (ps :> a) () -proveNamedArgs x npn args off mb_args = - do _ <- implTraceM (\i -> pretty "proveNamedArgs:" <> softline <> - ppImpl i x (ValPerm_Named npn args off) - (fmap (\args' -> ValPerm_Named npn args' off) mb_args)) - psubst <- getPSubst - mapM_ (\case Some memb -> - proveNamedArg x npn args off memb psubst $ - fmap (`nthPermExpr` memb) mb_args) - (getPermExprsMembers args) - - --- | Prove @P |- P@ where @arg@ is specified --- by a 'Member' proof in the input @args@ and @arg'@ potentially has --- existential variables. Assume the LHS is on the top of the stack and leave --- the RHS, if proved, on the top of the stack. -proveNamedArg :: NuMatchingAny1 r => ExprVar a -> - NamedPermName ns args a -> PermExprs args -> - PermOffset a -> Member args b -> PartialSubst vars -> - Mb vars (PermExpr b) -> - ImplM vars s r (ps :> a) (ps :> a) () -proveNamedArg x npn args off memb psubst arg = case mbMatch arg of - - -- Prove P -o P for free variable l - [nuMP| PExpr_Var z |] - | PExpr_Always <- nthPermExpr args memb - , Right l <- mbNameBoundP z -> - implSimplM Proxy (SImpl_NamedArgAlways x npn args off memb (PExpr_Var l)) - - -- Prove P -o P for assigned variable l - [nuMP| PExpr_Var z |] - | PExpr_Always <- nthPermExpr args memb - , Left memb_z <- mbNameBoundP z - , Just e <- psubstLookup psubst memb_z -> - implSimplM Proxy (SImpl_NamedArgAlways x npn args off memb e) - - -- Prove P -o P for l1/=l2 using l1:[l2]lcurrent - [nuMP| PExpr_Var z |] - | Right l1 <- mbNameBoundP z - , LifetimeRepr <- cruCtxLookup (namedPermNameArgs npn) memb - , PExpr_Var l2 <- nthPermExpr args memb - , l1 /= l2 -> - proveVarImplInt l1 (mbConst (ValPerm_LCurrent $ PExpr_Var l2) arg) >>> - implSimplM Proxy (SImpl_NamedArgCurrent x npn args off memb (PExpr_Var l2)) - - -- Prove P -o P for any variable rw - [nuMP| PExpr_Var z |] - | Right rw <- mbNameBoundP z - , PExpr_RWModality Write <- nthPermExpr args memb -> - implSimplM Proxy (SImpl_NamedArgWrite x npn args off memb (PExpr_Var rw)) - - -- Prove P -o P for any rw - [nuMP| PExpr_RWModality Read |] -> - implSimplM Proxy (SImpl_NamedArgRead x npn args off memb) - - -- Otherwise, prove P -o P by proving e1=e2 - _ -> - proveEqCast x (\e -> ValPerm_Named npn (setNthPermExpr args memb e) off) - (nthPermExpr args memb) arg - - -{- - -- Prove x:P -o x:P when P is a reachability permission by - -- eliminating the LHS into x:P and y:p1, proving y:P, and - -- applying transitivity of reachability permissions - [nuMP| PExpr_ValPerm mb_p |] - | RecursiveSortRepr b TrueRepr <- namedPermNameSort npn - , NameReachConstr <- namedPermNameReachConstr npn -> - implLookupNamedPerm npn >>>= \(NamedPerm_Rec rp) -> - implElimReachabilityPermM x rp args off p >>>= \y -> - proveVarImpl y (fmap (\e' -> - ValPerm_Named npn (PExprs_Cons - args e') off) mb_e) >>> - partialSubstForceM mb_p - "proveNamedArg: incomplete psubst: p_y" >>>= \p_y -> - implSimplM Proxy (SImpl_ReachabilityTrans x rp args off y p_y) --} - -{- - -- Fail in any other case - _ -> - implFailVarM "proveNamedArg" x - (ValPerm_Named npn args off) - (fmap (\args' -> - ValPerm_Named npn (setNthPermExpr args memb args') off) mb_arg) --} - ----------------------------------------------------------------------- --- * 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 :: - (1 <= w, KnownNat w, NuMatchingAny1 r) => ExprVar (LLVMPointerType w) -> - [AtomicPerm (LLVMPointerType w)] -> Mb vars (LLVMBlockPerm w) -> - ImplM vars s r (ps :> LLVMPointerType w) (ps :> LLVMPointerType w) () -proveVarLLVMBlock x ps mb_bp = - do psubst <- getPSubst - proveVarLLVMBlocks x ps psubst [mb_bp] - --- | Prove a conjunction of block and atomic permissions for @x@ from the --- permissions on top of the stack, which are given by the second argument. --- --- 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 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 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)] -> - ImplM vars s r (ps :> LLVMPointerType w) (ps :> LLVMPointerType w) () - -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) >>>= \mb_bps' -> - implTraceM - (\i -> sep [pretty "proveVarLLVMBlocks", - permPretty i x <> colon <> permPretty i ps, - pretty "-o", permPretty i mb_bps']) >>> - proveVarLLVMBlocks1 x ps psubst mb_bps - - --- | Call 'proveVarLLVMBlock' in a context extended with a fresh existential --- variable, which is used only in the first block permission we want to prove, --- and return the value assigned to that evar -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)] -> - ImplM vars s r (ps :> LLVMPointerType w) (ps :> LLVMPointerType w) (PermExpr tp) -proveVarLLVMBlocksExt1 x ps psubst mb_bp_ext mb_bps = - fmap snd $ withExtVarsM $ - proveVarLLVMBlocks x ps (extPSubst psubst) - (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 -proveVarLLVMBlocksExt2 :: - (1 <= w, KnownNat w, KnownRepr TypeRepr tp1, - KnownRepr TypeRepr tp2, NuMatchingAny1 r) => - ExprVar (LLVMPointerType w) -> [AtomicPerm (LLVMPointerType w)] -> - PartialSubst vars -> Mb (vars :> tp1 :> tp2) [LLVMBlockPerm 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 = - withExtVarsM - (withExtVarsM $ - proveVarLLVMBlocks x ps (extPSubst $ extPSubst psubst) - (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) - (mbLLVMBlockLifetime 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)] -> - ImplM vars s r (ps :> LLVMPointerType w) (ps :> LLVMPointerType w) () - --- We are done, yay! Pop ps and build a true permission -proveVarLLVMBlocks1 x ps _ [] = - recombinePerm 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) - | Just off <- partialSubst psubst $ mbLLVMBlockOffset mb_bp - , Just len <- partialSubst psubst $ mbLLVMBlockLen mb_bp - , Just sh <- partialSubst psubst $ mbLLVMBlockShape mb_bp - , Just i <- findIndex (\case - Perm_LLVMBlock bp -> - bvEq (llvmBlockOffset bp) off && - bvEq (llvmBlockLen bp) len && - llvmBlockShape bp == sh - _ -> False) ps - , Perm_LLVMBlock bp <- ps!!i = - - -- Move the memblock perm we chose to the top of the stack - implExtractSwapConjM x ps i >>> - let ps' = deleteNth i ps in - - -- Make the input block have the required modalities - equalizeBlockModalities x bp mb_bp >>>= \bp' -> - - -- Duplicate and save the block permission if it is copyable - (if atomicPermIsCopyable (Perm_LLVMBlock bp') then - implCopyM x (ValPerm_LLVMBlock bp') >>> - recombinePerm x (ValPerm_LLVMBlock bp') - else return ()) >>> - - -- Move it down below ps' - implSwapM x (ValPerm_Conj ps') x (ValPerm_LLVMBlock bp') >>> - - -- Recursively prove the remaining perms - proveVarLLVMBlocks x ps' psubst mb_bps >>> - getTopDistConj "proveVarLLVMBlocks1" x >>>= \ps_out -> - - -- Finally, combine the one memblock perm we chose with the rest of them - 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 either a defined shape or a named --- shape with modalities, eliminate the left-hand block. -proveVarLLVMBlocks1 x ps psubst mb_bps_in@(mb_bp:_) - | Just off <- partialSubst psubst $ mbLLVMBlockOffset mb_bp - , Just len <- partialSubst psubst $ mbLLVMBlockLen mb_bp - , Just i <- findIndex - (\case - Perm_LLVMBlock bp - | PExpr_NamedShape _ _ nmsh _ <- llvmBlockShape bp - , DefinedShapeBody _ <- namedShapeBody nmsh -> - bvEq (llvmBlockOffset bp) off && - bvEq (llvmBlockLen bp) len - - | PExpr_NamedShape maybe_rw maybe_l _ _ <- llvmBlockShape bp - , isJust maybe_rw || isJust maybe_l -> - bvEq (llvmBlockOffset bp) off && - bvEq (llvmBlockLen bp) len - - _ -> False) ps = - implElimAppendIthLLVMBlock x ps i >>>= \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:_) - | Just off <- partialSubst psubst $ mbLLVMBlockOffset mb_bp - , Just len <- partialSubst psubst $ mbLLVMBlockLen mb_bp - , Just i <- findIndex - (\case - Perm_LLVMBlock bp - | PExpr_SeqShape sh1 PExpr_EmptyShape <- llvmBlockShape bp - , Just len' <- llvmShapeLength sh1 -> - bvEq (llvmBlockOffset bp) off && - bvEq (llvmBlockLen bp) len && - bvEq len len' - _ -> False) ps = - implElimAppendIthLLVMBlock x ps i >>>= \ps' -> - proveVarLLVMBlocks x ps' psubst mb_bps_in - - --- If there is a left-hand permission with empty shape whose range overlaps with --- but is not contained in that of mb_bp, split it into pieces wholly contained --- 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:_) - | Just off <- partialSubst psubst $ mbLLVMBlockOffset mb_bp - , Just len <- partialSubst psubst $ mbLLVMBlockLen mb_bp - , rng <- BVRange off len - , not (bvIsZero len) - , Just i <- findIndex (\case - Perm_LLVMBlock bp -> - llvmBlockShape bp == PExpr_EmptyShape && - bvRangesOverlap (llvmBlockRange bp) rng && - not (bvRangeSubset (llvmBlockRange bp) rng) - _ -> False) ps - , Perm_LLVMBlock bp <- ps!!i = - implExtractSwapConjM x ps i >>> - -- If the end of mb_bp is contained in bp, split bp at the end of mb_bp, - -- otherwise split it at the beginning of mb_bp - let len1 = if bvInRange (bvAdd off len) (llvmBlockRange bp) then - bvSub (bvAdd off len) (llvmBlockOffset bp) - else - bvSub off (llvmBlockOffset bp) in - implSimplM Proxy (SImpl_SplitLLVMBlockEmpty x bp len1) >>> - getTopDistConj "proveVarLLVMBlocks1" x >>>= \ps' -> - implAppendConjsM x (deleteNth i ps) 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:_) - | 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 -> - bvRangesOverlap (llvmBlockRange bp) rng && - not (bvRangeSubset (llvmBlockRange bp) rng) - _ -> False) ps = - implElimAppendIthLLVMBlock x ps i >>>= \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) = - proveVarLLVMBlocks2 x ps psubst mb_bp (mbMatch $ - mbLLVMBlockShape mb_bp) mb_bps - - --- | Stage 2 of 'proveVarLLVMBlocks'. See that comments on that function. The --- 5th argument is the shape of the 4th argument. -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)] -> - 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 - | Just len <- partialSubst psubst $ mbLLVMBlockLen mb_bp - , bvIsZero len = - - -- Do the recursive call without the empty shape and remember what - -- permissions it proved - proveVarLLVMBlocks x ps psubst mb_bps >>> - getTopDistConj "proveVarLLVMBlocks2" x >>>= \ps_out -> - - -- Substitute into the required block perm and prove it with - -- SImpl_IntroLLVMBlockEmpty - -- - -- FIXME: if the rwmodality or lifetime are still unset at this point, we - -- could set them to default values, but this will be a rare case - partialSubstForceM mb_bp "proveVarLLVMBlock" >>>= \bp -> - implSimplM Proxy (SImpl_IntroLLVMBlockEmpty x bp) >>> - - -- Finally, recombine the resulting permission with the rest of them - implSwapInsertConjM x (Perm_LLVMBlock bp) ps_out 0 - - --- 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 = - -- Locally bind z_sh for the shape of the memblock perm and recurse - let mb_bp' = - mbCombine RL.typeCtxProxies $ - mbMapCl $(mkClosed [| \bp -> nu $ \z_sh -> - bp { llvmBlockShape = PExpr_Var z_sh } |]) mb_bp in - proveVarLLVMBlocksExt1 x ps psubst mb_bp' mb_bps >>> - - -- Extract out the block perm we proved and coerce it to the empty shape - getTopDistConj "proveVarLLVMBlocks2" x >>>= \ps_out -> - let (ps_out_hd, ps_out') = expectLengthAtLeastOne ps_out - bp = case ps_out_hd of - Perm_LLVMBlock bp_ -> bp_ - _ -> error "proveVarLLVMBlocks2: expected block permission" in - implSplitSwapConjsM x ps_out 1 >>> - implSimplM Proxy (SImpl_CoerceLLVMBlockEmpty x bp) >>> - - -- Finally, recombine the resulting permission with the rest of them - implSwapInsertConjM x (Perm_LLVMBlock $ - bp { llvmBlockShape = PExpr_EmptyShape }) ps_out' 0 - - --- If proving a memblock permission (with shape other than emptysh, as it does --- 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 - | Just len <- partialSubst psubst (mbLLVMBlockLen mb_bp) - , mbLift $ fmap (maybe False (`bvLt` len) - . llvmShapeLength . llvmBlockShape) mb_bp = - - -- First, build the list of the correctly-sized perm + the empty shape one - let mb_bps' = - mbMapCl - $(mkClosed - [| \bp -> - let sh_len = fromJust (llvmShapeLength (llvmBlockShape bp)) in - [bp { llvmBlockLen = sh_len }, - bp { llvmBlockOffset = bvAdd (llvmBlockOffset bp) sh_len, - llvmBlockLen = bvSub (llvmBlockLen bp) sh_len, - llvmBlockShape = PExpr_EmptyShape }] |]) mb_bp in - - -- Next, do the recursive call - 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 - getTopDistConj "proveVarLLVMBlocks2" x >>>= \ps' -> - let (bp1,bp2,ps'') = case ps' of - (Perm_LLVMBlock bp1_ : Perm_LLVMBlock bp2_ : ps''_) -> - (bp1_,bp2_,ps''_) - _ -> error "proveVarLLVMBlocks2: expected two block permissions" - len2 = llvmBlockLen bp2 - bp_out = bp1 { llvmBlockLen = bvAdd (llvmBlockLen bp1) len2 } in - implSplitSwapConjsM x ps' 2 >>> - implSplitConjsM x [Perm_LLVMBlock bp1, Perm_LLVMBlock bp2] 1 >>> - implSimplM Proxy (SImpl_IntroLLVMBlockSeq x bp1 len2 PExpr_EmptyShape) >>> - implSimplM Proxy (SImpl_ElimLLVMBlockSeqEmpty x bp_out) >>> - - -- Finally, recombine the resulting permission with the rest of them - implSwapInsertConjM x (Perm_LLVMBlock bp_out) ps'' 0 - - --- For a named shape with modalities, prove it without the modalities first and --- then add the modalities -proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps - | [nuMP| PExpr_NamedShape mb_maybe_rw mb_maybe_l _ _ |] <- mb_sh - , isJust (mbMaybe mb_maybe_rw) || isJust (mbMaybe mb_maybe_l) = - - -- Recurse using the shape without the modalities - let mb_bp' = - flip mbMapCl mb_bp - $(mkClosed - [| \bp -> case llvmBlockShape bp of - PExpr_NamedShape maybe_rw maybe_l nmsh args - | rw <- fromMaybe (llvmBlockRW bp) maybe_rw - , l <- fromMaybe (llvmBlockLifetime bp) maybe_l -> - bp { llvmBlockRW = rw, llvmBlockLifetime = l, - llvmBlockShape = - PExpr_NamedShape Nothing Nothing nmsh args } - _ -> error "Unreachable!" |]) in - proveVarLLVMBlocks x ps psubst (mb_bp' : mb_bps) >>> - - -- Extract out the block perm we proved - getTopDistConj "proveVarLLVMBlocks2" x >>>= \ps_out -> - let (_, ps_out') = expectLengthAtLeastOne ps_out in - implSplitSwapConjsM x ps_out 1 >>> - - -- Introduce the modalities - partialSubstForceM mb_bp "proveVarLLVMBlocks" >>>= \bp -> - implSimplM Proxy (SImpl_IntroLLVMBlockNamedMods x bp) >>> - - -- Finally, recombine the resulting permission with the rest of them - implSwapInsertConjM x (Perm_LLVMBlock bp) ps_out' 0 - - --- For a recursive named shape with an equality permission on the left that has --- the same offset and length, eliminate the equality permission, because it --- might expose an occurrence of the same recursive named shape on the left, and --- because eliminating it is necessary anyway (unless the recursive permission --- on the right unfolds to an equality shape, which should never be the case in --- practice) -proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps - | [nuMP| PExpr_NamedShape _ _ mb_nmsh _ |] <- mb_sh - , mbNamedShapeIsRecursive mb_nmsh - , Just off <- partialSubst psubst $ mbLLVMBlockOffset mb_bp - , Just len <- partialSubst psubst $ mbLLVMBlockLen mb_bp - , Just i <- findIndex - (\case - Perm_LLVMBlock bp - | PExpr_EqShape _ _ <- llvmBlockShape bp -> - bvEq (llvmBlockOffset bp) off && - bvEq (llvmBlockLen bp) len - _ -> False) ps = - implElimAppendIthLLVMBlock x ps i >>>= \ps' -> - proveVarLLVMBlocks x ps' psubst (mb_bp:mb_bps) - - --- For an unfoldable named shape, prove its unfolding first and then fold it -proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps - | [nuMP| PExpr_NamedShape _ _ mb_nmsh _ |] <- mb_sh - , Just mb_bp' <- mbUnfoldModalizeNamedShapeBlock mb_bp = - - -- Recurse using the unfolded shape - (if mbNamedShapeIsRecursive mb_nmsh then implSetRecRecurseRightM - else return ()) >>> - proveVarLLVMBlocks x ps psubst (mb_bp' : mb_bps) >>> - - -- Extract out the block perm we proved - getTopDistConj "proveVarLLVMBlocks2" x >>>= \ps_out -> - let (ps_out_hd, ps_out') = expectLengthAtLeastOne ps_out - bp = case ps_out_hd of - Perm_LLVMBlock bp_ -> bp_ - _ -> error "proveVarLLVMBlocks2: expected block permission" in - implSplitSwapConjsM x ps_out 1 >>> - - -- Fold the named shape - partialSubstForceM (mbLLVMBlockShape mb_bp) "proveVarLLVMBlocks" >>>= \sh -> - let bp' = bp { llvmBlockShape = sh } in - implIntroLLVMBlockNamed x bp' >>> - - -- Finally, recombine the resulting permission with the rest of them - implSwapInsertConjM x (Perm_LLVMBlock bp') ps_out' 0 - - --- If proving an opaque named shape, the only way to prove the memblock --- 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 - | [nuMP| PExpr_NamedShape _ _ mb_nmsh _ |] <- mb_sh - , FalseRepr <- mbNamedShapeCanUnfoldRepr mb_nmsh - , Just off <- partialSubst psubst $ mbLLVMBlockOffset mb_bp - , Just i <- findIndex (\case - p@(Perm_LLVMBlock _) -> - isJust (llvmPermContainsOffset off p) - _ -> False) ps - , Perm_LLVMBlock _ <- ps!!i = - implElimAppendIthLLVMBlock x ps i >>>= \ps' -> - proveVarLLVMBlocks x ps' psubst (mb_bp:mb_bps) - - --- If proving an equality shape eqsh(len,z) for evar z which has already been --- set, substitute for z and recurse -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 = - let mb_bp' = - fmap (\bp -> - case llvmBlockShape bp of - PExpr_EqShape len _ -> - bp { llvmBlockShape = PExpr_EqShape len blk } - _ -> error "proveVarLLVMBlocks2: expected eq shape") mb_bp in - proveVarLLVMBlocks x ps psubst (mb_bp' : mb_bps) - - --- If proving an equality shape eqsh(len,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 - | [nuMP| PExpr_EqShape mb_len (PExpr_Var mb_z) |] <- mb_sh - , Left memb <- mbNameBoundP mb_z - , Just len <- partialSubst psubst mb_len - , Nothing <- psubstLookup psubst memb = - - -- Locally bind z_sh for the shape of the memblock perm and recurse - let mb_bp' = - mbCombine RL.typeCtxProxies $ flip mbMapCl mb_bp $ - $(mkClosed [| \bp -> nu $ \z_sh -> - bp { llvmBlockShape = PExpr_Var z_sh } |]) in - proveVarLLVMBlocksExt1 x ps psubst mb_bp' mb_bps >>> - - -- Extract out the block perm we proved - getTopDistConj "proveVarLLVMBlocks2" x >>>= \ps_out -> - let (ps_out_hd, ps_out') = expectLengthAtLeastOne ps_out - bp = case ps_out_hd of - Perm_LLVMBlock bp_ -> bp_ - _ -> error "proveVarLLVMBlocks2: expected block perm" in - implSplitSwapConjsM x ps_out 1 >>> - - -- Eliminate that block perm to have an equality shape, and set z to the - -- resulting block - implElimLLVMBlockToEq x bp >>>= \y_blk -> - let bp' = bp { llvmBlockShape = PExpr_EqShape len $ PExpr_Var y_blk } in - setVarM memb (PExpr_Var y_blk) >>> - - -- Finally, recombine the resulting permission with the rest of them - implSwapInsertConjM x (Perm_LLVMBlock bp') ps_out' 0 - - --- If z is a free variable, the only way to prove the memblock permission is to --- 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 - | [nuMP| PExpr_EqShape _ (PExpr_Var mb_z) |] <- mb_sh - , Right _ <- mbNameBoundP mb_z - , Just off <- partialSubst psubst $ mbLLVMBlockOffset mb_bp - , Just i <- findIndex (\case - p@(Perm_LLVMBlock _) -> - isJust (llvmPermContainsOffset off p) - _ -> False) ps - , Perm_LLVMBlock _ <- ps!!i = - implElimAppendIthLLVMBlock x ps i >>>= \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 - getTopDistConj "proveVarLLVMBlocks2" x >>>= \ps' -> - implExtractSwapConjM x ps' 0 >>> - - -- Use the SImpl_IntroLLVMBlockPtr rule to prove the required memblock perm - partialSubstForceM mb_bp "proveVarLLVMBlocks" >>>= \bp -> - implSimplM Proxy (SImpl_IntroLLVMBlockPtr x bp) >>> - - -- Finally, move the memblock perm we proved back into position - let (_, ps'') = expectLengthAtLeastOne ps' in - implSwapInsertConjM x (Perm_LLVMBlock bp) ps'' 0 - - --- If proving a field shape, prove the remaining blocks and then prove the --- corresponding field permission --- --- FIXME: instead of proving the field for this field shape after the remaining --- shapes, proveVarLLVMBlocks should collect all field and array shapes that --- need to be proved and bottom out with a call to proveVarConjImpl, so that --- each of these shapes is proved in the proper order to make sure all variables --- get determined. The current approach just happens to work because the only --- undetermined variables in shapes coming from Rust types most of the time are --- the lengths of slices, which are stored after the array. -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 = - - -- Recursively prove the remaining block permissions - proveVarLLVMBlocks x ps psubst mb_bps >>> - getTopDistConj "proveVarLLVMBlocks2" x >>>= \ps' -> - - -- Prove the corresponding field permission - proveVarImplInt x (mbValPerm_LLVMField mb_fp) >>> - getTopDistPerm x >>>= \case - (ValPerm_LLVMField fp) -> - -- Finally, convert the field perm to a block and move it into position - implSimplM Proxy (SImpl_IntroLLVMBlockField x fp) >>> - implSwapInsertConjM x (Perm_LLVMBlock $ llvmFieldPermToBlock fp) ps' 0 - _ -> error "proveVarLLVMBlocks2: expected field permission" - - --- If proving an array shape, prove the remaining blocks and then prove the --- corresponding array permission --- --- FIXME: see above FIXME on proving field shapes -proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps - | [nuMP| PExpr_ArrayShape _ _ _ |] <- mb_sh = - -- Recursively prove the remaining block permissions - proveVarLLVMBlocks x ps psubst mb_bps >>> - getTopDistConj "proveVarLLVMBlocks2" x >>>= \ps' -> - - -- Prove the corresponding array permission - proveVarImplInt x (mbMapCl $(mkClosed [| ValPerm_LLVMArray . fromJust . - llvmBlockPermToArray |]) mb_bp) >>> - getTopDistPerm x >>>= \case - ValPerm_LLVMArray ap -> - -- Finally, convert the array perm to a block and move it into position - implSimplM Proxy (SImpl_IntroLLVMBlockArray x ap) >>> - implSwapInsertConjM x (Perm_LLVMBlock $ fromJust $ - llvmArrayPermToBlock ap) ps' 0 - _ -> error "proveVarLLVMBlocks2: expected array permission" - --- If proving a tuple shape, prove the contents of the tuple and add the tuple -proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps - | [nuMP| PExpr_TupShape _ |] <- mb_sh = - - -- Recursively call proveVarLLVMBlocks with sh in place of tuplesh(sh) - let mb_bp' = mbMapCl $(mkClosed - [| \bp -> - case llvmBlockShape bp of - PExpr_TupShape sh -> - bp { llvmBlockShape = sh } - _ -> error "proveVarLLVMBlocks2: expected tuple shape" - |]) mb_bp in - proveVarLLVMBlocks x ps psubst (mb_bp':mb_bps) >>> - - -- Extract the sh permission from the top of the stack and tuple it - getTopDistConj "proveVarLLVMBlocks2" x >>>= \ps' -> - implExtractSwapConjM x ps' 0 >>> - let (ps_hd', ps'') = expectLengthAtLeastOne ps' - bp = case ps_hd' of - Perm_LLVMBlock bp_ -> bp_ - _ -> panic "proveVarLLVMBlocks2" ["expected block permission"] - sh = llvmBlockShape bp in - implSimplM Proxy (SImpl_IntroLLVMBlockTuple x bp) >>> - - -- Finally, put the new tuplesh(sh) permission back in place - implSwapInsertConjM x (Perm_LLVMBlock - (bp { llvmBlockShape = PExpr_TupShape sh })) - ps'' 0 - --- If proving a sequence shape with an unneeded empty shape, i.e., of the form --- sh1;emptysh where the length of sh1 equals the entire length of the required --- memblock permission, then prove sh1 by itself and then add the empty shape -proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps - | [nuMP| PExpr_SeqShape _ PExpr_EmptyShape |] <- mb_sh - , mbLift $ mbMapCl $(mkClosed - [| \bp -> - case llvmBlockShape bp of - PExpr_SeqShape sh1 _ -> - bvEq (llvmBlockLen bp) (fromJust $ - llvmShapeLength sh1) - _ -> error "proveVarLLVMBlocks2: expected seq shape" - |]) mb_bp = - -- Recursively call proveVarLLVMBlocks with sh1 in place of sh1;emptysh - let mb_bp' = mbMapCl $(mkClosed - [| \bp -> - case llvmBlockShape bp of - PExpr_SeqShape sh1 _ -> - bp { llvmBlockShape = sh1 } - _ -> error "proveVarLLVMBlocks2: expected seq shape" - |]) mb_bp in - proveVarLLVMBlocks x ps psubst (mb_bp':mb_bps) >>> - - -- Extract the sh1 permission from the top of the stack and sequence an - -- empty shape onto the end of it - getTopDistConj "proveVarLLVMBlocks2" x >>>= \ps' -> - implExtractSwapConjM x ps' 0 >>> - let (ps_hd', ps'') = expectLengthAtLeastOne ps' - bp = case ps_hd' of - Perm_LLVMBlock bp_ -> bp_ - _ -> error "proveVarLLVMBlocks2: expected block permission" - sh1 = llvmBlockShape bp in - implSimplM Proxy (SImpl_IntroLLVMBlockSeqEmpty x bp) >>> - - -- Finally, put the new sh1;emptysh permission back in place - implSwapInsertConjM x (Perm_LLVMBlock - (bp { llvmBlockShape = - PExpr_SeqShape sh1 PExpr_EmptyShape })) - ps'' 0 - - --- If proving a sequence shape otherwise, 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 - | [nuMP| PExpr_SeqShape mb_sh1 _ |] <- mb_sh - , mbLift $ mbMapCl $(mkClosed [| isJust . llvmShapeLength |]) mb_sh1 = - - -- Add the two shapes to mb_bps and recursively call proveVarLLVMBlocks - let mb_bps12 = - mbMapCl - $(mkClosed [| \bp -> - let (sh1,sh2) = case llvmBlockShape bp of - PExpr_SeqShape sh1_ sh2_ -> (sh1_,sh2_) - _ -> error "proveVarLLVMBlocks2: expected seq shape" in - let len1 = fromJust (llvmShapeLength sh1) in - [bp { llvmBlockLen = len1, llvmBlockShape = sh1 }, - 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) >>> - - -- Move the block permissions we proved to the top of the stack - getTopDistConj "proveVarLLVMBlocks2" x >>>= \ps' -> - let (bp1,bp2,ps'') = - (case ps' of - (Perm_LLVMBlock bp1_ : Perm_LLVMBlock bp2_ : ps''_) -> - (bp1_,bp2_,ps''_) - _ -> error "proveVarLLVMBlocks2: expected 2 block permissions") - len2 = llvmBlockLen bp2 - sh2 = llvmBlockShape bp2 in - implSplitSwapConjsM x ps' 2 >>> - - -- Use the SImpl_IntroLLVMBlockSeq rule combine them into one memblock perm - implSplitConjsM x [Perm_LLVMBlock bp1, Perm_LLVMBlock bp2] 1 >>> - implSimplM Proxy (SImpl_IntroLLVMBlockSeq x bp1 len2 sh2) >>> - - -- Finally, move the memblock perm we proved back into position - partialSubstForceM mb_bp "proveVarLLVMBlock" >>>= \bp -> - implSwapInsertConjM x (Perm_LLVMBlock bp) ps'' 0 - - --- 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 = - - -- 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; if e_tag is - -- known to be different from all possible tags, we can fail right away; - -- 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 - (bvMatchConst -> Just _) -> - implFailVarM - "proveVarLLVMBlock (tag does not match any in disjuctive shape)" - x (ValPerm_Conj ps) (mbValPerm_LLVMBlock mb_bp) - _ -> - let len = - mbLift $ mbMapCl $(mkClosed [| length . - taggedUnionDisjs |]) mb_tag_u in - foldr1 (implCatchM "proveVarLLVMBlocks2" - (ColonPair x (mb_bp:mb_bps))) $ - 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 - proveVarLLVMBlocks x ps' psubst (mbTaggedUnionNthDisjBlock i mb_bp - : mb_bps) >>> - - -- Move the block permission with shape mb_sh to the top of the stack - getTopDistConj "proveVarLLVMBlocks2" x >>>= \ps'' -> - implExtractSwapConjM x ps'' 0 >>> - - -- Finally, weaken the block permission to be the desired tagged union - -- shape, and move it back into position - let (_, ps''') = expectLengthAtLeastOne ps'' in - partialSubstForceM mb_shs "proveVarLLVMBlock" >>>= \shs -> - partialSubstForceM mb_bp "proveVarLLVMBlock" >>>= \bp -> - implIntroOrShapeMultiM x bp shs i >>> - implSwapInsertConjM x (Perm_LLVMBlock bp) ps''' 0 - - --- If proving a disjunctive shape, try to prove one of the disjuncts -proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps - | [nuMP| PExpr_OrShape _ _ |] <- mb_sh = - - -- Build a computation that tries returning True here, and if that fails - -- returns False; True is used for sh1 while False is used for sh2 - implCatchM "proveVarLLVMBlocks2" (ColonPair x (mb_bp:mb_bps)) - (pure True) (pure False) >>>= \is_case1 -> - - -- Prove the chosen shape by recursively calling proveVarLLVMBlocks - let mb_bp' = mbDisjBlockToSubShape is_case1 mb_bp in - proveVarLLVMBlocks x ps psubst (mb_bp' : mb_bps) >>> - - -- Move the block permission we proved to the top of the stack - getTopDistConj "proveVarLLVMBlocks2" x >>>= \ps' -> - implSplitSwapConjsM x ps' 1 >>> - - -- Prove the disjunction of the two memblock permissions - partialSubstForceM mb_bp "proveVarLLVMBlock" >>>= \bp -> - let (sh1, sh2) = case llvmBlockShape bp of - PExpr_OrShape sh1' sh2' -> (sh1',sh2') - _ -> error "proveVarLLVMBlocks2: expected or shape" in - let introM = if is_case1 then introOrLM else introOrRM in - introM x (ValPerm_LLVMBlock $ bp { llvmBlockShape = sh1 }) - (ValPerm_LLVMBlock $ bp { llvmBlockShape = sh2 }) >>> - - -- Now coerce the disjunctive permission on top of the stack to an or shape, - -- and move it back into position - let (_, ps'') = expectLengthAtLeastOne ps' in - implSimplM Proxy (SImpl_IntroLLVMBlockOr - x (bp { llvmBlockShape = sh1 }) sh2) >>> - implSwapInsertConjM x (Perm_LLVMBlock bp) ps'' 0 - - --- If proving an existential shape, introduce an evar and recurse -proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps - | [nuMP| PExpr_ExShape mb_mb_sh |] <- mb_sh - , (_ :: Mb ctx (Binding a (PermExpr (LLVMShapeType w)))) <- mb_mb_sh - , a <- knownRepr :: TypeRepr a - , mb_bp' <- mbExBlockToSubShape a mb_bp = - - -- Prove the sub-shape in the context of a new existential variable - proveVarLLVMBlocksExt1 x ps psubst mb_bp' mb_bps >>>= \e -> - - -- Move the block permission we proved to the top of the stack - getTopDistConj "proveVarLLVMBlocks2" x >>>= \ps' -> - implSplitSwapConjsM x ps' 1 >>> - - -- Prove an existential around the memblock permission we proved - partialSubstForceM mb_bp "proveVarLLVMBlock" >>>= \bp_out -> - introExistsM x e (mbValPerm_LLVMBlock $ exBlockToSubShape a bp_out) >>> - - -- Now coerce the existential permission on top of the stack to a memblock - -- perm with existential shape, and move it back into position - let (_, ps'') = expectLengthAtLeastOne ps' in - implSimplM Proxy (SImpl_IntroLLVMBlockEx x bp_out) >>> - implSwapInsertConjM x (Perm_LLVMBlock bp_out) ps'' 0 - - --- If proving an evar shape that has already been set, substitute and recurse -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) - - --- 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 - | [nuMP| PExpr_Var mb_z |] <- mb_sh - , Left memb <- mbNameBoundP mb_z - , Nothing <- psubstLookup psubst memb - , Just len <- partialSubst psubst (mbLLVMBlockLen mb_bp) - , bvIsZero len = - setVarM memb PExpr_EmptyShape >>> - let mb_bp' = mbMapCl $(mkClosed - [| \bp -> bp { llvmBlockShape = - PExpr_EmptyShape } |]) mb_bp in - proveVarLLVMBlocks x ps psubst (mb_bp' : mb_bps) - - --- If the shape of mb_bp is an unset variable z, mb_bp has a fixed constant --- length, and there is an any permission on the left, recursively prove a --- memblock permission with shape fieldsh(any) -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 - , elem Perm_Any ps - , Just len <- partialSubst psubst (mbLLVMBlockLen mb_bp) - , Just len_int <- bvMatchConstInt len - , Just (Some (sz :: NatRepr sz)) <- someNat (8 * len_int) - , Left LeqProof <- decideLeq (knownNat @1) sz - , p <- ValPerm_Any :: ValuePerm (LLVMPointerType sz) = - setVarM memb (withKnownNat sz $ PExpr_FieldShape $ LLVMFieldShape p) >>> - getPSubst >>>= \psubst' -> - proveVarLLVMBlocks2 x ps psubst' mb_bp mb_sh mb_bps - --- If the shape of mb_bp is an unset variable z and there is a field permission --- on the left that contains all the offsets of mb_bp, recursively prove a --- memblock permission with shape fieldsh(eq(y)) for fresh evar y, which is the --- most general field permission -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 - , Just off <- partialSubst psubst (mbLLVMBlockOffset mb_bp) - , Just len <- partialSubst psubst (mbLLVMBlockLen mb_bp) - , Just i <- findIndex (llvmPermContainsOffsetBool off) ps - , Perm_LLVMField fp <- ps!!i - , len1 <- bvSub (llvmFieldEndOffset fp) off - , bvLeq len len1 - , Just len1_int <- bvMatchConstInt len1 - , Just (Some (sz1 :: NatRepr sz1)) <- someNat (8 * len1_int) - , Left LeqProof <- decideLeq (knownNat @1) sz1 = - - -- Recursively prove a membblock with shape fieldsh(eq(y)) for fresh evar y - withKnownNat sz1 $ - let mb_bp' = - mbCombine (MNil :>: (Proxy :: Proxy (LLVMPointerType sz1))) $ - mbMapCl $(mkClosed - [| \bp -> nu $ \y -> - bp { llvmBlockShape = - PExpr_FieldShape $ LLVMFieldShape $ - ValPerm_Eq $ PExpr_Var y } |]) mb_bp in - 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 - -- and in the correct spot on the stack - setVarM memb (PExpr_FieldShape $ LLVMFieldShape $ ValPerm_Eq e) - - --- If the shape of mb_bp is an unset variable z and there is an array permission --- on the left that contains all the offsets of mb_bp, recursively prove a --- memblock permission with the corresponding array shape -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 - , Just off <- partialSubst psubst (mbLLVMBlockOffset mb_bp) - , Just len <- partialSubst psubst (mbLLVMBlockLen mb_bp) - , Just i <- findIndex (llvmPermContainsOffsetBool off) ps - , (Perm_LLVMArray ap) <- ps!!i - , Just (LLVMArrayIndex bp_cell (BV.BV 0)) <- matchLLVMArrayIndex ap off - , bvIsZero (bvMod len (llvmArrayStride ap)) - , sh_len <- bvDiv len (llvmArrayStride ap) - , bvLeq (bvAdd bp_cell sh_len) (llvmArrayLen ap) - , sh <- PExpr_ArrayShape sh_len (llvmArrayStride ap) (llvmArrayCellShape ap) = - setVarM memb sh >>> - proveVarLLVMBlocks x ps psubst - (fmap (\bp -> bp { llvmBlockShape = sh }) mb_bp : mb_bps) - - --- If the shape of mb_bp is an unset variable z and there is a block permission --- on the left with the required offset and length, set z to the shape of that --- block permission and recurse. Note that proveVarLLVMBlocks1 removes the case --- where there is a block permission that overlaps with mb_bp. -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 - , Just off <- partialSubst psubst (mbLLVMBlockOffset mb_bp) - , Just len <- partialSubst psubst (mbLLVMBlockLen mb_bp) - , Just i <- findIndex (llvmPermContainsOffsetBool off) ps - , (Perm_LLVMBlock bp_lhs) <- ps!!i - , bvEq off (llvmBlockOffset bp_lhs) - , bvEq len (llvmBlockLen bp_lhs) - , sh_lhs <- llvmBlockShape bp_lhs = - setVarM memb sh_lhs >>> - proveVarLLVMBlocks x ps psubst - (fmap (\bp -> bp { llvmBlockShape = sh_lhs }) mb_bp : mb_bps) - - --- If z is unset and there is an atomic permission that contains the required --- offset of mb_bp but is shorter than mb_bp, split mb_bp into two memblock --- permissions with unknown shapes but where the first has the length of this --- atomic permission, and then recurse -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 - , Just off <- partialSubst psubst (mbLLVMBlockOffset mb_bp) - , Just len <- partialSubst psubst (mbLLVMBlockLen mb_bp) - , Just i <- findIndex (llvmPermContainsOffsetBool off) ps - , Just end_lhs <- llvmAtomicPermEndOffset (ps!!i) - , len1 <- bvSub end_lhs off - , bvLt len1 len = - - -- Build existential memblock perms with fresh variables for shapes, where - -- the first one has the length of the atomic perm we found and the other - -- has the remaining length, and recurse - let mb_bps12 = - mbCombine RL.typeCtxProxies $ flip fmap mb_bp $ \bp -> - nuMulti (MNil :>: Proxy :>: Proxy) $ \(_ :>: z_sh1 :>: z_sh2) -> - [bp { llvmBlockLen = len1, llvmBlockShape = PExpr_Var z_sh1 }, - 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 >>> - - -- Move the two block permissions we proved to the top of the stack - getTopDistPerm x >>>= \p_top -> - (case p_top of - ValPerm_Conj - ps_ret@(Perm_LLVMBlock bp1 : Perm_LLVMBlock bp2 : ps_ret') -> - return (ps_ret, bp1, bp2, ps_ret') - _ -> error "proveVarLLVMBlocks2: unexpected permission on top of the stack") - >>>= \(ps_ret, bp1, bp2, ps_ret') -> - let len2 = llvmBlockLen bp2 - sh2 = llvmBlockShape bp2 in - implSplitSwapConjsM x ps_ret 2 >>> - implSplitConjsM x (map Perm_LLVMBlock [bp1,bp2]) 1 >>> - - -- Sequence these two block permissions together - implSimplM Proxy (SImpl_IntroLLVMBlockSeq x bp1 len2 sh2) >>> - let bp = bp1 { llvmBlockLen = bvAdd (llvmBlockLen bp1) len2, - llvmBlockShape = PExpr_SeqShape (llvmBlockShape bp1) sh2 } in - - -- Finally, set z to the memblock permission we ended up proving, and move - -- this proof back into position - setVarM memb (llvmBlockShape bp) >>> - implSwapInsertConjM x (Perm_LLVMBlock bp) ps_ret' 0 - - -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 ----------------------------------------------------------------------- - --- | 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' -> - 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 >>> - recombinePerm x (ValPerm_Conj $ deleteNth i ps) >>> - implNamedFromConjM x npn args off >>> - implUnfoldNamedM x npn args off >>>= \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) - - -- 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 --- unfolding of @P@ folding it. Assume that @x:p1@ is on top of the stack. -proveVarImplFoldRight :: NuMatchingAny1 r => ExprVar a -> ValuePerm a -> - Mb vars (ValuePerm a) -> - ImplM vars s r (ps :> a) (ps :> a) () -proveVarImplFoldRight x p mb_p = case mbMatch mb_p of - [nuMP| ValPerm_Named mb_npn mb_args mb_off |] - | npn <- mbLift mb_npn - , TrueRepr <- nameCanFoldRepr npn -> - (case namedPermNameSort npn of - RecursiveSortRepr _ _ -> implSetRecRecurseRightM - _ -> pure ()) >>> - implLookupNamedPerm npn >>>= \np -> - recombinePerm x p >>> - -- FIXME: how to replace this mbMap2 with mbMapCl, to avoid refreshing all - -- the names in mb_args and mb_off? Maybe they aren't that big anyway... - proveVarImplInt x (mbMap2 (unfoldPerm np) mb_args mb_off) >>> - partialSubstForceM mb_args "proveVarImplFoldRight" >>>= \args -> - partialSubstForceM mb_off "proveVarImplFoldRight" >>>= \off -> - implFoldNamedM x npn args off - _ -> - error ("proveVarImplFoldRight: malformed inputs") - - ----------------------------------------------------------------------- --- * Proving Atomic Permissions ----------------------------------------------------------------------- - --- | We were not able to prove @x:(p1 * ... * pn) |- x:p@ as is, so try --- unfolding named permissions in the @pi@s as a last resort. If there are none, --- or our recursion flag does not allow it, then fail. -proveVarAtomicImplUnfoldOrFail :: NuMatchingAny1 r => ExprVar a -> - [AtomicPerm a] -> Mb vars (AtomicPerm a) -> - ImplM vars s r (ps :> a) (ps :> a) () -proveVarAtomicImplUnfoldOrFail x ps mb_ap = - 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 --- the LHS is on the top of the stack and represents all the permissions on @x@, --- i.e., we also assume the variable permissions for @x@ are currently --- @true@. Any remaining perms for @x@ are popped off of the stack. -proveVarAtomicImpl :: - NuMatchingAny1 r => - HasCallStack => - ExprVar a -> - [AtomicPerm a] -> - Mb vars (AtomicPerm a) -> - ImplM vars s r (ps :> a) (ps :> a) () -proveVarAtomicImpl x ps mb_p = case mbMatch mb_p of - - [nuMP| Perm_LLVMField mb_fp |] -> - partialSubstForceM (mbLLVMFieldOffset mb_fp) "proveVarPtrPerms" >>>= \off -> - proveVarLLVMField x ps off mb_fp - [nuMP| Perm_LLVMArray mb_ap |] -> proveVarLLVMArray x ps mb_ap - [nuMP| Perm_LLVMBlock mb_bp |] -> proveVarLLVMBlock x ps mb_bp - - [nuMP| Perm_LLVMFree mb_e |] -> - partialSubstForceM mb_e "proveVarAtomicImpl" >>>= \e -> - case findMaybeIndices (\case - Perm_LLVMFree e' -> Just e' - _ -> Nothing) ps of - (i, e'):_ -> - implCopyConjM x ps i >>> recombinePerm x (ValPerm_Conj ps) >>> - castLLVMFreeM x e' e - _ -> proveVarAtomicImplUnfoldOrFail x ps mb_p - - [nuMP| Perm_LLVMFunPtr tp mb_p' |] -> - partialSubstForceM mb_p' "proveVarAtomicImpl" >>>= \p -> - case elemIndex (Perm_LLVMFunPtr (mbLift tp) p) ps of - Just i -> implCopyConjM x ps i >>> recombinePerm x (ValPerm_Conj ps) - _ -> proveVarAtomicImplUnfoldOrFail x ps mb_p - - [nuMP| Perm_IsLLVMPtr |] - | Just i <- elemIndex Perm_IsLLVMPtr ps -> - implCopyConjM x ps i >>> recombinePerm x (ValPerm_Conj ps) - - [nuMP| Perm_IsLLVMPtr |] - | Just i <- findIndex isLLVMFieldPerm ps - , p@(Perm_LLVMField fp) <- ps !! i -> - implExtractConjM x ps i >>> recombinePerm x (ValPerm_Conj $ deleteNth i ps) >>> - implSimplM Proxy (SImpl_LLVMFieldIsPtr x fp) >>> - implPushM x (ValPerm_Conj $ deleteNth i ps) >>> - implInsertConjM x p (deleteNth i ps) i >>> - recombinePerm x (ValPerm_Conj ps) - - [nuMP| Perm_IsLLVMPtr |] - | Just i <- findIndex isLLVMArrayPerm ps - , p@(Perm_LLVMArray ap) <- ps !! i -> - implExtractConjM x ps i >>> recombinePerm x (ValPerm_Conj $ deleteNth i ps) >>> - implSimplM Proxy (SImpl_LLVMArrayIsPtr x ap) >>> - implPushM x (ValPerm_Conj $ deleteNth i ps) >>> - implInsertConjM x p (deleteNth i ps) i >>> - recombinePerm x (ValPerm_Conj ps) - - [nuMP| Perm_IsLLVMPtr |] - | Just i <- findIndex isLLVMBlockPerm ps - , p@(Perm_LLVMBlock bp) <- ps !! i -> - implExtractConjM x ps i >>> recombinePerm x (ValPerm_Conj $ deleteNth i ps) >>> - implSimplM Proxy (SImpl_LLVMBlockIsPtr x bp) >>> - implPushM x (ValPerm_Conj $ deleteNth i ps) >>> - implInsertConjM x p (deleteNth i ps) i >>> - recombinePerm x (ValPerm_Conj ps) - - [nuMP| Perm_IsLLVMPtr |] -> - proveVarAtomicImplUnfoldOrFail x ps mb_p - - [nuMP| Perm_LLVMBlockShape mb_sh |] - | Just i <- findIndex (\case - Perm_LLVMBlockShape _ -> True - _ -> False) ps - , Perm_LLVMBlockShape sh <- ps!!i -> - implGetPopConjM x ps i >>> - proveEqCast x (ValPerm_Conj1 . Perm_LLVMBlockShape) sh mb_sh - - [nuMP| Perm_NamedConj mb_n mb_args mb_off |] -> - let n = mbLift mb_n in - proveVarImplH x (ValPerm_Conj ps) (mbMap2 (ValPerm_Named n) - mb_args mb_off) >>> - partialSubstForceM mb_args "proveVarAtomicImpl" >>>= \args -> - partialSubstForceM mb_off "proveVarAtomicImpl" >>>= \off -> - implNamedToConjM x n args off - - [nuMP| Perm_LLVMFrame mb_fperms |] - | [Perm_LLVMFrame fperms] <- ps -> - proveEq fperms mb_fperms >>>= \eqp -> - implCastPermM Proxy x (fmap (ValPerm_Conj1 . Perm_LLVMFrame) eqp) - - -- FIXME HERE: eventually we should handle lowned permissions on the right - -- with arbitrary contained lifetimes, by equalizing the two sides - [nuMP| Perm_LOwned [] _ _ _ _ |] - | [Perm_LOwned (PExpr_Var l2:_) _ _ _ _] <- ps -> - recombinePerm x (ValPerm_Conj ps) >>> implEndLifetimeRecM l2 >>> - proveVarImplInt x (mbValPerm_Conj1 mb_p) - - [nuMP| Perm_LOwned [] mb_tps_inR mb_tps_outR mb_ps_inR mb_ps_outR |] - | [Perm_LOwned [] tps_inL tps_outL ps_inL ps_outL] <- ps - , tps_inR <- mbLift mb_tps_inR - , tps_outR <- mbLift mb_tps_outR -> - - -- Compute the necessary "permission subtractions" to figure out what - -- additional permissions are needed to prove both ps_inR -o ps_inL and - -- ps_outL -o ps_outR. These required permissions are called ps1 and ps2, - -- respectively. Note that the RHS for both of these implications needs to - -- be in a name-binding for the evars and the LHS needs to not be in a - -- name-binding, so ps_inR cannot have any evars. - partialSubstForceM mb_ps_inR "proveVarAtomicImpl" >>>= \ps_inR -> - let mb_ps_inL = mbConst ps_inL mb_ps_inR in - solveForPermListImpl ps_inR tps_inL mb_ps_inL >>>= \(Some neededs1) -> - solveForPermListImpl ps_outL tps_outR mb_ps_outR >>>= \(Some neededs2) -> - - -- Prove neededs1 and neededs2 along with their corresponding auxiliary - -- permissions, and then look at the substitution instances of these - -- permissions that were actually proved on top of the stack. We do it - -- this way because we can't substitute expressions for variables in a - -- DistPerms, because DistPerms need to have variables on the LHSs and not - -- arbitrary expressions - implTraceM (\i -> hang 2 - (pretty "Proving needed perms for lowned implication:" - <> line <> permPretty i neededs1 <> line <> - pretty "And:" <> line <> permPretty i neededs2)) >>> - getVarProxies >>>= \vars -> - getDistPermsProxies >>>= \prxs0_a -> - let prxs0 = RL.tail prxs0_a in - proveNeededPerms vars neededs1 >>>= \(Some auxs1) -> - mbVarsM auxs1 >>>= \mb_auxs1 -> - proveVarsImplAppendIntAssoc prxs0_a neededs1 mb_auxs1 >>> - let prxs1 = rlToProxies neededs1 `RL.append` rlToProxies auxs1 in - proveNeededPermsAssoc vars prxs0_a prxs1 neededs2 >>>= \(Some auxs2) -> - mbVarsM auxs2 >>>= \mb_auxs2 -> - proveVarsImplAppendIntAssoc4 prxs0_a prxs1 neededs2 mb_auxs2 >>> - let prxs2 = rlToProxies neededs2 `RL.append` rlToProxies auxs2 - prxs12 = RL.append prxs1 prxs2 in - getTopDistPerms prxs0_a prxs12 >>>= \ps12 -> - let (ps1,ps2) = RL.split prxs1 prxs2 ps12 in - partialSubstForceM mb_ps_outR "proveVarAtomicImpl" >>>= \ps_outR -> - - -- Build the local implications ps_inR -o ps_inL and ps_outL -o ps_outR - (case (exprPermsToDistPerms ps_inL, exprPermsToDistPerms ps_outL, - exprPermsToDistPerms ps_inR, exprPermsToDistPerms ps_outR) of - (Just dps_inL, Just dps_outL, Just dps_inR, Just dps_outR) -> - pure (dps_inL, dps_outL, dps_inR, dps_outR) - _ -> implFailM (LifetimeError ImplicationLifetimeError)) - >>>= \(dps_inL, dps_outL, dps_inR, dps_outR) -> - localProveVars (RL.append ps1 dps_inR) dps_inL >>>= \impl_in -> - localProveVars (RL.append ps2 dps_outL) dps_outR >>>= \impl_out -> - - -- Finally, apply the MapLifetime proof step, first moving the input - -- lowned permissions to the top of the stack - implMoveUpM prxs0 ps12 x MNil >>> - implSimplM Proxy (SImpl_MapLifetime x [] - tps_inL tps_outL ps_inL ps_outL - tps_inR tps_outR ps_inR ps_outR - ps1 ps2 impl_in impl_out) - - [nuMP| Perm_LOwnedSimple mb_tps mb_lops |] - | Just mb_dps <- mbMaybe (mbMapCl - $(mkClosed [| exprPermsToDistPerms |]) mb_lops) -> - -- Pop the permissions for x, and prove the mb_lops permissions that are - -- going to be borrowed by the lifetime x - implPopM x (ValPerm_Conj ps) >>> - getDistPerms >>>= \(ps0 :: DistPerms ps0) -> - proveVarsImplAppendInt mb_dps >>> - partialSubstForceM mb_lops "proveVarAtomicImpl" >>>= \lops -> - - -- Prove an empty lowned permission for x - mbVarsM (distPerms1 x $ - ValPerm_LOwned [] CruCtxNil CruCtxNil MNil MNil) >>>= \mb_p' -> - proveVarsImplAppendInt mb_p' >>> - - -- Coerce the lowned permission to a simple lowned permission, and then - -- recombine all the resulting permissions for mb_lops - let tps = mbLift mb_tps in - implSimplM (Proxy :: Proxy ps0) (SImpl_IntroLOwnedSimple x tps lops) >>> - getDistPerms >>>= \perms -> - let (_, ps_lops_l@(ps_lops :>: p_l)) = - RL.split ps0 (rlToProxies lops :>: Proxy) perms in - implMoveDownM ps0 ps_lops_l x MNil >>> - recombinePermsPartial (ps0 :>: p_l) ps_lops - - [nuMP| Perm_LCurrent mb_l' |] -> - -- We are trying to prove x is current whenever l' is, meaning that the - -- duration of l' is guaranteed to be contained inside that of x - partialSubstForceM mb_l' "proveVarAtomicImpl" >>>= \l' -> - case ps of - _ | l' == PExpr_Var x -> - -- If l' == x, proceed by reflexivity of lcurrent - recombinePerm x (ValPerm_Conj ps) >>> - implSimplM Proxy (SImpl_LCurrentRefl x) - [Perm_LCurrent l] - -- If we already have x:lcurrent l' on the LHS, we are done - | l == l' -> pure () - [Perm_LCurrent (PExpr_Var l)] -> - -- If we have x:lcurrent l for some other l, prove l:lcurrent l' and - -- proceed by transitivity of lcurent - proveVarImplInt l (mbValPerm_Conj1 mb_p) >>> - implSimplM Proxy (SImpl_LCurrentTrans x l l') - [Perm_LOwned ls tps_in tps_out ps_in ps_out] - | elem l' ls -> - -- If we already have a lifetime ownership permission for x that - -- contains l' as a sub-lifetime, use that - implContainedLifetimeCurrentM x ls tps_in tps_out ps_in ps_out l' - [Perm_LOwned ls tps_in tps_out ps_in ps_out] - | PExpr_Var n' <- l' -> - -- If we have a lifetime ownership permission for x that does not - -- contain l', add l' as a sub-lifetime of x, but only if l' does not - -- already contain x - containedLifetimes n' >>>= \sub_ls -> - if elem x sub_ls then - proveVarAtomicImplUnfoldOrFail x ps mb_p - else - implSubsumeLifetimeM x ls tps_in tps_out ps_in ps_out l' >>> - implContainedLifetimeCurrentM x (l':ls) tps_in tps_out ps_in ps_out l' - _ -> proveVarAtomicImplUnfoldOrFail x ps mb_p - - [nuMP| Perm_LFinished |] -> - recombinePerm x (ValPerm_Conj ps) >>> implEndLifetimeRecM x >>> - implPushCopyM x ValPerm_LFinished - - -- If we have a struct permission on the left, eliminate it to a sequence of - -- variables and prove the required permissions for each variable - [nuMP| Perm_Struct mb_str_ps |] - | Just i <- findIndex isStructPerm ps - , Perm_Struct str_ps <- ps!!i -> - getDistPerms >>>= \perms -> - implGetPopConjM x ps i >>> implElimStructAllFields x str_ps >>>= \ys -> - proveVarsImplAppendInt (fmap (valuePermsToDistPerms ys) mb_str_ps) >>> - partialSubstForceM mb_str_ps "proveVarAtomicImpl" >>>= \str_ps' -> - implMoveUpM (distPermsSnoc perms) str_ps' x MNil >>> - implIntroStructAllFields x - - -- If we do not have a struct permission on the left, introduce a vacuous struct - -- permission and fall back to the previous case - [nuMP| Perm_Struct mb_str_ps |] -> - let prxs = mbLift $ fmap rlToProxies mb_str_ps in - implSimplM Proxy (SImpl_IntroStructTrue x prxs) >>> - implInsertConjM x (Perm_Struct $ trueValuePerms prxs) ps (length ps) >>> - proveVarAtomicImpl x (ps ++ [Perm_Struct $ trueValuePerms prxs]) mb_p - - -- NOTE: existential Perm_Fun vars don't seem to make sense, as they translate - -- to a weird form of polymorphism... - {- - [nuMP| Perm_Fun (PExpr_Var z) |] - | [Perm_Fun fun_perm] <- ps - , Left memb <- mbNameBoundP z -> - getPSubst >>>= \psubst -> - case psubstLookup psubst memb of - Just fun_perm' - | Just Refl <- funPermEq fun_perm fun_perm' -> pure () - Just _ -> implFailM - Nothing -> setVarM memb fun_perm - -} - - [nuMP| Perm_Fun mb_fun_perm |] -> - partialSubstForceM mb_fun_perm "proveVarAtomicImpl" >>>= \fun_perm' -> - foldr (\(i::Int,p) rest -> - case p of - Perm_Fun fun_perm - | Just (Refl,Refl,Refl,Refl) <- funPermEq4 fun_perm fun_perm' -> - implCopyConjM x ps i >>> recombinePerm x (ValPerm_Conj ps) - _ -> rest) - (proveVarAtomicImplUnfoldOrFail x ps mb_p) - (zip [0..] ps) - - [nuMP| Perm_BVProp mb_prop |] -> - recombinePerm x (ValPerm_Conj ps) >>> - partialSubstForceM mb_prop "proveVarAtomicImpl" >>>= \prop -> - implTryProveBVProp x prop - - [nuMP| Perm_Any |] - | Just i <- findIndex (== Perm_Any) ps -> - implCopyConjM x ps i >>> implPopM x (ValPerm_Conj ps) - - _ -> proveVarAtomicImplUnfoldOrFail x ps mb_p - - --- | Prove @x:(p1 * ... * pn) |- x:(p1' * ... * pm')@ assuming that the LHS --- conjunction is on the top of the stack, and push any leftover permissions for --- @x@ back to the primary permissions for @x@. --- --- The main complexity here is in dealing with the fact that both the left- and --- right-hand sides could contain recursive permissions. We can't unfold --- recursive permissions on both sides, because this could lead to an infinite --- loop, where proving the unfolded implication depends on proving another copy --- of the same implication. Instead, when we get to such a case, we have to pick --- one side or the other to unfold, and then disallow unfolding the other side. --- The exception is when we have an instance of the same recursive name on each --- side, in which case we can prove the right-hand one from the left-hand one --- and not unfold either side. --- --- Additionally, the existence of recursive names on either side could be masked --- by the existence of defined names that unfold to recursive names, so we have --- to resolve all the defined names first. --- --- Most of this machinery is actually handled by the 'proveVarImplH' cases for --- recursive and defined names. Here, we just have to make sure to prove defined --- names first, followed by recursive names and then other permissions. -proveVarConjImpl :: NuMatchingAny1 r => ExprVar a -> [AtomicPerm a] -> - Mb vars [AtomicPerm a] -> - ImplM vars s r (ps :> a) (ps :> a) () - --- If we are done, we are done -proveVarConjImpl x ps (mbMatch -> [nuMP| [] |]) = - recombinePerm x (ValPerm_Conj ps) >>> introConjM x - --- If there is a defined or recursive name on the right, prove it first, --- ensuring that we only choose recursive names if there are no defined ones, --- and that, in all cases, we choose a permission that is provable with the --- currently-set evars -proveVarConjImpl x ps_lhs mb_ps = - getPSubst >>>= \psubst -> - case mbMatch $ - mbMapClWithVars - ($(mkClosed - [| \unsetVarsBool ns ps -> - let unsetVars = nameSetFromFlags ns unsetVarsBool in - findBestIndex - (\p -> case isProvablePerm unsetVars Nothing (ValPerm_Conj1 p) of - rank | rank > 0 && isDefinedConjPerm p -> isProvablePermMax + 2 - rank | rank > 0 && isRecursiveConjPerm p -> isProvablePermMax + 1 - rank -> rank) - ps |]) - `clApply` toClosed (psubstUnsetVarsBool psubst)) mb_ps of - [nuMP| Just mb_i |] -> - let i = mbLift mb_i in - let mb_p = mbNth i mb_ps in - let mb_ps' = mbDeleteNth i mb_ps in - proveVarAtomicImpl x ps_lhs mb_p >>> - proveVarImplInt x (mbValPerm_Conj mb_ps') >>> - partialSubstForceM mb_ps' "proveVarConjImpl" >>>= \ps' -> - partialSubstForceM mb_p "proveVarConjImpl" >>>= \p -> - implInsertConjM x p ps' i - [nuMP| Nothing |] -> - use implStatePPInfo >>>= \ppinfo -> - implFailM $ InsufficientVariablesError $ - permPretty ppinfo (fmap ValPerm_Conj mb_ps) - - - ----------------------------------------------------------------------- --- * Proving Permission Implications ----------------------------------------------------------------------- - --- | Prove @x:p'@, where @p@ may have existentially-quantified variables in --- it. The \"@Int@\" suffix indicates that this call is internal to the --- implication prover, similar to 'proveVarsImplAppendInt', meaning that this --- version will not end lifetimes, which must be done at the top level. -proveVarImplInt :: NuMatchingAny1 r => ExprVar a -> Mb vars (ValuePerm a) -> - ImplM vars s r (ps :> a) ps () -proveVarImplInt x mb_p = - getPerm x >>>= \ !p -> - implPushM x p >>> - implTraceM (\i -> pretty "proveVarImpl:" <> softline <> ppImpl i x p mb_p) >>> - proveVarImplH x p mb_p >>> - - -- Check that the top of the stack == mb_p - partialSubstForceM mb_p "proveVarImpl" >>>= \p_req -> - getTopDistPerm x >>>= \p_actual -> - if p_req == p_actual then pure () else - implTraceM (\i -> - pretty "proveVarImpl: incorrect permission on top of the stack" <> softline <> - pretty "expected:" <+> permPretty i p_req <> softline <> - pretty "actual:" <+> permPretty i p_actual) >>>= error - --- | Prove @x:p'@ assuming that the primary permissions for @x@ have all been --- pushed to the top of the stack and are equal to @p@. Pop the remaining --- permissions for @x@ back to its primary permission when we are finished. -proveVarImplH :: NuMatchingAny1 r => ExprVar a -> ValuePerm a -> - Mb vars (ValuePerm a) -> - ImplM vars s r (ps :> a) (ps :> a) () -proveVarImplH x p mb_p = case (p, mbMatch mb_p) of - - -- Prove an empty conjunction trivially - (_, [nuMP| ValPerm_Conj [] |]) -> recombinePerm x p >>> introConjM x - - -- Prove x:eq(e) by calling proveVarEq; note that we do not eliminate - -- disjunctive permissions first because some trivial equalities do not require - -- any eq permissions on the left, and we do not eliminate equalities on the - -- left first because that may be the equality we are trying to prove! - (_, [nuMP| ValPerm_Eq e |]) -> recombinePerm x p >>> proveVarEq x e - - -- Eliminate any disjunctions and existentials on the left - (ValPerm_Or _ _, _) -> - elimOrsExistsM x >>>= \ !p' -> proveVarImplH x p' mb_p - - -- Eliminate any disjunctions and existentials on the left - (ValPerm_Exists _, _) -> - elimOrsExistsM x >>>= \ !p' -> proveVarImplH x p' mb_p - - -- Eliminate an equality permission for a variable on the left, i.e., prove x:p - -- from x:eq(y) by first proving y:p and then casting - (ValPerm_Eq (PExpr_Var y), _) -> - introEqCopyM x (PExpr_Var y) >>> - recombinePerm x p >>> - proveVarImplInt y mb_p >>> - partialSubstForceM mb_p "proveVarImpl" >>>= \p' -> - introCastM x y p' - - -- Prove x:eq(y &+ off) |- x:p by proving y:p@off and then casting - (ValPerm_Eq e@(PExpr_LLVMOffset y off), _) -> - introEqCopyM x e >>> recombinePerm x p >>> - proveVarImplInt y (fmap (offsetLLVMPerm off) mb_p) >>> - partialSubstForceM mb_p "proveVarImpl" >>>= \p_r -> - castLLVMPtrM y (offsetLLVMPerm off p_r) off x - - -- Prove x:(p1 \/ p2) by trying to prove x:p1 and x:p2 in two branches - (_, [nuMP| ValPerm_Or mb_p1 mb_p2 |]) -> - recombinePerm x p >>> - implCatchM "proveVarImplH" (ColonPair x mb_p) - (proveVarImplInt x mb_p1 >>> - partialSubstForceM mb_p1 "proveVarImpl" >>>= \p1 -> - partialSubstForceM mb_p2 "proveVarImpl" >>>= \p2 -> - introOrLM x p1 p2) - (proveVarImplInt x mb_p2 >>> - partialSubstForceM mb_p1 "proveVarImpl" >>>= \p1 -> - partialSubstForceM mb_p2 "proveVarImpl" >>>= \p2 -> - introOrRM x p1 p2) - - -- Prove x:exists (z:tp).p by proving x:p in an extended vars context - (_, [nuMP| ValPerm_Exists mb_p' |]) -> - withExtVarsM (proveVarImplH x p (mbCombine RL.typeCtxProxies mb_p')) >>>= \((), e) -> - partialSubstForceM mb_p' "proveVarImpl" >>>= - introExistsM x e - - -- If proving P |- P for the same reachability permission, - -- try to prove the RHS by either reflexivity, meaning x:eq(e2), or - -- transitivity, meaning e1:P - (ValPerm_Named npn args1 off, [nuMP| ValPerm_Named mb_npn mb_args2 mb_off |]) - | Just (Refl, Refl, Refl) <- testNamedPermNameEq npn (mbLift mb_npn) - , mbLift (fmap (offsetsEq off) mb_off) - , RecursiveSortRepr _ TrueRepr <- namedPermNameSort npn - , NameReachConstr <- namedPermNameReachConstr npn - , PExprs_Cons args1_pre e1 <- args1 - , [nuMP| PExprs_Cons mb_args2_pre mb_e2 |] <- mbMatch mb_args2 -> - implCatchM "proveVarImplH" (ColonPair x mb_p) - - -- Reflexivity branch: pop x:P<...>, prove x:eq(e), and use reflexivity - (recombinePerm x p >>> proveVarImplInt x (mbValPerm_Eq mb_e2) >>> - partialSubstForceM mb_args2 "proveVarImpl" >>>= \args2 -> - implReachabilityReflM x npn args2 off) - - -- Transitivity branch: copy x:P if possible, equalize the - -- arguments by proving x:P, introduce variable y:eq(e1), prove - -- y:P, and then finally use transitivity - (implMaybeCopyPopM x p >>> - proveNamedArgs x npn args1 off (fmap (:>: e1) mb_args2_pre) >>> - (case e1 of - PExpr_Var y -> pure y - _ -> - -- If e1 is not a variable, bind a fresh variable y:eq(e1), then - -- cast x:P to x:P - implGetVarType x >>>= \tp -> - implLetBindVar tp e1 >>>= \y -> - proveEqCast x (\z -> ValPerm_Named npn (args1_pre :>: z) off) e1 - (fmap (const $ PExpr_Var y) mb_npn) >>> - pure y) >>>= \y -> - proveVarImplInt y mb_p >>> - partialSubstForceM mb_args2 "proveVarImpl" >>>= \args2 -> - implReachabilityTransM x npn args2 off y) - - -- If proving P |- P for the same named permission, try to - -- equalize the arguments and the offsets using proveNamedArgs. Note that we - -- currently are *not* solving for offsets on the right, meaning that - -- proveVarImplInt will fail for offsets with existential variables in them. - (ValPerm_Named npn args off, [nuMP| ValPerm_Named mb_npn mb_args mb_off |]) - | Just (Refl, Refl, Refl) <- testNamedPermNameEq npn (mbLift mb_npn) - , mbLift (fmap (offsetsEq off) mb_off) -> - implMaybeCopyPopM x p >>> - proveNamedArgs x npn args off mb_args - - -- If proving x:p1 * ... * pn |- P@off where P@off for some args' - -- occurs as one of the pi, then reduce to the above case - -- - -- FIXME: if P is a defined permission, then it is possible that we can't prove - -- P |- P but could still prove x:p1 * ... |- P by unfolding - -- P, so we should also check that args' is compatible in some way with args - (ValPerm_Conj ps, [nuMP| ValPerm_Named mb_npn mb_args mb_off |]) - | npn <- mbLift mb_npn - , TrueRepr <- nameIsConjRepr npn - , (i, (args, off)):_ <- - findMaybeIndices (\case - Perm_NamedConj npn' args off - | Just (Refl, Refl, Refl) <- - testNamedPermNameEq npn npn' - , mbLift (fmap (offsetsEq off) mb_off) -> - Just (args, off) - _ -> Nothing) ps -> - implGetPopConjM x ps i >>> - implNamedFromConjM x npn args off >>> - proveNamedArgs x npn args off mb_args - - -- If proving P where P is defined, unfold P - (_, [nuMP| ValPerm_Named mb_npn _ _ |]) - | DefinedSortRepr _ <- namedPermNameSort $ mbLift mb_npn -> - proveVarImplFoldRight x p mb_p - - -- If proving P |- p where P is defined, unfold P - (ValPerm_Named npn _ _, _) - | DefinedSortRepr _ <- namedPermNameSort npn -> - proveVarImplUnfoldLeft x p mb_p Nothing - - -- If proving x:p1 * ... * P * ... |- p where P is defined, unfold P - (ValPerm_Conj ps, _) - | Just i <- findIndex isDefinedConjPerm ps -> - proveVarImplUnfoldLeft x p mb_p (Just i) - - -- If proving P1 |- P2 where both P1 and P2 are recursive, try - -- unfolding P1 or P2, depending on the recursion flags - (ValPerm_Named npn1 _ _, [nuMP| ValPerm_Named mb_npn2 _ _ |]) - | RecursiveSortRepr _ _ <- namedPermNameSort npn1 - , RecursiveSortRepr _ _ <- namedPermNameSort $ mbLift mb_npn2 -> - implRecFlagCaseM - "proveVarImplH" (ColonPair x mb_p) - (proveVarImplFoldRight x p mb_p) - (proveVarImplUnfoldLeft x p mb_p Nothing) - - -- If proving x:p1 * ... |- P where both P and at least one of the pi are - -- recursive, try unfolding P or the LHS, depending on the recursion flags. Note - -- that there are no defined perms on the LHS at this point because that would - -- have been caught by one of the above cases. - (ValPerm_Conj ps, [nuMP| ValPerm_Named mb_npn _ _ |]) - | Just i <- findIndex isRecursiveConjPerm ps - , RecursiveSortRepr _ _ <- namedPermNameSort $ mbLift mb_npn -> - implRecFlagCaseM - "proveVarImplH" (ColonPair x mb_p) - (proveVarImplUnfoldLeft x p mb_p (Just i)) - (proveVarImplFoldRight x p mb_p) - - -- If proving P where P is recursive and we have gotten to this case, we - -- know there are no recursive perms on the left, so unfold P - (_, [nuMP| ValPerm_Named mb_npn _ _ |]) - | RecursiveSortRepr _ _ <- namedPermNameSort $ mbLift mb_npn -> - proveVarImplFoldRight x p mb_p - - -- If proving P |- p1 * ... * pn for a conjoinable P, then change the LHS - -- to a conjunction and recurse - (ValPerm_Named npn args off, _) - | TrueRepr <- nameIsConjRepr npn -> - implNamedToConjM x npn args off >>> - proveVarImplH x (ValPerm_Conj1 $ Perm_NamedConj npn args off) mb_p - - -- If proving P |- p1 * ... * pn for a non-conjoinable recursive P, then - -- we unfold P because we will have to at some point to prove a conjunction - (ValPerm_Named _ _ _, _) -> - proveVarImplUnfoldLeft x p mb_p Nothing - - - {- FIXME: This is an example of how we used embedMbImplM to prove the body - of one mu from another; remove it when we have used it for arrays - (ValPerm_Mu p_body, [nuMP| ValPerm_Mu mb_p'_body |]) -> - partialSubstForceM mb_p'_body - "proveVarImpl: incomplete psubst: implMu" >>>= \p'_body -> - embedMbImplM (fmap (\p -> distPermSet $ distPerms1 x p) p_body) - (mbMap2 (\p p' -> proveVarImplH x p (emptyMb p') >>> pure Refl) - p_body p'_body) >>>= \mb_impl -> - implSimplM Proxy (SImpl_Mu x p_body p'_body mb_impl) - -} - - -- If x:eq(LLVMword(e)) then we cannot prove any pointer permissions for it - (ValPerm_Eq (PExpr_LLVMWord _), [nuMP| ValPerm_Conj _ |]) -> - implFailVarM "proveVarImplH" x p mb_p - - -- If x:eq(struct(e1,...,en)) then we eliminate to x:struct(eq(e1),...,eq(en)) - (ValPerm_Eq (PExpr_Struct exprs), [nuMP| ValPerm_Conj _ |]) -> - implSimplM Proxy (SImpl_StructEqToPerm x exprs) >>> - recombinePerm x (ValPerm_Conj1 $ Perm_Struct $ - RL.map ValPerm_Eq $ exprsToRAssign exprs) >>> - proveVarImplInt x mb_p - - -- If proving a function permission for an x we know equals a constant function - -- handle f, look up the function permission for f - (ValPerm_Eq (PExpr_Fun f), [nuMP| ValPerm_Conj [Perm_Fun mb_fun_perm] |]) -> - use implStatePermEnv >>>= \env -> - case lookupFunPerm env f of - Just (SomeFunPerm fun_perm, ident) - | [nuMP| Just (Refl,Refl,Refl, Refl) |] <- - mbMatch $ fmap (funPermEq4 fun_perm) mb_fun_perm -> - introEqCopyM x (PExpr_Fun f) >>> - recombinePerm x p >>> - implSimplM Proxy (SImpl_ConstFunPerm x f fun_perm ident) - _ -> implFailVarM "proveVarImplH" x p mb_p - - (ValPerm_Eq _, [nuMP| ValPerm_Conj _ |]) -> - implFailVarM "proveVarImplH" x p mb_p - -- FIXME HERE: are there other x:eq(e) |- x:pps cases? - - -- For conjunction |- conjunction, call proveVarConjImpl - (ValPerm_Conj ps, [nuMP| ValPerm_Conj mb_ps |]) -> - proveVarConjImpl x ps mb_ps - - -- Prove x:p |- x:z@off for existential variable z by setting z = p - (_, [nuMP| ValPerm_Var z mb_off |]) - | Left memb <- mbNameBoundP z -> - getPSubst >>>= \psubst -> - case (partialSubst psubst mb_off, psubstLookup psubst memb) of - (Just off, Just (PExpr_ValPerm p')) -> - let mb_p' = fmap (const $ offsetPerm off p') z in - implTraceM (\i -> pretty "proveVarImplH:" <> softline <> ppImpl i x p mb_p') >>> - proveVarImplH x p mb_p' - (Just off, Just (PExpr_Var z')) -> - let mb_p' = fmap (const $ ValPerm_Var z' off) z in - implTraceM (\i -> pretty "proveVarImplH:" <> softline <> ppImpl i x p mb_p') >>> - proveVarImplH x p mb_p' - (Just off, Nothing) -> - setVarM memb (PExpr_ValPerm $ offsetPerm (negatePermOffset off) p) >>> - implMaybeCopyPopM x p - (Nothing, _) -> - implFailVarM "proveVarImplH" x p mb_p - - -- Prove x:z@off |- x:z@off for variable z by reflexivity - (ValPerm_Var z off, [nuMP| ValPerm_Var mb_z' mb_off |]) - | Right z' <- mbNameBoundP mb_z' - , z' == z - , mbLift (fmap (offsetsEq off) mb_off) -> pure () - - -- Fail if nothing else matched - _ -> implFailVarM "proveVarImplH" x p mb_p - - ----------------------------------------------------------------------- --- * Proving Permission Implications for Existential Variables ----------------------------------------------------------------------- - --- | Prove an existentially-quantified permission where the variable holding the --- permission could itself be existentially-quantified. If that variable is --- existentially quantified, be sure to instantiate it with a variable that is --- locally bound inside the current implication proof, i.e., that is returned by --- 'getVarVarM'. Return the variable that was used. -proveExVarImpl :: NuMatchingAny1 r => PartialSubst vars -> Mb vars (Name tp) -> - Mb vars (ValuePerm tp) -> - ImplM vars s r (ps :> tp) ps (Name tp) - --- If the variable is a free variable, just call proveVarImpl -proveExVarImpl _psubst mb_x mb_p - | Right n <- mbNameBoundP mb_x - = proveVarImplInt n mb_p >>> pure n - --- If the variable is instantiated to a non-variable expression, bind a fresh --- variable for it and then call proveVarImpl -proveExVarImpl psubst mb_x mb_p - | Left memb <- mbNameBoundP mb_x - , Just _ <- psubstLookup psubst memb = - getVarVarM memb >>>= \n -> - proveVarImplInt n mb_p >>> pure n - --- Special case: if proving an LLVM frame permission, look for an LLVM frame in --- the current context and use it -proveExVarImpl _ mb_x mb_p@(mbMatch -> [nuMP| ValPerm_Conj [Perm_LLVMFrame _] |]) - | Left memb <- mbNameBoundP mb_x = - getExVarType memb >>>= \x_tp -> - implFindVarOfType x_tp >>>= \maybe_n -> - case maybe_n of - Just n -> - -- NOTE: we still need to call getVarVarM to get a locally-bound var - setVarM memb (PExpr_Var n) >>> - getVarVarM memb >>>= \n' -> - proveVarImplInt n' mb_p >>> pure n' - Nothing -> - implFailM NoFrameInScopeError - --- Otherwise we fail -proveExVarImpl _ mb_x mb_p = - use implStatePPInfo >>>= \ppinfo -> - implFailM $ ExistentialError - (permPretty ppinfo mb_x) - (permPretty ppinfo mb_p) - - ----------------------------------------------------------------------- --- * Proving Multiple Permission Implications ----------------------------------------------------------------------- - --- | A list of distinguished permissions with existential variables -type ExDistPerms vars ps = Mb vars (DistPerms ps) - --- | Existentially quantify a list of distinguished permissions over the empty --- set of existential variables -distPermsToExDistPerms :: DistPerms ps -> ExDistPerms RNil ps -distPermsToExDistPerms = emptyMb - --- | Substitute arguments into a function permission to get the existentially --- quantified input permissions needed on the arguments -funPermExDistIns :: FunPerm ghosts args gouts ret -> RAssign Name args -> - ExDistPerms ghosts (ghosts :++: args) -funPermExDistIns fun_perm args = - fmap (varSubst (permVarSubstOfNames args)) $ mbSeparate args $ - mbValuePermsToDistPerms $ funPermIns fun_perm - --- | Make a \"base case\" 'DistPermsSplit' where the split is at the end -baseDistPermsSplit :: DistPerms ps -> ExprVar a -> ValuePerm a -> - DistPermsSplit (ps :> a) -baseDistPermsSplit ps x p = - DistPermsSplit (rlToProxies ps) MNil ps x p - --- | Extend the @ps@ argument of a 'DistPermsSplit' -extDistPermsSplit :: DistPermsSplit ps -> ExprVar b -> ValuePerm b -> - DistPermsSplit (ps :> b) -extDistPermsSplit (DistPermsSplit prxs1 prxs2 ps12 x p) y p' = - DistPermsSplit prxs1 (prxs2 :>: Proxy) (DistPermsCons ps12 y p') x p - - --- | The maximum priority returned by 'isProvablePerm' -isProvablePermMax :: Int -isProvablePermMax = 3 - --- | Test if a permission is of a form where 'proveExVarImpl' will succeed, --- given the current set of existential variables whose values have not been --- set. Return a priority for the permission, where higher priorities are proved --- first and 0 means it cannot be proved. -isProvablePerm :: NameSet CrucibleType -> Maybe (ExprVar a) -> - ValuePerm a -> Int - --- Simple lifetime permissions should be proved first, so get highest priority -isProvablePerm unsetVars maybe_x p@(ValPerm_Conj [Perm_LOwnedSimple _ _]) - | neededs <- maybe id (\x -> NameSet.insert x) maybe_x $ neededVars p - , NameSet.null $ NameSet.intersection neededs unsetVars = 3 - --- Lifetime permissions can always be proved, but we want to prove them after --- any other permissions that might depend on them, so they get priority 1 -isProvablePerm _ _ (ValPerm_Conj ps) - | any (isJust . isLifetimePerm) ps = 1 - --- If x and all the needed vars in p are set, we can prove x:p -isProvablePerm unsetVars maybe_x p - | neededs <- maybe id (\x -> NameSet.insert x) maybe_x $ neededVars p - , NameSet.null $ NameSet.intersection neededs unsetVars = 2 - --- Special case: an LLVMFrame permission can always be proved -isProvablePerm _ _ (ValPerm_Conj [Perm_LLVMFrame _]) = 2 - --- Special case: a variable permission X can always be proved when the variable --- x and the offset are known, since X is either a free variable, so we can --- substitute the current permissions on x, or X is set to a ground permission, --- so we can definitely try to prove it -isProvablePerm unsetVars maybe_x (ValPerm_Var _ off) - | neededs <- maybe id (\x -> NameSet.insert x) maybe_x $ freeVars off - , NameSet.null $ NameSet.intersection neededs unsetVars = 2 - --- Otherwise we cannot prove the permission, so we return priority 0 -isProvablePerm _ _ _ = 0 - - --- | Choose the next permission in the supplied list to try to prove by picking --- one with maximal priority, as returned by 'isProvablePerm', and return its --- location in the supplied list along with its priority. We assume that the --- list is non-empty. -findProvablePerm :: NameSet CrucibleType -> DistPerms ps -> - (Int, DistPermsSplit ps) -findProvablePerm unsetVars ps = case ps of - DistPermsNil -> error "findProvablePerm: empty list" - DistPermsCons DistPermsNil x p -> - (isProvablePerm unsetVars (Just x) p, - baseDistPermsSplit DistPermsNil x p) - DistPermsCons ps' x p -> - let (best_rank,best) = findProvablePerm unsetVars ps' in - let rank = isProvablePerm unsetVars (Just x) p in - if rank > best_rank then - (rank, baseDistPermsSplit ps' x p) - else - (best_rank, extDistPermsSplit best x p) - - --- | Find all existential lifetime variables with @lowned@ permissions in an --- 'ExDistPerms' list, and instantiate them with fresh lifetimes -instantiateLifetimeVars :: NuMatchingAny1 r => ExDistPerms vars ps -> - ImplM vars s r ps_in ps_in () -instantiateLifetimeVars mb_ps = - do psubst <- getPSubst - instantiateLifetimeVars' psubst mb_ps - --- | The main loop for 'instantiateLifetimeVars' -instantiateLifetimeVars' :: NuMatchingAny1 r => PartialSubst vars -> - ExDistPerms vars ps -> ImplM vars s r ps_in ps_in () -instantiateLifetimeVars' psubst mb_ps = case mbMatch mb_ps of - [nuMP| DistPermsNil |] -> pure () - [nuMP| DistPermsCons mb_ps' mb_x (ValPerm_Conj1 mb_p) |] - | [nuP| Just Refl |] <- mbMapCl $(mkClosed - [| isLifetimeOwnershipPerm |]) mb_p - , Left memb <- mbNameBoundP mb_x - , Nothing <- psubstLookup psubst memb -> - implBeginLifetimeM >>>= \l -> - setVarM memb (PExpr_Var l) >>> - instantiateLifetimeVars' (psubstSet memb (PExpr_Var l) psubst) mb_ps' - [nuMP| DistPermsCons mb_ps' _ _ |] -> - instantiateLifetimeVars' psubst mb_ps' - - --- | Internal-only version of 'proveVarsImplAppend' that is called recursively --- by the implication prover. The distinction is that this version does not end --- any lifetimes, because lifetimes are only ended at the top level, by --- 'proveVarsImplAppend'. -proveVarsImplAppendInt :: NuMatchingAny1 r => ExDistPerms vars ps -> - ImplM vars s r (ps_in :++: ps) ps_in () -proveVarsImplAppendInt (mbMatch -> [nuMP| DistPermsNil |]) = return () -proveVarsImplAppendInt mb_ps = - getPSubst >>>= \psubst -> - use implStatePerms >>>= \cur_perms -> - case mbMatch $ - mbMapClWithVars - ($(mkClosed - [| \unsetVarsBool ns ps -> - let unsetVars = nameSetFromFlags ns unsetVarsBool in - findProvablePerm unsetVars ps |]) - `clApply` toClosed (psubstUnsetVarsBool psubst)) mb_ps of - [nuMP| (mb_rank, DistPermsSplit prxs1 prxs2 ps12 mb_x mb_p) |] -> - if mbLift mb_rank > 0 then - proveExVarImpl psubst mb_x mb_p >>>= \x -> - proveVarsImplAppendInt ps12 >>> - implMoveUpM cur_perms (mbLift prxs1) x (mbLift prxs2) - else - use implStatePPInfo >>>= \ppinfo -> - implFailM $ InsufficientVariablesError $ - permPretty ppinfo mb_ps - --- | Like 'proveVarsImplAppendInt' but re-associate the appends -proveVarsImplAppendIntAssoc :: - NuMatchingAny1 r => prx ps_in -> prx1 ps1 -> ExDistPerms vars ps -> - ImplM vars s r (ps_in :++: (ps1 :++: ps)) (ps_in :++: ps1) () -proveVarsImplAppendIntAssoc ps_in ps1 ps - | ps_prxs <- mbLift $ mbMapCl $(mkClosed [| rlToProxies |]) ps - , Refl <- RL.appendAssoc ps_in ps1 ps_prxs = - proveVarsImplAppendInt ps - --- | Like 'proveVarsImplAppendInt' but re-associate the appends -proveVarsImplAppendIntAssoc4 :: - NuMatchingAny1 r => prx ps_in -> prx1 ps1 -> prx2 ps2 -> - ExDistPerms vars ps -> - ImplM vars s r (ps_in :++: (ps1 :++: (ps2 :++: ps))) (ps_in :++: (ps1 :++: ps2)) () -proveVarsImplAppendIntAssoc4 ps_in (ps1 :: prx1 ps1) (ps2 :: prx2 ps2) ps - | ps_prxs <- mbLift $ mbMapCl $(mkClosed [| rlToProxies |]) ps - , ps12 <- Proxy :: Proxy (ps1 :++: ps2) - , Refl <- RL.appendAssoc ps1 ps2 ps_prxs = - proveVarsImplAppendIntAssoc ps_in ps12 ps - --- | Prove a list of existentially-quantified distinguished permissions and put --- those proofs onto the stack. This is the same as 'proveVarsImplAppendInt' --- except that the stack starts out empty and is replaced by the proofs, rather --- than appending the proofs to the stack that is already there. -proveVarsImplInt :: NuMatchingAny1 r => ExDistPerms vars as -> - ImplM vars s r as RNil () -proveVarsImplInt ps - | Refl <- mbLift (fmap RL.prependRNilEq $ mbDistPermsToValuePerms ps) = - proveVarsImplAppendInt ps - --- | Prove one sequence of permissions from another and capture the proof as a --- 'LocalPermImpl' -localProveVars :: NuMatchingAny1 r => DistPerms ps_in -> DistPerms ps_out -> - ImplM vars s r ps ps (LocalPermImpl ps_in ps_out) -localProveVars ps_in ps_out = - implTraceM (\i -> sep [pretty "localProveVars:", permPretty i ps_in, - pretty "-o", permPretty i ps_out]) >>> - LocalPermImpl <$> - embedImplM ps_in (recombinePermsRev ps_in >>> - proveVarsImplInt (emptyMb ps_out) >>> - pure (LocalImplRet Refl)) - --- | 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 => 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, - pretty "-o", permPretty i mb_ps_out]) >>> - fmap LocalPermImpl <$> - embedMbImplM mb_ps_in (mbMap2 - (\ps_in ps_out -> - recombinePermsRev ps_in >>> - proveVarsImplInt (emptyMb ps_out) >>> - pure (LocalImplRet Refl)) - mb_ps_in mb_ps_out) - - ----------------------------------------------------------------------- --- * External Entrypoints to the Implication Prover ----------------------------------------------------------------------- - --- | End a lifetime and, recursively, all lifetimes it contains, assuming that --- @lowned@ permissions are held for all of those lifetimes. For each lifetime --- that is ended, prove its required input permissions and recombine the --- resulting output permissions. Also remove each ended lifetime from any --- @lowned@ permission in the variable permissions that contains it. If a --- lifetime has already ended, do nothing. -implEndLifetimeRecM :: NuMatchingAny1 r => ExprVar LifetimeType -> - ImplM vars s r ps ps () -implEndLifetimeRecM l = - implVerbTraceM (\i -> pretty "implEndLifetimeRecM" <+> permPretty i l) >>> - getPerm l >>>= \case - ValPerm_LFinished -> return () - p@(ValPerm_LOwned [] tps_in tps_out ps_in ps_out) - | Just dps_in <- exprPermsToDistPerms ps_in -> - -- Get the permission stack on entry - getDistPerms >>>= \ps0 -> - -- Save the lowned permission for l - implPushM l p >>> - -- Prove the required input permissions ps_in for ending l - mbVarsM dps_in >>>= \mb_dps_in -> - proveVarsImplAppendInt mb_dps_in >>> - -- Move the lowned permission for l to the top of the stack - implMoveUpM ps0 ps_in l MNil >>> - -- End l - implEndLifetimeM Proxy l tps_in tps_out ps_in ps_out >>> - -- Find all lowned perms that contain l and remove l from them - implFindLOwnedPerms >>>= \lowned_ps -> - forM_ lowned_ps $ \case - (l', p'@(ValPerm_LOwned ls' tps_in' tps_out' ps_in' ps_out')) - | elem (PExpr_Var l) ls' -> - implPushM l' p' >>> implPushCopyM l ValPerm_LFinished >>> - implRemoveContainedLifetimeM l' ls' tps_in' tps_out' ps_in' ps_out' l - _ -> return () - (ValPerm_LOwned ((asVar -> Just l') : _) _ _ _ _) -> - implEndLifetimeRecM l' >>> implEndLifetimeRecM l - _ -> - implTraceM (\i -> - pretty "implEndLifetimeRecM: could not end lifetime: " <> - permPretty i l) >>> - implFailM (LifetimeError EndLifetimeError) - --- | Prove a list of existentially-quantified distinguished permissions, adding --- those proofs to the top of the stack. In the case that a the variable itself --- whose permissions are being proved is existentially-quantified --- that is, --- if we are proving @x:p@ for existentially-quantified @x@ --- then the --- resulting permission on top of the stack will be @y:[e/x]p@, where @y@ is a --- fresh variable and @e@ is the expression used to instantiate @x@. -proveVarsImplAppend :: NuMatchingAny1 r => ExDistPerms vars ps -> - ImplM vars s r (ps_in :++: ps) ps_in () -proveVarsImplAppend mb_ps = - use implStatePerms >>>= \(_ :: PermSet ps_in) -> - lifetimesThatCouldProve mb_ps >>>= \ls -> - implVerbTraceM (\i -> pretty "Lifetimes that could prove:" <+> permPretty i ls) >>> - foldr1 (implCatchM "proveVarsImplAppend" mb_ps) - ((proveVarsImplAppendInt mb_ps) - : - flip map ls - (\l -> - implTraceM (\i -> - sep [pretty "Ending lifetime" <+> permPretty i l, - pretty "in order to prove:", - permPretty i mb_ps]) >>> - implEndLifetimeRecM l >>> proveVarsImplAppend mb_ps)) - --- | Prove a list of existentially-quantified distinguished permissions and put --- those proofs onto the stack. This is the same as 'proveVarsImplAppend' except --- that the stack starts out empty and is replaced by the proofs, rather than --- appending the proofs to the stack that is already there. -proveVarsImpl :: NuMatchingAny1 r => ExDistPerms vars as -> - ImplM vars s r as RNil () -proveVarsImpl ps - | Refl <- mbLift (fmap RL.prependRNilEq $ mbDistPermsToValuePerms ps) = - proveVarsImplAppend ps - --- | Prove a list of existentially-quantified distinguished permissions and put --- those proofs onto the stack, and then return the expressions assigned to the --- existential variables -proveVarsImplEVarExprs :: NuMatchingAny1 r => ExDistPerms vars as -> - ImplM vars s r as RNil (PermExprs vars) -proveVarsImplEVarExprs ps = - proveVarsImpl ps >>> - use implStateVars >>>= \vars -> - fmap (exprsOfSubst . completePSubst vars) getPSubst - --- | Prove a list of existentially-quantified permissions and put the proofs on --- the stack, similarly to 'proveVarsImpl', but ensure that the existential --- variables are themselves only instanitated with variables, not arbitrary --- terms. The variables must be distinct from each other and from any other --- variables in scope. Return the variables used to instantiate the evars. -proveVarsImplVarEVars :: NuMatchingAny1 r => ExDistPerms vars as -> - ImplM vars s r as RNil (RAssign ExprVar vars) -proveVarsImplVarEVars mb_ps = - -- First, prove the required permissions mb_ps. Note that this will prove - -- [es/vars]mb_ps, for some instantiation es for the evars vars. The rest of - -- this function is then to cast this to [xs/vars]mb_ps for fresh vars xs. - proveVarsImpl mb_ps >>> - -- Next, call getVarVarM to get fresh variables for all the evars - use implStateVars >>>= \vars -> - let var_membs = RL.members $ cruCtxProxies vars in - traverseRAssign getVarVarM var_membs >>>= \xs -> - -- Now get the instantiations es for the evars; NOTE: we call completePSubst - -- as a convenience, but all evars should be set by getVarVarM - getPSubst >>>= \psubst -> - let s = completePSubst vars psubst - es = exprsOfSubst s - mb_es = fmap (const es) mb_ps in - -- Prove that x:eq(e) for each evar x and its instantiation e - proveVarsEq xs mb_es >>> - -- Build the proof that [es/vars]mb_ps = [xs/vars]mb_ps - let eqpf = - fmap (\es' -> subst (substOfExprs es') $ - mbDistPermsToValuePerms mb_ps) $ - eqProofFromPermsRev xs es in - -- Use eqpf to cast the permission stack - implCastStackM eqpf >>> - return xs - --- | Prove @x:p'@, where @p@ may have existentially-quantified variables in it. -proveVarImpl :: NuMatchingAny1 r => ExprVar a -> Mb vars (ValuePerm a) -> - ImplM vars s r (ps :> a) ps () -proveVarImpl x mb_p = proveVarsImplAppend $ fmap (distPerms1 x) mb_p - --- | Terminate the current proof branch with a failure -implFailM :: NuMatchingAny1 r => ImplError -> ImplM vars s r ps_any ps a -implFailM err = - use implStateFailPrefix >>>= \prefix -> - implTraceM (const $ pretty $ prefix <> ppError err) >>> - implApplyImpl1 (Impl1_Fail err) MNil - --- | Terminate the current proof branch with a failure proving @x:p -o mb_p@ -implFailVarM :: NuMatchingAny1 r => String -> ExprVar tp -> ValuePerm tp -> - Mb vars (ValuePerm tp) -> ImplM vars s r ps_any ps a -implFailVarM f x p mb_p = - use implStatePPInfo >>>= \ppinfo -> - use implStateVars >>>= \ctx -> - findPermsContainingVar x >>>= \case - (Some distperms) -> - implFailM $ ImplVariableError - (ppImpl ppinfo x p mb_p) - f - (permPretty ppinfo x, x) - (permPretty ppinfo p, p) - ctx - distperms - -instance ErrorPretty ImplError where - ppError (GeneralError doc) = renderDoc doc - ppError NoFrameInScopeError = - "No LLVM frame in scope" - ppError ArrayStepError = - "Error proving array permissions" - ppError MuUnfoldError = - "Tried to unfold a mu on the left after unfolding on the right" - ppError FunctionPermissionError = - "Could not find function permission" - ppError (PartialSubstitutionError caller doc) = renderDoc $ - sep [ pretty ("Incomplete susbtitution in " ++ caller ++ " for: ") - , doc ] - ppError (LifetimeError EndLifetimeError) = - "implEndLifetimeM: lownedPermsToDistPerms" - ppError (LifetimeError ImplicationLifetimeError) = - "proveVarAtomicImpl: lownedPermsToDistPerms" - ppError (LifetimeError (LifetimeCurrentError doc)) = renderDoc $ - pretty "Could not prove lifetime is current:" <+> doc - ppError (MemBlockError doc) = renderDoc $ - pretty "Could not eliminate permission" <+> doc - -- permPretty pp (Perm_LLVMBlock bp) - ppError (EqualityProofError edoc mbedoc) = renderDoc $ - sep [ pretty "proveEq" <> colon <+> pretty "Could not prove" - , edoc <+> pretty "=" <+> mbedoc] - ppError (InsufficientVariablesError doc) = renderDoc $ - sep [PP.fillSep [PP.pretty - "Could not determine enough variables to prove permissions:", - doc]] - ppError (ExistentialError docx docp ) = renderDoc $ - pretty "proveExVarImpl: existential variable" <+> - docx <+> - pretty "not resolved when trying to prove:" <> softline <> - docp - ppError (ImplVariableError doc f _ev _vp _ctx _dp) = renderDoc $ - sep [ pretty f <> colon <+> pretty "Could not prove" - , doc ] - --- | Try to prove @x:p@, returning whether or not this was successful -checkVarImpl :: - PermSet ps_in -> - ImplM RNil Int (Constant ()) ps_out ps_in a -> - Bool -checkVarImpl ps act = 0 /= permImplSucceeds (evalState st (toClosed 0)) - where - st = runImplM - CruCtxNil - ps - emptyPermEnv - emptyPPInfo - "checkVarImpl" - (DebugLevel 2) - NameMap.empty - Nothing - LittleEndian - act - (\_ -> return (Constant ())) diff --git a/heapster/src/Heapster/ImplicationError.hs b/heapster/src/Heapster/ImplicationError.hs deleted file mode 100644 index e69de29bb2..0000000000 diff --git a/heapster/src/Heapster/JSONExport.hs b/heapster/src/Heapster/JSONExport.hs deleted file mode 100644 index 000ff8a5db..0000000000 --- a/heapster/src/Heapster/JSONExport.hs +++ /dev/null @@ -1,211 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts, FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE OverloadedLists, OverloadedStrings #-} -{-# LANGUAGE ParallelListComp #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -Wno-orphans #-} -- hobbits instances for Value -module Heapster.JSONExport - (JsonExport, JsonExport1, ppToJson) - where - -import Data.Aeson ( ToJSON(toJSON), Value(..), object ) -import Data.Binding.Hobbits -import Data.BitVector.Sized ( BV, asUnsigned ) -import Data.Kind (Type) -import Data.Parameterized.BoolRepr ( BoolRepr ) -import Data.Parameterized.Context ( Assignment ) -import Data.Parameterized.Nonce (Nonce, indexValue) -import Data.Parameterized.TraversableFC ( FoldableFC(toListFC) ) -import Data.Text (Text) -import Data.Traversable (for) -import Data.Type.RList ( mapToList ) -import GHC.Natural (Natural) -import Lang.Crucible.FunctionHandle ( FnHandle ) -import Lang.Crucible.LLVM.Bytes ( Bytes ) -import Lang.Crucible.LLVM.DataLayout (EndianForm) -import Lang.Crucible.Types -import qualified Language.Haskell.TH as TH -import qualified Language.Haskell.TH.Datatype as TH -import Heapster.CruUtil ( CruCtx ) -import Heapster.Implication -import Heapster.Permissions -import SAWCore.Name ( Ident ) -import What4.FunctionName ( FunctionName ) - -instance NuMatching Value where - nuMatchingProof = unsafeMbTypeRepr - -instance Liftable Value where - mbLift = unClosed . mbLift . fmap unsafeClose - --- | Uniformly export the algebraic datatype structure --- Heapster permissions. -ppToJson :: JsonExport a => PPInfo -> a -> Value -ppToJson ppi = let ?ppi = ppi in jsonExport - --- | Class of types that can be uniformly exported as JSON --- using the Heapster pretty-printing information for names -class JsonExport a where - jsonExport :: (?ppi::PPInfo) => a -> Value - default jsonExport :: ToJSON a => (?ppi::PPInfo) => a -> Value - jsonExport = toJSON - - --- This code generates generic JSON generation instances for --- algebraic data types. --- --- - All instances will generate an object. --- - The object will have a @tag@ field containing the name --- of the constructor used. --- - Record constructors will add each record field to the --- object using the field name --- - Normal constructors with fields will have a field called --- @contents@. If this constructor has more than one parameter --- the @contents@ field will have a list. Otherwise it will --- have a single element. -let fields :: String -> TH.ConstructorVariant -> [TH.ExpQ] -> TH.ExpQ - - -- Record constructor, use record field names as JSON field names - fields tag (TH.RecordConstructor fieldNames) xs = - TH.listE - $ [| ("tag", tag) |] - : [ [| (n, $x) |] | n <- TH.nameBase <$> fieldNames | x <- xs] - - -- No fields, so just report the constructor tag - fields tag _ [] = [| [("tag", tag)] |] - - -- One field, just report that field as @contents@ - fields tag _ [x] = [| [("tag", tag), ("contents", $x)] |] - - -- Multiple fields, report them as a list as @contents@ - fields tag _ xs = [| [("tag", tag), ("contents", Array $(TH.listE xs))] |] - - clauses :: TH.DatatypeInfo -> [TH.ClauseQ] - clauses info = - [do fieldVars <- for [0..length (TH.constructorFields con)-1] $ \i -> - TH.newName ("x" ++ show i) - TH.clause - [TH.conP (TH.constructorName con) (TH.varP <$> fieldVars)] - (TH.normalB [| - object - $(fields - (TH.nameBase (TH.constructorName con)) - (TH.constructorVariant con) - [ [| jsonExport $(TH.varE v) |] | v <- fieldVars ]) |]) - [] - | con <- TH.datatypeCons info ] - - generateJsonExport :: TH.Name -> TH.DecQ - generateJsonExport n = - do info <- TH.reifyDatatype n - let t = foldl TH.appT (TH.conT n) - $ zipWith (\c _ -> TH.varT (TH.mkName [c])) ['a'..] - $ TH.datatypeInstTypes info - TH.instanceD (TH.cxt []) [t|JsonExport $t|] - [TH.funD 'jsonExport (clauses info)] - - typesNeeded :: [TH.Name] - typesNeeded = - [''AtomicPerm, ''BaseTypeRepr, ''BoolRepr, ''BVFactor, ''BVProp, - ''BVRange, ''CruCtx, ''FloatInfoRepr, ''FloatPrecisionRepr, - ''FnHandle, ''FunPerm, ''LLVMArrayBorrow, - ''LLVMArrayIndex, ''LLVMArrayPerm, ''LLVMBlockPerm, ''LLVMFieldPerm, - ''LLVMFieldShape, ''NamedPermName, ''NamedShape, - ''NamedShapeBody, ''NameReachConstr, ''NameSortRepr, ''NatRepr, - ''PermExpr, ''PermOffset, ''StringInfoRepr, ''SymbolRepr, ''TypeRepr, - ''ValuePerm, ''RWModality, ''PermImpl1, ''Member, ''SimplImpl, - ''VarAndPerm, ''LocalPermImpl, ''LifetimeFunctor, ''NamedPerm, - ''RecPerm, ''OpaquePerm, ''DefinedPerm, ''ReachMethods, ''MbPermImpls, - ''ExprAndPerm, ''OrListDisj, ''EndianForm - ] - - in traverse generateJsonExport typesNeeded - -instance JsonExport (Name (t :: CrucibleType)) where - jsonExport = toJSON . permPrettyString ?ppi - -instance JsonExport1 f => JsonExport (Assignment f x) where - jsonExport = toJSON . toListFC jsonExport1 - -instance JsonExport1 f => JsonExport (RAssign f x) where - jsonExport = toJSON . mapToList jsonExport1 - - -instance JsonExport b => JsonExport (Mb (a :: RList CrucibleType) b) where - jsonExport mb = mbLift $ flip nuMultiWithElim1 mb $ \names body -> - let ?ppi = ppInfoAddExprNames "x" names ?ppi in - object [ - ("args", jsonExport names), - ("body", jsonExport body) - ] - -instance JsonExport (Nonce a b) where - jsonExport = toJSON . indexValue - -instance JsonExport Bytes where - jsonExport = toJSON . show -- Show instance is pretty - -instance JsonExport Ident where - jsonExport = toJSON . show -- Show instance is pretty - -instance JsonExport FunctionName where - jsonExport = toJSON . show -- Show instance is pretty - -instance JsonExport (EqProof a b) where - jsonExport _ = object [] - -instance JsonExport a => JsonExport (Maybe a) where - jsonExport = maybe Null jsonExport - -instance (JsonExport a, JsonExport b) => JsonExport (a,b) where - jsonExport (x,y) = toJSON (jsonExport x, jsonExport y) - -instance JsonExport a => JsonExport [a] where - jsonExport xs = toJSON (jsonExport <$> xs) - -instance JsonExport (BV n) where - jsonExport = toJSON . asUnsigned - -instance JsonExport (Proxy a) where - jsonExport _ = object [] - -instance JsonExport ImplError where - jsonExport = toJSON . ppError - --- Custom instance avoids the polymorphic field on the Done case -instance JsonExport (PermImpl f ps) where - jsonExport (PermImpl_Done _eq) = - object [("tag", "PermImpl_Done")] - jsonExport (PermImpl_Step rs mb) = - object - [("tag", "PermImpl_Step"), - ("contents", Array - [jsonExport rs, - jsonExport mb])] - -instance JsonExport Natural -instance JsonExport Integer -instance JsonExport Int -instance JsonExport Bool -instance JsonExport Text -instance {-# OVERLAPPING #-} JsonExport String - --- | 'JsonExport' lifted to work on types with higher kinds -class JsonExport1 f where - jsonExport1 :: (?ppi::PPInfo) => f a -> Value - default jsonExport1 :: JsonExport (f a) => (?ppi::PPInfo) => f a -> Value - jsonExport1 = jsonExport - -instance JsonExport1 BaseTypeRepr -instance JsonExport1 TypeRepr -instance JsonExport1 (Name :: CrucibleType -> Type) -instance JsonExport1 PermExpr -instance JsonExport1 ValuePerm -instance JsonExport1 VarAndPerm -instance JsonExport1 Proxy -instance JsonExport1 ExprAndPerm -instance JsonExport1 (OrListDisj ps a) diff --git a/heapster/src/Heapster/LLVMGlobalConst.hs b/heapster/src/Heapster/LLVMGlobalConst.hs deleted file mode 100644 index f800f8a7fb..0000000000 --- a/heapster/src/Heapster/LLVMGlobalConst.hs +++ /dev/null @@ -1,313 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ViewPatterns #-} - -module Heapster.LLVMGlobalConst ( - permEnvAddGlobalConst - ) where - -import Data.Bits -import Data.List (intercalate) -import Control.Monad (MonadPlus(..)) -import Control.Monad.Reader (MonadReader(..), ReaderT(..)) -import Control.Monad.Trans.Class (MonadTrans(..)) -import GHC.TypeLits (KnownNat) -import qualified Text.PrettyPrint.HughesPJ as PPHPJ - -import qualified Data.BitVector.Sized as BV -import qualified Text.LLVM.AST as L -import qualified Text.LLVM.PP as L - -import Data.Binding.Hobbits hiding (sym) - -import Data.Parameterized.NatRepr -import Data.Parameterized.Some - -import Lang.Crucible.Types -import Lang.Crucible.LLVM.DataLayout -import Lang.Crucible.LLVM.MemModel -import Lang.Crucible.LLVM.PrettyPrint - -import SAWCore.Name (mkSafeIdent) -import SAWCore.OpenTerm -import SAWCore.Term.Functor (ModuleName) -import SAWCore.SharedTerm -import Heapster.Permissions - - --- FIXME: move these utilities to OpenTerm.hs - --- | Generate a SAW core term for a bitvector literal whose length is given by --- the first integer and whose value is given by the second -bvLitOfIntOpenTerm :: Integer -> Integer -> OpenTerm -bvLitOfIntOpenTerm n i = - bvLitOpenTerm (map (testBit i) $ reverse [0..(fromIntegral n)-1]) - --- | Helper function to build a SAW core term of type @BVVec w len a@, i.e., a --- bitvector-indexed vector, containing a given list of elements of type --- @a@. The roundabout way we do this currently requires a default element of --- type @a@, even though this value is never actually used. Also required is the --- bitvector width @w@. -bvVecValueOpenTerm :: NatRepr w -> OpenTerm -> [OpenTerm] -> OpenTerm -> - OpenTerm -bvVecValueOpenTerm w tp ts def_tm = - applyOpenTermMulti (globalOpenTerm "Prelude.genBVVecFromVec") - [natOpenTerm (fromIntegral $ length ts), tp, arrayValueOpenTerm tp ts, - def_tm, natOpenTerm (natValue w), - bvLitOfIntOpenTerm (intValue w) (fromIntegral $ length ts)] - --- | Helper function to build a SAW core term of type @BVVec w len a@, i.e., a --- bitvector-indexed vector, containing a single repeated value -repeatBVVecOpenTerm :: NatRepr w -> OpenTerm -> OpenTerm -> OpenTerm -> - OpenTerm -repeatBVVecOpenTerm w len tp t = - applyOpenTermMulti (globalOpenTerm "Prelude.repeatBVVec") - [natOpenTerm (natValue w), len, tp, t] - --- | The information needed to translate an LLVM global to Heapster -data LLVMTransInfo = LLVMTransInfo { - llvmTransInfoEnv :: PermEnv, - llvmTransInfoEndianness :: EndianForm, - llvmTransInfoDebugLevel :: DebugLevel } - --- | The monad for translating LLVM globals to Heapster -type LLVMTransM = ReaderT LLVMTransInfo Maybe - --- | Run the 'LLVMTransM' monad -runLLVMTransM :: LLVMTransM a -> LLVMTransInfo -> Maybe a -runLLVMTransM = runReaderT - --- | Use 'debugTrace' to output a string message and then call 'mzero' -traceAndZeroM :: String -> LLVMTransM a -traceAndZeroM msg = - do dlevel <- llvmTransInfoDebugLevel <$> ask - debugTraceTraceLvl dlevel msg mzero - --- | Helper function to pretty-print the value of a global -ppLLVMValue :: L.Value -> String -ppLLVMValue val = - show $ PPHPJ.nest 2 $ ppValue val - --- | Helper function to pretty-print an LLVM constant expression -ppLLVMConstExpr :: L.ConstExpr -> String -ppLLVMConstExpr ce = - ppLLVMLatest (show $ PPHPJ.nest 2 $ L.ppConstExpr ce) - --- | Translate a typed LLVM 'L.Value' to a Heapster shape + elements of the --- translation of that shape to 0 or more SAW core types -translateLLVMValue :: (1 <= w, KnownNat w) => NatRepr w -> L.Type -> L.Value -> - LLVMTransM (PermExpr (LLVMShapeType w), [OpenTerm]) -translateLLVMValue w tp@(L.PrimType (L.Integer n)) (L.ValInteger i) = - translateLLVMType w tp >>= \(sh,_) -> - return (sh, [bvLitOfIntOpenTerm (fromIntegral n) i]) -translateLLVMValue w _ (L.ValSymbol sym) = - do env <- llvmTransInfoEnv <$> ask - -- (p, ts) <- lift (lookupGlobalSymbol env (GlobalSymbol sym) w) - (p, ts) <- case lookupGlobalSymbol env (GlobalSymbol sym) w of - Just (p, GlobalTrans ts) -> return (p, ts) - Nothing -> traceAndZeroM ("Could not find symbol: " ++ show sym) - return (PExpr_FieldShape (LLVMFieldShape p), ts) -translateLLVMValue w _ (L.ValArray tp elems) = - do - -- First, translate the elements and their type - ts <- concat <$> map snd <$> mapM (translateLLVMValue w tp) elems - (sh, saw_tps) <- translateLLVMType w tp - let saw_tp = tupleTypeOpenTerm' saw_tps - - -- Compute the array stride as the length of the element shape - sh_len_expr <- lift $ llvmShapeLength sh - sh_len <- fromInteger <$> lift (bvMatchConstInt sh_len_expr) - - -- Generate a default element of type tp using the zero initializer; this is - -- currently needed by bvVecValueOpenTerm - (_,def_tms) <- translateZeroInit w tp - let def_tm = tupleOpenTerm' def_tms - - -- Finally, build our array shape and SAW core value - 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,tss)) -> - return (foldr PExpr_SeqShape PExpr_EmptyShape shs, concat tss) -translateLLVMValue _ _ (L.ValString []) = mzero -translateLLVMValue _ _ (L.ValString bytes) = - let sh = - foldr1 PExpr_SeqShape $ - map (PExpr_FieldShape . LLVMFieldShape . ValPerm_Eq . - PExpr_LLVMWord . bvBV . BV.word8) bytes in - -- let tm = foldr1 pairOpenTerm $ map (const unitOpenTerm) bytes in - - -- NOTE: the equality permissions have no translations, so the sequence of - -- them doesn't either - return (sh, []) --- NOTE: we don't translate strings to one big bitvector value because that --- seems to mess up the endianness -{- -translateLLVMValue _ _ (L.ValString bytes) = - do endianness <- llvmTransInfoEndianness <$> ask - case bvFromBytes endianness bytes of - Some (BVExpr e) -> - return (PExpr_FieldShape (LLVMFieldShape $ - ValPerm_Eq $ PExpr_LLVMWord e), - unitOpenTerm) --} --- NOTE: we don't convert string values to arrays because we sometimes need to --- statically know the values of the bytes in a string value as eq perms -{- -translateLLVMValue w tp (L.ValString bytes) = - translateLLVMValue w tp (L.ValArray - (L.PrimType (L.Integer 8)) - (map (L.ValInteger . toInteger) bytes)) --} -translateLLVMValue w _ (L.ValConstExpr ce) = - translateLLVMConstExpr w ce -translateLLVMValue w tp L.ValZeroInit = - translateZeroInit w tp -translateLLVMValue _ _ v = - traceAndZeroM ("translateLLVMValue does not yet handle:\n" ++ ppLLVMValue v) - --- | Helper function for 'translateLLVMValue' -translateLLVMTypedValue :: (1 <= w, KnownNat w) => NatRepr w -> L.Typed L.Value -> - LLVMTransM (PermExpr (LLVMShapeType w), [OpenTerm]) -translateLLVMTypedValue w (L.Typed tp v) = translateLLVMValue w tp v - --- | Translate an LLVM type into a shape plus the SAW core types of the 0 or --- more elements of the translation of that shape -translateLLVMType :: (1 <= w, KnownNat w) => NatRepr w -> L.Type -> - LLVMTransM (PermExpr (LLVMShapeType w), [OpenTerm]) -translateLLVMType _ (L.PrimType (L.Integer n)) - | Just (Some (n_repr :: NatRepr n)) <- someNat n - , Left leq_pf <- decideLeq (knownNat @1) n_repr = - withKnownNat n_repr $ withLeqProof leq_pf $ - return (PExpr_FieldShape (LLVMFieldShape $ ValPerm_Exists $ nu $ \bv -> - ValPerm_Eq $ PExpr_LLVMWord $ - PExpr_Var (bv :: Name (BVType n))), - [bvTypeOpenTerm n]) -translateLLVMType _ tp = - traceAndZeroM ("translateLLVMType does not yet handle:\n" - ++ show (ppType tp)) - --- | Helper function for 'translateLLVMValue' applied to a constant expression -translateLLVMConstExpr :: (1 <= w, KnownNat w) => NatRepr w -> L.ConstExpr -> - LLVMTransM (PermExpr (LLVMShapeType w), [OpenTerm]) -translateLLVMConstExpr w (L.ConstGEP _ _ _ (L.Typed tp ptr) ixs) = - translateLLVMValue w tp ptr >>= \ptr_trans -> - translateLLVMGEP w tp ptr_trans ixs -translateLLVMConstExpr w (L.ConstConv L.BitCast - (L.Typed fromTp v) toTp) - | L.isPointer fromTp && L.isPointer toTp - = -- A bitcast from one LLVM pointer type to another is a no-op for us - translateLLVMValue w fromTp v -translateLLVMConstExpr _ ce = - traceAndZeroM ("translateLLVMConstExpr does not yet handle:\n" - ++ ppLLVMConstExpr ce) - --- | Helper function for 'translateLLVMValue' applied to a constant --- @getelementptr@ expression. --- --- For now, we only support uses of @getelementptr@ where all indices are zero, --- as this will return the pointer argument without needing to compute an offset --- into the pointer. Of course, this does mean that any @getelementptr@ --- expressions involving non-zero indices aren't supported (see #1875 for a --- contrived example of this). Thankfully, this function is only used to --- translate LLVM globals, and using @getelementptr@ to initialize globals is --- quite rare in practice. As such, we choose to live with this limitation until --- someone complains about it. -translateLLVMGEP :: (1 <= w, KnownNat w) => NatRepr w -> L.Type -> - (PermExpr (LLVMShapeType w), [OpenTerm]) -> - [L.Typed L.Value] -> - LLVMTransM (PermExpr (LLVMShapeType w), [OpenTerm]) -translateLLVMGEP _ tp vtrans ixs - | all (isZeroIdx . L.typedValue) ixs - = return vtrans - | otherwise - = traceAndZeroM ("translateLLVMGEP cannot handle arguments:\n" ++ - " " ++ intercalate "," (show tp : map show ixs)) - where - -- Check if an index is equal to 0. - isZeroIdx :: L.Value -> Bool - isZeroIdx (L.ValInteger 0) = True - isZeroIdx _ = False - --- | Build an LLVM value for a @zeroinitializer@ field of the supplied type -translateZeroInit :: (1 <= w, KnownNat w) => NatRepr w -> L.Type -> - LLVMTransM (PermExpr (LLVMShapeType w), [OpenTerm]) -translateZeroInit w tp@(L.PrimType (L.Integer _)) = - translateLLVMValue w tp (L.ValInteger 0) -translateZeroInit w (L.Array len tp) = - -- First, translate the zero element and its type - do (sh, elem_tms) <- translateZeroInit w tp - let elem_tm = tupleOpenTerm' elem_tms - (_, saw_tps) <- translateLLVMType w tp - let saw_tp = tupleTypeOpenTerm' saw_tps - - -- Compute the array stride as the length of the element shape - sh_len_expr <- lift $ llvmShapeLength sh - sh_len <- fromInteger <$> lift (bvMatchConstInt sh_len_expr) - - let arr_len = bvInt $ fromIntegral len - let saw_len = bvLitOfIntOpenTerm (intValue w) (fromIntegral len) - return (PExpr_ArrayShape arr_len sh_len sh, - [repeatBVVecOpenTerm w saw_len saw_tp elem_tm]) - -translateZeroInit w (L.PackedStruct tps) = - mapM (translateZeroInit w) tps >>= \(unzip -> (shs,tss)) -> - return (foldr PExpr_SeqShape PExpr_EmptyShape shs, concat tss) - -translateZeroInit _ tp = - traceAndZeroM ("translateZeroInit cannot handle type:\n" - ++ show (ppType tp)) - - --- | Top-level call to 'translateLLVMValue', running the 'LLVMTransM' monad -translateLLVMValueTop :: (1 <= w, KnownNat w) => DebugLevel -> EndianForm -> - NatRepr w -> PermEnv -> L.Global -> - Maybe (PermExpr (LLVMShapeType w), [OpenTerm]) -translateLLVMValueTop dlevel endianness w env global = - let sym = show (L.globalSym global) in - let trans_info = LLVMTransInfo { llvmTransInfoEnv = env, - llvmTransInfoEndianness = endianness, - llvmTransInfoDebugLevel = dlevel } in - debugTraceTraceLvl dlevel ("Global: " ++ sym ++ "; value =\n" ++ - maybe "None" ppLLVMValue - (L.globalValue global)) $ - (\x -> case x of - Just (sh,ts) -> - debugTraceTraceLvl dlevel (sym ++ " translated to " ++ - show (length ts) ++ " terms for perm:\n" ++ - permPrettyString emptyPPInfo sh) x - Nothing -> debugTraceTraceLvl dlevel (sym ++ " not translated") x) $ - flip runLLVMTransM trans_info $ - do val <- lift $ L.globalValue global - translateLLVMValue w (L.globalType global) val - --- | Add an LLVM global constant to a 'PermEnv', if the global has a type and --- value we can translate to Heapster, otherwise silently ignore it -permEnvAddGlobalConst :: (1 <= w, KnownNat w) => SharedContext -> ModuleName -> - DebugLevel -> EndianForm -> NatRepr w -> PermEnv -> - L.Global -> IO PermEnv -permEnvAddGlobalConst sc mod_name dlevel endianness w env global = - case translateLLVMValueTop dlevel endianness w env global of - Nothing -> return env - Just (sh, []) -> - let p = ValPerm_LLVMBlock $ llvmReadBlockOfShape sh in - return $ permEnvAddGlobalSyms env [PermEnvGlobalEntry (GlobalSymbol $ - L.globalSym global) - p (GlobalTrans [])] - Just (sh, ts) -> - do let (L.Symbol glob_str) = L.globalSym global - ident <- - scFreshenGlobalIdent sc $ mkSafeIdent mod_name $ show glob_str - let t = tupleOpenTerm' ts - complete_t <- completeOpenTerm sc t - let tps = map openTermType ts - complete_tp <- completeOpenTerm sc $ tupleTypeOpenTerm' tps - scInsertDef sc ident complete_tp complete_t - let p = ValPerm_LLVMBlock $ llvmReadBlockOfShape sh - return $ permEnvAddGlobalSyms env - [PermEnvGlobalEntry (GlobalSymbol $ L.globalSym global) p - (GlobalTrans [globalOpenTerm ident])] diff --git a/heapster/src/Heapster/Lexer.x b/heapster/src/Heapster/Lexer.x deleted file mode 100644 index 9dffcb7b57..0000000000 --- a/heapster/src/Heapster/Lexer.x +++ /dev/null @@ -1,104 +0,0 @@ -{ -module Heapster.Lexer (lexer) where - -import Heapster.Located (Located(..), Pos(..)) -import Heapster.Token (Token(..)) - -} - -%wrapper "posn" - -$alpha = [a-z A-Z] -$digit = [0-9] - -heapster :- - -$white+ ; -"(" { token_ TOpenParen } -")" { token_ TCloseParen } -"[" { token_ TOpenBrack } -"]" { token_ TCloseBrack } -"{" { token_ TOpenBrace } -"}" { token_ TCloseBrace } -"<" { token_ TOpenAngle } -">" { token_ TCloseAngle } -":" { token_ TColon } -";" { token_ TSemicolon } -"." { token_ TDot } -"," { token_ TComma } -"+" { token_ TPlus } -"-" { token_ TMinus } -"*" { token_ TStar } -"@" { token_ TAt } -"-o" { token_ TLoli } -"|->" { token_ TMapsTo } -"==" { token_ TEqual } -"/=" { token_ TNotEqual } -" Pos -mkPos (AlexPn x y z) = Pos x y z - --- | Helper for building a 'Located' 'Token' -token :: (String -> Token) -> AlexPosn -> String -> Located Token -token tok p str = Located (mkPos p) (tok str) - --- | Helper for building a 'Located' 'Token' with no argument -token_ :: Token -> AlexPosn -> String -> Located Token -token_ tok p _ = Located (mkPos p) tok - --- | Transform input text into a token stream. Errors are --- reported inline with the 'TError' token. -lexer :: - String {- ^ input text -} -> - [Located Token] {- ^ token stream -} -lexer = alexScanTokens -} diff --git a/heapster/src/Heapster/Located.hs b/heapster/src/Heapster/Located.hs deleted file mode 100644 index e3160cf30e..0000000000 --- a/heapster/src/Heapster/Located.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# Language DeriveTraversable #-} -{-# Language TemplateHaskell #-} -{-# Options_GHC -Wno-unused-foralls #-} -module Heapster.Located - ( Located(..), - Pos(..), - HasPos(..), - )where - -import Data.Binding.Hobbits - --- | A thing paired with its location -data Located a = Located - { locPos :: !Pos -- ^ location - , locThing :: a -- ^ thing - } - deriving (Functor, Foldable, Traversable, Show) - --- | A position in a text-file -data Pos = Pos - { posChar :: !Int -- ^ 0-based absolute index - , posLine :: !Int -- ^ 1-based line number - , posCol :: !Int -- ^ 1-based column number - } - deriving Show - --- | Convenience class for types of things with a known location -class HasPos a where - -- | Get contained position - pos :: a -> Pos - --- | Returns 'locPos' -instance HasPos (Located a) where - pos = locPos - --- | Returns itself -instance HasPos Pos where - pos = id - -mkNuMatching [t| Pos |] diff --git a/heapster/src/Heapster/NamePropagation.hs b/heapster/src/Heapster/NamePropagation.hs deleted file mode 100644 index 41a90734ca..0000000000 --- a/heapster/src/Heapster/NamePropagation.hs +++ /dev/null @@ -1,65 +0,0 @@ -{-# Language ScopedTypeVariables #-} -{-# Language GADTs #-} -module Heapster.NamePropagation where - -import Data.Functor.Constant -import Data.Parameterized.TraversableFC ( FoldableFC(toListFC), FunctorFC(fmapFC) ) -import Lang.Crucible.Analysis.Fixpoint -import Lang.Crucible.CFG.Core ( Some(Some), CFG(cfgHandle) ) -import Lang.Crucible.FunctionHandle ( FnHandle(handleArgTypes) ) -import Lang.Crucible.LLVM.Extension ( LLVM, LLVMStmt(..), LLVM_Dbg(..) ) -import qualified Data.Parameterized.Context as Ctx -import qualified Data.Parameterized.Map as PM -import qualified Text.LLVM.AST as L - -type NameDom = Pointed (Constant String) - -nameJoin :: Constant String a -> Constant String a -> NameDom a -nameJoin (Constant x) (Constant y) | x == y = Pointed (Constant x) -nameJoin _ _ = Top - -nameDomain :: Domain (Pointed (Constant String)) -nameDomain = pointed nameJoin (==) WTO - -nameInterpretation :: Interpretation LLVM NameDom -nameInterpretation = Interpretation - { interpExpr = \_ _ _ names -> (Just names, Bottom) - , interpCall = \_ _ _ _ _ names -> (Just names, Bottom) - , interpReadGlobal = \_ names -> (Just names, Bottom) - , interpWriteGlobal = \_ _ names -> Just names - , interpBr = \_ _ _ _ names -> (Just names, Just names) - , interpMaybe = \_ _ _ names -> (Just names, Bottom, Just names) - , interpExt = \_ stmt names -> - let names' = - case stmt of - LLVM_Debug (LLVM_Dbg_Declare ptr di _) | Just n <- L.dilvName di -> - modifyAbstractRegValue names ptr (\_ -> Pointed (Constant ("&" ++ n))) - LLVM_Debug (LLVM_Dbg_Addr ptr di _) | Just n <- L.dilvName di -> - modifyAbstractRegValue names ptr (\_ -> Pointed (Constant ("&" ++ n))) - LLVM_Debug (LLVM_Dbg_Value _ val di _) | Just n <- L.dilvName di -> - modifyAbstractRegValue names val (\_ -> Pointed (Constant n)) - _ -> names - in (Just names', Bottom) - } - -computeNames :: - forall blocks init ret. - CFG LLVM blocks init ret -> - Ctx.Assignment (Constant [Maybe String]) blocks -computeNames cfg = - case alg of - (_, end, _) -> fmapFC (\(Ignore (Some p)) -> Constant (toListFC flatten (_paRegisters p))) end - where - flatten :: NameDom a -> Maybe String - flatten Top = Nothing - flatten Bottom = Nothing - flatten (Pointed (Constant x)) = Just x - - sz = Ctx.size (handleArgTypes (cfgHandle cfg)) - alg = - forwardFixpoint' - nameDomain - nameInterpretation - cfg - PM.empty - (Ctx.replicate sz Bottom) diff --git a/heapster/src/Heapster/NamedMb.hs b/heapster/src/Heapster/NamedMb.hs deleted file mode 100644 index 6394666020..0000000000 --- a/heapster/src/Heapster/NamedMb.hs +++ /dev/null @@ -1,95 +0,0 @@ -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TypeOperators #-} -module Heapster.NamedMb where - -import Data.Binding.Hobbits -import Data.Binding.Hobbits.MonadBind -import Data.Type.RList -import Control.Lens - --- | A constant type functor for 'String's -newtype StringF a = StringF { unStringF :: String } - -mkNuMatching [t| forall a. StringF a |] - --- | An 'Mb' multi-binding where each bound 'Name' has an associated 'String' --- for parsing and printing it -data NamedMb ctx a = NamedMb - { _mbNames :: RAssign StringF ctx - , _mbBinding :: Mb ctx a - } - deriving Functor - --- | A 'Binding' of a single 'Name' with a 'String' -type NamedBinding c = NamedMb (RNil :> c) - -instance Liftable (StringF a) where - mbLift (mbMatch -> [nuMP| StringF x |]) = StringF (mbLift x) - -instance LiftableAny1 StringF where - mbLiftAny1 = mbLift - -mkNuMatching [t| forall ctx a. NuMatching a => NamedMb ctx a |] - --- | Apply a binary function to the body of a 'NamedMb'; similar to 'mbMap2' -mbMap2Named :: (a -> b -> c) -> NamedMb ctx a -> NamedMb ctx b -> NamedMb ctx c -mbMap2Named f mb1 mb2 = - NamedMb (_mbNames mb1) (mbMap2 f (_mbBinding mb1) (_mbBinding mb2)) - --- | A 'Lens' to get the binding ouf of a 'NamedMb' -mbBinding :: Lens (NamedMb ctx a) (NamedMb ctx b) (Mb ctx a) (Mb ctx b) -mbBinding f x = NamedMb (_mbNames x) <$> f (_mbBinding x) - --- | Build a 'NamedMb' that binds multiple 'Name's with the given 'String's -nuMultiNamed :: RAssign StringF ctx -> (RAssign Name ctx -> b) -> NamedMb ctx b -nuMultiNamed tps f = NamedMb - { _mbNames = tps - , _mbBinding = nuMulti (mapRAssign (const Proxy) tps) f - } - --- | A version of 'nuMultiWithElim1' for 'NamedMb' -nuMultiWithElim1Named :: (RAssign Name ctx -> arg -> b) -> - NamedMb ctx arg -> NamedMb ctx b -nuMultiWithElim1Named k = over mbBinding (nuMultiWithElim1 k) - --- | Commute a 'NamedMb' inside a strong binding monad -strongMbMNamed :: MonadStrongBind m => NamedMb ctx (m a) -> m (NamedMb ctx a) -strongMbMNamed = traverseOf mbBinding strongMbM - --- | Commute a 'NamedMb' inside a binding monad -mbMNamed :: (MonadBind m, NuMatching a) => NamedMb ctx (m a) -> m (NamedMb ctx a) -mbMNamed = traverseOf mbBinding mbM - --- | Swap the order of two nested named bindings -mbSwapNamed :: RAssign Proxy ctx -> NamedMb ctx' (NamedMb ctx a) -> - NamedMb ctx (NamedMb ctx' a) -mbSwapNamed p (NamedMb names' body') = - NamedMb - { _mbNames = mbLift (_mbNames <$> body') - , _mbBinding = NamedMb names' <$> mbSwap p (_mbBinding <$> body') - } - --- | Swap the order of a binding with 'String' names with one without -mbSink :: RAssign Proxy ctx -> Mb ctx' (NamedMb ctx a) -> NamedMb ctx (Mb ctx' a) -mbSink p m = - NamedMb - { _mbNames = mbLift (_mbNames <$> m) - , _mbBinding = mbSwap p (_mbBinding <$> m) - } - --- | Lift a 'Liftable' value out of a 'NamedMb' -mbLiftNamed :: Liftable a => NamedMb ctx a -> a -mbLiftNamed = views mbBinding mbLift - --- | Eliminate a 'NamedMb' that binds zero names -elimEmptyNamedMb :: NamedMb RNil a -> a -elimEmptyNamedMb = views mbBinding elimEmptyMb - --- | Create a 'NamedMb' that binds zero names -emptyNamedMb :: a -> NamedMb RNil a -emptyNamedMb = NamedMb MNil . emptyMb diff --git a/heapster/src/Heapster/Panic.hs b/heapster/src/Heapster/Panic.hs deleted file mode 100644 index ab7566cf80..0000000000 --- a/heapster/src/Heapster/Panic.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{- | -Module : Heapster.Panic -Copyright : Galois, Inc. 2025 -License : BSD3 -Maintainer : saw@galois.com -Stability : experimental -Portability : non-portable (language extensions) --} - --- Panic hooks. See SAWSupport.PanicSupport for discussion. - -module Heapster.Panic (panic) where - -import qualified Data.Text as Text - -import SAWSupport.PanicSupport - --- FUTURE: switch from String to Text. This requires turning on --- OverloadedStrings, which currently causes thousands of errors in --- Heapster because of ambiguous prettyprinter instances; that needs --- to be mopped up first. -panic :: HasCallStack => String -> [String] -> a -panic loc msgs = doPanic "heapster" (Text.pack loc) (map Text.pack msgs) diff --git a/heapster/src/Heapster/ParsedCtx.hs b/heapster/src/Heapster/ParsedCtx.hs deleted file mode 100644 index c4f285926f..0000000000 --- a/heapster/src/Heapster/ParsedCtx.hs +++ /dev/null @@ -1,78 +0,0 @@ -{-# Language ScopedTypeVariables #-} -{-# Language GADTs #-} -{-# Language TypeOperators #-} -module Heapster.ParsedCtx where - -import Data.Functor.Constant - -import Data.Binding.Hobbits - -import qualified Data.Type.RList as RL - -import Data.Parameterized.Some (Some(Some)) - -import Lang.Crucible.Types - -import Heapster.CruUtil - --- | A sequence of variable names and their types -data ParsedCtx ctx = ParsedCtx { - parsedCtxNames :: RAssign (Constant String) ctx, - parsedCtxCtx :: CruCtx ctx - } - --- | Remove the last variable in a 'ParsedCtx' -parsedCtxUncons :: ParsedCtx (ctx :> tp) -> ParsedCtx ctx -parsedCtxUncons (ParsedCtx (xs :>: _) (CruCtxCons ctx _)) = ParsedCtx xs ctx - --- | Add a variable name and type to a 'ParsedCtx' -consParsedCtx :: String -> TypeRepr tp -> ParsedCtx ctx -> - ParsedCtx (ctx :> tp) -consParsedCtx x tp (ParsedCtx xs ctx) = - ParsedCtx (xs :>: Constant x) (CruCtxCons ctx tp) - --- | An empty 'ParsedCtx' -emptyParsedCtx :: ParsedCtx RNil -emptyParsedCtx = ParsedCtx MNil CruCtxNil - --- | A 'ParsedCtx' with a single element -singletonParsedCtx :: String -> TypeRepr tp -> ParsedCtx (RNil :> tp) -singletonParsedCtx x tp = - ParsedCtx (MNil :>: Constant x) (CruCtxCons CruCtxNil tp) - --- | Append two 'ParsedCtx's -appendParsedCtx :: ParsedCtx ctx1 -> ParsedCtx ctx2 -> - ParsedCtx (ctx1 :++: ctx2) -appendParsedCtx (ParsedCtx ns1 ctx1) (ParsedCtx ns2 ctx2) = - ParsedCtx (RL.append ns1 ns2) (appendCruCtx ctx1 ctx2) - --- | Add a variable name and type to the beginning of an unknown 'ParsedCtx' -preconsSomeParsedCtx :: String -> Some TypeRepr -> Some ParsedCtx -> - Some ParsedCtx -preconsSomeParsedCtx x (Some (tp :: TypeRepr tp)) (Some (ParsedCtx ns tps)) = - Some $ ParsedCtx - (RL.append (MNil :>: (Constant x :: Constant String tp)) ns) - (appendCruCtx (singletonCruCtx tp) tps) - --- | Make a 'ParsedCtx' where the string names are @"arg0,arg1,..."@ -mkArgsParsedCtx :: CruCtx ctx -> ParsedCtx ctx -mkArgsParsedCtx = mkPrefixParsedCtx "arg" - -mkPrefixParsedCtx :: String -> CruCtx ctx -> ParsedCtx ctx -mkPrefixParsedCtx prefix ctx = ParsedCtx (mkPrefixParsedCtx' prefix ctx) ctx - -mkPrefixParsedCtx' :: String -> CruCtx ctx -> RAssign (Constant String) ctx -mkPrefixParsedCtx' _ CruCtxNil = MNil -mkPrefixParsedCtx' prefix (CruCtxCons ctx _) = - mkPrefixParsedCtx' prefix ctx :>: Constant (prefix ++ show (cruCtxLen ctx)) - --- | Change the type of the last element of a 'ParsedCtx' -parsedCtxSetLastType :: TypeRepr tp -> ParsedCtx (ctx :> tp') -> - ParsedCtx (ctx :> tp) -parsedCtxSetLastType tp (ParsedCtx (xs :>: Constant str) (CruCtxCons ctx _)) = - (ParsedCtx (xs :>: Constant str) (CruCtxCons ctx tp)) - --- | Extract out the last element of a 'ParsedCtx' as a singleton 'ParsedCtx' -parsedCtxLast :: ParsedCtx (ctx :> tp) -> ParsedCtx (RNil :> tp) -parsedCtxLast (ParsedCtx (_ :>: Constant str) (CruCtxCons _ tp)) = - ParsedCtx (MNil :>: Constant str) (CruCtxCons CruCtxNil tp) diff --git a/heapster/src/Heapster/Parser.y b/heapster/src/Heapster/Parser.y deleted file mode 100644 index 552873ce2f..0000000000 --- a/heapster/src/Heapster/Parser.y +++ /dev/null @@ -1,274 +0,0 @@ -{ -{-# Language ViewPatterns #-} -module Heapster.Parser ( - - -- * Parser entry points - parseCtx, - parseType, - parseFunPerm, - parseExpr, - parseValuePerms, - - -- * Parser errors - ParseError(..), - - ) where - -import GHC.Natural - -import Heapster.Located -import Heapster.Token -import Heapster.UntypedAST - -} - -%expect 0 -- shift/reduce conflicts - -%tokentype { Located Token } -%token -'(' { Located $$ TOpenParen } -')' { Located $$ TCloseParen } -'[' { Located $$ TOpenBrack } -']' { Located $$ TCloseBrack } -'{' { Located $$ TOpenBrace } -'}' { Located $$ TCloseBrace } -'<' { Located $$ TOpenAngle } -'>' { Located $$ TCloseAngle } -':' { Located $$ TColon } -';' { Located $$ TSemicolon } -'.' { Located $$ TDot } -',' { Located $$ TComma } -'+' { Located $$ TPlus } -'-' { Located $$ TMinus } -'*' { Located $$ TStar } -'@' { Located $$ TAt } -'-o' { Located $$ TLoli } -'|->' { Located $$ TMapsTo } -'==' { Located $$ TEqual } -'/=' { Located $$ TNotEqual } -' Just $$) } -NAT { (traverse tokenNat -> Just $$) } - - -%monad { Either ParseError } -%error { errorP } - -%name parseCtx ctx -%name parseType type -%name parseFunPerm funPerm -%name parseExpr expr -%name parseValuePerms funPermList - -%right '.' -%left 'orsh' -%right ';' -%left 'or' -%nonassoc '==' '/=' '' expr ')' - { ExPtr (pos $2) $1 $5 $7 (Just $9) $12 } - | lifetime 'ptr' '(' '(' expr ',' expr ')' '|->' expr ')' - { ExPtr (pos $2) $1 $5 $7 Nothing $10 } - - | 'shape' '(' expr ')' { ExShape (pos $1) $3} - | 'lowned' lifetimes '(' list(varExpr) '-o' list1(varExpr) ')' - { ExLOwned (pos $1) $2 $4 $6} - | lifetime 'lcurrent' { ExLCurrent (pos $2) $1 } - | 'lfinished' { ExLFinished (pos $1) } - --- BV Props (Value Permissions) - - | expr '==' expr { ExEqual (pos $2) $1 $3} - | expr '/=' expr { ExNotEqual (pos $2) $1 $3} - | expr '' { Just $2 } - -permOffset :: { Maybe AstExpr } - : { Nothing } - | '@' expr { Just $2 } - -funPerm :: { AstFunPerm } - : '(' ctx ')' '.' funPermList '-o' funPermList - { AstFunPerm (pos $6) $2 $5 [] $7 } - | '(' ctx ')' '.' funPermList '-o' '(' ctx ')' '.' funPermList - { AstFunPerm (pos $6) $2 $5 $8 $11 } - -funPermList :: { [(Located String, AstExpr)] } - : 'empty' { [] } - | list1(varExpr) { $1 } - -varExpr :: { (Located String, AstExpr) } - : IDENT ':' expr { ($1, $3) } - -varType :: { (Located String, AstType) } - : IDENT ':' type { ($1, $3) } - -lifetime :: { Maybe AstExpr } - : { Nothing } - | '[' expr ']' { Just $2 } - -lifetimes :: { [AstExpr] } - : { [] } - | '[' list(expr) ']' { $2 } - -llvmFieldPermArray :: { ArrayPerm } - : lifetime '(' expr ',' expr ',' expr ')' '|->' expr - { ArrayPerm (pos $9) $1 $3 $5 (Just $7) $10 } - | lifetime '(' expr ',' expr ')' '|->' expr - { ArrayPerm (pos $7) $1 $3 $5 Nothing $8 } - -list(p) :: { [p] } - : { [] } - | list1(p) { $1 } - -list1(p) :: { [p] } - : list1R(p) { reverse $1 } - -list1R(p) :: { [p] } - : p { [$1] } - | list1R(p) ',' p { $3 : $1 } - -{ - --- | Errors that can terminate parsing. -data ParseError - = UnexpectedToken Pos Token -- ^ Unexpected token - | UnexpectedEnd -- ^ Unexpected end of input - deriving Show - --- | Generate an error message from the remaining token stream. -errorP :: [Located Token] -> Either ParseError a -errorP (Located p t:_) = Left (UnexpectedToken p t) -errorP [] = Left UnexpectedEnd -} diff --git a/heapster/src/Heapster/PatternMatchUtil.hs b/heapster/src/Heapster/PatternMatchUtil.hs deleted file mode 100644 index 742a77d2bb..0000000000 --- a/heapster/src/Heapster/PatternMatchUtil.hs +++ /dev/null @@ -1,20 +0,0 @@ --- | Pattern-matching utilities used within @heapster@. -module Heapster.PatternMatchUtil - ( expectLengthAtLeastOne - , expectLengthAtLeastTwo - ) where - -import GHC.Stack - --- | Use this in places where you maintain the invariant that the list argument --- has at least one element. -expectLengthAtLeastOne :: HasCallStack => [a] -> (a, [a]) -expectLengthAtLeastOne (x:xs) = (x, xs) -expectLengthAtLeastOne [] = error "expectLengthAtLeastOne: Unexpected empty list" - --- | Use this in places where you maintain the invariant that the list argument --- has at least two elements. -expectLengthAtLeastTwo :: HasCallStack => [a] -> (a, a, [a]) -expectLengthAtLeastTwo (x1:x2:xs) = (x1, x2, xs) -expectLengthAtLeastTwo [_] = error "expectLengthAtLeastTwo: Unexpected singleton list" -expectLengthAtLeastTwo [] = error "expectLengthAtLeastTwo: Unexpected empty list" diff --git a/heapster/src/Heapster/PermParser.hs b/heapster/src/Heapster/PermParser.hs deleted file mode 100644 index 10f549a023..0000000000 --- a/heapster/src/Heapster/PermParser.hs +++ /dev/null @@ -1,224 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE DataKinds #-} - -module Heapster.PermParser ( - parseFunPermString, - parseParsedCtxString, - parseCtxString, - parseTypeString, - parsePermsString, - parseFunPermStringMaybeRust, - - parseAtomicPermsInCtxString, - parsePermInCtxString, - parseExprInCtxString, - parseRustTypeString, - ) where - -import Data.List (find, replicate) -import GHC.TypeLits -import qualified Control.Monad.Fail as Fail -import Data.Binding.Hobbits - -import Data.Parameterized.Some -import Data.Parameterized.TraversableF - -import Lang.Crucible.Types - -import Heapster.CruUtil -import Heapster.Permissions -import Heapster.RustTypes - -import Heapster.Lexer (lexer) -import Heapster.Located (Pos(..), Located(..)) -import Heapster.Token (Token, describeToken) -import Heapster.Parser (ParseError(..), parseFunPerm, parseCtx, parseType, parseExpr, parseValuePerms) -import Heapster.TypeChecker (Tc, TypeError(..), startTc, tcFunPerm, tcCtx, tcType, tcExpr, inParsedCtxM, tcAtomicPerms, tcSortedMbValuePerms, tcValPerm) -import Heapster.ParsedCtx (ParsedCtx, parsedCtxCtx) - ----------------------------------------------------------------------- --- * Top-level Entrypoints for Parsing Things ----------------------------------------------------------------------- - --- | One of the generated parsers from "Heapster.Parser" --- which is intended to be used with 'Heapster.Lexer.lexer' -type Parser p = [Located Token] -> Either ParseError p - --- | Harness for running the lexer, parser, and type-checker. --- Human-readable errors are raised through 'fail'. -runParser :: - Fail.MonadFail m => - String {- ^ object name -} -> - PermEnv {- ^ permission environment -} -> - Parser p {- ^ parser -} -> - (p -> Tc a) {- ^ checker -} -> - String {- ^ input -} -> - m a -runParser obj env parser checker str = - case parser (lexer str) of - Left UnexpectedEnd -> - fail $ unlines - [ "Error parsing " ++ obj - , "Unexpected end of input" - , pointEnd str - ] - Left (UnexpectedToken p t) -> - fail $ unlines - [ "Error parsing " ++ obj ++ " at " ++ renderPos p - , "Unexpected " ++ describeToken t - , point p str - ] - Right ast -> - case startTc (checker ast) env of - Left (TypeError p e) -> - fail $ unlines - [ "Error checking " ++ obj ++ " at " ++ renderPos p - , e - , point p str - ] - Right x -> pure x - --- | Human-readable rendering of error location -renderPos :: - Pos {- ^ error position -} -> - String {- ^ rendered output -} -renderPos p = "line " ++ show (posLine p) ++ " column " ++ show (posCol p) - --- | Point to the error in the line with an error. -point :: - Pos {- ^ error position -} -> - String {- ^ full input string -} -> - String {- ^ rendered output -} -point p str = - lines str !! (posLine p - 1) ++ "\n" ++ - Data.List.replicate (posCol p - 1) ' ' ++ "^" - --- | Point to the end of the file -pointEnd :: - String {- ^ full input string -} -> - String {- ^ rendered output -} -pointEnd "" = "<>" -pointEnd str = end ++ "\n" ++ (' ' <$ end) ++ "^" - where - end = last (lines str) - --- | Parse a permission set @x1:p1, x2:p2, ...@ for the variables in the --- supplied context -parsePermsString :: - Fail.MonadFail m => - String {- ^ object name -} -> - PermEnv {- ^ permission environment -} -> - ParsedCtx ctx {- ^ parsed context -} -> - String {- ^ input text -} -> - m (MbValuePerms ctx) -parsePermsString nm env ctx = - runParser nm env parseValuePerms (tcSortedMbValuePerms ctx) - --- | Parse a permission of the given type within the given context and with --- the given named permission variables in scope -parsePermInCtxString :: - Fail.MonadFail m => - String {- ^ object name -} -> - PermEnv {- ^ permission environment -} -> - ParsedCtx ctx {- ^ parsed context -} -> - TypeRepr a {- ^ expected permission type -} -> - String {- ^ input text -} -> - m (Mb ctx (ValuePerm a)) -parsePermInCtxString nm env ctx tp = - runParser nm env parseExpr (inParsedCtxM ctx . const . tcValPerm tp) - --- | Parse a sequence of atomic permissions within the given context and with --- the given named permission variables in scope -parseAtomicPermsInCtxString :: - Fail.MonadFail m => - String {- ^ object name -} -> - PermEnv {- ^ permission environment -} -> - ParsedCtx ctx {- ^ parsed context -} -> - TypeRepr a {- ^ expected permission type -} -> - String {- ^ input text -} -> - m (Mb ctx [AtomicPerm a]) -parseAtomicPermsInCtxString nm env ctx tp = - runParser nm env parseExpr (inParsedCtxM ctx . const . tcAtomicPerms tp) - --- | Parse a 'FunPerm' named by the first 'String' from the second 'String' -parseFunPermString :: - Fail.MonadFail m => - String {- ^ object name -} -> - PermEnv {- ^ permission environment -} -> - CruCtx args {- ^ argument types -} -> - TypeRepr ret {- ^ return type -} -> - String {- ^ input text -} -> - m (SomeFunPerm args ret) -parseFunPermString nm env args ret = - runParser nm env parseFunPerm (tcFunPerm args ret) - --- | Parse a type context @x1:tp1, x2:tp2, ...@ named by the first 'String' from --- the second 'String' and return a 'ParsedCtx', which contains both the --- variable names @xi@ and their types @tpi@ -parseParsedCtxString :: - Fail.MonadFail m => - String {- ^ object name -} -> - PermEnv {- ^ permission environment -} -> - String {- ^ input text -} -> - m (Some ParsedCtx) -parseParsedCtxString nm env = runParser nm env parseCtx tcCtx - --- | Parse a type context named by the first 'String' from the second 'String' -parseCtxString :: - Fail.MonadFail m => - String {- ^ object name -} -> - PermEnv {- ^ permission environment -} -> - String {- ^ input text -} -> - m (Some CruCtx) -parseCtxString nm env str = - fmapF parsedCtxCtx <$> parseParsedCtxString nm env str - --- | Parse a type named by the first 'String' from the second 'String' -parseTypeString :: - Fail.MonadFail m => - String {- ^ object name -} -> - PermEnv {- ^ permission environment -} -> - String {- ^ input text -} -> - m (Some TypeRepr) -parseTypeString nm env = runParser nm env parseType tcType - --- | Parse an expression of a given type from a 'String' -parseExprInCtxString :: - Fail.MonadFail m => - PermEnv -> TypeRepr a -> ParsedCtx ctx -> String -> m (Mb ctx (PermExpr a)) -parseExprInCtxString env tp ctx = - runParser (permPrettyString emptyPPInfo tp) env parseExpr - (inParsedCtxM ctx . const . tcExpr tp) - --- | Parse a 'FunPerm' named by the first 'String' from the second 'String'. --- The 'FunPerm' can either be standard Heapster syntax, which begins with an --- open parenthesis (after optional whitespace), or it could be given in Rust --- syntax, which begins with an angle bracket. The @w@ argument gives the bit --- width of pointers in the current architecture. -parseFunPermStringMaybeRust :: - (1 <= w, KnownNat w, Fail.MonadFail m) => - String {- ^ object name -} -> - prx w {- ^ pointer bit-width proxy -} -> - PermEnv {- ^ permission environment -} -> - CruCtx args {- ^ argument types -} -> - TypeRepr ret {- ^ return type -} -> - String {- ^ input text -} -> - m (SomeFunPerm args ret) -parseFunPermStringMaybeRust nm w env args ret str = - case find (\c -> c == '<' || c == '(') str of - Just '<' -> parseFunPermFromRust env w args ret str - _ -> parseFunPermString nm env args ret str - --- | Parse a 'SomeNamedShape' from the given 'String'. This 'SomeNamedShape' --- must be a valid Rust @struct@ or @enum@ declaration given in Rust syntax. --- The @w@ argument gives the bit width of pointers in the current\ --- architecture. -parseRustTypeString :: - (1 <= w, KnownNat w, Fail.MonadFail m) => - PermEnv {- ^ permission environment -} -> - prx w {- ^ pointer bit-width proxy -} -> - String {- ^ input text -} -> - m (SomePartialNamedShape w) -parseRustTypeString = parseNamedShapeFromRustDecl diff --git a/heapster/src/Heapster/Permissions.hs b/heapster/src/Heapster/Permissions.hs deleted file mode 100644 index 361c436bc8..0000000000 --- a/heapster/src/Heapster/Permissions.hs +++ /dev/null @@ -1,8763 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE EmptyCase #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# OPTIONS_GHC -Wno-orphans #-} -module Heapster.Permissions where - -import Prelude hiding (pred) - -import Data.Char -import Data.Word -import Data.Maybe -import Data.Either -import Data.List (delete, find, findIndex, foldl') -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as NonEmpty -import Data.String -import Data.Proxy -import Data.Reflection -import Data.Functor.Constant -import Data.Functor.Compose -import qualified Data.BitVector.Sized as BV -import Data.BitVector.Sized (BV) -import Numeric.Natural -import GHC.TypeLits (KnownNat, natVal) -import Data.Kind -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import Data.Set (Set) -import qualified Data.Set as Set -import Control.Applicative hiding (empty) -import Control.Monad (MonadPlus(..), (>=>)) -import Control.Monad.Extra (concatMapM) -import Control.Monad.Identity () -import Control.Monad.Reader (MonadReader(..), Reader, ReaderT(..), runReader) -import Control.Monad.State (MonadState(..), State, evalState, modify) -import Control.Lens hiding ((:>), Index, Empty, ix, op) - -import Data.Binding.Hobbits hiding (sym) -import Data.Type.RList (append, memberElem, mapRAssign, mapToList, Eq1(..)) -import qualified Data.Type.RList as RL -import Data.Binding.Hobbits.MonadBind as MB -import Data.Binding.Hobbits.NameMap (NameMap, NameAndElem(..)) -import qualified Data.Binding.Hobbits.NameMap as NameMap -import Data.Binding.Hobbits.NameSet (NameSet, SomeName(..), toList, - SomeRAssign(..), namesListToNames, - nameSetIsSubsetOf) -import qualified Data.Binding.Hobbits.NameSet as NameSet - -import Data.Parameterized.Context (Assignment, AssignView(..), - pattern Empty, viewAssign) -import qualified Data.Parameterized.Context as Ctx -import Data.Parameterized.BoolRepr -import Data.Parameterized.NatRepr -import Data.Parameterized.Pair - -import Prettyprinter as PP -import Prettyprinter.Render.String (renderString) - -import Lang.Crucible.Types -import Lang.Crucible.FunctionHandle -import Lang.Crucible.LLVM.DataLayout -import Lang.Crucible.LLVM.MemModel -import Lang.Crucible.LLVM.Bytes -import Lang.Crucible.CFG.Core -import SAWCore.SharedTerm hiding (Constant) -import SAWCore.OpenTerm - -import Heapster.Panic -import Heapster.NamedMb -import Heapster.CruUtil - -import GHC.Stack -import Debug.Trace - - --- * 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 - --- | Map a monadic function over an 'RAssign' list from left to right while --- maintaining an \"accumulator\" that is threaded through the mapping -rlMapMWithAccum :: Monad m => (forall a. accum -> f a -> m (g a, accum)) -> - accum -> RAssign f tps -> m (RAssign g tps, accum) -rlMapMWithAccum _ accum MNil = return (MNil, accum) -rlMapMWithAccum f accum (xs :>: x) = - do (ys,accum') <- rlMapMWithAccum f accum xs - (y,accum'') <- f accum' x - return (ys :>: y, accum'') - --- | Map a monomorphic binary function across a pair of 'RAssign's to create a --- standard list, similarly to 'zipWith' -mapToList2 :: (forall a. f a -> g a -> b) -> - RAssign f tps -> RAssign g tps -> [b] -mapToList2 f fs gs = RL.toList $ RL.map2 (\x y -> Constant $ f x y) fs gs - --- | Convert any 'RAssign' sequence to a sequence of 'Proxy' objects -rlToProxies :: RAssign f ctx -> RAssign Proxy ctx -rlToProxies = RL.map (const Proxy) - --- | Extend the context of a name-binding to the left with multiple types -extMbMultiL :: RAssign Proxy ctx1 -> Mb ctx2 a -> Mb (ctx1 :++: ctx2) a -extMbMultiL vars mb_a = - mbCombine (mbToProxy mb_a) $ nuMulti vars $ const mb_a - - ----------------------------------------------------------------------- --- * Data types and related types ----------------------------------------------------------------------- - --- | The Haskell type of expression variables -type ExprVar = (Name :: CrucibleType -> Type) - --- | Crucible type for lifetimes; we give them a Crucible type so they can be --- existentially bound in the same way as other Crucible objects -type LifetimeType = IntrinsicType "Lifetime" EmptyCtx - --- | Crucible type for read/write modalities; we give them a Crucible type so --- they can be used as variables in recursive permission definitions -type RWModalityType = IntrinsicType "RWModality" EmptyCtx - --- | Crucible type for lists of expressions and permissions on them -type PermListType = IntrinsicType "PermList" EmptyCtx - --- | Crucible type for LLVM stack frame objects -type LLVMFrameType w = IntrinsicType "LLVMFrame" (EmptyCtx ::> BVType w) - --- | Crucible type for value permissions themselves -type ValuePermType a = IntrinsicType "Perm" (EmptyCtx ::> a) - --- | Crucible type for LLVM shapes -type LLVMShapeType w = IntrinsicType "LLVMShape" (EmptyCtx ::> BVType w) - --- | Crucible type for LLVM memory blocks -type LLVMBlockType w = IntrinsicType "LLVMBlock" (EmptyCtx ::> BVType w) - --- | Expressions that are considered \"pure\" for use in permissions. Note that --- these are in a normal form, that makes them easier to analyze. -data PermExpr (a :: CrucibleType) where - -- | A variable of any type - PExpr_Var :: ExprVar a -> PermExpr a - - -- | A unit literal - PExpr_Unit :: PermExpr UnitType - - -- | A literal Boolean number - PExpr_Bool :: Bool -> PermExpr BoolType - - -- | A literal natural number - PExpr_Nat :: Natural -> PermExpr NatType - - -- | A literal string - PExpr_String :: String -> PermExpr (StringType Unicode) - - -- | A bitvector expression is a linear expression in @N@ variables, i.e., sum - -- of constant times variable factors plus a constant - -- - -- FIXME: make the offset a 'Natural' - PExpr_BV :: (1 <= w, KnownNat w) => - [BVFactor w] -> BV w -> PermExpr (BVType w) - - -- | A struct expression is an expression for each argument of the struct type - PExpr_Struct :: PermExprs (CtxToRList args) -> PermExpr (StructType args) - - -- | The @always@ lifetime that is always current - PExpr_Always :: PermExpr LifetimeType - - -- | An LLVM value that represents a word, i.e., whose region identifier is 0 - PExpr_LLVMWord :: (1 <= w, KnownNat w) => PermExpr (BVType w) -> - PermExpr (LLVMPointerType w) - - -- | An LLVM value built by adding an offset to an LLVM variable - PExpr_LLVMOffset :: (1 <= w, KnownNat w) => - ExprVar (LLVMPointerType w) -> - PermExpr (BVType w) -> - PermExpr (LLVMPointerType w) - - -- | A literal function pointer - PExpr_Fun :: FnHandle args ret -> PermExpr (FunctionHandleType args ret) - - -- | An empty permission list - PExpr_PermListNil :: PermExpr PermListType - - -- | A cons of an expression and a permission on it to a permission list - PExpr_PermListCons :: TypeRepr a -> PermExpr a -> ValuePerm a -> - PermExpr PermListType -> PermExpr PermListType - - -- | A read/write modality - PExpr_RWModality :: RWModality -> PermExpr RWModalityType - - -- | The empty / vacuously true shape - PExpr_EmptyShape :: PermExpr (LLVMShapeType w) - - -- | A named shape along with arguments for it, with optional read/write and - -- lifetime modalities that are applied to the body of the shape - PExpr_NamedShape :: KnownNat w => Maybe (PermExpr RWModalityType) -> - Maybe (PermExpr LifetimeType) -> - NamedShape b args w -> PermExprs args -> - PermExpr (LLVMShapeType w) - - -- | The equality shape, which describes some @N@ bytes of memory that are - -- equal to a given LLVM block - PExpr_EqShape :: PermExpr (BVType w) -> PermExpr (LLVMBlockType w) -> - PermExpr (LLVMShapeType w) - - -- | A shape for a pointer to another memory block, i.e., a @memblock@ - -- permission, with a given shape. This @memblock@ permission will have the - -- same read/write and lifetime modalities as the @memblock@ permission - -- containing this pointer shape, unless they are specifically overridden by - -- the pointer shape; i.e., we have that - -- - -- > [l]memblock(rw,off,len,ptrsh(rw',l',sh)) = - -- > [l]memblock(rw,off,len,fieldsh([l']memblock(rw',0,len(sh),sh))) - -- - -- where @rw'@ and/or @l'@ can be 'Nothing', in which case they default to - -- @rw@ and @l@, respectively. - PExpr_PtrShape :: Maybe (PermExpr RWModalityType) -> - Maybe (PermExpr LifetimeType) -> - PermExpr (LLVMShapeType w) -> PermExpr (LLVMShapeType w) - - -- | A shape for a single field with a given permission - PExpr_FieldShape :: (1 <= w, KnownNat w) => LLVMFieldShape w -> - PermExpr (LLVMShapeType w) - - -- | 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 -> - PermExpr (LLVMShapeType w) -> - PermExpr (LLVMShapeType w) - - -- | The explicit tupling of the translation of a shape into a tuple type - PExpr_TupShape :: PermExpr (LLVMShapeType w) -> PermExpr (LLVMShapeType w) - - -- | A sequence of two shapes - PExpr_SeqShape :: PermExpr (LLVMShapeType w) -> PermExpr (LLVMShapeType w) -> - PermExpr (LLVMShapeType w) - - -- | A disjunctive shape - PExpr_OrShape :: PermExpr (LLVMShapeType w) -> PermExpr (LLVMShapeType w) -> - PermExpr (LLVMShapeType w) - - -- | An existential shape - PExpr_ExShape :: KnownRepr TypeRepr a => - Binding a (PermExpr (LLVMShapeType w)) -> - PermExpr (LLVMShapeType w) - - -- | A false shape - PExpr_FalseShape :: PermExpr (LLVMShapeType w) - - -- | A permission as an expression - PExpr_ValPerm :: ValuePerm a -> PermExpr (ValuePermType a) - --- | A sequence of permission expressions -type PermExprs = RAssign PermExpr - -{- -data PermExprs (as :: RList CrucibleType) where - PExprs_Nil :: PermExprs RNil - PExprs_Cons :: PermExprs as -> PermExpr a -> PermExprs (as :> a) --} - --- | A bitvector variable, possibly multiplied by a constant -data BVFactor w where - -- | A variable of type @'BVType' w@ multiplied by a constant @i@, which - -- should be in the range @0 <= i < 2^w@ - BVFactor :: (1 <= w, KnownNat w) => BV w -> ExprVar (BVType w) -> - BVFactor w - --- | Whether a permission allows reads or writes -data RWModality - = Write - | Read - deriving Eq - --- | The Haskell type of permission variables, that is, variables that range --- over 'ValuePerm's -type PermVar (a :: CrucibleType) = Name (ValuePermType a) - --- | Ranges @[off,off+len)@ of bitvector values @x@ equal to @off+y@ for some --- unsigned @y < len@. Note that ranges are allowed to wrap around 0, meaning --- @off+y@ can overflow when testing whether @x@ is in the range. Thus, @x@ is --- in range @[off,off+len)@ iff @x-off@ is unsigned less than @len@. -data BVRange w = BVRange { bvRangeOffset :: PermExpr (BVType w), - bvRangeLength :: PermExpr (BVType w) } - --- | A range of offsets, possibly inside bindings for zero or more existential --- variables, that makes sense for a given Crucible type, along with read/write --- and lifetime modalities -data MbRangeForType a where - MbRangeForLLVMType :: - (1 <= w, KnownNat w) => CruCtx vars -> - Mb vars (PermExpr RWModalityType) -> Mb vars (PermExpr LifetimeType) -> - Mb vars (BVRange w) -> MbRangeForType (LLVMPointerType w) - --- | Build an 'MbRangeForType' from a 'BVRange' -rangeForLLVMType :: (1 <= w, KnownNat w) => - PermExpr RWModalityType -> PermExpr LifetimeType -> - BVRange w -> MbRangeForType (LLVMPointerType w) -rangeForLLVMType rw l rng = - MbRangeForLLVMType CruCtxNil (emptyMb rw) (emptyMb l) (emptyMb rng) - --- | A name-binding over some list of typed existential variables -data SomeTypedMb a where - SomeTypedMb :: CruCtx ctx -> Mb ctx a -> SomeTypedMb a - - --- | Propositions about bitvectors -data BVProp w - -- | True iff the two expressions are equal - = BVProp_Eq (PermExpr (BVType w)) (PermExpr (BVType w)) - -- | True iff the two expressions are not equal - | BVProp_Neq (PermExpr (BVType w)) (PermExpr (BVType w)) - -- | True iff the first expression is unsigned less-than the second - | BVProp_ULt (PermExpr (BVType w)) (PermExpr (BVType w)) - -- | True iff the first expression is unsigned @<=@ the second - | BVProp_ULeq (PermExpr (BVType w)) (PermExpr (BVType w)) - -- | True iff the first expression is unsigned @<=@ the difference of the - -- second minus the third - | (1 <= w, KnownNat w) => - BVProp_ULeq_Diff (PermExpr (BVType w)) (PermExpr (BVType w)) - (PermExpr (BVType w)) - --- | An atomic permission is a value permission that is not one of the compound --- constructs in the 'ValuePerm' type; i.e., not a disjunction, existential, --- recursive, or equals permission. These are the permissions that we can put --- together with separating conjuctions. -data AtomicPerm (a :: CrucibleType) where - -- | Gives permissions to a single field pointed to by an LLVM pointer - Perm_LLVMField :: (1 <= w, KnownNat w, 1 <= sz, KnownNat sz) => - LLVMFieldPerm w sz -> - AtomicPerm (LLVMPointerType w) - - -- | Gives permissions to an array pointer to by an LLVM pointer - Perm_LLVMArray :: (1 <= w, KnownNat w) => LLVMArrayPerm w -> - AtomicPerm (LLVMPointerType w) - - -- | Gives read or write access to a memory block, whose contents also give - -- some permissions - Perm_LLVMBlock :: (1 <= w, KnownNat w) => LLVMBlockPerm w -> - AtomicPerm (LLVMPointerType w) - - -- | Says that we have permission to free the memory pointed at by this - -- pointer if we have write permission to @e@ words of size @w@ - Perm_LLVMFree :: (1 <= w, KnownNat w) => PermExpr (BVType w) -> - AtomicPerm (LLVMPointerType w) - - -- | Says that we know an LLVM value is a function pointer whose function has - -- the given permissions - Perm_LLVMFunPtr :: (1 <= w, KnownNat w) => - TypeRepr (FunctionHandleType cargs ret) -> - ValuePerm (FunctionHandleType cargs ret) -> - AtomicPerm (LLVMPointerType w) - - -- | Says that a memory block has a given shape - Perm_LLVMBlockShape :: (1 <= w, KnownNat w) => PermExpr (LLVMShapeType w) -> - AtomicPerm (LLVMBlockType w) - - -- | Says we know an LLVM value is a pointer value, meaning that its block - -- value is non-zero. Note that this does not say the pointer is allocated. - Perm_IsLLVMPtr :: (1 <= w, KnownNat w) => - AtomicPerm (LLVMPointerType w) - - -- | A named conjunctive permission - Perm_NamedConj :: NameSortIsConj ns ~ 'True => - NamedPermName ns args a -> PermExprs args -> - PermOffset a -> AtomicPerm a - - -- | Permission to allocate (via @alloca@) on an LLVM stack frame, and - -- permission to delete that stack frame if we have exclusive permissions to - -- all the given LLVM pointer objects - Perm_LLVMFrame :: (1 <= w, KnownNat w) => LLVMFramePerm w -> - AtomicPerm (LLVMFrameType w) - - -- | Ownership permission for a lifetime, including an assertion that it is - -- still current and permission to end that lifetime. A lifetime also - -- represents a permission \"borrow\" of some sub-permissions out of some - -- larger permissions. For example, we might borrow a portion of an array, or - -- a portion of a larger data structure. When the lifetime is ended, you have - -- to give back to sub-permissions to get back the larger permissions. - -- Together, these are a form of permission implication, so we write lifetime - -- ownership permissions as @lowned(Pin -o Pout)@. Intuitively, @Pin@ must be - -- given back before the lifetime is ended, and @Pout@ is returned afterwards. - -- Additionally, a lifetime may contain some other lifetimes, meaning the all - -- must end before the current one can be ended. - Perm_LOwned :: [PermExpr LifetimeType] -> - CruCtx ps_in -> CruCtx ps_out -> - ExprPerms ps_in -> ExprPerms ps_out -> - AtomicPerm LifetimeType - - -- | A simplified version of @lowned@, written just @lowned(ps)@, which - -- represents a lifetime where the permissions @ps@ have been borrowed and no - -- simplifications have been done. Semantically, this is logically equivalent - -- to @lowned ([l](R)ps -o ps)@, i.e., an @lowned@ permissions where the input - -- and output permissions are the same except that the input permissions are - -- the minimal possible versions of @ps@ in lifetime @l@ that could be given - -- back when @l@ is ended. - Perm_LOwnedSimple :: CruCtx ps -> ExprPerms ps -> AtomicPerm LifetimeType - - -- | Assertion that a lifetime is current during another lifetime; - -- @l1:lcurrent l2@ can also be read as @l1@ contains @l2@ as a sub-lifetime - Perm_LCurrent :: PermExpr LifetimeType -> AtomicPerm LifetimeType - - -- | Assertion that a lifetime has finished - Perm_LFinished :: AtomicPerm LifetimeType - - -- | A struct permission = a sequence of permissions for each field - Perm_Struct :: RAssign ValuePerm (CtxToRList ctx) -> - AtomicPerm (StructType ctx) - - -- | A function permission - Perm_Fun :: FunPerm ghosts (CtxToRList cargs) gouts ret -> - AtomicPerm (FunctionHandleType cargs ret) - - -- | An LLVM permission that asserts a proposition about bitvectors - Perm_BVProp :: (1 <= w, KnownNat w) => BVProp w -> - AtomicPerm (LLVMPointerType w) - - -- | A false / unsatisfiable permission from which any permission can be - -- proved. This is different from the false permission because it translated - -- to the unit type instead of the empty type in specifications, and is used - -- in cases where the empty type cannot be proved in specifications - Perm_Any :: AtomicPerm a - - --- | A value permission is a permission to do something with a value, such as --- use it as a pointer. This also includes a limited set of predicates on values --- (you can think about this as \"permission to assume the value satisfies this --- predicate\" if you like). -data ValuePerm (a :: CrucibleType) where - - -- | Says that a value is equal to a known static expression - ValPerm_Eq :: PermExpr a -> ValuePerm a - - -- | The disjunction of two value permissions - ValPerm_Or :: ValuePerm a -> ValuePerm a -> ValuePerm a - - -- | An existential binding of a value in a value permission - -- - -- FIXME: turn the 'KnownRepr' constraint into a normal 'TypeRepr' argument - ValPerm_Exists :: KnownRepr TypeRepr a => - Binding a (ValuePerm b) -> - ValuePerm b - - -- | A named permission - ValPerm_Named :: NamedPermName ns args a -> PermExprs args -> - PermOffset a -> ValuePerm a - - -- | A permission variable plus an offset - ValPerm_Var :: PermVar a -> PermOffset a -> ValuePerm a - - -- | A separating conjuction of 0 or more atomic permissions, where 0 - -- permissions is the trivially true permission - ValPerm_Conj :: [AtomicPerm a] -> ValuePerm a - - -- | The false / unsatisfiable permission - ValPerm_False :: ValuePerm a - --- | A sequence of value permissions -type ValuePerms = RAssign ValuePerm - --- | A binding of 0 or more variables, each with permissions -type MbValuePerms ctx = Mb ctx (ValuePerms ctx) - --- | A frame permission is a list of the pointers that have been allocated in --- the frame and their corresponding allocation sizes in words of size --- @w@. Write permissions of the given sizes are required to these pointers in --- order to delete the frame. -type LLVMFramePerm w = [(PermExpr (LLVMPointerType w), Integer)] - --- | A permission for a pointer to a specific field of a given size -data LLVMFieldPerm w sz = - LLVMFieldPerm { llvmFieldRW :: PermExpr RWModalityType, - -- ^ Whether this is a read or write permission - llvmFieldLifetime :: PermExpr LifetimeType, - -- ^ 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) - -- ^ The permissions we get for the value read from this field - } - --- | Helper type to represent byte offsets --- --- > stride * ix + off --- --- 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), - llvmArrayIndexOffset :: BV w } - --- | 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 { 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 - 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 - } - --- | An index or range of indices that are missing from an array perm --- --- FIXME: think about calling the just @LLVMArrayIndexSet@ -data LLVMArrayBorrow w - = 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' - -- bytes long - --- | An LLVM block permission is read or write access to the memory at a given --- offset with a given length with a given shape -data LLVMBlockPerm w = - LLVMBlockPerm { llvmBlockRW :: PermExpr RWModalityType, - -- ^ Whether this is a read or write block permission - llvmBlockLifetime :: PermExpr LifetimeType, - -- ^ The lifetime during with this block permission is active - llvmBlockOffset :: PermExpr (BVType w), - -- ^ The offset of the block from the pointer in bytes - llvmBlockLen :: PermExpr (BVType w), - -- ^ The length of the block in bytes - llvmBlockShape :: PermExpr (LLVMShapeType w) - -- ^ The shape of the permissions in the block - } - --- | An LLVM shape for a single pointer field of unknown size -data LLVMFieldShape w = - forall sz. (1 <= sz, KnownNat sz) => - LLVMFieldShape (ValuePerm (LLVMPointerType sz)) - --- | A pair of an epxression and its permission; we give it its own datatype to --- make certain typeclass instances (like pretty-printing) specific to it -data ExprAndPerm a = - ExprAndPerm { exprAndPermExpr :: PermExpr a, - exprAndPermPerm :: ValuePerm a } - --- | A list of expressions and associated permissions; different from --- 'DistPerms' because the expressions need not be variables -type ExprPerms = RAssign ExprAndPerm - --- | A function permission is a set of input and output permissions inside a --- context of ghost variables @ghosts@ with an additional context of output --- ghost variables @gouts@ -data FunPerm ghosts args gouts ret where - FunPerm :: CruCtx ghosts -> CruCtx args -> CruCtx gouts -> TypeRepr ret -> - MbValuePerms (ghosts :++: args) -> - MbValuePerms ((ghosts :++: args) :++: gouts :> ret) -> - FunPerm ghosts args gouts ret - --- | A function permission that existentially quantifies the ghost types -data SomeFunPerm args ret where - SomeFunPerm :: FunPerm ghosts args gouts ret -> SomeFunPerm args ret - --- | The different sorts of name, each of which comes with a 'Bool' flag --- indicating whether the name can be used as an atomic permission. A recursive --- sort also comes with a second flag indicating whether it is a reachability --- permission. -data NameSort = DefinedSort Bool | OpaqueSort Bool | RecursiveSort Bool Bool - -type DefinedSort = 'DefinedSort -type OpaqueSort = 'OpaqueSort -type RecursiveSort = 'RecursiveSort - --- | Test whether a name of a given 'NameSort' is conjoinable -type family NameSortIsConj (ns::NameSort) :: Bool where - NameSortIsConj (DefinedSort b) = b - NameSortIsConj (OpaqueSort b) = b - NameSortIsConj (RecursiveSort b _) = b - --- | Test whether a name of a given 'NameSort' is a reachability permission -type family IsReachabilityName (ns::NameSort) :: Bool where - IsReachabilityName (DefinedSort _) = 'False - IsReachabilityName (OpaqueSort _) = 'False - IsReachabilityName (RecursiveSort _ reach) = reach - --- | A singleton representation of 'NameSort' -data NameSortRepr (ns::NameSort) where - DefinedSortRepr :: BoolRepr b -> NameSortRepr (DefinedSort b) - OpaqueSortRepr :: BoolRepr b -> NameSortRepr (OpaqueSort b) - RecursiveSortRepr :: BoolRepr b -> BoolRepr reach -> - NameSortRepr (RecursiveSort b reach) - --- | A constraint that the last argument of a reachability permission is a --- permission argument -data NameReachConstr ns args a where - NameReachConstr :: (IsReachabilityName ns ~ 'True) => - NameReachConstr ns (args :> a) a - NameNonReachConstr :: (IsReachabilityName ns ~ 'False) => - NameReachConstr ns args a - --- | A name for a named permission -data NamedPermName ns args a = NamedPermName { - namedPermNameName :: String, - namedPermNameType :: TypeRepr a, - namedPermNameArgs :: CruCtx args, - namedPermNameSort :: NameSortRepr ns, - namedPermNameReachConstr :: NameReachConstr ns args a - } - --- | An existentially quantified 'NamedPermName' -data SomeNamedPermName where - SomeNamedPermName :: NamedPermName ns args a -> SomeNamedPermName - --- | A named LLVM shape is a name, a list of arguments, and a body, where the --- Boolean flag @b@ determines whether the shape can be unfolded or not -data NamedShape b args w = NamedShape { - namedShapeName :: String, - namedShapeArgs :: CruCtx args, - namedShapeBody :: NamedShapeBody b args w - } - -data NamedShapeBody b args w where - -- | A defined shape is just a definition in terms of the arguments - DefinedShapeBody :: Mb args (PermExpr (LLVMShapeType w)) -> - NamedShapeBody 'True args w - - -- | An opaque shape has no body, just a length and a translation to two - -- identifiers, the first for a function from translations of the @args@ to - -- the type to use as the translation of the opaque shape applied to @args@ and - -- one for a type description with @args@ as free variables - OpaqueShapeBody :: Mb args (PermExpr (BVType w)) -> Ident -> Ident -> - NamedShapeBody 'False args w - - -- | A recursive shape body has a one-step unfolding to a shape, which can - -- refer to the shape itself via the last bound variable. It also has two - -- identifiers, one for a function from translations of the @args@ to the type - -- to use as the translation of the shape applied to @args@ and one for a type - -- description with @args@ plus a variable for the shape itself (for - -- recursively referring to itself) as free variables. - RecShapeBody :: Mb (args :> LLVMShapeType w) (PermExpr (LLVMShapeType w)) -> - Ident -> Ident -> NamedShapeBody 'True args w - --- | An offset that is added to a permission. Only makes sense for llvm --- permissions (at least for now...?) -data PermOffset a where - NoPermOffset :: PermOffset a - -- | NOTE: the invariant is that the bitvector offset is non-zero - LLVMPermOffset :: (1 <= w, KnownNat w) => PermExpr (BVType w) -> - PermOffset (LLVMPointerType w) - --- | The semantics of a named permission, which can can either be an opaque --- named permission, a recursive named permission, a defined permission, or an --- LLVM shape -data NamedPerm ns args a where - NamedPerm_Opaque :: OpaquePerm b args a -> NamedPerm (OpaqueSort b) args a - NamedPerm_Rec :: RecPerm b reach args a -> - NamedPerm (RecursiveSort b reach) args a - NamedPerm_Defined :: DefinedPerm b args a -> NamedPerm (DefinedSort b) args a - --- | An opaque named permission is just a name and a SAW core type given by --- identifier that it is translated to -data OpaquePerm b args a = OpaquePerm { - opaquePermName :: NamedPermName (OpaqueSort b) args a, - opaquePermTrans :: Ident, - opaquePermTransDesc :: Ident - } - --- | The interpretation of a recursive permission as a reachability permission. --- Reachability permissions are recursive permissions of the form --- --- > reach = eq(x) | p --- --- where @reach@ occurs exactly once in @p@ in the form @reach@ and @x@ --- does not occur at all in @p@. This means their interpretations look like a --- list type, where the @eq(x)@ is the nil constructor and the @p@ is the --- cons. To support the transitivity rule, we need an append function for these --- lists, which is given by the transitivity method listed here, which has type --- --- > trans : forall args (x y:A), t args x -> t args y -> t args y --- --- where @args@ are the arguments and @A@ is the translation of type @a@ (which --- may correspond to 0 or more arguments) -data ReachMethods reach args a where - ReachMethods :: { - reachMethodTrans :: Ident - } -> ReachMethods (args :> a) a 'True - NoReachMethods :: ReachMethods args a 'False - --- | A recursive permission is a permission that can recursively refer to --- itself. This is represented as a \"body\" of the recursive permission that has --- free variables for a list of arguments along with an extra free variable to --- recursively refer to the permission. The @b@ flag indicates whether this --- recursive permission can be used as an atomic permission, which should be --- 'True' iff 'isConjPerm' is for all substitution instances of the body. A --- recursive permission also has two SAW core identifiers that cache the --- translation of its body to a type and to a type description: --- 'recPermTransType' is a function that maps (translations of) the arguments to --- the translation of its body with these arguments to a type; while --- 'recPermTransDesc' is a type description with free deBruijn variable 0 for --- recursive instances of the recursive permission itself and free variables --- starting at 1 for all the arguments. If the recursive permission is a --- reachability permission, then it also has a 'ReachMethods' structure. -data RecPerm b reach args a = RecPerm { - recPermName :: NamedPermName (RecursiveSort b reach) args a, - recPermTransType :: Ident, - recPermTransDesc :: Ident, - recPermReachMethods :: ReachMethods args a reach, - recPermBody :: Mb (args :> ValuePermType a) (ValuePerm a) - } - --- | A defined permission is a name and a permission to which it is --- equivalent. The @b@ flag indicates whether this permission can be used as an --- atomic permission, which should be 'True' iff the associated permission is a --- conjunctive permission as in 'isConjPerm'. -data DefinedPerm b args a = DefinedPerm { - definedPermName :: NamedPermName (DefinedSort b) args a, - definedPermDef :: Mb args (ValuePerm a) -} - --- | A pair of a variable and its permission; we give it its own datatype to --- make certain typeclass instances (like pretty-printing) specific to it -data VarAndPerm a = VarAndPerm (ExprVar a) (ValuePerm a) - --- | A list of \"distinguished\" permissions to named variables --- FIXME: just call these VarsAndPerms or something like that... -type DistPerms = RAssign VarAndPerm - --- | A special-purpose 'DistPerms' that specifies a list of permissions needed --- to prove that a lifetime is current -data LifetimeCurrentPerms ps_l where - -- | The @always@ lifetime needs no proof that it is current - AlwaysCurrentPerms :: LifetimeCurrentPerms RNil - -- | A variable @l@ that is @lowned@ is current, requiring perms - -- - -- > l:lowned[ls](ps_in -o ps_out) - LOwnedCurrentPerms :: ExprVar LifetimeType -> [PermExpr LifetimeType] -> - CruCtx ps_in -> CruCtx ps_out -> - ExprPerms ps_in -> ExprPerms ps_out -> - LifetimeCurrentPerms (RNil :> LifetimeType) - -- | A variable @l@ with a simple @lowned@ perm is also current - LOwnedSimpleCurrentPerms :: ExprVar LifetimeType -> - CruCtx ps -> ExprPerms ps -> - LifetimeCurrentPerms (RNil :> LifetimeType) - - -- | A variable @l@ that is @lcurrent@ during another lifetime @l'@ is - -- current, i.e., if @ps@ ensure @l'@ is current then we need perms - -- - -- > ps, l:lcurrent(l') - CurrentTransPerms :: LifetimeCurrentPerms ps_l -> ExprVar LifetimeType -> - LifetimeCurrentPerms (ps_l :> LifetimeType) - --- | A lifetime functor is a function from a lifetime plus a set of 0 or more --- rwmodalities to a permission that satisfies a number of properties discussed --- in Issue #62 (FIXME: copy those here). Rather than try to enforce these --- properties, we syntactically restrict lifetime functors to one of a few forms --- that are guaranteed to satisfy the properties. The @args@ type lists all --- arguments (which should all be rwmodalities) other than the lifetime --- argument. -data LifetimeFunctor args a where - -- | The functor @\(l,rw) -> [l]ptr((rw,off) |-> p)@ - LTFunctorField :: (1 <= w, KnownNat w, 1 <= sz, KnownNat sz) => - 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) -> - PermExpr (LLVMShapeType w) -> - LifetimeFunctor (RNil :> RWModalityType) (LLVMPointerType w) - - -- FIXME: add functors for arrays and named permissions - --- | An 'LLVMBlockPerm' with a proof that its type is valid -data SomeLLVMBlockPerm a where - SomeLLVMBlockPerm :: (1 <= w, KnownNat w) => LLVMBlockPerm w -> - SomeLLVMBlockPerm (LLVMPointerType w) - --- | A block permission in a binding at some unknown type -data SomeBindingLLVMBlockPerm w = - forall a. SomeBindingLLVMBlockPerm (Binding a (LLVMBlockPerm w)) - --- | A tagged union shape is a shape of the form --- --- > sh1 orsh sh2 orsh ... orsh shn --- --- where each @shi@ is equivalent up to associativity of the @;@ operator to a --- shape of the form --- --- > fieldsh(eq(llvmword(bvi)));shi' --- --- That is, each disjunct of the shape starts with an equality permission that --- 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 sz - = TaggedUnionShape (NonEmpty (BV sz, PermExpr (LLVMShapeType w))) - --- | A 'TaggedUnionShape' with existentially quantified tag size -data SomeTaggedUnionShape w - = forall sz. (1 <= sz, KnownNat sz) => - SomeTaggedUnionShape (TaggedUnionShape w sz) - --- | Like a substitution but assigns variables instead of arbitrary expressions --- to bound variables -data PermVarSubst (ctx :: RList CrucibleType) where - PermVarSubst_Nil :: PermVarSubst RNil - PermVarSubst_Cons :: PermVarSubst ctx -> Name tp -> PermVarSubst (ctx :> tp) - --- | An entry in a permission environment that associates a permission and --- translation with a Crucible function handle -data PermEnvFunEntry where - PermEnvFunEntry :: args ~ CtxToRList cargs => FnHandle cargs ret -> - FunPerm ghosts args gouts ret -> Ident -> - PermEnvFunEntry - --- | An existentially quantified 'NamedPerm' -data SomeNamedPerm where - SomeNamedPerm :: NamedPerm ns args a -> SomeNamedPerm - --- | An existentially quantified LLVM shape with arguments -data SomeNamedShape where - SomeNamedShape :: (1 <= w, KnownNat w) => NamedShape b args w -> - SomeNamedShape - --- | The result of translating a global symbol to SAW core terms, whose types --- should be the result of translating the permissions associated with the --- global symbol to SAW core types -newtype GlobalTrans = GlobalTrans { globalTransTerms :: [OpenTerm] } - --- | An entry in a permission environment that associates a 'GlobalSymbol' with --- a permission and a translation of that permission to either a list of terms --- or a recursive call to the @n@th function in the most recently bound frame of --- recursive functions -data PermEnvGlobalEntry where - PermEnvGlobalEntry :: (1 <= w, KnownNat w) => GlobalSymbol -> - ValuePerm (LLVMPointerType w) -> - GlobalTrans -> PermEnvGlobalEntry - --- | The different sorts hints for blocks -data BlockHintSort args where - -- | This hint specifies the ghost args and input permissions for a block - BlockEntryHintSort :: - CruCtx top_args -> CruCtx ghosts -> - MbValuePerms ((top_args :++: CtxToRList args) :++: ghosts) -> - BlockHintSort args - - -- | This hint says that the input perms for a block should be generalized - GenPermsHintSort :: BlockHintSort args - - -- | This hint says that a block should be a join point - JoinPointHintSort :: BlockHintSort args - --- | A hint for a block -data BlockHint blocks init ret args where - BlockHint :: FnHandle init ret -> Assignment CtxRepr blocks -> - BlockID blocks args -> BlockHintSort args -> - BlockHint blocks init ret args - --- | A \"hint\" from the user for type-checking -data Hint where - Hint_Block :: BlockHint blocks init ret args -> Hint - --- | A permission environment that maps function names, permission names, and --- 'GlobalSymbols' to their respective permission structures -data PermEnv = PermEnv { - permEnvFunPerms :: [PermEnvFunEntry], - permEnvNamedPerms :: [SomeNamedPerm], - permEnvNamedShapes :: [SomeNamedShape], - permEnvGlobalSyms :: [PermEnvGlobalEntry], - permEnvHints :: [Hint], - permEnvEventType :: EventType - } - --- | Get the 'EventType' of a 'PermEnv' as a SAW core term -permEnvEventTypeTerm :: PermEnv -> OpenTerm -permEnvEventTypeTerm = evTypeTerm . permEnvEventType - - ----------------------------------------------------------------------- --- * Template Haskell–generated instances ----------------------------------------------------------------------- - --- Many of these types are mutually recursive. Moreover, Template Haskell --- declaration splices strictly separate top-level groups, so if we were to --- write each $(mkNuMatching [t| ... |]) splice individually, the splices --- involving mutually recursive types would not typecheck. As a result, we --- must put everything into a single splice so that it forms a single top-level --- group. -$(concatMapM mkNuMatching - [ [t| forall a . BVFactor a |] - , [t| RWModality |] - , [t| forall b args w. NamedShapeBody b args w |] - , [t| forall b args w. NamedShape b args w |] - , [t| forall w . LLVMFieldShape w |] - , [t| forall a . PermExpr a |] - , [t| forall w. BVRange w |] - , [t| forall a. MbRangeForType a |] - , [t| forall a. NuMatching a => SomeTypedMb a |] - , [t| forall w. BVProp w |] - , [t| forall w sz . LLVMFieldPerm w sz |] - , [t| forall w . LLVMArrayBorrow w |] - , [t| forall w . LLVMArrayPerm w |] - , [t| forall w . LLVMBlockPerm w |] - , [t| forall ns. NameSortRepr ns |] - , [t| forall ns args a. NameReachConstr ns args a |] - , [t| forall ns args a. NamedPermName ns args a |] - , [t| forall a. PermOffset a |] - , [t| forall ghosts args gouts ret. FunPerm ghosts args gouts ret |] - , [t| forall a . AtomicPerm a |] - , [t| forall a . ValuePerm a |] - -- , [t| forall as. ValuePerms as |] - , [t| forall a . VarAndPerm a |] - , [t| forall a . ExprAndPerm a |] - ]) - -$(mkNuMatching [t| forall w . LLVMArrayIndex w |]) -$(mkNuMatching [t| forall args ret. SomeFunPerm args ret |]) -$(mkNuMatching [t| SomeNamedPermName |]) -$(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 ns args a. NamedPerm ns args a |]) -$(mkNuMatching [t| forall args a. LifetimeFunctor args a |]) -$(mkNuMatching [t| forall ps. LifetimeCurrentPerms ps |]) -$(mkNuMatching [t| forall a. SomeLLVMBlockPerm a |]) -$(mkNuMatching [t| forall w. SomeBindingLLVMBlockPerm 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 |]) -$(mkNuMatching [t| SomeNamedShape |]) -$(mkNuMatching [t| GlobalTrans |]) -$(mkNuMatching [t| PermEnvGlobalEntry |]) -$(mkNuMatching [t| forall args. BlockHintSort args |]) -$(mkNuMatching [t| forall blocks init ret args. - BlockHint blocks init ret args |]) -$(mkNuMatching [t| Hint |]) -$(mkNuMatching [t| EventType |]) -$(mkNuMatching [t| PermEnv |]) - --- NOTE: this instance would require a NuMatching instance for NameMap... --- $(mkNuMatching [t| forall ps. PermSet ps |]) - - ----------------------------------------------------------------------- --- * Utility Functions and Definitions ----------------------------------------------------------------------- - --- | Call 'RL.split' twice to split a nested appended 'RAssign' into three -rlSplit3 :: prx1 ctx1 -> RAssign prx2 ctx2 -> RAssign prx3 ctx3 -> - RAssign f ((ctx1 :++: ctx2) :++: ctx3) -> - (RAssign f ctx1, RAssign f ctx2, RAssign f ctx3) -rlSplit3 (ctx1 :: prx1 ctx1) (ctx2 :: RAssign prx2 ctx2) ctx3 fs123 = - let (fs12, fs3) = RL.split (Proxy :: Proxy (ctx1 :++: ctx2)) ctx3 fs123 in - let (fs1, fs2) = RL.split ctx1 ctx2 fs12 in - (fs1, fs2, fs3) - --- | Take the ceiling of a division -ceil_div :: Integral a => a -> a -> a -ceil_div a b = (a + b - fromInteger 1) `div` b - --- | Replace the body of a binding with a constant -mbConst :: a -> Mb ctx b -> Mb ctx a -mbConst a = fmap $ const a - --- | Get the first element of a pair in a binding -mbFst :: NuMatching a => NuMatching b => Mb ctx (a,b) -> Mb ctx a -mbFst = mbMapCl $(mkClosed [| fst |]) - --- | Get the second element of a pair in a binding -mbSnd :: NuMatching a => NuMatching b => Mb ctx (a,b) -> Mb ctx b -mbSnd = mbMapCl $(mkClosed [| snd |]) - --- | Get the first element of a triple in a binding -mbFst3 :: NuMatching a => NuMatching b => NuMatching c => - Mb ctx (a,b,c) -> Mb ctx a -mbFst3 = mbMapCl $(mkClosed [| \(a,_,_) -> a |]) - --- | Get the first element of a triple in a binding -mbSnd3 :: NuMatching a => NuMatching b => NuMatching c => - Mb ctx (a,b,c) -> Mb ctx b -mbSnd3 = mbMapCl $(mkClosed [| \(_,b,_) -> b |]) - --- | Get the first element of a triple in a binding -mbThd3 :: NuMatching a => NuMatching b => NuMatching c => - Mb ctx (a,b,c) -> Mb ctx c -mbThd3 = mbMapCl $(mkClosed [| \(_,_,c) -> c |]) - --- | FIXME: put this somewhere more appropriate -subNat' :: NatRepr m -> NatRepr n -> Maybe (NatRepr (m-n)) -subNat' m n - | Left leq <- decideLeq n m = - Just $ withLeqProof leq $ subNat m n -subNat' _ _ = Nothing - --- | Delete the nth element of a list -deleteNth :: Int -> [a] -> [a] -deleteNth i xs | i >= length xs = error "deleteNth" -deleteNth i xs = take i xs ++ drop (i+1) xs - --- | Apply 'deleteNth' inside a name-binding -mbDeleteNth :: NuMatching a => Int -> Mb ctx [a] -> Mb ctx [a] -mbDeleteNth i = mbMapCl ($(mkClosed [| deleteNth |]) `clApply` toClosed i) - --- | Replace the nth element of a list -replaceNth :: Int -> a -> [a] -> [a] -replaceNth i _ xs | i >= length xs = error "replaceNth" -replaceNth i x xs = take i xs ++ x : drop (i+1) xs - --- | Insert an element at the nth location in a list -insertNth :: Int -> a -> [a] -> [a] -insertNth i x xs = take i xs ++ x : drop i xs - --- | Find the @n@th element of a list in a binding -mbNth :: NuMatching a => Int -> Mb ctx [a] -> Mb ctx a -mbNth i = mbMapCl ($(mkClosed [| flip (!!) |]) `clApply` toClosed i) - --- | Find all elements of list @l@ where @f@ returns a value and return that --- value plus its index into @l@ -findMaybeIndices :: (a -> Maybe b) -> [a] -> [(Int, b)] -findMaybeIndices f l = catMaybes $ zipWith (\i a -> (i,) <$> f a) [0 ..] l - --- | Find the index of the first element of a list that returns the maximal --- positive value from the supplied ranking function, or return 'Nothing' if all --- elements have non-positive rank -findBestIndex :: (a -> Int) -> [a] -> Maybe Int -findBestIndex rank_f l = - fst $ foldl (\(best_ix,best_rank) (ix,rank) -> - if rank > best_rank then (Just ix, rank) else - (best_ix,best_rank)) - (Nothing, 0) (zipWith (\i a -> (i,rank_f a)) [0 ..] l) - --- | Combine all elements of a list like 'foldr1' unless the list is empty, in --- which case return the default case -foldr1WithDefault :: (a -> a -> a) -> a -> [a] -> a -foldr1WithDefault _ def [] = def -foldr1WithDefault _ _ [a] = a -foldr1WithDefault f def (a:as) = f a $ foldr1WithDefault f def as - --- | Map a function across a list and then call 'foldr1WithDefault'. This is a --- form of map-reduce where the default is returned as a special case for the --- empty list. -foldMapWithDefault :: (b -> b -> b) -> b -> (a -> b) -> [a] -> b -foldMapWithDefault comb def f l = foldr1WithDefault comb def $ map f l - --- | Build a 'NameSet' from a sequence of names and a list of 'Bool' flags -nameSetFromFlags :: RAssign Name (ctx :: RList k) -> [Bool] -> NameSet k -nameSetFromFlags ns flags = - NameSet.fromList $ - mapMaybe (\(n,flag) -> if flag then Just n else Nothing) $ - zip (RL.mapToList SomeName ns) flags - --- | A flag indicating whether an equality test has unfolded a --- recursively-defined name on one side of the equation already -data RecurseFlag = RecLeft | RecRight | RecNone - deriving (Eq, Show, Read) - - ----------------------------------------------------------------------- --- * Pretty-printing ----------------------------------------------------------------------- - --- | A special-purpose type used to indicate debugging level -data DebugLevel = DebugLevel Int deriving (Eq,Ord) - --- | The debug level for no debugging -noDebugLevel :: DebugLevel -noDebugLevel = DebugLevel 0 - --- | The debug level to enable tracing -traceDebugLevel :: DebugLevel -traceDebugLevel = DebugLevel 1 - --- | The debug level to enable more verbose tracing -verboseDebugLevel :: DebugLevel -verboseDebugLevel = DebugLevel 2 - --- | Output a debug statement to @stderr@ using 'trace' if the second --- 'DebugLevel' is at least the first, i.e., the first is the required level for --- emitting this trace and the second is the current level -debugTrace :: DebugLevel -> DebugLevel -> String -> a -> a -debugTrace req dlevel | dlevel >= req = trace -debugTrace _ _ = const id - --- | Call 'debugTrace' at 'traceDebugLevel' -debugTraceTraceLvl :: DebugLevel -> String -> a -> a -debugTraceTraceLvl = debugTrace traceDebugLevel - --- | Like 'debugTrace' but take in a 'Doc' instead of a 'String' -debugTracePretty :: DebugLevel -> DebugLevel -> Doc ann -> a -> a -debugTracePretty req dlevel d a = debugTrace req dlevel (renderDoc d) a - --- | Convert a type to a base name for printing variables of that type -typeBaseName :: TypeRepr a -> String -typeBaseName UnitRepr = "u" -typeBaseName BoolRepr = "b" -typeBaseName NatRepr = "n" -typeBaseName (BVRepr _) = "bv" -typeBaseName (LLVMPointerRepr _) = "ptr" -typeBaseName (LLVMBlockRepr _) = "blk" -typeBaseName (LLVMFrameRepr _) = "frm" -typeBaseName LifetimeRepr = "l" -typeBaseName RWModalityRepr = "rw" -typeBaseName (ValuePermRepr _) = "perm" -typeBaseName (LLVMShapeRepr _) = "shape" -typeBaseName (StringRepr _) = "str" -typeBaseName (FunctionHandleRepr _ _) = "fn" -typeBaseName (StructRepr _) = "strct" -typeBaseName _ = "x" - - --- | A 'PPInfo' maps bound 'Name's to strings used for printing, with the --- invariant that each 'Name' is mapped to a different string. This invariant is --- maintained by always assigning each 'Name' to a \"base string\", which is --- often determined by the Crucible type of the 'Name', followed by a unique --- integer. Note that this means no base name should end with an integer. To --- ensure the uniqueness of these integers, the 'PPInfo' structure tracks the --- next integer to be used for each base string. -data PPInfo = - PPInfo { ppExprNames :: NameMap (StringF :: CrucibleType -> Type), - ppBaseNextInt :: Map String Int } - --- | Build an empty 'PPInfo' structure -emptyPPInfo :: PPInfo -emptyPPInfo = PPInfo NameMap.empty Map.empty - --- | Add an expression variable to a 'PPInfo' with the given base name -ppInfoAddExprName :: String -> ExprVar a -> PPInfo -> PPInfo -ppInfoAddExprName base x ppi = - let (ppi', str) = ppInfoAllocateName base ppi in - ppInfoApplyName x str ppi' - -ppInfoApplyName :: Name (x :: CrucibleType) -> String -> PPInfo -> PPInfo -ppInfoApplyName x str ppi = - ppi { ppExprNames = NameMap.insert x (StringF str) (ppExprNames ppi) } - -ppInfoAllocateName :: String -> PPInfo -> (PPInfo, String) -ppInfoAllocateName base _ - | length base == 0 || isDigit (last base) = - error ("ppInfoAddExprName: invalid base name: " ++ base) -ppInfoAllocateName base ppi = - let (i',str) = - case Map.lookup base (ppBaseNextInt ppi) of - Just i -> (i+1, base ++ show i) - Nothing -> (1, base) in - (ppi { ppBaseNextInt = Map.insert base i' (ppBaseNextInt ppi) }, str) - --- | Add a sequence of variables to a 'PPInfo' with the given base name -ppInfoAddExprNames :: String -> RAssign Name (tps :: RList CrucibleType) -> - PPInfo -> PPInfo -ppInfoAddExprNames _ MNil info = info -ppInfoAddExprNames base (ns :>: n) info = - ppInfoAddExprNames base ns $ ppInfoAddExprName base n info - --- | -ppInfoAllocateExprNames :: - String {- ^ base name -} -> - RAssign pxy (tps :: RList CrucibleType) -> - PPInfo -> - (PPInfo, RAssign StringF tps) -ppInfoAllocateExprNames _ MNil info = (info, MNil) -ppInfoAllocateExprNames base (ns :>: _) ppi = - case ppInfoAllocateName base ppi of - (ppi1, str) -> - case ppInfoAllocateExprNames base ns ppi1 of - (ppi2, ns') -> (ppi2, ns' :>: StringF str) - --- | Add a sequence of variables to a 'PPInfo' using their 'typeBaseName's -ppInfoAddTypedExprNames :: CruCtx tps -> RAssign Name tps -> PPInfo -> PPInfo -ppInfoAddTypedExprNames _ MNil info = info -ppInfoAddTypedExprNames (CruCtxCons tps tp) (ns :>: n) info = - ppInfoAddTypedExprNames tps ns $ ppInfoAddExprName (typeBaseName tp) n info - -ppInfoApplyAllocation :: - RAssign Name (tps :: RList CrucibleType) -> - RAssign StringF tps -> - PPInfo -> - PPInfo -ppInfoApplyAllocation MNil MNil ppi = ppi -ppInfoApplyAllocation (ns :>: n) (ss :>: StringF s) ppi = - ppInfoApplyAllocation ns ss (ppInfoApplyName n s ppi) - -type PermPPM = Reader PPInfo - -instance NuMatching (Doc ann) where - nuMatchingProof = unsafeMbTypeRepr - -instance Closable (Doc ann) where - toClosed = unsafeClose - -instance Liftable (Doc ann) where - mbLift = unClosed . mbLift . fmap toClosed - - -class PermPretty a where - permPrettyM :: a -> PermPPM (Doc ann) - -class PermPrettyF f where - permPrettyMF :: f a -> PermPPM (Doc ann) - -permPretty :: PermPretty a => PPInfo -> a -> Doc ann -permPretty info a = runReader (permPrettyM a) info - -renderDoc :: Doc ann -> String -renderDoc doc = renderString (layoutPretty opts doc) - where opts = LayoutOptions (AvailablePerLine 80 0.8) - -permPrettyString :: PermPretty a => PPInfo -> a -> String -permPrettyString info a = renderDoc $ permPretty info a - -tracePretty :: Doc ann -> a -> a -tracePretty doc = trace (renderDoc doc) - --- | Pretty-print a comma-separated list -ppCommaSep :: [Doc ann] -> Doc ann -ppCommaSep ds = - PP.group $ align $ fillSep $ map PP.group $ PP.punctuate comma ds - --- | Pretty-print a comma-separated list using 'fillSep' enclosed inside either --- parentheses (if the supplied flag is 'True') or brackets (if it is 'False') -ppEncList :: Bool -> [Doc ann] -> Doc ann -ppEncList flag ds = - (if flag then parens else brackets) $ ppCommaSep ds - -instance (PermPretty a, PermPretty b) => PermPretty (a,b) where - permPrettyM (a,b) = ppEncList True <$> sequence [permPrettyM a, permPrettyM b] - -instance (PermPretty a, PermPretty b, PermPretty c) => PermPretty (a,b,c) where - permPrettyM (a,b,c) = - ppEncList True <$> sequence [permPrettyM a, permPrettyM b, permPrettyM c] - -instance PermPretty a => PermPretty [a] where - permPrettyM as = ppEncList False <$> mapM permPrettyM as - -instance PermPretty a => PermPretty (Maybe a) where - permPrettyM Nothing = return $ pretty "Nothing" - permPrettyM (Just a) = do - a_pp <- permPrettyM a - return (pretty "Just" <+> a_pp) - -instance PermPrettyF f => PermPretty (Some f) where - permPrettyM (Some x) = permPrettyMF x - -instance PermPretty (ExprVar a) where - permPrettyM x = - do maybe_str <- NameMap.lookup x <$> ppExprNames <$> ask - case maybe_str of - Just (StringF str) -> return $ pretty str - Nothing -> return $ pretty (show x) - -instance PermPrettyF (Name :: CrucibleType -> Type) where - permPrettyMF = permPrettyM - -instance PermPretty (SomeName CrucibleType) where - permPrettyM (SomeName x) = permPrettyM x - -instance PermPrettyF f => PermPretty (RAssign f ctx) where - permPrettyM xs = - ppCommaSep <$> sequence (RL.mapToList permPrettyMF xs) - -instance PermPrettyF f => PermPrettyF (RAssign f) where - permPrettyMF xs = permPrettyM xs - - -instance PermPretty (TypeRepr a) where - permPrettyM UnitRepr = return $ pretty "unit" - permPrettyM BoolRepr = return $ pretty "bool" - permPrettyM NatRepr = return $ pretty "nat" - permPrettyM (BVRepr w) = return (pretty "bv" <+> pretty (intValue w)) - permPrettyM (LLVMPointerRepr w) = - return (pretty "llvmptr" <+> pretty (intValue w)) - permPrettyM (LLVMFrameRepr w) = - return (pretty "llvmframe" <+> pretty (intValue w)) - permPrettyM LifetimeRepr = return $ pretty "lifetime" - permPrettyM RWModalityRepr = return $ pretty "rwmodality" - permPrettyM (LLVMShapeRepr w) = - return (pretty "llvmshape" <+> pretty (intValue w)) - permPrettyM (LLVMBlockRepr w) = - return (pretty "llvmblock" <+> pretty (intValue w)) - permPrettyM PermListRepr = return $ pretty "permlist" - permPrettyM (StructRepr flds) = - (pretty "struct" <+>) <$> parens <$> permPrettyM (assignToRList flds) - permPrettyM (ValuePermRepr tp) = (pretty "perm" <+>) <$> permPrettyM tp - permPrettyM tp = - return (pretty "not-yet-printable type" <+> parens (pretty tp)) - -instance PermPrettyF TypeRepr where - permPrettyMF = permPrettyM - -instance PermPretty (CruCtx ctx) where - permPrettyM = permPrettyM . cruCtxToTypes - --- | A pair of a variable and its 'CrucibleType', for pretty-printing -data VarAndType a = VarAndType (ExprVar a) (TypeRepr a) - -instance PermPretty (VarAndType a) where - permPrettyM (VarAndType x tp) = - do x_pp <- permPrettyM x - tp_pp <- permPrettyM tp - return (x_pp <> colon <> tp_pp) - -instance PermPrettyF VarAndType where - permPrettyMF = permPrettyM - - --- | Pretty-print a name-binding using a function that takes the pretty-printed --- names along with the body of the name-binding -permPrettyMb :: (RAssign (Constant (Doc ann)) ctx -> a -> PermPPM (Doc ann)) -> - Mb (ctx :: RList CrucibleType) a -> PermPPM (Doc ann) -permPrettyMb f mb = - fmap mbLift $ strongMbM $ flip nuMultiWithElim1 mb $ \ns a -> - local (ppInfoAddExprNames "z" ns) $ - do ns_pp <- traverseRAssign (\n -> Constant <$> permPrettyM n) ns - PP.group <$> hang 2 <$> f ns_pp a - --- | Pretty-print an expression-like construct in a name-binding using a --- function that combines the pretty-printed names along with the pretty-printed --- body of the name-binding -permPrettyExprMb :: PermPretty a => - (RAssign (Constant (Doc ann)) ctx -> PermPPM (Doc ann) -> - PermPPM (Doc ann)) -> - Mb (ctx :: RList CrucibleType) a -> PermPPM (Doc ann) -permPrettyExprMb f = permPrettyMb (\ns_pp a -> f ns_pp (permPrettyM a)) - - --- | Pretty-print an expression-like construct in a name-binding using --- a function that combines the pretty-printed names along with the --- pretty-printed body of the name-binding, using the types of the --- found names to generate their string names -permPrettyExprMbTyped :: PermPretty a => - CruCtx ctx -> - (RAssign (Constant (Doc ann)) ctx -> PermPPM (Doc ann) -> PermPPM (Doc ann)) -> - Mb (ctx :: RList CrucibleType) a -> PermPPM (Doc ann) -permPrettyExprMbTyped ctx f mb = - fmap mbLift $ strongMbM $ flip nuMultiWithElim1 mb $ \ns a -> - local (ppInfoAddTypedExprNames ctx ns) $ - do docs <- traverseRAssign (\n -> Constant <$> permPrettyM n) ns - f docs $ permPrettyM a - -instance (PermPretty a) => PermPretty (Mb (ctx :: RList CrucibleType) a) where - permPrettyM = - permPrettyExprMb $ \docs ppm -> - (\pp -> ppEncList True (RL.toList docs) <> dot <> line <> pp) <$> ppm - -instance PermPretty Integer where - permPrettyM = return . pretty - - ----------------------------------------------------------------------- --- * Expressions for Permissions ----------------------------------------------------------------------- - --- | The object-level representation of 'LifetimeType' -lifetimeTypeRepr :: TypeRepr LifetimeType -lifetimeTypeRepr = knownRepr - --- | Pattern for building/destructing lifetime types -pattern LifetimeRepr :: () => (ty ~ LifetimeType) => TypeRepr ty -pattern LifetimeRepr <- - IntrinsicRepr (testEquality (knownSymbol :: SymbolRepr "Lifetime") -> - Just Refl) - Empty - where LifetimeRepr = IntrinsicRepr knownSymbol Empty - --- | A lifetime is an expression of type 'LifetimeType' ---type Lifetime = PermExpr LifetimeType - --- | The object-level representation of 'RWModalityType' -rwModalityTypeRepr :: TypeRepr RWModalityType -rwModalityTypeRepr = knownRepr - --- | Pattern for building/destructing RWModality types -pattern RWModalityRepr :: () => (ty ~ RWModalityType) => TypeRepr ty -pattern RWModalityRepr <- - IntrinsicRepr (testEquality (knownSymbol :: SymbolRepr "RWModality") -> - Just Refl) - Empty - where RWModalityRepr = IntrinsicRepr knownSymbol Empty - --- | Pattern for building/desctructing permission list types -pattern PermListRepr :: () => ty ~ PermListType => TypeRepr ty -pattern PermListRepr <- - IntrinsicRepr (testEquality (knownSymbol :: SymbolRepr "PermList") -> - Just Refl) Empty - where - PermListRepr = IntrinsicRepr knownSymbol Empty - --- | Pattern for building/desctructing LLVM frame types -pattern LLVMFrameRepr :: () => (1 <= w, ty ~ LLVMFrameType w) => - NatRepr w -> TypeRepr ty -pattern LLVMFrameRepr w <- - IntrinsicRepr (testEquality (knownSymbol :: SymbolRepr "LLVMFrame") -> - Just Refl) - (viewAssign -> AssignExtend Empty (BVRepr w)) - where - LLVMFrameRepr w = IntrinsicRepr knownSymbol (Ctx.extend Empty (BVRepr w)) - --- | Pattern for building/desctructing permissions as expressions -pattern ValuePermRepr :: () => (ty ~ ValuePermType a) => TypeRepr a -> - TypeRepr ty -pattern ValuePermRepr a <- - IntrinsicRepr (testEquality (knownSymbol :: SymbolRepr "Perm") -> - Just Refl) - (viewAssign -> AssignExtend Empty a) - where - ValuePermRepr a = IntrinsicRepr knownSymbol (Ctx.extend Empty a) - --- | Pattern for building/desctructing LLVM frame types -pattern LLVMShapeRepr :: () => (1 <= w, ty ~ LLVMShapeType w) => - NatRepr w -> TypeRepr ty -pattern LLVMShapeRepr w <- - IntrinsicRepr (testEquality (knownSymbol :: SymbolRepr "LLVMShape") -> - Just Refl) - (viewAssign -> AssignExtend Empty (BVRepr w)) - where - LLVMShapeRepr w = IntrinsicRepr knownSymbol (Ctx.extend Empty (BVRepr w)) - --- | Pattern for building/desctructing LLVM frame types -pattern LLVMBlockRepr :: () => (1 <= w, ty ~ LLVMBlockType w) => - NatRepr w -> TypeRepr ty -pattern LLVMBlockRepr w <- - IntrinsicRepr (testEquality (knownSymbol :: SymbolRepr "LLVMBlock") -> - Just Refl) - (viewAssign -> AssignExtend Empty (BVRepr w)) - where - LLVMBlockRepr w = IntrinsicRepr knownSymbol (Ctx.extend Empty (BVRepr w)) - - --- | Pattern for an empty 'PermExprs' list -pattern PExprs_Nil :: () => (tps ~ RNil) => PermExprs tps -pattern PExprs_Nil = MNil - --- | Pattern for a non-empty 'PermExprs' list -pattern PExprs_Cons :: () => (tps ~ (tps' :> a)) => - PermExprs tps' -> PermExpr a -> PermExprs tps -pattern PExprs_Cons es e <- es :>: e - where - PExprs_Cons es e = es :>: e - -{-# COMPLETE PExprs_Nil, PExprs_Cons #-} - --- | Convert a 'PermExprs' to an 'RAssign' -exprsToRAssign :: PermExprs as -> RAssign PermExpr as -exprsToRAssign PExprs_Nil = MNil -exprsToRAssign (PExprs_Cons es e) = exprsToRAssign es :>: e - --- | Convert an 'RAssign' to a 'PermExprs' -rassignToExprs :: RAssign PermExpr as -> PermExprs as -rassignToExprs MNil = PExprs_Nil -rassignToExprs (es :>: e) = PExprs_Cons (rassignToExprs es) e - --- | Convert a list of names to a 'PermExprs' list -namesToExprs :: RAssign Name as -> PermExprs as -namesToExprs MNil = PExprs_Nil -namesToExprs (ns :>: n) = PExprs_Cons (namesToExprs ns) (PExpr_Var n) - --- | Create a list of phantom 'Proxy' arguments from a 'PermExprs' list -proxiesOfExprs :: PermExprs as -> RAssign Proxy as -proxiesOfExprs PExprs_Nil = MNil -proxiesOfExprs (PExprs_Cons es _) = proxiesOfExprs es :>: Proxy - --- | Append two 'PermExprs' lists -appendExprs :: PermExprs as -> PermExprs bs -> PermExprs (as :++: bs) -appendExprs as PExprs_Nil = as -appendExprs as (PExprs_Cons bs b) = PExprs_Cons (appendExprs as bs) b - --- | Convenience function to get the known type of an expression-like construct -exprType :: KnownRepr TypeRepr a => f a -> TypeRepr a -exprType _ = knownRepr - --- | Convenience function to get the known type of bound name -bindingType :: KnownRepr TypeRepr a => Binding a b -> TypeRepr a -bindingType _ = knownRepr - --- | Convenience function to get the bit width of an LLVM pointer type -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 a bitvector type -exprBVTypeWidth :: KnownNat w => f (BVType w) -> NatRepr w -exprBVTypeWidth _ = knownNat - --- | Convenience function to get the bit width of an LLVM pointer type -mbExprBVTypeWidth :: KnownNat w => Mb ctx (f (BVType w)) -> NatRepr w -mbExprBVTypeWidth _ = knownNat - --- | Convenience function to get the bit width of an LLVM pointer type -shapeLLVMTypeWidth :: KnownNat w => f (LLVMShapeType w) -> NatRepr w -shapeLLVMTypeWidth _ = knownNat - --- | Convenience function to get the number of bytes = the bit width divided by --- 8 of an LLVM pointer type rounded up -exprLLVMTypeBytes :: KnownNat w => f (LLVMPointerType w) -> Integer -exprLLVMTypeBytes e = intValue (exprLLVMTypeWidth e) `ceil_div` 8 - --- | Convenience function to get the number of bytes = the bit width divided by --- 8 of an LLVM pointer type as an expr. Note that this assumes the bit width is --- a multiple of 8, so does not worry about rounding. -exprLLVMTypeBytesExpr :: (1 <= w, KnownNat w, 1 <= sz, KnownNat sz) => - f (LLVMPointerType sz) -> PermExpr (BVType w) -exprLLVMTypeBytesExpr e = bvInt (intValue (exprLLVMTypeWidth e) `ceil_div` 8) - --- | Convenience function to get the width of an LLVM pointer type of an --- expression in a binding as an expression -mbExprLLVMTypeBytesExpr :: (1 <= w, KnownNat w, 1 <= sz, KnownNat sz) => - Mb ctx (f (LLVMPointerType sz)) -> - PermExpr (BVType w) -mbExprLLVMTypeBytesExpr mb_e = - bvInt $ ceil_div (intValue $ mbLift $ fmap exprLLVMTypeWidth mb_e) 8 - --- | Pattern-match a permission list expression as a typed list of permissions --- consed onto a terminator, which can either be the empty list (represented by --- 'Nothing') or a variable expression -matchPermList :: PermExpr PermListType -> (Some ExprPerms, - Maybe (ExprVar PermListType)) -matchPermList PExpr_PermListNil = (Some MNil, Nothing) -matchPermList (PExpr_Var ps) = (Some MNil, Just ps) -matchPermList (PExpr_PermListCons _ e p l) - | (Some eperms, term) <- matchPermList l - = (Some (RL.append (MNil :>: ExprAndPerm e p) eperms), term) - --- | Pattern-match a permission list expression as a list of permissions on --- variables with an empty list (not a variable) as a terminator -matchVarPermList :: PermExpr PermListType -> Maybe (Some DistPerms) -matchVarPermList PExpr_PermListNil = Just $ Some MNil -matchVarPermList (PExpr_PermListCons _ (PExpr_Var x) p l) - | Just (Some perms) <- matchVarPermList l = - Just $ Some $ RL.append (MNil :>: VarAndPerm x p) perms -matchVarPermList _ = Nothing - --- | Fold over all permissions associated with a specific variable in a --- permission list -foldPermList :: ExprVar a -> (ValuePerm a -> r -> r) -> r -> - PermExpr PermListType -> r -foldPermList _ _ r PExpr_PermListNil = r -foldPermList _ _ r (PExpr_Var _) = r -foldPermList x f r (PExpr_PermListCons _ (PExpr_Var y) p plist) - | Just Refl <- testEquality x y = - f p $ foldPermList x f r plist -foldPermList x f r (PExpr_PermListCons _ _ _ plist) = - foldPermList x f r plist - --- | Fold over all atomic permissions associated with a specific variable in a --- permission list -foldPermListAtomic :: ExprVar a -> (AtomicPerm a -> r -> r) -> r -> - PermExpr PermListType -> r -foldPermListAtomic x f = - foldPermList x (\p rest -> - case p of - ValPerm_Conj ps -> foldr f rest ps - _ -> rest) - --- | Find a permission on a specific variable in a permission list -findPermInList :: ExprVar a -> (ValuePerm a -> Bool) -> PermExpr PermListType -> - Maybe (ValuePerm a) -findPermInList x pred plist = - foldPermList x (\p rest -> if pred p then Just p else rest) Nothing plist - --- | Find an atomic permission on a specific variable in a permission list -findAtomicPermInList :: ExprVar a -> (AtomicPerm a -> Bool) -> - PermExpr PermListType -> Maybe (AtomicPerm a) -findAtomicPermInList x pred plist = - foldPermListAtomic x (\p rest -> - if pred p then Just p else rest) Nothing plist - -instance Eq (PermExpr a) where - (PExpr_Var x1) == (PExpr_Var x2) = x1 == x2 - (PExpr_Var _) == _ = False - - PExpr_Unit == PExpr_Unit = True - PExpr_Unit == _ = False - - (PExpr_Nat n1) == (PExpr_Nat n2) = n1 == n2 - (PExpr_Nat _) == _ = False - - (PExpr_String str1) == (PExpr_String str2) = str1 == str2 - (PExpr_String _) == _ = False - - (PExpr_Bool b1) == (PExpr_Bool b2) = b1 == b2 - (PExpr_Bool _) == _ = False - - (PExpr_BV factors1 const1) == (PExpr_BV factors2 const2) = - const1 == const2 && eqFactors factors1 factors2 - where - eqFactors :: [BVFactor w] -> [BVFactor w] -> Bool - eqFactors [] [] = True - eqFactors (f : fs1) fs2 - | elem f fs2 = eqFactors fs1 (delete f fs2) - eqFactors _ _ = False - (PExpr_BV _ _) == _ = False - - (PExpr_Struct args1) == (PExpr_Struct args2) = args1 == args2 where - (PExpr_Struct _) == _ = False - - PExpr_Always == PExpr_Always = True - PExpr_Always == _ = False - - (PExpr_LLVMWord e1) == (PExpr_LLVMWord e2) = e1 == e2 - (PExpr_LLVMWord _) == _ = False - - (PExpr_LLVMOffset x1 e1) == (PExpr_LLVMOffset x2 e2) = - x1 == x2 && e1 == e2 - (PExpr_LLVMOffset _ _) == _ = False - - (PExpr_Fun fh1) == (PExpr_Fun fh2) = fh1 == fh2 - (PExpr_Fun _) == _ = False - - PExpr_PermListNil == PExpr_PermListNil = True - PExpr_PermListNil == _ = False - - (PExpr_PermListCons tp1 e1 p1 l1) == (PExpr_PermListCons tp2 e2 p2 l2) - | Just Refl <- testEquality tp1 tp2 - = e1 == e2 && p1 == p2 && l1 == l2 - (PExpr_PermListCons _ _ _ _) == _ = False - - (PExpr_RWModality rw1) == (PExpr_RWModality rw2) = rw1 == rw2 - (PExpr_RWModality _) == _ = False - - PExpr_EmptyShape == PExpr_EmptyShape = True - PExpr_EmptyShape == _ = False - - (PExpr_NamedShape maybe_rw1 maybe_l1 nmsh1 args1) - == (PExpr_NamedShape maybe_rw2 maybe_l2 nmsh2 args2) - | Just (Refl,Refl) <- namedShapeEq nmsh1 nmsh2 = - maybe_rw1 == maybe_rw2 && maybe_l1 == maybe_l2 && args1 == args2 - (PExpr_NamedShape _ _ _ _) == _ = False - - (PExpr_EqShape len1 b1) == (PExpr_EqShape len2 b2) = len1 == len2 && b1 == b2 - (PExpr_EqShape _ _) == _ = False - - (PExpr_PtrShape rw1 l1 sh1) == (PExpr_PtrShape rw2 l2 sh2) = - rw1 == rw2 && l1 == l2 && sh1 == sh2 - (PExpr_PtrShape _ _ _) == _ = False - - (PExpr_FieldShape p1) == (PExpr_FieldShape p2) = p1 == p2 - (PExpr_FieldShape _) == _ = False - - (PExpr_ArrayShape len1 s1 sh1) == (PExpr_ArrayShape len2 s2 sh2) = - len1 == len2 && s1 == s2 && sh1 == sh2 - (PExpr_ArrayShape _ _ _) == _ = False - - (PExpr_TupShape sh1) == (PExpr_TupShape sh2) = sh1 == sh2 - (PExpr_TupShape _) == _ = False - - (PExpr_SeqShape sh1 sh1') == (PExpr_SeqShape sh2 sh2') = - sh1 == sh2 && sh1' == sh2' - (PExpr_SeqShape _ _) == _ = False - - (PExpr_OrShape sh1 sh1') == (PExpr_OrShape sh2 sh2') = - sh1 == sh2 && sh1' == sh2' - (PExpr_OrShape _ _) == _ = False - - (PExpr_ExShape mb_sh1) == (PExpr_ExShape mb_sh2) - | Just Refl <- testEquality (bindingType mb_sh1) (bindingType mb_sh2) - = mbLift $ mbMap2 (==) mb_sh1 mb_sh2 - (PExpr_ExShape _) == _ = False - - PExpr_FalseShape == PExpr_FalseShape = True - PExpr_FalseShape == _ = False - - (PExpr_ValPerm p1) == (PExpr_ValPerm p2) = p1 == p2 - (PExpr_ValPerm _) == _ = False - - -instance Eq1 PermExpr where - eq1 = (==) - -instance Eq (BVFactor w) where - (BVFactor i1 x1) == (BVFactor i2 x2) = i1 == i2 && x1 == x2 - -instance PermPretty (PermExpr a) where - permPrettyM (PExpr_Var x) = permPrettyM x - permPrettyM PExpr_Unit = return $ pretty "()" - permPrettyM (PExpr_Nat n) = return $ pretty $ show n - permPrettyM (PExpr_String str) = return (pretty '"' <> pretty str <> pretty '"') - permPrettyM (PExpr_Bool b) = return $ pretty b - permPrettyM (PExpr_BV [] constant) = - return $ pretty $ BV.asSigned knownNat constant - permPrettyM (PExpr_BV factors constant) = - do factors_pp <- - encloseSep mempty mempty (pretty "+") <$> mapM permPrettyM factors - case BV.asSigned knownNat constant of - 0 -> return factors_pp - c | c > 0 -> return (factors_pp <> pretty "+" <> pretty c) - c -> return (factors_pp <> pretty c) - permPrettyM (PExpr_Struct args) = - (\pp -> pretty "struct" <+> parens pp) <$> permPrettyM args - permPrettyM PExpr_Always = return $ pretty "always" - permPrettyM (PExpr_LLVMWord e) = (pretty "LLVMword" <+>) <$> permPrettyM e - permPrettyM (PExpr_LLVMOffset x e) = - (\ppx ppe -> ppx <+> pretty "&+" <+> ppe) - <$> permPrettyM x <*> permPrettyM e - permPrettyM (PExpr_Fun fh) = return $ angles $ pretty ("fun" ++ show fh) - permPrettyM e@PExpr_PermListNil = prettyPermListM e - permPrettyM e@(PExpr_PermListCons _ _ _ _) = prettyPermListM e - permPrettyM (PExpr_RWModality rw) = permPrettyM rw - permPrettyM PExpr_EmptyShape = return $ pretty "emptysh" - permPrettyM (PExpr_NamedShape maybe_rw maybe_l nmsh args) = - do l_pp <- maybe (return mempty) permPrettyLifetimePrefix maybe_l - rw_pp <- case maybe_rw of - Just rw -> parens <$> permPrettyM rw - Nothing -> return mempty - args_pp <- permPrettyM args - return (l_pp <> rw_pp <> pretty (namedShapeName nmsh) <> - pretty '<' <> align (args_pp <> pretty '>')) - permPrettyM (PExpr_EqShape len b) = - do len_pp <- permPrettyM len - b_pp <- permPrettyM b - return (pretty "eqsh" <> parens (len_pp <> comma <> b_pp)) - permPrettyM (PExpr_PtrShape maybe_rw maybe_l sh) = - do l_pp <- maybe (return mempty) permPrettyLifetimePrefix maybe_l - rw_pp <- case maybe_rw of - Just rw -> (<> pretty ",") <$> permPrettyM rw - Nothing -> return mempty - sh_pp <- permPrettyM sh - return (l_pp <> pretty "ptrsh" <> parens (rw_pp <> sh_pp)) - permPrettyM (PExpr_FieldShape fld) = - (pretty "fieldsh" <>) <$> permPrettyM fld - permPrettyM (PExpr_ArrayShape len stride sh) = - do len_pp <- permPrettyM len - sh_pp <- permPrettyM sh - let stride_pp = pretty (toInteger stride) - return (pretty "arraysh" <> - ppEncList True [pretty "<" <> len_pp, - pretty "*" <> stride_pp, sh_pp]) - permPrettyM (PExpr_TupShape sh) = - do pp <- permPrettyM sh - return $ nest 2 $ sep [pretty "tuplesh" <+> parens pp] - permPrettyM (PExpr_SeqShape sh1 sh2) = - do pp1 <- permPrettyM sh1 - pp2 <- permPrettyM sh2 - return $ nest 2 $ sep [pp1 <> pretty ';', pp2] - permPrettyM (PExpr_OrShape sh1 sh2) = - do pp1 <- permPrettyM sh1 - pp2 <- permPrettyM sh2 - return $ nest 2 $ sep [pp1 <+> pretty "orsh", pp2] - permPrettyM (PExpr_ExShape mb_sh) = - flip (permPrettyExprMbTyped (CruCtxNil `CruCtxCons` knownRepr)) mb_sh $ \(_ :>: Constant pp_n) ppm -> - do pp <- ppm - return $ sep [pretty "exsh" <+> pp_n <> dot, pp] - permPrettyM PExpr_FalseShape = return $ pretty "falsesh" - permPrettyM (PExpr_ValPerm p) = permPrettyM p - -instance (1 <= w, KnownNat w) => PermPretty (LLVMFieldShape w) where - permPrettyM fsh@(LLVMFieldShape p) - | Just Refl <- testEquality (natRepr fsh) (exprLLVMTypeWidth p) = - parens <$> permPrettyM p - permPrettyM (LLVMFieldShape p) = - do p_pp <- permPrettyM p - return $ ppEncList True [pretty (intValue $ exprLLVMTypeWidth p), p_pp] - -prettyPermListM :: PermExpr PermListType -> PermPPM (Doc ann) -prettyPermListM PExpr_PermListNil = - -- Special case for an empty list of permissions - return $ pretty "empty" -prettyPermListM e = - case matchPermList e of - (Some perms, Just term_var) -> - do pps <- sequence (RL.mapToList permPrettyMF perms) - pp_term <- permPrettyM term_var - return $ align $ fillSep (map (<> comma) (take (length pps - 1) pps) - ++ [last pps <+> pretty "::", pp_term]) - (Some perms, Nothing) -> permPrettyM perms - -instance PermPrettyF PermExpr where - permPrettyMF = permPrettyM - -instance PermPretty (BVFactor w) where - permPrettyM (BVFactor i x) = - ((pretty (BV.asSigned knownNat i) <> pretty "*") <>) <$> permPrettyM x - -instance PermPretty RWModality where - permPrettyM Read = return $ pretty "R" - permPrettyM Write = return $ pretty "W" - --- | The 'Write' modality as an expression -pattern PExpr_Write :: PermExpr RWModalityType -pattern PExpr_Write = PExpr_RWModality Write - --- | The 'Read' modality as an expression -pattern PExpr_Read :: PermExpr RWModalityType -pattern PExpr_Read = PExpr_RWModality Read - --- | Build a \"default\" expression for a given type -zeroOfType :: TypeRepr tp -> PermExpr tp -zeroOfType (BVRepr w) = withKnownNat w $ PExpr_BV [] $ BV.mkBV w 0 -zeroOfType LifetimeRepr = PExpr_Always -zeroOfType _ = error "zeroOfType" - - ----------------------------------------------------------------------- --- * Operations on Bitvector and LLVM Pointer Expressions ----------------------------------------------------------------------- - --- | Build a 'BVFactor' for a variable -varFactor :: (1 <= w, KnownNat w) => ExprVar (BVType w) -> BVFactor w -varFactor = BVFactor $ BV.one knownNat - --- | Merge two normalized / sorted lists of 'BVFactor's -bvMergeFactors :: [BVFactor w] -> [BVFactor w] -> [BVFactor w] -bvMergeFactors fs1 fs2 = - filter (\(BVFactor i _) -> i /= BV.zero knownNat) $ - helper fs1 fs2 - where - helper factors1 [] = factors1 - helper [] factors2 = factors2 - helper ((BVFactor i1 x1):factors1) ((BVFactor i2 x2):factors2) - | x1 == x2 - = BVFactor (BV.add knownNat i1 i2) x1 : helper factors1 factors2 - helper (f1@(BVFactor _ x1):factors1) (f2@(BVFactor _ x2):factors2) - | x1 < x2 = f1 : helper factors1 (f2 : factors2) - helper (f1@(BVFactor _ _):factors1) (f2@(BVFactor _ _):factors2) = - f2 : helper (f1 : factors1) factors2 - --- | Convert a bitvector expression to a sum of factors plus a constant -bvMatch :: (1 <= w, KnownNat w) => PermExpr (BVType w) -> - ([BVFactor w], BV w) -bvMatch (PExpr_Var x) = ([varFactor x], BV.zero knownNat) -bvMatch (PExpr_BV factors constant) = (factors, constant) - --- | Test if a bitvector expression is a constant value -bvMatchConst :: PermExpr (BVType w) -> Maybe (BV w) -bvMatchConst (PExpr_BV [] constant) = Just constant -bvMatchConst _ = Nothing - --- | Test if a bitvector expression is a constant unsigned 'Integer' value -bvMatchConstInt :: PermExpr (BVType w) -> Maybe Integer -bvMatchConstInt = fmap BV.asUnsigned . bvMatchConst - - --- | Normalize a bitvector expression to a canonical form. Currently this just --- means converting @1*x+0@ to @x@. -normalizeBVExpr :: PermExpr (BVType w) -> PermExpr (BVType w) -normalizeBVExpr (PExpr_BV [BVFactor (BV.BV 1) x] (BV.BV 0)) = PExpr_Var x -normalizeBVExpr e = e - --- | Test whether two bitvector expressions are semantically equal -bvEq :: PermExpr (BVType w) -> PermExpr (BVType w) -> Bool -bvEq e1 e2 = normalizeBVExpr e1 == normalizeBVExpr e2 - --- | Test whether a bitvector expression is less than another for all --- substitutions to the free variables. The comparison is unsigned. This is an --- underapproximation, meaning that it could return 'False' in cases where it is --- actually 'True'. The current algorithm returns 'False' when the right-hand --- side is 0, 'True' for constant expressions @k1 < k2@, and 'False' otherwise. -bvLt :: PermExpr (BVType w) -> PermExpr (BVType w) -> Bool -bvLt _ (PExpr_BV [] (BV.BV 0)) = False -bvLt e1 e2 | bvEq e1 e2 = False -bvLt (PExpr_BV [] k1) (PExpr_BV [] k2) = BV.ult k1 k2 -bvLt _ _ = False - --- | Test whether a bitvector expression is less than another for all --- substitutions to the free variables. The comparison is signed. This is an --- underapproximation, meaning that it could return 'False' in cases where it is --- actually 'True'. The current algorithm only returns 'True' for constant --- expressions @k1 < k2@. -bvSLt :: (1 <= w, KnownNat w) => - PermExpr (BVType w) -> PermExpr (BVType w) -> Bool -bvSLt (bvMatchConst -> Just i1) (bvMatchConst -> Just i2) = - BV.slt knownNat i1 i2 -bvSLt _ _ = False - --- | Test whether a bitvector expression @e@ is in a 'BVRange' for all --- substitutions to the free variables. This is an underapproximation, meaning --- that it could return 'False' in cases where it is actually 'True'. It is --- implemented by testing whether @e - off < len@ using the unsigned comparison --- 'bvLt', where @off@ and @len@ are the offset and length of the 'BVRange'. -bvInRange :: (1 <= w, KnownNat w) => PermExpr (BVType w) -> BVRange w -> Bool -bvInRange e (BVRange off len) = bvLt (bvSub e off) len - --- | Test whether a bitvector @e@ equals @0@ -bvIsZero :: PermExpr (BVType w) -> Bool -bvIsZero (PExpr_Var _) = False -bvIsZero (PExpr_BV [] (BV.BV 0)) = True -bvIsZero (PExpr_BV _ _) = False - --- | Test whether a bitvector @e@ could equal @0@, i.e., whether the equation --- @e=0@ has any solutions. --- --- NOTE: this is an overapproximation, meaning that it may return 'True' for --- complex expressions that technically cannot unify with @0@. -bvZeroable :: PermExpr (BVType w) -> Bool -bvZeroable (PExpr_Var _) = True -bvZeroable (PExpr_BV _ (BV.BV 0)) = True -bvZeroable (PExpr_BV [] _) = False -bvZeroable (PExpr_BV _ _) = - -- NOTE: there are cases that match this pattern but are still not solvable, - -- like 8*x + 3 = 0. - True - --- | Test whether two bitvector expressions are potentially unifiable, i.e., --- whether some substitution to the variables could make them equal. This is an --- overapproximation, meaning that some expressions are marked as \"could\" --- equal when they actually cannot. -bvCouldEqual :: PermExpr (BVType w) -> PermExpr (BVType w) -> Bool -bvCouldEqual e1@(PExpr_BV _ _) e2 = - -- NOTE: we can only call bvSub when at least one side matches PExpr_BV - bvZeroable (bvSub e1 e2) -bvCouldEqual e1 e2@(PExpr_BV _ _) = bvZeroable (bvSub e1 e2) -bvCouldEqual _ _ = True - --- | Test whether a bitvector expression could potentially be less than another, --- for some substitution to the free variables. The comparison is unsigned. This --- is an overapproximation, meaning that some expressions are marked as --- \"could\" be less than when they actually cannot. The current algorithm --- returns 'False' 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 e1 e2 | bvEq e1 e2 = False -bvCouldBeLt (PExpr_BV [] (BV.BV k1)) (PExpr_BV [] (BV.BV k2)) = k1 < k2 -bvCouldBeLt _ _ = True - --- | Test whether a bitvector expression could potentially be less than another, --- for some substitution to the free variables. The comparison is signed. This --- is an overapproximation, meaning that some expressions are marked as --- \"could\" be less than when they actually cannot. The current algorithm --- returns 'True' in all cases except constant expressions @k1 >= k2@. -bvCouldBeSLt :: (1 <= w, KnownNat w) => - PermExpr (BVType w) -> PermExpr (BVType w) -> Bool -bvCouldBeSLt (bvMatchConst -> Just i1) (bvMatchConst -> Just i2) = - BV.slt knownNat i1 i2 -bvCouldBeSLt _ _ = True - --- | Test whether a bitvector expression is less than or equal to another for --- all substitutions of the free variables. The comparison is unsigned. This is --- an underapproximation, meaning that it could return 'False' in cases where it --- is actually 'True'. The current algorithm simply tests if the second --- epxression 'bvCouldBeLt' the first, and returns the negation of that result. -bvLeq :: (1 <= w, KnownNat w) => - PermExpr (BVType w) -> PermExpr (BVType w) -> Bool -bvLeq e1 e2 = not (bvCouldBeLt e2 e1) - --- | Test whether a bitvector expression @e@ is in a 'BVRange' for all --- substitutions to the free variables. This is an overapproximation, meaning --- that some expressions are marked as \"could\" be in the range when they --- actually cannot. The current algorithm tests if @e - off < len@ using the --- unsigned comparison 'bvCouldBeLt', where @off@ and @len@ are the offset and --- length of the 'BVRange'. -bvCouldBeInRange :: (1 <= w, KnownNat w) => PermExpr (BVType w) -> BVRange w -> Bool -bvCouldBeInRange e (BVRange off len) = bvCouldBeLt (bvSub e off) len - --- | Test whether a 'BVProp' holds for all substitutions of the free --- variables. This is an underapproximation, meaning that some propositions are --- marked as not holding when they actually do. -bvPropHolds :: (1 <= w, KnownNat w) => BVProp w -> Bool -bvPropHolds (BVProp_Eq e1 e2) = bvEq e1 e2 -bvPropHolds (BVProp_Neq e1 e2) = not (bvCouldEqual e1 e2) -bvPropHolds (BVProp_ULt e1 e2) = bvLt e1 e2 -bvPropHolds (BVProp_ULeq e1 e2) = bvLeq e1 e2 -bvPropHolds (BVProp_ULeq_Diff e1 e2 e3) = - not (bvCouldBeLt (bvSub e2 e3) e1) - --- | Test whether a 'BVProp' \"could\" hold for all substitutions of the free --- variables. This is an overapproximation, meaning that some propositions are --- marked as \"could\" hold when they actually cannot. -bvPropCouldHold :: (1 <= w, KnownNat w) => BVProp w -> Bool -bvPropCouldHold (BVProp_Eq e1 e2) = bvCouldEqual e1 e2 -bvPropCouldHold (BVProp_Neq e1 e2) = not (bvEq e1 e2) -bvPropCouldHold (BVProp_ULt e1 e2) = bvCouldBeLt e1 e2 -bvPropCouldHold (BVProp_ULeq e1 e2) = not (bvLt e2 e1) -bvPropCouldHold (BVProp_ULeq_Diff e1 e2 e3) = not (bvLt (bvSub e2 e3) e1) - --- | Negate a 'BVProp' -bvPropNegate :: BVProp w -> BVProp w -bvPropNegate (BVProp_Eq e1 e2) = BVProp_Neq e1 e2 -bvPropNegate (BVProp_Neq e1 e2) = BVProp_Eq e1 e2 -bvPropNegate (BVProp_ULt e1 e2) = BVProp_ULeq e2 e1 -bvPropNegate (BVProp_ULeq e1 e2) = BVProp_ULt e2 e1 -bvPropNegate (BVProp_ULeq_Diff e1 e2 e3) = - BVProp_ULt (bvSub e2 e3) e1 - --- | Build the proposition that @x@ is in the range @[off,off+len)@ as the --- proposition --- --- > x-off - PermExpr (BVType w) -> BVRange w -> BVProp w -bvPropInRange e (BVRange off len) = BVProp_ULt (bvSub e off) len - --- | Build the proposition that @x@ is /not/ in the range @[off,off+len)@ as the --- negation of 'bvPropInRange' -bvPropNotInRange :: (1 <= w, KnownNat w) => - PermExpr (BVType w) -> BVRange w -> BVProp w -bvPropNotInRange e rng = bvPropNegate $ bvPropInRange e rng - --- | Build the proposition that @[off1,off1+len1)@ is a subset of --- @[off2,off2+len2)@ as the following pair of propositions: --- --- > off1 - off2 <=u len2 --- > len1 <=u len2 - (off1 - off2) --- --- The first one states that the first @off1 - off2@ elements of the range --- @[off2,off2+len2)@ can be removed to get the range --- @[off1,off1+(len2-(off1-off2)))@. This also ensures that @len2-(off1- off2)@ --- does not underflow. The second then ensures that removing @off1-off2@ --- elements from the front of the second interval still yields a length that is --- at least as long as @len1@. --- --- NOTE: this is technically not complete, because the subset relation should --- always hold when @len1=0@ while the first proposition above does not always --- hold in this case, but we are ok with this. Equivalently, this approach views --- @[off1,off1+len1)@ as always containing @off1@ even when @len1=0@. --- --- NOTE: we cannot simplify the subtraction @len2 - (off1 - off2)@ because when --- we translate to SAW core both @len2@ and @(off1 - off2)@ become different --- arguments to @sliceBVVec@ and @updSliceBVVec@, and SAW core does not simplify --- the subtraction of these two arguments. -bvPropRangeSubset :: (1 <= w, KnownNat w) => - BVRange w -> BVRange w -> [BVProp w] -bvPropRangeSubset (BVRange off1 len1) (BVRange off2 len2) = - [BVProp_ULeq (bvSub off1 off2) len2, - BVProp_ULeq_Diff len1 len2 (bvSub off1 off2)] - --- | Test that one range is a subset of another, by testing that the --- propositions returned by 'bvPropRangeSubset' all hold (in the sense of --- 'bvPropHolds') -bvRangeSubset :: (1 <= w, KnownNat w) => BVRange w -> BVRange w -> Bool -bvRangeSubset rng1 rng2 = all bvPropHolds $ bvPropRangeSubset rng1 rng2 - --- | Build the proposition that @[off1,off1+len1)@ and @[off2,off2+len2)@ are --- disjoint as following pair of propositions: --- --- > len2 <=u off1 - off2 --- > len1 <=u off2 - off1 --- --- These say that each @off@ is not in the other range. -bvPropRangesDisjoint :: (1 <= w, KnownNat w) => - BVRange w -> BVRange w -> [BVProp w] -bvPropRangesDisjoint (BVRange off1 len1) (BVRange off2 len2) = - [BVProp_ULeq len2 (bvSub off1 off2), BVProp_ULeq len1 (bvSub off2 off1)] - --- | Test if @[off1,off1+len1)@ and @[off2,off2+len2)@ overlap, i.e., share at --- least one element, by testing that they could not satisfy (in the sense of --- 'bvPropCouldHold') the results of 'bvPropRangesDisjoint' -bvRangesOverlap :: (1 <= w, KnownNat w) => BVRange w -> BVRange w -> Bool -bvRangesOverlap rng1 rng2 = - not $ all bvPropCouldHold $ bvPropRangesDisjoint rng1 rng2 - --- | Test if @[off1,off1+len1)@ and @[off2,off2+len2)@ could overlap, i.e., --- share at least one element, by testing that they do not definitely satisfy --- (in the sense of 'bvPropHolds') the results of 'bvPropRangesDisjoint' -bvRangesCouldOverlap :: (1 <= w, KnownNat w) => BVRange w -> BVRange w -> Bool -bvRangesCouldOverlap rng1 rng2 = - not $ all bvPropHolds $ bvPropRangesDisjoint rng1 rng2 - --- | Get the ending offset of a range -bvRangeEnd :: (1 <= w, KnownNat w) => BVRange w -> PermExpr (BVType w) -bvRangeEnd (BVRange off len) = bvAdd off len - --- | Take the suffix of a range starting at a given offset, assuming that offset --- is in the range -bvRangeSuffix :: (1 <= w, KnownNat w) => PermExpr (BVType w) -> BVRange w -> - BVRange w -bvRangeSuffix off' (BVRange off len) = - BVRange off' (bvSub len (bvSub off' off)) - --- | Build the range of offsets not in a 'BVRange' -bvRangeInvert :: (1 <= w, KnownNat w) => BVRange w -> BVRange w -bvRangeInvert (BVRange off len) = - BVRange (bvAdd off len) (bvSub (bvInt 0) len) - --- | Subtract a bitvector word from the offset of a 'BVRange' -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] - --- | Find all offsets in the first range that could (in the sense of --- 'bvPropCouldHold') be in the second. This is an asymmetric form of --- intersection, and is equivalent to 'bvRangeDelete' of the complement of the --- second range -bvRangeSubsetTo :: (1 <= w, KnownNat w) => BVRange w -> BVRange w -> - [BVRange w] -bvRangeSubsetTo rng1 rng2 = bvRangeDelete rng1 $ bvRangeInvert rng2 - --- | Find all offsets in any of the first list of ranges that could (in the --- sense of 'bvPropCouldHold') be in one of those in the second list -bvRangesSubsetTo :: (1 <= w, KnownNat w) => [BVRange w] -> [BVRange w] -> - [BVRange w] -bvRangesSubsetTo rngs1 rngs2 = - flip concatMap rngs1 $ \rng1 -> flip concatMap rngs2 $ \rng2 -> - bvRangeSubsetTo rng1 rng2 - --- | Convert an 'MbRangeForType' in a binding to an 'MbRangeForType' -mbMbRangeForType :: CruCtx ctx -> Mb ctx (MbRangeForType a) -> - MbRangeForType a --- If the range can be lifted out of the binding, do so -mbMbRangeForType ctx mb_rngft - | Just rngft <- partialSubst (emptyPSubst $ cruCtxProxies ctx) mb_rngft - = rngft --- Otherwise, add the new variables to the existing bound variables -mbMbRangeForType ctx mb_rngft = case mbMatch mb_rngft of - [nuMP| MbRangeForLLVMType vars rw l rng |] -> - MbRangeForLLVMType (appendCruCtx ctx $ mbLift vars) - (mbCombine (cruCtxProxies $ mbLift vars) rw) - (mbCombine (cruCtxProxies $ mbLift vars) l) - (mbCombine (cruCtxProxies $ mbLift vars) rng) - --- | Add a 'PermOffset' to an 'MbRangeForType -offsetMbRangeForType :: PermOffset a -> MbRangeForType a -> MbRangeForType a -offsetMbRangeForType NoPermOffset rng = rng -offsetMbRangeForType (LLVMPermOffset off) (MbRangeForLLVMType - vars mb_rw mb_l mb_rng) = - MbRangeForLLVMType vars mb_rw mb_l $ fmap (offsetBVRange off) mb_rng - --- | Test if the first read/write modality in a binding \"covers\" the second, --- meaning a permission relative to the first implies or can be coerced to a --- similar permission relative to the second, possibly by instantiating evars on --- the right -mbRWModCovers :: - Mb (ctx1 :: RList CrucibleType) (PermExpr RWModalityType) -> - Mb (ctx2 :: RList CrucibleType) (PermExpr RWModalityType) -> Bool -mbRWModCovers [nuP| PExpr_Write |] _ = True -mbRWModCovers _ [nuP| PExpr_Read |] = True -mbRWModCovers _ [nuP| PExpr_Var mb_x |] - | Left _ <- mbNameBoundP mb_x = True -mbRWModCovers mb_rw2 mb_rw1 = - fromMaybe False ((==) <$> tryLift mb_rw1 <*> tryLift mb_rw2) - --- | Test if the first lifetime in a binding \"covers\" the second, meaning a --- permission relative to the second implies or can be coerced to a similar --- permission relative to the first, possibly by instantiating evars on the --- right -mbLifetimeCovers :: - Mb (ctx1 :: RList CrucibleType) (PermExpr LifetimeType) -> - Mb (ctx2 :: RList CrucibleType) (PermExpr LifetimeType) -> Bool -mbLifetimeCovers _ [nuP| PExpr_Always |] = True -mbLifetimeCovers _ [nuP| PExpr_Var mb_x |] - | Left _ <- mbNameBoundP mb_x = True -mbLifetimeCovers mb_l1 mb_l2 = - fromMaybe False ((==) <$> tryLift mb_l1 <*> tryLift mb_l2) - --- | Delete one range from another, where the deletion only happens if the --- modalities of the RHS cover those of the LHS -mbRangeFTDelete :: MbRangeForType a -> MbRangeForType a -> - [MbRangeForType a] -mbRangeFTDelete - (MbRangeForLLVMType vars1 mb_rw1 mb_l1 mb_rng1) - (MbRangeForLLVMType vars2 mb_rw2 mb_l2 mb_rng2) - | mbRWModCovers mb_rw2 mb_rw1 - , mbLifetimeCovers mb_l2 mb_l1 - , mb_rw2' <- extMbMultiL (cruCtxProxies vars1) mb_rw2 - , mb_l2' <- extMbMultiL (cruCtxProxies vars1) mb_l2 = - map (MbRangeForLLVMType (appendCruCtx vars1 vars2) mb_rw2' mb_l2') $ - mbList $ mbCombine (cruCtxProxies vars2) $ - flip fmap mb_rng1 $ \rng1 -> flip fmap mb_rng2 $ \rng2 -> - bvRangeDelete rng1 rng2 -mbRangeFTDelete mb_rng _ = [mb_rng] - --- | Delete all ranges in any of a list of ranges from -mbRangeFTsDelete :: [MbRangeForType a] -> [MbRangeForType a] -> - [MbRangeForType a] -mbRangeFTsDelete rngs_l rngs_r = - foldr (\rng_r rngs -> concatMap (flip mbRangeFTDelete rng_r) rngs) rngs_l rngs_r - --- | Find all the offsets in the first 'MbRangeForType' that could be in the --- second, in a manner similar to 'bvRangeSubsetTo', preserving the modalities --- of the first -mbRangeFTSubsetTo :: MbRangeForType a -> MbRangeForType a -> - [MbRangeForType a] -mbRangeFTSubsetTo - (MbRangeForLLVMType vars1 mb_rw1 mb_l1 mb_rng1) - (MbRangeForLLVMType vars2 _ _ mb_rng2) - | mb_rw1' <- extMbMulti (cruCtxProxies vars2) mb_rw1 - , mb_l1' <- extMbMulti (cruCtxProxies vars2) mb_l1 = - map (MbRangeForLLVMType (appendCruCtx vars1 vars2) mb_rw1' mb_l1') $ mbList $ - mbCombine (cruCtxProxies vars2) $ - flip fmap mb_rng1 $ \rng1 -> flip fmap mb_rng2 $ \rng2 -> - bvRangeSubsetTo rng1 rng2 - --- | Find all the offsets in an 'MbRangeForType' in the first list that could be --- in one in the second, in a manner similar to 'bvRangesSubsetTo' -mbRangeFTsSubsetTo :: [MbRangeForType a] -> [MbRangeForType a] -> - [MbRangeForType a] -mbRangeFTsSubsetTo rngs1 rngs2 = - flip concatMap rngs1 $ \rng1 -> flip concatMap rngs2 $ \rng2 -> - mbRangeFTSubsetTo rng1 rng2 - --- | Test if one 'MbRangeForType' could cover part of another, using --- 'mbRWModCovers' and 'mbLifetimeCovers' for the modalities -mbRangeFTCouldCoverPart :: MbRangeForType a -> MbRangeForType a -> Bool -mbRangeFTCouldCoverPart - (MbRangeForLLVMType _ mb_rw1 mb_l1 mb_rng1) - (MbRangeForLLVMType _ mb_rw2 mb_l2 mb_rng2) = - mbRWModCovers mb_rw1 mb_rw2 && - mbLifetimeCovers mb_l1 mb_l2 && - (mbLift $ flip fmap mb_rng1 $ \rng1 -> - mbLift $ flip fmap mb_rng2 $ \rng2 -> - bvRangesCouldOverlap rng1 rng2) - --- | Test if any offsets in one list of 'MbRangeForType's could (as in --- 'bvPropCouldHold') covert some offsets in another -mbRangeFTsCouldCoverPart :: [MbRangeForType a] -> [MbRangeForType a] -> Bool -mbRangeFTsCouldCoverPart rngs1 rngs2 = - or $ flip concatMap rngs1 $ \rng1 -> - map (mbRangeFTCouldCoverPart rng1) rngs2 - --- | Build a bitvector expression from an integer -bvInt :: (1 <= w, KnownNat w) => Integer -> PermExpr (BVType w) -bvInt i = PExpr_BV [] $ BV.mkBV knownNat i - --- | Build a bitvector expression of a given size from an integer -bvIntOfSize :: (1 <= sz, KnownNat sz) => prx sz -> Integer -> PermExpr (BVType sz) -bvIntOfSize _ = bvInt - --- | Build a bitvector expression from a Haskell bitvector -bvBV :: (1 <= w, KnownNat w) => BV w -> PermExpr (BVType w) -bvBV i = PExpr_BV [] i - --- | Helper datatype for 'bvFromBytes' -data BVExpr w = (1 <= w, KnownNat w) => BVExpr (PermExpr (BVType w)) - --- | Build a bitvector expression from a list of bytes, depending on the --- endianness -bvFromBytes :: EndianForm -> [Word8] -> Some BVExpr -bvFromBytes endianness bytes = - let bv_fun = - case endianness of - BigEndian -> BV.bytesBE - LittleEndian -> BV.bytesLE in - case bv_fun bytes of - Pair sz bv - | Left leq_proof <- decideLeq (knownNat @1) sz -> - withKnownNat sz $ withLeqProof leq_proof $ Some $ BVExpr $ bvBV bv - Pair _ _ -> error "bvFromBytes: zero-sized bitvector" - --- | Concatenate two bitvectors, using the current endianness to determine how --- they combine -bvConcat :: KnownNat sz1 => KnownNat sz2 => EndianForm -> - BV.BV sz1 -> BV.BV sz2 -> BV.BV (sz1+sz2) -bvConcat BigEndian bv1 bv2 = BV.concat knownRepr knownRepr bv1 bv2 -bvConcat LittleEndian bv1 bv2 - | Refl <- plusComm bv1 bv2 = - BV.concat knownRepr knownRepr bv2 bv1 - --- | Split a bitvector in two, if this is possible, using the current endianness --- to determine which is the first versus second part of the split -bvSplit :: KnownNat sz1 => KnownNat sz2 => EndianForm -> - NatRepr sz1 -> BV.BV sz2 -> Maybe (BV.BV sz1, BV.BV (sz2 - sz1)) -bvSplit LittleEndian sz1 bv2 - | n0 <- knownNat @0 - , sz2 <- natRepr bv2 - , Left LeqProof <- decideLeq (addNat n0 sz1) sz2 - , Left LeqProof <- decideLeq (addNat sz1 (subNat sz2 sz1)) sz2 = - Just (BV.select n0 sz1 bv2, BV.select sz1 (subNat sz2 sz1) bv2) -bvSplit BigEndian sz1 bv2 - | n0 <- knownNat @0 - , sz2 <- natRepr bv2 - , Left LeqProof <- decideLeq sz1 sz2 - , Left LeqProof <- decideLeq (addNat (subNat sz2 sz1) sz1) sz2 - , Left LeqProof <- decideLeq (addNat n0 (subNat sz2 sz1)) sz2 = - Just (BV.select (subNat sz2 sz1) sz1 bv2, - BV.select n0 (subNat sz2 sz1) bv2) -bvSplit _ _ _ = Nothing - --- | Build a bitvector expression consisting of a single single 'BVFactor', --- i.e. a variable multiplied by some constant -bvFactorExpr :: (1 <= w, KnownNat w) => - BV w -> ExprVar (BVType w) -> PermExpr (BVType w) -bvFactorExpr (BV.BV 1) x = PExpr_Var x -bvFactorExpr i x = PExpr_BV [BVFactor i x] (BV.zero knownNat) - --- | Add two bitvector expressions -bvAdd :: (1 <= w, KnownNat w) => PermExpr (BVType w) -> PermExpr (BVType w) -> - PermExpr (BVType w) -bvAdd (bvMatch -> (factors1, const1)) (bvMatch -> (factors2, const2)) = - normalizeBVExpr $ - PExpr_BV (bvMergeFactors factors1 factors2) (BV.add knownNat const1 const2) - --- | Multiply a bitvector expression by a bitvector -bvMultBV :: (1 <= w, KnownNat w) => BV.BV w -> PermExpr (BVType w) -> - PermExpr (BVType w) -bvMultBV i_bv (bvMatch -> (factors, off)) = - normalizeBVExpr $ - PExpr_BV (map (\(BVFactor j x) -> - BVFactor (BV.mul knownNat i_bv j) x) factors) - (BV.mul knownNat i_bv off) - --- | Multiply a bitvector expression by a constant -bvMult :: (1 <= w, KnownNat w, Integral a) => a -> PermExpr (BVType w) -> - PermExpr (BVType w) -bvMult i = bvMultBV (BV.mkBV knownNat $ toInteger i) - --- | Negate a bitvector expression -bvNegate :: (1 <= w, KnownNat w) => PermExpr (BVType w) -> PermExpr (BVType w) -bvNegate = bvMult (-1 :: Integer) - --- | Subtract one bitvector expression from another --- --- FIXME: this would be more efficient if we did not use 'bvNegate', which could --- make very large 'Integer's for negative numbers wrapped around to be positive -bvSub :: (1 <= w, KnownNat w) => PermExpr (BVType w) -> PermExpr (BVType w) -> - PermExpr (BVType w) -bvSub e1 e2 = bvAdd e1 (bvNegate e2) - --- | Integer division on bitvector expressions, truncating any factors @i*x@ --- where @i@ is not a multiple of the divisor to zero -bvDiv :: (1 <= w, KnownNat w, Integral a) => PermExpr (BVType w) -> a -> - PermExpr (BVType w) -bvDiv (bvMatch -> (factors, off)) n = - let n_bv = BV.mkBV knownNat (toInteger n) in - normalizeBVExpr $ - PExpr_BV (mapMaybe (\(BVFactor i x) -> - if BV.urem i n_bv == BV.zero knownNat then - Just (BVFactor (BV.uquot i n_bv) x) - else Nothing) factors) - (BV.uquot off n_bv) - --- | Integer Modulus on bitvector expressions, where any factors @i*x@ with @i@ --- not a multiple of the divisor are included in the modulus -bvMod :: (1 <= w, KnownNat w, Integral a) => PermExpr (BVType w) -> a -> - PermExpr (BVType w) -bvMod (bvMatch -> (factors, off)) n = - let n_bv = BV.mkBV knownNat $ toInteger n in - normalizeBVExpr $ - PExpr_BV (mapMaybe (\f@(BVFactor i _) -> - if BV.urem i n_bv /= BV.zero knownNat - then Just f else Nothing) factors) - (BV.urem off n_bv) - --- | Given a constant factor @a@, test if a bitvector expression can be written --- as @a*x+y@ for some constant @y@ -bvMatchFactorPlusConst :: (1 <= w, KnownNat w) => - Integer -> PermExpr (BVType w) -> - Maybe (PermExpr (BVType w), BV w) -bvMatchFactorPlusConst a e = - bvMatchConst (bvMod e a) >>= \y -> Just (bvDiv e a, y) - --- | Returns the greatest common divisor of all the coefficients (i.e. offsets --- and factor coefficients) of the given bitvectors, returning a negative --- number iff all coefficients are <= 0 -bvGCD :: (1 <= w, KnownNat w) => - PermExpr (BVType w) -> PermExpr (BVType w) -> BV w -bvGCD (bvMatch -> (fs1, off1)) (bvMatch -> (fs2, off2)) = - fromMaybe (error "bvGCD: overflow") . BV.mkBVSigned knownNat $ - foldl' (\d (BVFactor i _) -> d `gcdS` BV.asSigned knownNat i) - (foldl' (\d (BVFactor i _) -> d `gcdS` BV.asSigned knownNat i) - (BV.asSigned knownNat off1 `gcdS` BV.asSigned knownNat off2) - fs1) - fs2 - where -- A version of 'gcd' whose return value is negative iff both of - -- its arguments are <= 0 - gcdS :: Integer -> Integer -> Integer - gcdS x y | x <= 0 && y <= 0 = - gcd x y - | otherwise = gcd x y - --- | Convert an LLVM pointer expression to a variable + optional offset, if this --- is possible -asLLVMOffset :: (1 <= w, KnownNat w) => PermExpr (LLVMPointerType w) -> - Maybe (ExprVar (LLVMPointerType w), PermExpr (BVType w)) -asLLVMOffset (PExpr_Var x) = Just (x, bvInt 0) -asLLVMOffset (PExpr_LLVMOffset x off) = Just (x, off) -asLLVMOffset _ = Nothing - --- | Add a word expression to an LLVM pointer expression -addLLVMOffset :: (1 <= w, KnownNat w) => - PermExpr (LLVMPointerType w) -> PermExpr (BVType w) -> - PermExpr (LLVMPointerType w) -addLLVMOffset (PExpr_Var x) off = PExpr_LLVMOffset x off -addLLVMOffset (PExpr_LLVMWord e) off = PExpr_LLVMWord $ bvAdd e off -addLLVMOffset (PExpr_LLVMOffset x e) off = - PExpr_LLVMOffset x $ bvAdd e off - --- | Build a range that contains exactly one index -bvRangeOfIndex :: (1 <= w, KnownNat w) => PermExpr (BVType w) -> BVRange w -bvRangeOfIndex e = BVRange e (bvInt 1) - --- | Add an offset to a 'BVRange' -offsetBVRange :: (1 <= w, KnownNat w) => PermExpr (BVType w) -> BVRange w -> - BVRange w -offsetBVRange off (BVRange off' len) = (BVRange (bvAdd off' off) len) - - ----------------------------------------------------------------------- --- * Permissions ----------------------------------------------------------------------- - -deriving instance Eq (BVRange w) -deriving instance Eq (BVProp w) - --- | Build an equality permission in a binding -mbValPerm_Eq :: Mb ctx (PermExpr a) -> Mb ctx (ValuePerm a) -mbValPerm_Eq = mbMapCl $(mkClosed [| ValPerm_Eq |]) - --- | The conjunction of a list of atomic permissions in a binding -mbValPerm_Conj :: Mb ctx [AtomicPerm a] -> Mb ctx (ValuePerm a) -mbValPerm_Conj = mbMapCl $(mkClosed [| ValPerm_Conj |]) - --- | The vacuously true permission is the conjunction of 0 atomic permissions -pattern ValPerm_True :: ValuePerm a -pattern ValPerm_True = ValPerm_Conj [] - --- | The conjunction of exactly 1 atomic permission -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) => - LLVMFieldPerm w sz -> ValuePerm a -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 -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 -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) => - PermExpr b -> ValuePerm a -pattern ValPerm_LLVMBlockShape sh <- ValPerm_Conj [Perm_LLVMBlockShape sh] - where - ValPerm_LLVMBlockShape sh = ValPerm_Conj [Perm_LLVMBlockShape sh] - --- | The conjunction of exactly 1 @llvmfunptr@ permission -pattern ValPerm_LLVMFunPtr :: () => - (a ~ LLVMPointerType w, 1 <= w, KnownNat w) => - TypeRepr (FunctionHandleType cargs ret) -> - ValuePerm (FunctionHandleType cargs ret) -> - ValuePerm a -pattern ValPerm_LLVMFunPtr tp p <- ValPerm_Conj [Perm_LLVMFunPtr tp p] - where - ValPerm_LLVMFunPtr tp p = ValPerm_Conj [Perm_LLVMFunPtr tp p] - --- | A single @lowned@ permission -pattern ValPerm_LOwned :: () => (a ~ LifetimeType) => [PermExpr LifetimeType] -> - CruCtx ps_in -> CruCtx ps_out -> - ExprPerms ps_in -> ExprPerms ps_out -> ValuePerm a -pattern ValPerm_LOwned ls tps_in tps_out ps_in ps_out <- - ValPerm_Conj [Perm_LOwned ls tps_in tps_out ps_in ps_out] - where - ValPerm_LOwned ls tps_in tps_out ps_in ps_out = - ValPerm_Conj [Perm_LOwned ls tps_in tps_out ps_in ps_out] - --- | A single simple @lowned@ permission -pattern ValPerm_LOwnedSimple :: () => (a ~ LifetimeType) => - CruCtx ps -> ExprPerms ps -> ValuePerm a -pattern ValPerm_LOwnedSimple tps ps <- ValPerm_Conj [Perm_LOwnedSimple tps ps] - where - ValPerm_LOwnedSimple tps ps = ValPerm_Conj [Perm_LOwnedSimple tps ps] - --- | A single @lcurrent@ permission -pattern ValPerm_LCurrent :: () => (a ~ LifetimeType) => - PermExpr LifetimeType -> ValuePerm a -pattern ValPerm_LCurrent l <- ValPerm_Conj [Perm_LCurrent l] - where - ValPerm_LCurrent l = ValPerm_Conj [Perm_LCurrent l] - --- | A single @lfinished@ permission -pattern ValPerm_LFinished :: () => (a ~ LifetimeType) => ValuePerm a -pattern ValPerm_LFinished <- ValPerm_Conj [Perm_LFinished] - where - ValPerm_LFinished = ValPerm_Conj [Perm_LFinished] - --- | A single @struct@ permission -pattern ValPerm_Struct :: () => (a ~ StructType ctx) => - RAssign ValuePerm (CtxToRList ctx) -> - ValuePerm a -pattern ValPerm_Struct ps <- ValPerm_Conj [Perm_Struct ps] - where - ValPerm_Struct ps = ValPerm_Conj [Perm_Struct ps] - --- | A single @any@ permission -pattern ValPerm_Any :: ValuePerm a -pattern ValPerm_Any = ValPerm_Conj [Perm_Any] - --- | A single function permission -pattern ValPerm_Fun :: () => (a ~ FunctionHandleType cargs ret) => - FunPerm ghosts (CtxToRList cargs) gouts ret -> - ValuePerm a -pattern ValPerm_Fun fun_perm <- ValPerm_Conj [Perm_Fun fun_perm] - where - ValPerm_Fun fun_perm = ValPerm_Conj [Perm_Fun fun_perm] - -pattern ValPerms_Nil :: () => (tps ~ RNil) => ValuePerms tps -pattern ValPerms_Nil = MNil - -pattern ValPerms_Cons :: () => (tps ~ (tps' :> a)) => - ValuePerms tps' -> ValuePerm a -> ValuePerms tps -pattern ValPerms_Cons ps p = ps :>: p - -{-# COMPLETE ValPerms_Nil, ValPerms_Cons #-} - - --- | Fold a function over a 'ValuePerms' list, where --- --- > foldValuePerms f b ('ValuePermsCons' --- > ('ValuePermsCons' (... 'ValuePermsNil' ...) p2) p1) = --- > f (f (... b ...) p2) p1 --- --- FIXME: implement more functions on ValuePerms in terms of this -foldValuePerms :: (forall a. b -> ValuePerm a -> b) -> b -> ValuePerms as -> b -foldValuePerms _ b ValPerms_Nil = b -foldValuePerms f b (ValPerms_Cons ps p) = f (foldValuePerms f b ps) p - --- | Build a one-element 'ValuePerms' list from a single permission -singletonValuePerms :: ValuePerm a -> ValuePerms (RNil :> a) -singletonValuePerms = ValPerms_Cons ValPerms_Nil - --- | Build a 'ValuePerms' from an 'RAssign' of permissions -assignToPerms :: RAssign ValuePerm ps -> ValuePerms ps -assignToPerms MNil = ValPerms_Nil -assignToPerms (ps :>: p) = ValPerms_Cons (assignToPerms ps) p - --- | An LLVM pointer permission is an 'AtomicPerm' of type 'LLVMPointerType' -type LLVMPtrPerm w = AtomicPerm (LLVMPointerType w) - -deriving instance Eq (LLVMFieldPerm w sz) - --- | Helper to get a 'NatRepr' for the size of an 'LLVMFieldPerm' -llvmFieldSize :: KnownNat sz => LLVMFieldPerm w sz -> NatRepr sz -llvmFieldSize _ = knownNat - --- | Get the size of an 'LLVMFieldPerm' in bytes -llvmFieldSizeBytes :: KnownNat sz => LLVMFieldPerm w sz -> Integer -llvmFieldSizeBytes fp = intValue (llvmFieldSize fp) `ceil_div` 8 - --- | Get the size of an 'LLVMFieldPerm' as an expression -llvmFieldLen :: (1 <= w, KnownNat w, 1 <= sz, KnownNat sz) => - LLVMFieldPerm w sz -> PermExpr (BVType w) -llvmFieldLen fp = exprLLVMTypeBytesExpr $ llvmFieldContents fp - --- | Get the ending offset of an 'LLVMFieldPerm' -llvmFieldEndOffset :: (1 <= w, KnownNat w, 1 <= sz, KnownNat sz) => - LLVMFieldPerm w sz -> PermExpr (BVType w) -llvmFieldEndOffset fp = bvAdd (llvmFieldOffset fp) (llvmFieldLen fp) - --- | 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 lifetime-in-binding of a field permission in binding -mbLLVMFieldLifetime :: Mb ctx (LLVMFieldPerm w sz) -> - Mb ctx (PermExpr LifetimeType) -mbLLVMFieldLifetime = mbMapCl $(mkClosed [| llvmFieldLifetime |]) - --- | 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 |]) - --- | Get the range of bytes contained in a field permisison -llvmFieldRange :: (1 <= w, KnownNat w, KnownNat sz) => LLVMFieldPerm w sz -> - BVRange w -llvmFieldRange fp = - BVRange (llvmFieldOffset fp) (bvInt $ llvmFieldSizeBytes fp) - - --- 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 - -deriving instance Eq (LLVMArrayPerm w) - --- | Get the stride of an array in bits -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 offset-in-binding of an array permission in binding -mbLLVMArrayOffsetBytes :: Mb ctx (LLVMArrayPerm w) -> Mb ctx (PermExpr (BVType w)) -mbLLVMArrayOffsetBytes = 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 length-in-binding of an array permission in binding -mbLLVMArrayLenBytes :: (1 <= w, KnownNat w) => Mb ctx (LLVMArrayPerm w) -> - Mb ctx (PermExpr (BVType w)) -mbLLVMArrayLenBytes = mbMapCl $(mkClosed [| llvmArrayLengthBytes |]) - --- | Get the range of offsets of an array permission in binding -mbLLVMArrayRange :: (1 <= w, KnownNat w) => Mb ctx (LLVMArrayPerm w) -> - Mb ctx (BVRange w) -mbLLVMArrayRange = mbMapCl $(mkClosed [| llvmArrayRange |]) - --- | 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 |]) - -deriving instance Eq (LLVMArrayBorrow w) -deriving instance Eq (LLVMBlockPerm w) - --- | 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 |]) - --- | Get the range of offsets represented by an 'LLVMBlockPerm' -llvmBlockRange :: LLVMBlockPerm w -> BVRange w -llvmBlockRange bp = BVRange (llvmBlockOffset bp) (llvmBlockLen bp) - --- | Get the range-in-binding of a block permission in binding -mbLLVMBlockRange :: Mb ctx (LLVMBlockPerm w) -> Mb ctx (BVRange w) -mbLLVMBlockRange = mbMapCl $(mkClosed [| llvmBlockRange |]) - -instance Eq (LLVMFieldShape w) where - (LLVMFieldShape p1) == (LLVMFieldShape p2) - | Just Refl <- testEquality (exprType p1) (exprType p2) = p1 == p2 - _ == _ = False - - --- | Convert an 'ExprAndPerm' to a variable plus permission, if possible -exprPermVarAndPerm :: ExprAndPerm a -> Maybe (VarAndPerm a) -exprPermVarAndPerm (ExprAndPerm e p) - | Just (x, off) <- asVarOffset e = - Just $ VarAndPerm x (offsetPerm off p) -exprPermVarAndPerm _ = Nothing - --- | Convert an 'ExprPerms' to a 'DistPerms', if possible -exprPermsToDistPerms :: ExprPerms ctx -> Maybe (DistPerms ctx) -exprPermsToDistPerms = traverseRAssign exprPermVarAndPerm - --- | Convert an 'ExprPerms' in bindings to a 'DistPerms' in bindings -mbExprPermsToDistPerms :: Mb ctx (ExprPerms ps) -> - Maybe (Mb ctx (DistPerms ps)) -mbExprPermsToDistPerms = - mbMaybe . mbMapCl $(mkClosed [| exprPermsToDistPerms |]) - --- | Find all permissions in an 'ExprPerms' list for a variable -exprPermsForVar :: ExprVar a -> ExprPerms ps -> [ValuePerm a] -exprPermsForVar _ MNil = [] -exprPermsForVar x (ps :>: e_and_p) - | Just (VarAndPerm y p) <- exprPermVarAndPerm e_and_p - , Just Refl <- testEquality x y - = p : exprPermsForVar x ps -exprPermsForVar x (ps :>: _) = exprPermsForVar x ps - --- | Get the permissions resulting from converting an 'ExprPerms' to a --- 'DistPerms', if possible. Note taht this can be different from just getting --- the permissions in the 'ExprPerms', because they may be offset by offsets on --- variables in the expressions. -exprPermsToValuePerms :: ExprPerms ctx -> Maybe (ValuePerms ctx) -exprPermsToValuePerms = fmap distPermsToValuePerms . exprPermsToDistPerms - --- | Get the permisisons in an 'ExprPerms' in bindings -mbExprPermsToValuePerms :: Mb ctx (ExprPerms ps) -> - Maybe (Mb ctx (ValuePerms ps)) -mbExprPermsToValuePerms = - mbMaybe . mbMapCl $(mkClosed [| exprPermsToValuePerms |]) - --- | Convert an expression plus permission to an 'ExprAndPerm' -varAndPermExprPerm :: VarAndPerm a -> ExprAndPerm a -varAndPermExprPerm (VarAndPerm x p) = ExprAndPerm (PExpr_Var x) p - --- | Convert a 'DistPerms' to an 'ExprPerms' -distPermsToExprPerms :: DistPerms ps -> ExprPerms ps -distPermsToExprPerms = RL.map varAndPermExprPerm - --- | Convert a 'DistPerms' in a binding to an 'ExprPerms' in a binding -mbDistPermsToExprPerms :: Mb ctx (DistPerms ps) -> Mb ctx (ExprPerms ps) -mbDistPermsToExprPerms = mbMapCl $(mkClosed [| distPermsToExprPerms |]) - --- | Convert the expressions in an 'ExprPerms' to variables, if possible -exprPermsVars :: ExprPerms ps -> Maybe (RAssign Name ps) -exprPermsVars = fmap distPermsVars . exprPermsToDistPerms - --- | Convert the variables in a 'DistPerms' in a binding to variables bound --- in that binding, if possible -mbDistPermsMembers :: Mb ctx (DistPerms ps) -> Maybe (RAssign (Member ctx) ps) -mbDistPermsMembers [nuP| mb_ps' :>: VarAndPerm mb_n _ |] - | Left memb <- mbNameBoundP mb_n = (:>: memb) <$> mbDistPermsMembers mb_ps' -mbDistPermsMembers [nuP| MNil |] = Just MNil -mbDistPermsMembers _ = Nothing - --- | Convert the expressions in an 'ExprPerms' in a binding to variables bound --- in that binding, if possible -mbExprPermsMembers :: Mb ctx (ExprPerms ps) -> Maybe (RAssign (Member ctx) ps) -mbExprPermsMembers = mbExprPermsToDistPerms >=> mbDistPermsMembers - --- | Convert the expressions in an 'ExprPerms' to variables, if possible, and --- collect them into a list -exprPermsVarsList :: ExprPerms ps -> [SomeName CrucibleType] -exprPermsVarsList ps = - case exprPermsVars ps of - Just ns -> RL.mapToList SomeName ns - Nothing -> [] - --- | Convert the expressions in an 'ExprPerms'-in-binding to variables, if --- possible, and collect them into a list -mbExprPermsVarsList :: Mb ctx (ExprPerms ps) -> [SomeName CrucibleType] -mbExprPermsVarsList = - concatMap (\case - [nuP| SomeName mb_n |] - | Right n <- mbNameBoundP mb_n -> [SomeName n] - _ -> []) . - mbList . mbMapCl $(mkClosed [| exprPermsVarsList |]) - --- | Convert the expressions in an 'ExprPerms' to variables, if possible, and --- collect them into a set -exprPermsVarsSet :: ExprPerms ps -> NameSet CrucibleType -exprPermsVarsSet = NameSet.fromList . exprPermsVarsList - --- | Convert the expressions in an 'ExprPerms'-in-binding to variables, if --- possible, and collect them in a 'NameSet' -mbExprPermsVarsSet :: Mb ctx (ExprPerms ps) -> NameSet CrucibleType -mbExprPermsVarsSet = NameSet.liftNameSet . fmap exprPermsVarsSet - --- | Extract the @args@ context from a function permission -funPermArgs :: FunPerm ghosts args gouts ret -> CruCtx args -funPermArgs (FunPerm _ args _ _ _ _) = args - --- | Extract the @ghosts@ context from a function permission -funPermGhosts :: FunPerm ghosts args gouts ret -> CruCtx ghosts -funPermGhosts (FunPerm ghosts _ _ _ _ _) = ghosts - --- | Extract the @ghosts@ and @args@ contexts from a function permission -funPermTops :: FunPerm ghosts args gouts ret -> CruCtx (ghosts :++: args) -funPermTops fun_perm = - appendCruCtx (funPermGhosts fun_perm) (funPermArgs fun_perm) - --- | Extract the return type from a function permission -funPermRet :: FunPerm ghosts args gouts ret -> TypeRepr ret -funPermRet (FunPerm _ _ _ ret _ _) = ret - --- | Extract the return types including ghosts from a function permission -funPermRets :: FunPerm ghosts args gouts ret -> CruCtx (gouts :> ret) -funPermRets fun_perm = CruCtxCons (funPermGouts fun_perm) (funPermRet fun_perm) - --- | Extract the @gouts@ context from a function permission -funPermGouts :: FunPerm ghosts args gouts ret -> CruCtx gouts -funPermGouts (FunPerm _ _ gouts _ _ _) = gouts - --- | Extract the input permissions of a function permission -funPermIns :: FunPerm ghosts args gouts ret -> MbValuePerms (ghosts :++: args) -funPermIns (FunPerm _ _ _ _ perms_in _) = perms_in - --- | Extract the output permissions of a function permission -funPermOuts :: FunPerm ghosts args gouts ret -> - MbValuePerms ((ghosts :++: args) :++: gouts :> ret) -funPermOuts (FunPerm _ _ _ _ _ perms_out) = perms_out - --- | Build the context of types for the output permissions of a function -funPermOutCtx :: FunPerm ghosts args gouts ret -> - CruCtx ((ghosts :++: args) :++: gouts :> ret) -funPermOutCtx fun_perm = - appendCruCtx (funPermTops fun_perm) (funPermRets fun_perm) - - --- | Test whether a name of a given 'NameSort' can be folded / unfolded -type family NameSortCanFold (ns::NameSort) :: Bool where - NameSortCanFold (DefinedSort _) = 'True - NameSortCanFold (OpaqueSort _) = 'False - NameSortCanFold (RecursiveSort b _) = 'True - --- | Get a 'BoolRepr' for whether a name sort is conjunctive -nameSortIsConjRepr :: NameSortRepr ns -> BoolRepr (NameSortIsConj ns) -nameSortIsConjRepr (DefinedSortRepr b) = b -nameSortIsConjRepr (OpaqueSortRepr b) = b -nameSortIsConjRepr (RecursiveSortRepr b _) = b - --- | Get a 'BoolRepr' for whether a 'NamedPermName' is conjunctive -nameIsConjRepr :: NamedPermName ns args a -> BoolRepr (NameSortIsConj ns) -nameIsConjRepr = nameSortIsConjRepr . namedPermNameSort - --- | Get a 'BoolRepr' for whether a name sort allows folds / unfolds -nameSortCanFoldRepr :: NameSortRepr ns -> BoolRepr (NameSortCanFold ns) -nameSortCanFoldRepr (DefinedSortRepr _) = TrueRepr -nameSortCanFoldRepr (OpaqueSortRepr _) = FalseRepr -nameSortCanFoldRepr (RecursiveSortRepr _ _) = TrueRepr - --- | Get a 'BoolRepr' for whether a 'NamedPermName' allows folds / unfolds -nameCanFoldRepr :: NamedPermName ns args a -> BoolRepr (NameSortCanFold ns) -nameCanFoldRepr = nameSortCanFoldRepr . namedPermNameSort - --- | Extract to Boolean value out of a 'BoolRepr' --- --- FIXME: this should probably go in @BoolRepr.hs@ -boolVal :: BoolRepr b -> Bool -boolVal TrueRepr = True -boolVal FalseRepr = False - --- | Test whether a name of a given sort can be used as an atomic permission -nameSortIsConj :: NameSortRepr ns -> Bool -nameSortIsConj = boolVal . nameSortIsConjRepr - --- | Get a 'Bool' for whether a 'NamedPermName' allows folds / unfolds -nameCanFold :: NamedPermName ns args a -> Bool -nameCanFold = boolVal . nameCanFoldRepr - -instance TestEquality NameSortRepr where - testEquality (DefinedSortRepr b1) (DefinedSortRepr b2) - | Just Refl <- testEquality b1 b2 = Just Refl - testEquality (DefinedSortRepr _) _ = Nothing - testEquality (OpaqueSortRepr b1) (OpaqueSortRepr b2) - | Just Refl <- testEquality b1 b2 = Just Refl - testEquality (OpaqueSortRepr _) _ = Nothing - testEquality (RecursiveSortRepr b1 reach1) (RecursiveSortRepr b2 reach2) - | Just Refl <- testEquality b1 b2 - , Just Refl <- testEquality reach1 reach2 - = Just Refl - testEquality (RecursiveSortRepr _ _) _ = Nothing - --- | Extract a 'BoolRepr' from a 'NameReachConstr' for whether the name it --- constrains is a reachability name -nameReachConstrBool :: NameReachConstr ns args a -> - BoolRepr (IsReachabilityName ns) -nameReachConstrBool NameReachConstr = TrueRepr -nameReachConstrBool NameNonReachConstr = FalseRepr - --- FIXME: NamedPermNames should maybe say something about which arguments are --- covariant? Right now we assume lifetime and rwmodalities are covariant --- w.r.t. their respective orders, and everything else is invariant, but that --- could potentially change - --- | Test if two 'NamedPermName's of possibly different types are equal -testNamedPermNameEq :: NamedPermName ns1 args1 a1 -> - NamedPermName ns2 args2 a2 -> - Maybe (ns1 :~: ns2, args1 :~: args2, a1 :~: a2) -testNamedPermNameEq (NamedPermName str1 tp1 ctx1 ns1 _r1) - (NamedPermName str2 tp2 ctx2 ns2 _r2) - | Just Refl <- testEquality tp1 tp2 - , Just Refl <- testEquality ctx1 ctx2 - , Just Refl <- testEquality ns1 ns2 - , str1 == str2 = Just (Refl, Refl, Refl) -testNamedPermNameEq _ _ = Nothing - -instance Eq (NamedPermName ns args a) where - n1 == n2 | Just (Refl, Refl, Refl) <- testNamedPermNameEq n1 n2 = True - _ == _ = False - -instance Eq SomeNamedPermName where - (SomeNamedPermName n1) == (SomeNamedPermName n2) - | Just (Refl, Refl, Refl) <- testNamedPermNameEq n1 n2 = True - _ == _ = False - --- | An existentially quantified conjunctive 'NamedPermName' -data SomeNamedConjPermName where - SomeNamedConjPermName :: - NameSortIsConj ns ~ 'True => NamedPermName ns args a -> - SomeNamedConjPermName - --- | Test if two 'NamedShapes' of possibly different @b@ and @args@ arguments --- are equal -namedShapeEq :: NamedShape b1 args1 w -> NamedShape b2 args2 w -> - Maybe (b1 :~: b2, args1 :~: args2) -namedShapeEq nmsh1 nmsh2 - | Just Refl <- testEquality (namedShapeArgs nmsh1) (namedShapeArgs nmsh2) - , b1 <- namedShapeCanUnfoldRepr nmsh1 - , b2 <- namedShapeCanUnfoldRepr nmsh2 - , Just Refl <- testEquality b1 b2 - , namedShapeName nmsh1 == namedShapeName nmsh2 - , namedShapeBody nmsh1 == namedShapeBody nmsh2 = - Just (Refl,Refl) -namedShapeEq _ _ = Nothing - -deriving instance Eq (NamedShapeBody b args w) - --- | Test if a 'NamedShape' is recursive -namedShapeIsRecursive :: NamedShape b args w -> Bool -namedShapeIsRecursive (NamedShape _ _ (RecShapeBody _ _ _)) = True -namedShapeIsRecursive _ = False - --- | Test if a 'NamedShape' in a binding is recursive -mbNamedShapeIsRecursive :: Mb ctx (NamedShape b args w) -> Bool -mbNamedShapeIsRecursive = - mbLift . mbMapCl $(mkClosed [| namedShapeIsRecursive |]) - --- | Get a 'BoolRepr' for the Boolean flag for whether a named shape can be --- unfolded -namedShapeCanUnfoldRepr :: NamedShape b args w -> BoolRepr b -namedShapeCanUnfoldRepr (NamedShape _ _ (DefinedShapeBody _)) = TrueRepr -namedShapeCanUnfoldRepr (NamedShape _ _ (OpaqueShapeBody _ _ _)) = FalseRepr -namedShapeCanUnfoldRepr (NamedShape _ _ (RecShapeBody _ _ _)) = TrueRepr - --- | Get a 'BoolRepr' for the Boolean flag for whether a named shape in a --- binding can be unfolded -mbNamedShapeCanUnfoldRepr :: Mb ctx (NamedShape b args w) -> BoolRepr b -mbNamedShapeCanUnfoldRepr = - mbLift . mbMapCl $(mkClosed [| namedShapeCanUnfoldRepr |]) - --- | Whether a 'NamedShape' can be unfolded -namedShapeCanUnfold :: NamedShape b args w -> Bool -namedShapeCanUnfold = boolVal . namedShapeCanUnfoldRepr - -instance Eq (PermOffset a) where - NoPermOffset == NoPermOffset = True - (LLVMPermOffset e1) == (LLVMPermOffset e2) = e1 == e2 - _ == _ = False - --- | Smart constructor for 'LLVMPermOffset', that maps a 0 to 'NoPermOffset' -mkLLVMPermOffset :: (1 <= w, KnownNat w) => PermExpr (BVType w) -> - PermOffset (LLVMPointerType 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 -offsetsEq (LLVMPermOffset off) NoPermOffset = bvIsZero off -offsetsEq NoPermOffset (LLVMPermOffset off) = bvIsZero off -offsetsEq (LLVMPermOffset off1) (LLVMPermOffset off2) = bvEq off1 off2 - --- | Add a 'PermOffset' to an expression -offsetExpr :: PermOffset a -> PermExpr a -> PermExpr a -offsetExpr NoPermOffset e = e -offsetExpr (LLVMPermOffset off) e = addLLVMOffset e off - --- | Convert an expression to a variable + optional offset, if this is possible -asVarOffset :: PermExpr a -> Maybe (ExprVar a, PermOffset a) -asVarOffset (PExpr_Var x) = Just (x, NoPermOffset) -asVarOffset (PExpr_LLVMOffset x off) = Just (x, LLVMPermOffset off) -asVarOffset _ = Nothing - --- | Convert an expression to a variable if possible -asVar :: PermExpr a -> Maybe (ExprVar a) -asVar e - | Just (x,off) <- asVarOffset e - , offsetsEq off NoPermOffset = - Just x -asVar _ = Nothing - --- | Negate a 'PermOffset' -negatePermOffset :: PermOffset a -> PermOffset a -negatePermOffset NoPermOffset = NoPermOffset -negatePermOffset (LLVMPermOffset off) = LLVMPermOffset $ bvNegate off - --- | Add two 'PermOffset's -addPermOffsets :: PermOffset a -> PermOffset a -> PermOffset a -addPermOffsets NoPermOffset off = off -addPermOffsets off NoPermOffset = off -addPermOffsets (LLVMPermOffset off1) (LLVMPermOffset off2) = - mkLLVMPermOffset (bvAdd off1 off2) - --- | Get the @n@th expression in a 'PermExprs' list -nthPermExpr :: PermExprs args -> Member args a -> PermExpr a -nthPermExpr PExprs_Nil m = case m of {} -nthPermExpr (PExprs_Cons _ arg) Member_Base = arg -nthPermExpr (PExprs_Cons args _) (Member_Step memb) = - nthPermExpr args memb - --- | Set the @n@th expression in a 'PermExprs' list -setNthPermExpr :: PermExprs args -> Member args a -> PermExpr a -> - PermExprs args -setNthPermExpr PExprs_Nil m _ = - case m of {} -setNthPermExpr (PExprs_Cons args _) Member_Base a = - PExprs_Cons args a -setNthPermExpr (PExprs_Cons args arg) (Member_Step memb) a = - PExprs_Cons (setNthPermExpr args memb a) arg - --- | Get a list of 'Member' proofs for each expression in a 'PermExprs' list -getPermExprsMembers :: PermExprs args -> - [Some (Member args :: CrucibleType -> Type)] -getPermExprsMembers PExprs_Nil = [] -getPermExprsMembers (PExprs_Cons args _) = - map (\case Some memb -> Some (Member_Step memb)) (getPermExprsMembers args) - ++ [Some Member_Base] - --- | Extract the name back out of the interpretation of a 'NamedPerm' -namedPermName :: NamedPerm ns args a -> NamedPermName ns args a -namedPermName (NamedPerm_Opaque op) = opaquePermName op -namedPermName (NamedPerm_Rec rp) = recPermName rp -namedPermName (NamedPerm_Defined dp) = definedPermName dp - --- | Extract out the argument context of the name of a 'NamedPerm' -namedPermArgs :: NamedPerm ns args a -> CruCtx args -namedPermArgs = namedPermNameArgs . namedPermName - --- | Get the @trans@ method from a 'RecPerm' for a reachability permission -recPermTransMethod :: RecPerm b 'True args a -> Ident -recPermTransMethod (RecPerm { recPermReachMethods = ReachMethods { .. }}) = - reachMethodTrans - --- | Extract the permissions from a 'VarAndPerm' -varAndPermPerm :: VarAndPerm a -> ValuePerm a -varAndPermPerm (VarAndPerm _ p) = p - --- | A pair that is specifically pretty-printing with a colon -data ColonPair a b = ColonPair a b - --- | Pattern for an empty 'DistPerms' -pattern DistPermsNil :: () => (ps ~ RNil) => DistPerms ps -pattern DistPermsNil = MNil - --- | Pattern for a non-empty 'DistPerms' -pattern DistPermsCons :: () => (ps ~ (ps' :> a)) => - DistPerms ps' -> ExprVar a -> ValuePerm a -> - DistPerms ps -pattern DistPermsCons ps x p <- ps :>: (VarAndPerm x p) - where - DistPermsCons ps x p = ps :>: VarAndPerm x p - -{-# COMPLETE DistPermsNil, DistPermsCons #-} - -{- -data DistPerms ps where - DistPermsNil :: DistPerms RNil - DistPermsCons :: DistPerms ps -> ExprVar a -> ValuePerm a -> - DistPerms (ps :> a) --} - -type MbDistPerms ps = Mb ps (DistPerms ps) - --- FIXME: change all of the following functions on DistPerms to use the RAssign --- combinators - --- | Fold a function over a 'DistPerms' list, where --- --- > foldDistPerms f b ('DistPermsCons' --- > ('DistPermsCons' (... 'DistPermsNil' ...) x2 p2) x1 p1) = --- > f (f (... b ...) x2 p2) x1 p1 --- --- FIXME: implement more functions on DistPerms in terms of this -foldDistPerms :: (forall a. b -> ExprVar a -> ValuePerm a -> b) -> - b -> DistPerms as -> b -foldDistPerms _ b DistPermsNil = b -foldDistPerms f b (DistPermsCons ps x p) = f (foldDistPerms f b ps) x p - --- | Find all permissions in a 'DistPerms' on a specific variable -varPermsInDistPerms :: ExprVar a -> DistPerms ps -> [ValuePerm a] -varPermsInDistPerms x = - RL.foldr (\case (VarAndPerm y p) | Just Refl <- testEquality x y -> (p:) - _ -> id) - [] - --- | Find all atomic permissions in a 'DistPerms' on a specific variable -varAtomicPermsInDistPerms :: ExprVar a -> DistPerms ps -> [AtomicPerm a] -varAtomicPermsInDistPerms x = - RL.foldr (\case (VarAndPerm y (ValPerm_Conj ps)) - | Just Refl <- testEquality x y -> (ps ++) - _ -> id) - [] - --- | Combine a list of variable names and a list of permissions into a list of --- distinguished permissions -valuePermsToDistPerms :: RAssign Name ps -> ValuePerms ps -> DistPerms ps -valuePermsToDistPerms MNil _ = DistPermsNil -valuePermsToDistPerms (ns :>: n) (ps :>: p) = - DistPermsCons (valuePermsToDistPerms ns ps) n p - --- | Convert a list of permissions inside bindings for variables into a list of --- distinguished permissions for those variables -mbValuePermsToDistPerms :: MbValuePerms ps -> MbDistPerms ps -mbValuePermsToDistPerms = nuMultiWithElim1 valuePermsToDistPerms - --- | Extract the permissions for a particular variable in a 'DistPerms' list -distPermsForVar :: ExprVar a -> DistPerms ps -> [ValuePerm a] -distPermsForVar _ MNil = [] -distPermsForVar x (ps :>: VarAndPerm y p) - | Just Refl <- testEquality x y = p : distPermsForVar x ps -distPermsForVar x (ps :>: _) = distPermsForVar x ps - --- | Extract the permissions from a 'DistPerms' -distPermsToValuePerms :: DistPerms ps -> ValuePerms ps -distPermsToValuePerms DistPermsNil = ValPerms_Nil -distPermsToValuePerms (DistPermsCons dperms _ p) = - ValPerms_Cons (distPermsToValuePerms dperms) p - --- | Extract the permissions-in-binding from a 'DistPerms' in a binding -mbDistPermsToValuePerms :: Mb ctx (DistPerms ps) -> Mb ctx (ValuePerms ps) -mbDistPermsToValuePerms = fmap distPermsToValuePerms - --- | Create a sequence @x1:eq(e1), ..., xn:eq(en)@ of equality permissions -eqDistPerms :: RAssign Name ps -> PermExprs ps -> DistPerms ps -eqDistPerms ns exprs = - valuePermsToDistPerms ns $ RL.map ValPerm_Eq $ exprsToRAssign exprs - --- | Create a sequence @x1:true, ..., xn:true@ of vacuous permissions -trueDistPerms :: RAssign Name ps -> DistPerms ps -trueDistPerms MNil = DistPermsNil -trueDistPerms (ns :>: n) = DistPermsCons (trueDistPerms ns) n ValPerm_True - --- | A list of \"distinguished\" permissions with types -type TypedDistPerms = RAssign (Typed VarAndPerm) - --- | Get the 'CruCtx' for a 'TypedDistPerms' -typedDistPermsCtx :: TypedDistPerms ctx -> CruCtx ctx -typedDistPermsCtx = cruCtxOfTypes . RL.map typedType - --- | Convert a permission list expression to a 'TypedDistPerms', if possible -permListToTypedPerms :: PermExpr PermListType -> Maybe (Some TypedDistPerms) -permListToTypedPerms PExpr_PermListNil = Just $ Some MNil -permListToTypedPerms (PExpr_PermListCons tp (PExpr_Var x) p l) - | Just (Some perms) <- permListToTypedPerms l = - Just $ Some $ RL.append (MNil :>: Typed tp (VarAndPerm x p)) perms -permListToTypedPerms _ = Nothing - --- | Convert a 'TypedDistPerms' to a permission list -typedPermsToPermList :: TypedDistPerms ps -> PermExpr PermListType -typedPermsToPermList = flip helper PExpr_PermListNil where - -- We use an accumulator to reverse as we go, because DistPerms cons to the - -- right while PermLists cons to the left - helper :: TypedDistPerms ps' -> PermExpr PermListType -> PermExpr PermListType - helper MNil accum = accum - helper (ps :>: Typed tp (VarAndPerm x p)) accum = - helper ps $ PExpr_PermListCons tp (PExpr_Var x) p accum - --- | Convert a 'TypedDistPerms' to a normal 'DistPerms' -unTypeDistPerms :: TypedDistPerms ps -> DistPerms ps -unTypeDistPerms = RL.map (\(Typed _ v_and_p) -> v_and_p) - - -instance TestEquality VarAndPerm where - testEquality (VarAndPerm x1 p1) (VarAndPerm x2 p2) - | Just Refl <- testEquality x1 x2 - , p1 == p2 - = Just Refl - testEquality _ _ = Nothing - -instance Eq (VarAndPerm a) where - vp1 == vp2 | Just _ <- testEquality vp1 vp2 = True - _ == _ = False - -instance Eq1 VarAndPerm where - eq1 = (==) - -instance Eq (ExprAndPerm a) where - ExprAndPerm e1 p1 == ExprAndPerm e2 p2 = e1 == e2 && p1 == p2 - -instance Eq1 ExprAndPerm where - eq1 = (==) - -{- -instance TestEquality DistPerms where - testEquality DistPermsNil DistPermsNil = Just Refl - testEquality (DistPermsCons ps1 x1 p1) (DistPermsCons ps2 x2 p2) - | Just Refl <- testEquality ps1 ps2 - , Just Refl <- testEquality x1 x2 - , p1 == p2 - = Just Refl - testEquality _ _ = Nothing - -instance Eq (DistPerms ps) where - perms1 == perms2 = - case testEquality perms1 perms2 of - Just _ -> True - Nothing -> False --} - - --- | Build the permission and the variable it applies to that is needed to prove --- that @l@ is current during @l2@. If @l@ is @always@, this holds vacuously, so --- return the permission @l2:true@, and otherwise, if @l@ is a variable, return --- @l:[l2]lcurrent@. -lcurrentPerm :: PermExpr LifetimeType -> ExprVar LifetimeType -> - (ExprVar LifetimeType, ValuePerm LifetimeType) -lcurrentPerm PExpr_Always l2 = (l2, ValPerm_True) -lcurrentPerm (PExpr_Var l) l2 = (l, ValPerm_LCurrent $ PExpr_Var l2) - --- | Get the lifetime that a 'LifetimeCurrentPerms' is about -lifetimeCurrentPermsLifetime :: LifetimeCurrentPerms ps_l -> - PermExpr LifetimeType -lifetimeCurrentPermsLifetime AlwaysCurrentPerms = PExpr_Always -lifetimeCurrentPermsLifetime (LOwnedCurrentPerms l _ _ _ _ _) = PExpr_Var l -lifetimeCurrentPermsLifetime (LOwnedSimpleCurrentPerms l _ _) = PExpr_Var l -lifetimeCurrentPermsLifetime (CurrentTransPerms _ l) = PExpr_Var l - --- | Convert a 'LifetimeCurrentPerms' to the 'DistPerms' it represent -lifetimeCurrentPermsPerms :: LifetimeCurrentPerms ps_l -> DistPerms ps_l -lifetimeCurrentPermsPerms AlwaysCurrentPerms = DistPermsNil -lifetimeCurrentPermsPerms (LOwnedCurrentPerms l ls tps_in tps_out ps_in ps_out) = - DistPermsCons DistPermsNil l $ ValPerm_LOwned ls tps_in tps_out ps_in ps_out -lifetimeCurrentPermsPerms (LOwnedSimpleCurrentPerms l tps lops) = - distPerms1 l $ ValPerm_LOwnedSimple tps lops -lifetimeCurrentPermsPerms (CurrentTransPerms cur_ps l) = - DistPermsCons (lifetimeCurrentPermsPerms cur_ps) l $ - ValPerm_Conj1 $ Perm_LCurrent $ lifetimeCurrentPermsLifetime cur_ps - --- | Build a lift of proxies for a 'LifetimeCurrentPerms' -mbLifetimeCurrentPermsProxies :: Mb ctx (LifetimeCurrentPerms ps_l) -> - RAssign Proxy ps_l -mbLifetimeCurrentPermsProxies mb_l = case mbMatch mb_l of - [nuMP| AlwaysCurrentPerms |] -> MNil - [nuMP| LOwnedCurrentPerms _ _ _ _ _ _ |] -> MNil :>: Proxy - [nuMP| LOwnedSimpleCurrentPerms _ _ _ |] -> MNil :>: Proxy - [nuMP| CurrentTransPerms cur_ps _ |] -> - mbLifetimeCurrentPermsProxies cur_ps :>: Proxy - --- | Apply a functor to its arguments to get out a permission -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 - --- | Apply a functor to a lifetime and the \"minimal\" rwmodalities, i.e., with --- all read permissions -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 - --- | Convert a field permission to a lifetime functor and its arguments -fieldToLTFunc :: (1 <= w, KnownNat w, 1 <= sz, KnownNat sz) => - LLVMFieldPerm w sz -> - (LifetimeFunctor (RNil :> RWModalityType) (LLVMPointerType w), - PermExprs (RNil :> RWModalityType)) -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), - PermExprs (RNil :> RWModalityType)) -blockToLTFunc bp = - (LTFunctorBlock (llvmBlockOffset bp) (llvmBlockLen bp) (llvmBlockShape bp), - MNil :>: llvmBlockRW bp) - -instance Eq (ValuePerm a) where - (ValPerm_Eq e1) == (ValPerm_Eq e2) = e1 == e2 - (ValPerm_Eq _) == _ = False - (ValPerm_Or p1 p1') == (ValPerm_Or p2 p2') = p1 == p2 && p1' == p2' - (ValPerm_Or _ _) == _ = False - (ValPerm_Exists (p1 :: Binding a1 (ValuePerm a))) == - (ValPerm_Exists (p2 :: Binding a2 (ValuePerm a))) - | Just Refl <- - testEquality (knownRepr :: TypeRepr a1) (knownRepr :: TypeRepr a2) - = p1 == p2 - (ValPerm_Exists _) == _ = False - (ValPerm_Named n1 args1 off1) == (ValPerm_Named n2 args2 off2) - | Just (Refl, Refl, Refl) <- testNamedPermNameEq n1 n2 = - args1 == args2 && off1 == off2 - (ValPerm_Named _ _ _) == _ = False - (ValPerm_Var x1 off1) == (ValPerm_Var x2 off2) = x1 == x2 && off1 == off2 - (ValPerm_Var _ _) == _ = False - (ValPerm_Conj aps1) == (ValPerm_Conj aps2) = aps1 == aps2 - (ValPerm_Conj _) == _ = False - ValPerm_False == ValPerm_False = True - ValPerm_False == _ = False - -instance Eq (AtomicPerm a) where - (Perm_LLVMField fp1) == (Perm_LLVMField fp2) - | Just Refl <- testEquality (llvmFieldSize fp1) (llvmFieldSize fp2) - = fp1 == fp2 - (Perm_LLVMField _) == _ = False - (Perm_LLVMArray ap1) == (Perm_LLVMArray ap2) = ap1 == ap2 - (Perm_LLVMArray _) == _ = False - (Perm_LLVMBlock bp1) == (Perm_LLVMBlock bp2) = bp1 == bp2 - (Perm_LLVMBlock _) == _ = False - (Perm_LLVMFree e1) == (Perm_LLVMFree e2) = e1 == e2 - (Perm_LLVMFree _) == _ = False - (Perm_LLVMFunPtr tp1 p1) == (Perm_LLVMFunPtr tp2 p2) - | Just Refl <- testEquality tp1 tp2 = p1 == p2 - (Perm_LLVMFunPtr _ _) == _ = False - Perm_IsLLVMPtr == Perm_IsLLVMPtr = True - Perm_IsLLVMPtr == _ = False - (Perm_LLVMBlockShape sh1) == (Perm_LLVMBlockShape sh2) = sh1 == sh2 - (Perm_LLVMBlockShape _) == _ = False - (Perm_LLVMFrame frame1) == (Perm_LLVMFrame frame2) = frame1 == frame2 - (Perm_LLVMFrame _) == _ = False - (Perm_LOwned - ls1 tps_in1 tps_out1 ps_in1 ps_out1) == (Perm_LOwned - ls2 tps_in2 tps_out2 ps_in2 ps_out2) - | Just Refl <- testEquality tps_in1 tps_in2 - , Just Refl <- testEquality tps_out1 tps_out2 - = ls1 == ls2 && ps_in1 == ps_in2 && ps_out1 == ps_out2 - (Perm_LOwned _ _ _ _ _) == _ = False - (Perm_LOwnedSimple tps1 lops1) == (Perm_LOwnedSimple tps2 lops2) - | Just Refl <- testEquality tps1 tps2 = lops1 == lops2 - (Perm_LOwnedSimple _ _) == _ = False - (Perm_LCurrent e1) == (Perm_LCurrent e2) = e1 == e2 - (Perm_LCurrent _) == _ = False - Perm_LFinished == Perm_LFinished = True - Perm_LFinished == _ = False - (Perm_Struct ps1) == (Perm_Struct ps2) = ps1 == ps2 - (Perm_Struct _) == _ = False - (Perm_Fun fperm1) == (Perm_Fun fperm2) - | Just (Refl, Refl) <- funPermEq fperm1 fperm2 = True - (Perm_Fun _) == _ = False - (Perm_NamedConj n1 args1 off1) == (Perm_NamedConj n2 args2 off2) - | Just (Refl, Refl, Refl) <- testNamedPermNameEq n1 n2 = - args1 == args2 && off1 == off2 - (Perm_NamedConj _ _ _) == _ = False - (Perm_BVProp p1) == (Perm_BVProp p2) = p1 == p2 - (Perm_BVProp _) == _ = False - Perm_Any == Perm_Any = True - Perm_Any == _ = False - -instance Eq1 ValuePerm where - eq1 = (==) - -{- -instance Eq (ValuePerms as) where - ValPerms_Nil == ValPerms_Nil = True - (ValPerms_Cons ps1 p1) == (ValPerms_Cons ps2 p2) = - ps1 == ps2 && p1 == p2 --} - --- | Test if function permissions with different ghost argument lists are equal -funPermEq :: FunPerm ghosts1 args gouts1 ret -> - FunPerm ghosts2 args gouts2 ret -> - Maybe (ghosts1 :~: ghosts2, gouts1 :~: gouts2) -funPermEq (FunPerm ghosts1 _ gouts1 _ perms_in1 perms_out1) - (FunPerm ghosts2 _ gouts2 _ perms_in2 perms_out2) - | Just Refl <- testEquality ghosts1 ghosts2 - , Just Refl <- testEquality gouts1 gouts2 - , perms_in1 == perms_in2 && perms_out1 == perms_out2 - = Just (Refl, Refl) -funPermEq _ _ = Nothing - --- | Test if function permissions with all 4 type args different are equal -funPermEq4 :: FunPerm ghosts1 args1 gouts1 ret1 -> - FunPerm ghosts2 args2 gouts2 ret2 -> - Maybe (ghosts1 :~: ghosts2, args1 :~: args2, - gouts1 :~: gouts2, ret1 :~: ret2) -funPermEq4 (FunPerm ghosts1 args1 ret1 gouts1 perms_in1 perms_out1) - (FunPerm ghosts2 args2 ret2 gouts2 perms_in2 perms_out2) - | Just Refl <- testEquality ghosts1 ghosts2 - , Just Refl <- testEquality args1 args2 - , Just Refl <- testEquality gouts1 gouts2 - , Just Refl <- testEquality ret1 ret2 - , perms_in1 == perms_in2 && perms_out1 == perms_out2 - = Just (Refl, Refl, Refl, Refl) -funPermEq4 _ _ = Nothing - -instance Eq (FunPerm ghosts args gouts ret) where - fperm1 == fperm2 = isJust (funPermEq fperm1 fperm2) - -instance PermPretty (NamedPermName ns args a) where - permPrettyM (NamedPermName str _ _ _ _) = return $ pretty str - -instance PermPretty (ValuePerm a) where - permPrettyM (ValPerm_Eq e) = ((pretty "eq" <>) . parens) <$> permPrettyM e - permPrettyM (ValPerm_Or p1 p2) = - -- FIXME: If we ever fix the SAW lexer to handle "\/"... - -- (\pp1 pp2 -> hang 2 (pp1 string "\\/" <> pp2)) - (\pp1 pp2 -> hang 2 (pp1 <> softline <> pretty "or" <+> pp2)) - <$> permPrettyM p1 <*> permPrettyM p2 - permPrettyM (ValPerm_Exists mb_p) = - flip (permPrettyExprMbTyped (CruCtxNil `CruCtxCons` knownRepr)) mb_p $ \(_ :>: Constant pp_n) ppm -> - (\pp -> hang 2 (pretty "exists" <+> pp_n <> dot <+> pp)) <$> ppm - permPrettyM (ValPerm_Named n args off) = - do n_pp <- permPrettyM n - args_pp <- permPrettyM args - off_pp <- permPrettyM off - return (n_pp <> pretty '<' <> - align (args_pp <> pretty '>') <> off_pp) - permPrettyM (ValPerm_Var n off) = - do n_pp <- permPrettyM n - off_pp <- permPrettyM off - return (n_pp <> off_pp) - permPrettyM ValPerm_True = return $ pretty "true" - permPrettyM (ValPerm_Conj ps) = - (hang 2 . encloseSep mempty mempty (pretty "*")) <$> mapM permPrettyM ps - permPrettyM (ValPerm_False) = return $ pretty "false" - -instance PermPrettyF ValuePerm where - permPrettyMF = permPrettyM - --- | Pretty-print a lifetime @l@ as either the string @[l]@, or as the empty --- string if @l==always@ -permPrettyLifetimePrefix :: PermExpr LifetimeType -> PermPPM (Doc ann) -permPrettyLifetimePrefix PExpr_Always = return emptyDoc -permPrettyLifetimePrefix l = brackets <$> permPrettyM l - --- | Pretty-print an 'LLVMFieldPerm', either by itself as the form --- @[l]ptr((rw,off) |-> p)@ if the 'Bool' flag is 'False' or as part of an array --- permission as the form @[l](rw,off) |-> p@ if the 'Bool' flag is 'True' -permPrettyLLVMField :: (KnownNat w, KnownNat sz) => - Bool -> LLVMFieldPerm w sz -> PermPPM (Doc ann) -permPrettyLLVMField in_array (LLVMFieldPerm {..} :: LLVMFieldPerm w sz) = - do let w = knownNat @w - let sz = knownNat @sz - pp_l <- permPrettyLifetimePrefix llvmFieldLifetime - pp_off <- permPrettyM llvmFieldOffset - pp_rw <- permPrettyM llvmFieldRW - let pp_parens = - parens $ - if intValue sz == intValue w then - pp_rw <> comma <> pp_off - else - pp_rw <> comma <> pp_off <> comma <> pretty (intValue sz) - pp_contents <- permPrettyM llvmFieldContents - return (pp_l <> - (if in_array then id else (pretty "ptr" <>) . parens) - (hang 2 - (pp_parens <+> pretty "|->" <> softline <> pp_contents))) - -instance (1 <= w, KnownNat w, 1 <= sz, KnownNat sz) => - PermPretty (LLVMFieldPerm w sz) where - permPrettyM = permPrettyLLVMField False - -instance (1 <= w, KnownNat w) => PermPretty (LLVMArrayPerm w) where - permPrettyM (LLVMArrayPerm {..}) = - do pp_l <- permPrettyLifetimePrefix llvmArrayLifetime - pp_rw <- permPrettyM llvmArrayRW - pp_off <- permPrettyM llvmArrayOffset - pp_len <- permPrettyM llvmArrayLen - let pp_stride = pretty (show llvmArrayStride) - pp_sh <- permPrettyM llvmArrayCellShape - pp_bs <- mapM permPrettyM llvmArrayBorrows - return $ PP.group (pp_l <> pretty "array" <> - ppEncList True [pp_rw, pp_off, pretty "<" <> pp_len, - pretty "*" <> pp_stride, - pp_sh, - ppEncList False pp_bs]) - -instance (1 <= w, KnownNat w) => PermPretty (LLVMBlockPerm w) where - permPrettyM (LLVMBlockPerm {..}) = - do pp_rw <- permPrettyM llvmBlockRW - pp_l <- permPrettyLifetimePrefix llvmBlockLifetime - pp_off <- permPrettyM llvmBlockOffset - pp_len <- permPrettyM llvmBlockLen - pp_sh <- permPrettyM llvmBlockShape - return $ PP.group (pp_l <> pretty "memblock" <> - ppEncList True [pp_rw, pp_off, pp_len, pp_sh]) - -instance PermPretty (AtomicPerm a) where - permPrettyM (Perm_LLVMField fp) = permPrettyLLVMField False fp - permPrettyM (Perm_LLVMArray ap) = permPrettyM ap - permPrettyM (Perm_LLVMBlock bp) = permPrettyM bp - permPrettyM (Perm_LLVMBlockShape sh) = - ((pretty "shape" <>) . parens) <$> permPrettyM sh - permPrettyM (Perm_LLVMFree e) = (pretty "free" <+>) <$> permPrettyM e - permPrettyM (Perm_LLVMFunPtr _tp fp) = - (\pp -> pretty "llvmfunptr" <+> parens pp) <$> permPrettyM fp - permPrettyM Perm_IsLLVMPtr = return (pretty "is_llvmptr") - permPrettyM (Perm_LLVMFrame fperm) = - do pps <- mapM (\(e,i) -> (<> (colon <> pretty i)) <$> permPrettyM e) fperm - return (pretty "llvmframe" <+> ppEncList False pps) - permPrettyM (Perm_LOwned ls _ _ ps_in ps_out) = - do pp_in <- permPrettyM ps_in - pp_out <- permPrettyM ps_out - ls_pp <- case ls of - [] -> return emptyDoc - _ -> ppEncList False <$> mapM permPrettyM ls - return (pretty "lowned" <> ls_pp <+> - parens (align $ sep [pp_in, pretty "-o", pp_out])) - permPrettyM (Perm_LOwnedSimple _ lops) = - (pretty "lowned" <>) <$> parens <$> permPrettyM lops - permPrettyM (Perm_LCurrent l) = (pretty "lcurrent" <+>) <$> permPrettyM l - permPrettyM Perm_LFinished = return (pretty "lfinished") - permPrettyM (Perm_Struct ps) = - ((pretty "struct" <+>) . parens) <$> permPrettyM ps - permPrettyM (Perm_Fun fun_perm) = permPrettyM fun_perm - permPrettyM (Perm_BVProp prop) = permPrettyM prop - permPrettyM Perm_Any = return $ pretty "any" - permPrettyM (Perm_NamedConj n args off) = - do n_pp <- permPrettyM n - args_pp <- permPrettyM args - off_pp <- permPrettyM off - return (n_pp <> pretty '<' <> args_pp <> pretty '>' <> off_pp) - -instance PermPretty (PermOffset a) where - permPrettyM NoPermOffset = return mempty - permPrettyM (LLVMPermOffset e) = - do e_pp <- permPrettyM e - return (pretty '@' <> parens e_pp) - -instance PermPretty (FunPerm ghosts args gouts ret) where - permPrettyM (FunPerm ghosts args gouts _ mb_ps_in mb_ps_out) = - fmap mbLift $ strongMbM $ - flip nuMultiWithElim1 (mbValuePermsToDistPerms mb_ps_out) $ - \(ghosts_args_gouts_ns :>: ret_n) ps_out -> - let (ghosts_ns, args_ns, gouts_ns) = - rlSplit3 (cruCtxProxies ghosts) (cruCtxProxies args) - (cruCtxProxies gouts) ghosts_args_gouts_ns in - let ps_in = - varSubst (permVarSubstOfNames $ RL.append ghosts_ns args_ns) - (mbValuePermsToDistPerms mb_ps_in) in - local (ppInfoAddExprName "ret" ret_n) $ - local (ppInfoAddExprNames "arg" args_ns) $ - local (ppInfoAddTypedExprNames ghosts ghosts_ns) $ - local (ppInfoAddTypedExprNames gouts gouts_ns) $ - do pp_ps_in <- permPrettyM ps_in - pp_ps_out <- permPrettyM ps_out - pp_ghosts <- permPrettyM (RL.map2 VarAndType ghosts_ns $ - cruCtxToTypes ghosts) - pp_gouts <- case gouts of - CruCtxNil -> return mempty - _ -> parens <$> permPrettyM (RL.map2 VarAndType gouts_ns $ - cruCtxToTypes gouts) - return $ align $ - sep [parens pp_ghosts <> dot, pp_ps_in, pretty "-o", - pp_gouts <> pp_ps_out] - -instance PermPretty (BVRange w) where - permPrettyM (BVRange e1 e2) = - (\pp1 pp2 -> braces (pp1 <> comma <+> pp2)) - <$> permPrettyM e1 <*> permPrettyM e2 - -instance PermPretty (MbRangeForType a) where - permPrettyM (MbRangeForLLVMType _ mb_rw mb_l mb_rng) = - permPrettyMb - (\ns_pp (rw,l,rng) -> - do pp_rw <- permPrettyM rw - pp_l_prefix <- permPrettyLifetimePrefix l - pp_rng <- permPrettyM rng - return (ppEncList True (RL.toList ns_pp) <> dot <> line <> - pp_l_prefix <> parens pp_rw <> pp_rng)) $ - mbMap3 (,,) mb_rw mb_l mb_rng - -instance PermPretty (BVProp w) where - permPrettyM (BVProp_Eq e1 e2) = - (\pp1 pp2 -> pp1 <+> equals <+> pp2) <$> permPrettyM e1 <*> permPrettyM e2 - permPrettyM (BVProp_Neq e1 e2) = - (\pp1 pp2 -> pp1 <+> pretty "/=" <+> pp2) <$> permPrettyM e1 <*> permPrettyM e2 - permPrettyM (BVProp_ULt e1 e2) = - (\pp1 pp2 -> pp1 <+> pretty " pp2) <$> permPrettyM e1 <*> permPrettyM e2 - permPrettyM (BVProp_ULeq e1 e2) = - (\pp1 pp2 -> pp1 <+> pretty "<=u" <+> pp2) <$> permPrettyM e1 <*> permPrettyM e2 - permPrettyM (BVProp_ULeq_Diff e1 e2 e3) = - (\pp1 pp2 pp3 -> pp1 <+> pretty "<=u" <+> pp2 <+> pretty '-' <+> pp3) - <$> permPrettyM e1 <*> permPrettyM e2 <*> permPrettyM e3 - -instance PermPretty (LLVMArrayBorrow w) where - permPrettyM (FieldBorrow ix) = permPrettyM ix - permPrettyM (RangeBorrow rng) = permPrettyM rng - -instance PermPretty (VarAndPerm a) where - permPrettyM (VarAndPerm x p) = - (\pp1 pp2 -> pp1 <> colon <> pp2) <$> permPrettyM x <*> permPrettyM p - -instance PermPrettyF VarAndPerm where - permPrettyMF = permPrettyM - -instance (PermPretty a, PermPretty b) => PermPretty (ColonPair a b) where - permPrettyM (ColonPair a b) = - (\pp1 pp2 -> pp1 <> colon <> pp2) <$> permPrettyM a <*> permPrettyM b - - -{- -instance PermPretty (DistPerms ps) where - permPrettyM ps = ppCommaSep <$> helper ps where - helper :: DistPerms ps' -> PermPPM [Doc ann] - helper DistPermsNil = return [] - helper (DistPermsCons ps x p) = - do x_pp <- permPrettyM x - p_pp <- permPrettyM p - (++ [x_pp <> colon <> p_pp]) <$> helper ps --} - -instance PermPretty (ExprAndPerm a) where - permPrettyM (ExprAndPerm x p) = - (\pp1 pp2 -> pp1 <> colon <> pp2) <$> permPrettyM x <*> permPrettyM p - -instance PermPrettyF ExprAndPerm where - permPrettyMF = permPrettyM - --- | Embed a 'ValuePerm' in a 'PermExpr' - like 'PExpr_ValPerm' but maps --- 'ValPerm_Var's to 'PExpr_Var's -permToExpr :: ValuePerm a -> PermExpr (ValuePermType a) -permToExpr (ValPerm_Var n NoPermOffset) = PExpr_Var n -permToExpr a = PExpr_ValPerm a - --- | Extract @p1@ from a permission of the form @p1 \/ p2@ -orPermLeft :: ValuePerm a -> ValuePerm a -orPermLeft (ValPerm_Or p _) = p -orPermLeft _ = error "orPermLeft" - --- | Extract @p2@ from a permission of the form @p1 \/ p2@ -orPermRight :: ValuePerm a -> ValuePerm a -orPermRight (ValPerm_Or _ p) = p -orPermRight _ = error "orPermRight" - --- | Extract the body @p@ from a permission of the form @exists (x:tp).p@ -exPermBody :: TypeRepr tp -> ValuePerm a -> Binding tp (ValuePerm a) -exPermBody tp (ValPerm_Exists (p :: Binding tp' (ValuePerm a))) - | Just Refl <- testEquality tp (knownRepr :: TypeRepr tp') = p -exPermBody _ _ = error "exPermBody" - --- | Construct 0 or more nested existential permissions -valPermExistsMulti :: KnownCruCtx ctx -> Mb ctx (ValuePerm a) -> ValuePerm a -valPermExistsMulti MNil mb_p = elimEmptyMb mb_p -valPermExistsMulti (ctx :>: KnownReprObj) mb_p = - valPermExistsMulti ctx (fmap ValPerm_Exists $ - mbSeparate (MNil :>: Proxy) mb_p) - --- | Test if an 'AtomicPerm' is a field permission -isLLVMFieldPerm :: AtomicPerm a -> Bool -isLLVMFieldPerm (Perm_LLVMField _) = True -isLLVMFieldPerm _ = False - --- | Test if an 'AtomicPerm' is a field permission with the given offset -isLLVMFieldPermWithOffset :: PermExpr (BVType w) -> - AtomicPerm (LLVMPointerType w) -> Bool -isLLVMFieldPermWithOffset off (Perm_LLVMField fp) = - bvEq off (llvmFieldOffset fp) -isLLVMFieldPermWithOffset _ _ = False - --- | Test if an 'AtomicPerm' starts with the given offset -isLLVMAtomicPermWithOffset :: PermExpr (BVType w) -> - AtomicPerm (LLVMPointerType w) -> Bool -isLLVMAtomicPermWithOffset off p - | Just off' <- llvmAtomicPermOffset p = bvEq off off' -isLLVMAtomicPermWithOffset _ _ = False - --- | Test if an 'AtomicPerm' is an array permission -isLLVMArrayPerm :: AtomicPerm a -> Bool -isLLVMArrayPerm (Perm_LLVMArray _) = True -isLLVMArrayPerm _ = False - --- | Test if an 'AtomicPerm' is an llvmblock permission -isLLVMBlockPerm :: AtomicPerm a -> Bool -isLLVMBlockPerm (Perm_LLVMBlock _) = True -isLLVMBlockPerm _ = False - --- | Test if an 'AtomicPerm' is any form of pointer permission -isLLVMPointerPerm :: AtomicPerm a -> Bool -isLLVMPointerPerm (Perm_LLVMField _) = True -isLLVMPointerPerm (Perm_LLVMArray _) = True -isLLVMPointerPerm (Perm_LLVMBlock _) = True -isLLVMPointerPerm (Perm_LLVMFunPtr _ _) = True -isLLVMPointerPerm _ = False - --- | Test if an 'AtomicPerm' is a lifetime permission -isLifetimePerm :: AtomicPerm a -> Maybe (a :~: LifetimeType) -isLifetimePerm (Perm_LOwned _ _ _ _ _) = Just Refl -isLifetimePerm (Perm_LOwnedSimple _ _) = Just Refl -isLifetimePerm (Perm_LCurrent _) = Just Refl -isLifetimePerm Perm_LFinished = Just Refl -isLifetimePerm _ = Nothing - --- | Test if an 'AtomicPerm' is a lifetime permission that gives ownership -isLifetimeOwnershipPerm :: AtomicPerm a -> Maybe (a :~: LifetimeType) -isLifetimeOwnershipPerm (Perm_LOwned _ _ _ _ _) = Just Refl -isLifetimeOwnershipPerm (Perm_LOwnedSimple _ _) = Just Refl -isLifetimeOwnershipPerm _ = Nothing - --- | Test if an 'AtomicPerm' is a struct permission -isStructPerm :: AtomicPerm a -> Bool -isStructPerm (Perm_Struct _) = True -isStructPerm _ = False - --- | Test if an 'AtomicPerm' is a function permission -isFunPerm :: AtomicPerm a -> Bool -isFunPerm (Perm_Fun _) = True -isFunPerm _ = False - --- | Test if an 'AtomicPerm' is a named conjunctive permission -isNamedConjPerm :: AtomicPerm a -> Bool -isNamedConjPerm (Perm_NamedConj _ _ _) = True -isNamedConjPerm _ = False - --- | Test if an 'AtomicPerm' is a foldable named conjunctive permission -isFoldableConjPerm :: AtomicPerm a -> Bool -isFoldableConjPerm (Perm_NamedConj npn _ _) = nameCanFold npn -isFoldableConjPerm _ = False - --- | Test if an 'AtomicPerm' is a defined conjunctive permission -isDefinedConjPerm :: AtomicPerm a -> Bool -isDefinedConjPerm (Perm_NamedConj - (namedPermNameSort -> DefinedSortRepr _) _ _) = True -isDefinedConjPerm _ = False - --- | Test if an 'AtomicPerm' is a recursive conjunctive permission -isRecursiveConjPerm :: AtomicPerm a -> Bool -isRecursiveConjPerm (Perm_NamedConj - (namedPermNameSort -> RecursiveSortRepr _ _) _ _) = True -isRecursiveConjPerm _ = False - --- | Test that a permission is a conjunctive permission, meaning that it is --- built inductively using only existentials, disjunctions, conjunctive named --- permissions, and conjunctions of atomic permissions. Note that an atomic --- permissions in such a conjunction can itself contain equality permissions; --- e.g., in LLVM field permissions. -isConjPerm :: ValuePerm a -> Bool -isConjPerm (ValPerm_Eq _) = False -isConjPerm (ValPerm_Or p1 p2) = isConjPerm p1 && isConjPerm p2 -isConjPerm (ValPerm_Exists mb_p) = mbLift $ fmap isConjPerm mb_p -isConjPerm (ValPerm_Named n _ _) = nameSortIsConj (namedPermNameSort n) -isConjPerm (ValPerm_Var _ _) = False -isConjPerm (ValPerm_Conj _) = True -isConjPerm (ValPerm_False) = False - --- | Return a struct permission where all fields have @true@ permissions -trueStructAtomicPerm :: Assignment prx ctx -> AtomicPerm (StructType ctx) -trueStructAtomicPerm = - Perm_Struct . RL.map (const ValPerm_True). assignToRList - --- | Take two list of atomic struct permissions, one for structs with fields --- given by @ctx1@ and one with those given by @ctx2@, and append them pointwise --- to get a list of atomic struct permissions whose fields are given by the --- append @ctx1 <+> ctx2@. If one list is shorter than the other, fill it out --- with struct permissions @struct (true, ..., true)@ of all @true@ permissions. --- This only works if both lists have only 'Perm_Struct' permissions, and --- otherwise return 'Nothing'. -tryAppendStructAPerms :: Assignment prx1 ctx1 -> Assignment prx2 ctx2 -> - [AtomicPerm (StructType ctx1)] -> - [AtomicPerm (StructType ctx2)] -> - Maybe [AtomicPerm (StructType (ctx1 <+> ctx2))] -tryAppendStructAPerms _ _ [] [] = return [] -tryAppendStructAPerms ctx1 ctx2 (Perm_Struct fs_ps:ps) (Perm_Struct fs_qs:qs) = - (Perm_Struct (assignToRListAppend ctx1 ctx2 fs_ps fs_qs) :) <$> - tryAppendStructAPerms ctx1 ctx2 ps qs -tryAppendStructAPerms ctx1 ctx2 [] qs = - tryAppendStructAPerms ctx1 ctx2 [trueStructAtomicPerm ctx1] qs -tryAppendStructAPerms ctx1 ctx2 ps [] = - tryAppendStructAPerms ctx1 ctx2 ps [trueStructAtomicPerm ctx2] -tryAppendStructAPerms _ _ _ _ = mzero - --- | Try to append struct permissions for structs with fields given by @ctx1@ --- and @ctx2@ to get a permission for structs with fields given by the append --- @ctx1 <+> ctx2@ of these two contexts. Return 'Nothing' if this is not --- possible. -tryAppendStructPerms :: Assignment prx1 ctx1 -> Assignment prx2 ctx2 -> - ValuePerm (StructType ctx1) -> - ValuePerm (StructType ctx2) -> - Maybe (ValuePerm (StructType (ctx1 <+> ctx2))) -tryAppendStructPerms ctx1 ctx2 (ValPerm_Or p1 p2) q = - ValPerm_Or <$> tryAppendStructPerms ctx1 ctx2 p1 q <*> - tryAppendStructPerms ctx1 ctx2 p2 q -tryAppendStructPerms ctx1 ctx2 p (ValPerm_Or q1 q2) = - ValPerm_Or <$> tryAppendStructPerms ctx1 ctx2 p q1 <*> - tryAppendStructPerms ctx1 ctx2 p q2 -tryAppendStructPerms ctx1 ctx2 (ValPerm_Exists mb_p) q = - ValPerm_Exists <$> mbMaybe (flip fmap mb_p $ \p -> - tryAppendStructPerms ctx1 ctx2 p q) -tryAppendStructPerms ctx1 ctx2 p (ValPerm_Exists mb_q) = - ValPerm_Exists <$> mbMaybe (flip fmap mb_q $ \q -> - tryAppendStructPerms ctx1 ctx2 p q) -tryAppendStructPerms ctx1 ctx2 (ValPerm_Conj ps) (ValPerm_Conj qs) = - ValPerm_Conj <$> tryAppendStructAPerms ctx1 ctx2 ps qs -tryAppendStructPerms _ _ _ _ = mzero - - --- | Helper function to build a 'Perm_LLVMFunPtr' from a 'FunPerm' -mkPermLLVMFunPtr :: (1 <= w, KnownNat w) => f w -> - FunPerm ghosts args gouts ret -> - AtomicPerm (LLVMPointerType w) -mkPermLLVMFunPtr (_w :: f w) fun_perm = - case cruCtxToReprEq (funPermArgs fun_perm) of - Refl -> - Perm_LLVMFunPtr (FunctionHandleRepr - (cruCtxToRepr $ funPermArgs fun_perm) - (funPermRet fun_perm)) - (ValPerm_Conj1 $ Perm_Fun fun_perm) - --- | Helper function to build a 'Perm_LLVMFunPtr' from a list of 'FunPerm's. The --- list must be non-empty. -mkPermLLVMFunPtrs :: (1 <= w, KnownNat w) => f w -> [SomeFunPerm args ret] -> - AtomicPerm (LLVMPointerType w) -mkPermLLVMFunPtrs (_w :: f w) [] = error "mkPermLLVMFunPtrs: empty list" -mkPermLLVMFunPtrs (_w :: f w) fun_perms@(SomeFunPerm fun_perm:_) = - case cruCtxToReprEq (funPermArgs fun_perm) of - Refl -> - Perm_LLVMFunPtr (FunctionHandleRepr - (cruCtxToRepr $ funPermArgs fun_perm) - (funPermRet fun_perm)) - (ValPerm_Conj $ map (\(SomeFunPerm fp) -> Perm_Fun fp) fun_perms) - --- | The shape for an @eq(llvmword(w))@ permission -llvmEqWordShape :: (1 <= w, KnownNat w) => prx w -> Integer -> - PermExpr (LLVMShapeType w) -llvmEqWordShape w i = - PExpr_FieldShape $ LLVMFieldShape $ ValPerm_Eq $ - PExpr_LLVMWord $ bvIntOfSize w i - --- | Existential permission @x:eq(word(e))@ for some @e@ -llvmExEqWord :: (1 <= w, KnownNat w) => prx w -> - Binding (BVType w) (ValuePerm (LLVMPointerType w)) -llvmExEqWord _ = nu $ \e -> ValPerm_Eq (PExpr_LLVMWord $ PExpr_Var e) - -{- --- | Create a field pointer permission with offset 0 and @eq(e)@ permissions --- with the given read-write modality -llvmFieldContents0Eq :: (1 <= w, KnownNat w) => - RWModality -> PermExpr (LLVMPointerType w) -> - LLVMPtrPerm w -llvmFieldContents0Eq rw e = - Perm_LLVMField $ LLVMFieldPerm { llvmFieldRW = rw, - llvmFieldOffset = bvInt 0, - llvmFieldContents = ValPerm_Eq e } --} - --- | Create a field permission to read a known value from offset 0 of an LLVM --- pointer using an existential modality, lifetime, and value -llvmPtr0EqEx :: (1 <= w, KnownNat w, 1 <= sz, KnownNat sz) => prx sz -> - Mb (RNil :> RWModalityType :> LifetimeType :> LLVMPointerType sz) - (LLVMFieldPerm w sz) -llvmPtr0EqEx _ = - nuMulti (MNil :>: Proxy :>: Proxy :>: Proxy) $ \(_ :>: rw :>: l :>: x) -> - LLVMFieldPerm { llvmFieldRW = PExpr_Var rw, - llvmFieldLifetime = PExpr_Var l, - llvmFieldOffset = bvInt 0, - llvmFieldContents = ValPerm_Eq (PExpr_Var x) } - --- | Create a permission to read a known value from offset 0 of an LLVM pointer --- using an existential modality, lifetime, and value, i.e., return the --- permission @exists rw,l,y.[l]ptr ((0,rw) |-> eq(y))@ -llvmPtr0EqExPerm :: (1 <= w, KnownNat w, 1 <= sz, KnownNat sz) => prx sz -> - Mb (RNil :> RWModalityType :> LifetimeType :> LLVMPointerType sz) - (ValuePerm (LLVMPointerType w)) -llvmPtr0EqExPerm = fmap (ValPerm_Conj1 . Perm_LLVMField) . llvmPtr0EqEx - --- | Create a permission to read a known value from offset 0 of an LLVM pointer --- in the given lifetime, i.e., return @exists y.[l]ptr ((0,R) |-> eq(e))@ -llvmRead0EqPerm :: (1 <= w, KnownNat w) => PermExpr LifetimeType -> - PermExpr (LLVMPointerType w) -> - ValuePerm (LLVMPointerType w) -llvmRead0EqPerm l e = - ValPerm_Conj [Perm_LLVMField $ - LLVMFieldPerm { llvmFieldRW = PExpr_Read, - llvmFieldLifetime = l, - llvmFieldOffset = bvInt 0, - llvmFieldContents = ValPerm_Eq e }] - --- | Create a field write permission with offset 0 and @true@ permissions of a --- given size -llvmSizedFieldWrite0True :: (1 <= w, KnownNat w, 1 <= sz, KnownNat sz) => - f1 w -> f2 sz -> LLVMFieldPerm w sz -llvmSizedFieldWrite0True _ _ = - LLVMFieldPerm { llvmFieldRW = PExpr_Write, - llvmFieldLifetime = PExpr_Always, - llvmFieldOffset = bvInt 0, - llvmFieldContents = ValPerm_True } - --- | Create a field write permission with offset 0 and @true@ permissions -llvmFieldWrite0True :: (1 <= w, KnownNat w) => LLVMFieldPerm w w -llvmFieldWrite0True = llvmSizedFieldWrite0True Proxy Proxy - --- | Create a field write permission with offset 0 and @true@ permissions -llvmWrite0TruePerm :: (1 <= w, KnownNat w) => ValuePerm (LLVMPointerType w) -llvmWrite0TruePerm = ValPerm_Conj [Perm_LLVMField llvmFieldWrite0True] - --- | Create a field write permission with offset 0 and an @eq(e)@ permission -llvmFieldWrite0Eq :: (1 <= w, KnownNat w) => PermExpr (LLVMPointerType w) -> - LLVMFieldPerm w w -llvmFieldWrite0Eq e = - LLVMFieldPerm { llvmFieldRW = PExpr_Write, - llvmFieldLifetime = PExpr_Always, - llvmFieldOffset = bvInt 0, - llvmFieldContents = ValPerm_Eq e } - --- | Create a field write permission with offset 0 and an @eq(e)@ permission -llvmWrite0EqPerm :: (1 <= w, KnownNat w) => PermExpr (LLVMPointerType w) -> - ValuePerm (LLVMPointerType w) -llvmWrite0EqPerm e = ValPerm_Conj [Perm_LLVMField $ llvmFieldWrite0Eq e] - --- | Create a field write permission with offset @e@ and lifetime @l@ -llvmFieldWriteTrueL :: (1 <= w, KnownNat w, 1 <= sz, KnownNat sz) => - prx sz -> PermExpr (BVType w) -> - PermExpr LifetimeType -> LLVMFieldPerm w sz -llvmFieldWriteTrueL _ off l = - LLVMFieldPerm { llvmFieldRW = PExpr_Write, - llvmFieldLifetime = l, - llvmFieldOffset = off, - llvmFieldContents = ValPerm_True } - --- | Create a field write permission with offset @e@ and an existential lifetime -llvmWriteTrueExLPerm :: (1 <= w, KnownNat w, 1 <= sz, KnownNat sz) => - prx sz -> PermExpr (BVType w) -> - Binding LifetimeType (ValuePerm (LLVMPointerType w)) -llvmWriteTrueExLPerm sz off = - nu $ \l -> - ValPerm_Conj1 $ Perm_LLVMField $ llvmFieldWriteTrueL sz off (PExpr_Var l) - --- | Create a field permission with offset @e@ and existential lifetime and rw -llvmReadExRWExLPerm :: (1 <= w, KnownNat w) => PermExpr (BVType w) -> - Mb (RNil :> RWModalityType :> LifetimeType) - (ValuePerm (LLVMPointerType w)) -llvmReadExRWExLPerm (off :: PermExpr (BVType w)) = - nuMulti (MNil :>: Proxy :>: Proxy) $ \(_ :>: rw :>: l) -> - ValPerm_Conj1 $ Perm_LLVMField @w @w $ - LLVMFieldPerm { llvmFieldRW = PExpr_Var rw, - llvmFieldLifetime = PExpr_Var l, - llvmFieldOffset = off, - llvmFieldContents = ValPerm_True } - --- | Add a bitvector expression to the offset of a field permission -llvmFieldAddOffset :: (1 <= w, KnownNat w) => LLVMFieldPerm w sz -> - PermExpr (BVType w) -> LLVMFieldPerm w sz -llvmFieldAddOffset fp off = - fp { llvmFieldOffset = bvAdd (llvmFieldOffset fp) off } - --- | Add an integer to the offset of a field permission -llvmFieldAddOffsetInt :: (1 <= w, KnownNat w) => LLVMFieldPerm w sz -> - Integer -> LLVMFieldPerm w sz -llvmFieldAddOffsetInt fp off = llvmFieldAddOffset fp (bvInt off) - --- | Set the contents of a field permission, possibly changing its size -llvmFieldSetContents :: LLVMFieldPerm w sz1 -> - ValuePerm (LLVMPointerType sz2) -> LLVMFieldPerm w sz2 -llvmFieldSetContents (LLVMFieldPerm {..}) p = - LLVMFieldPerm { llvmFieldContents = p, .. } - --- | Set the contents of a field permission to an @eq(llvmword(e))@ permission -llvmFieldSetEqWord :: (1 <= sz2, KnownNat sz2) => LLVMFieldPerm w sz1 -> - PermExpr (BVType sz2) -> LLVMFieldPerm w sz2 -llvmFieldSetEqWord fp e = - llvmFieldSetContents fp (ValPerm_Eq $ PExpr_LLVMWord e) - --- | Set the contents of a field permission to an @eq(y)@ permission -llvmFieldSetEqVar :: (1 <= sz2, KnownNat sz2) => LLVMFieldPerm w sz1 -> - ExprVar (LLVMPointerType sz2) -> LLVMFieldPerm w sz2 -llvmFieldSetEqVar fp y = - llvmFieldSetContents fp (ValPerm_Eq $ PExpr_Var y) - --- | Set the contents of a field permission to an @eq(llvmword(y))@ permission -llvmFieldSetEqWordVar :: (1 <= sz2, KnownNat sz2) => LLVMFieldPerm w sz1 -> - ExprVar (BVType sz2) -> LLVMFieldPerm w sz2 -llvmFieldSetEqWordVar fp y = - llvmFieldSetContents fp (ValPerm_Eq $ PExpr_LLVMWord $ PExpr_Var y) - --- | Set the contents of a field permission to an @true@ permission of a --- specific size -llvmFieldSetTrue :: (1 <= sz2, KnownNat sz2) => LLVMFieldPerm w sz1 -> - f sz2 -> LLVMFieldPerm w sz2 -llvmFieldSetTrue fp _ = llvmFieldSetContents fp ValPerm_True - --- | Convert a field permission to a block permission -llvmFieldPermToBlock :: (1 <= w, KnownNat w, 1 <= sz, KnownNat sz) => - LLVMFieldPerm w sz -> LLVMBlockPerm w -llvmFieldPermToBlock fp = - LLVMBlockPerm - { llvmBlockRW = llvmFieldRW fp, - llvmBlockLifetime = llvmFieldLifetime fp, - llvmBlockOffset = llvmFieldOffset 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 - --- | Get the range of bytes described by an array permisison. Note that these --- bytes may not currently be *in* the array permission, if it has any borrows. -llvmArrayRange :: (1 <= w, KnownNat w) => LLVMArrayPerm w -> BVRange w -llvmArrayRange fp = - BVRange (llvmArrayOffset fp) (llvmArrayLengthBytes fp) - --- | 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 = 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) = llvmArrayPermToBlock ap -llvmAtomicPermToBlock (Perm_LLVMBlock bp) = Just bp -llvmAtomicPermToBlock _ = Nothing - --- | Convert an atomic permission to several @memblocks@, if possible -llvmAtomicPermToBlocks :: AtomicPerm (LLVMPointerType w) -> - Maybe [LLVMBlockPerm w] -llvmAtomicPermToBlocks (Perm_LLVMArray ap) = llvmArrayToBlocks ap -llvmAtomicPermToBlocks p = pure <$> llvmAtomicPermToBlock p - --- | Convert an atomic permission whose type is unknown to a @memblock@, if --- possible, along with a proof that its type is a valid llvm pointer type -llvmAtomicPermToSomeBlock :: AtomicPerm a -> Maybe (SomeLLVMBlockPerm a) -llvmAtomicPermToSomeBlock p@(Perm_LLVMField _) = - SomeLLVMBlockPerm <$> llvmAtomicPermToBlock p -llvmAtomicPermToSomeBlock p@(Perm_LLVMArray _) = - SomeLLVMBlockPerm <$> llvmAtomicPermToBlock p -llvmAtomicPermToSomeBlock (Perm_LLVMBlock bp) = - Just $ SomeLLVMBlockPerm $ bp -llvmAtomicPermToSomeBlock _ = Nothing - --- | Get the lifetime of an atomic perm if it is a field, array, or memblock -atomicPermLifetime :: AtomicPerm a -> Maybe (PermExpr LifetimeType) -atomicPermLifetime (Perm_LLVMField fp) = Just $ llvmFieldLifetime fp -atomicPermLifetime (Perm_LLVMArray ap) = Just $ llvmArrayLifetime ap -atomicPermLifetime (Perm_LLVMBlock bp) = Just $ llvmBlockLifetime bp -atomicPermLifetime _ = Nothing - --- | Get the modality of an atomic perm if it is a field, array, or memblock -atomicPermModality :: AtomicPerm a -> Maybe (PermExpr RWModalityType) -atomicPermModality (Perm_LLVMField fp) = Just $ llvmFieldRW fp -atomicPermModality (Perm_LLVMArray ap) = Just $ llvmArrayRW ap -atomicPermModality (Perm_LLVMBlock bp) = Just $ llvmBlockRW bp -atomicPermModality _ = Nothing - --- | Get the starting offset of an atomic permission, if it has one. This --- includes array permissions which may have some cells borrowed. -llvmAtomicPermOffset :: AtomicPerm (LLVMPointerType w) -> - Maybe (PermExpr (BVType w)) -llvmAtomicPermOffset (Perm_LLVMField fp) = Just $ llvmFieldOffset fp -llvmAtomicPermOffset (Perm_LLVMArray ap) = Just $ llvmArrayOffset ap -llvmAtomicPermOffset (Perm_LLVMBlock bp) = Just $ llvmBlockOffset bp -llvmAtomicPermOffset _ = Nothing - --- | Get the length of an atomic permission, if it has one. This includes array --- permissions which may have some cells borrowed. -llvmAtomicPermLen :: AtomicPerm (LLVMPointerType w) -> - Maybe (PermExpr (BVType w)) -llvmAtomicPermLen (Perm_LLVMField fp) = Just $ llvmFieldLen fp -llvmAtomicPermLen (Perm_LLVMArray ap) = Just $ llvmArrayLengthBytes ap -llvmAtomicPermLen (Perm_LLVMBlock bp) = Just $ llvmBlockLen bp -llvmAtomicPermLen _ = Nothing - --- | Get the ending offset of an atomic permission, if it has one. This --- includes array permissions which may have some cells borrowed. -llvmAtomicPermEndOffset :: (1 <= w, KnownNat w) => - AtomicPerm (LLVMPointerType w) -> - Maybe (PermExpr (BVType w)) -llvmAtomicPermEndOffset p = - bvAdd <$> llvmAtomicPermOffset p <*> llvmAtomicPermLen p - --- | Get the range of offsets of an atomic permission, if it has one. Note that --- arrays with borrows do not have a well-defined range. -llvmAtomicPermRange :: AtomicPerm (LLVMPointerType w) -> Maybe (BVRange w) -llvmAtomicPermRange p = fmap llvmBlockRange $ llvmAtomicPermToBlock p - --- | Test if an LLVM atomic permission contains some range of offsets that have --- an array shape -llvmPermContainsArray :: AtomicPerm (LLVMPointerType w) -> Bool -llvmPermContainsArray (Perm_LLVMArray _) = True -llvmPermContainsArray (Perm_LLVMBlock bp) = - shapeContainsArray $ llvmBlockShape bp where - shapeContainsArray :: PermExpr (LLVMShapeType w) -> Bool - shapeContainsArray (PExpr_ArrayShape _ _ _) = True - shapeContainsArray (PExpr_SeqShape sh1 sh2) = - shapeContainsArray sh1 || shapeContainsArray sh2 - shapeContainsArray (PExpr_TupShape sh) = shapeContainsArray sh - shapeContainsArray _ = False -llvmPermContainsArray _ = False - --- | 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) -llvmBlockEndOffset = bvRangeEnd . llvmBlockRange - --- | Return the length in bytes of an 'LLVMFieldShape' -llvmFieldShapeLength :: LLVMFieldShape w -> Integer -llvmFieldShapeLength (LLVMFieldShape p) = exprLLVMTypeBytes p - --- | Simplify a shape, removing any trailing empty shapes and unfolding any --- unfoldable named shapes -simplifyShape :: PermExpr (LLVMShapeType w) -> PermExpr (LLVMShapeType w) -simplifyShape (PExpr_SeqShape sh PExpr_EmptyShape) = simplifyShape sh -simplifyShape (PExpr_NamedShape rw l nmsh args) - | TrueRepr <- namedShapeCanUnfoldRepr nmsh - , Just sh <- unfoldModalizeNamedShape rw l nmsh args = - simplifyShape sh -simplifyShape sh = sh - --- | Test if a shape describes a pointer -isLLVMPointerShape :: PermExpr (LLVMShapeType w) -> Bool -isLLVMPointerShape (PExpr_FieldShape (LLVMFieldShape (ValPerm_Conj1 p))) = - isLLVMPointerPerm p -isLLVMPointerShape (PExpr_PtrShape _ _ _) = True -isLLVMPointerShape _ = False - --- | Find any shapes of the form @fieldsh(eq(y))@ in a shape and return the @y@ --- variables -findEqVarFieldsInShape :: PermExpr (LLVMShapeType w) -> NameSet CrucibleType -findEqVarFieldsInShape sh = - runReader (findEqVarFieldsInShapeH sh) Set.empty - --- | Find any shapes of the form @fieldsh(eq(y))@ in a shape and return the @y@ --- variables, using the supplied 'Set' to indicate recursive named shapes that --- have already been unfolded to get the current shape, to avoid infinite loops -findEqVarFieldsInShapeH :: PermExpr (LLVMShapeType w) -> - Reader (Set String) (NameSet CrucibleType) -findEqVarFieldsInShapeH (PExpr_NamedShape _ _ nmsh args) - | DefinedShapeBody _ <- namedShapeBody nmsh = - -- NOTE: we don't need to modalize the unfolding because that doesn't change - -- the variable fields - findEqVarFieldsInShapeH (unfoldNamedShape nmsh args) -findEqVarFieldsInShapeH (PExpr_NamedShape _ _ nmsh args) - | RecShapeBody _ _ _ <- namedShapeBody nmsh = - do seen_names <- ask - if Set.member (namedShapeName nmsh) seen_names then - return NameSet.empty - else - -- NOTE: we don't need to modalize the unfolding because that doesn't - -- change the variable fields - local (Set.insert (namedShapeName nmsh)) $ - findEqVarFieldsInShapeH (unfoldNamedShape nmsh args) -findEqVarFieldsInShapeH (PExpr_PtrShape _ _ sh) = findEqVarFieldsInShapeH sh -findEqVarFieldsInShapeH (PExpr_FieldShape (LLVMFieldShape - (ValPerm_Eq (PExpr_Var y)))) = - return $ NameSet.singleton y -findEqVarFieldsInShapeH (PExpr_FieldShape _) = return $ NameSet.empty -findEqVarFieldsInShapeH (PExpr_ArrayShape _ _ sh) = findEqVarFieldsInShapeH sh -findEqVarFieldsInShapeH (PExpr_TupShape sh) = findEqVarFieldsInShapeH sh -findEqVarFieldsInShapeH (PExpr_SeqShape sh1 sh2) = - NameSet.union <$> findEqVarFieldsInShapeH sh1 <*> findEqVarFieldsInShapeH sh2 -findEqVarFieldsInShapeH (PExpr_OrShape sh1 sh2) = - NameSet.union <$> findEqVarFieldsInShapeH sh1 <*> findEqVarFieldsInShapeH sh2 -findEqVarFieldsInShapeH (PExpr_ExShape mb_sh) = - fmap NameSet.liftNameSet $ strongMbM $ - fmap findEqVarFieldsInShapeH mb_sh -findEqVarFieldsInShapeH _ = return $ NameSet.empty - --- | Return the expression for the length of a shape if there is one -llvmShapeLength :: (1 <= w, KnownNat w) => PermExpr (LLVMShapeType w) -> - Maybe (PermExpr (BVType w)) -llvmShapeLength (PExpr_Var _) = Nothing -llvmShapeLength PExpr_EmptyShape = Just $ bvInt 0 -llvmShapeLength (PExpr_NamedShape _ _ nmsh@(NamedShape _ _ - (DefinedShapeBody _)) args) = - llvmShapeLength (unfoldNamedShape nmsh args) -llvmShapeLength (PExpr_NamedShape _ _ (NamedShape _ _ - (OpaqueShapeBody mb_len _ _)) args) = - Just $ subst (substOfExprs args) mb_len -llvmShapeLength (PExpr_NamedShape _ _ nmsh@(NamedShape _ _ - (RecShapeBody _ _ _)) args) = - -- FIXME: if the recursive shape contains itself *not* under a pointer, then - -- this could diverge - llvmShapeLength (unfoldNamedShape nmsh args) -llvmShapeLength (PExpr_EqShape len _) = Just len -llvmShapeLength (PExpr_PtrShape _ _ sh) - | w <- shapeLLVMTypeWidth sh - = Just $ bvInt (intValue w `ceil_div` 8) -llvmShapeLength (PExpr_FieldShape fsh) = - Just $ bvInt $ llvmFieldShapeLength fsh -llvmShapeLength (PExpr_ArrayShape len stride _) = Just $ bvMult stride len -llvmShapeLength (PExpr_TupShape sh) = llvmShapeLength sh -llvmShapeLength (PExpr_SeqShape sh1 sh2) = - liftA2 bvAdd (llvmShapeLength sh1) (llvmShapeLength sh2) -llvmShapeLength (PExpr_OrShape sh1 sh2) = - -- We cannot represent a max expression, so we have to statically know which - -- shape is bigger in order to compute the length of an or shape - do len1 <- llvmShapeLength sh1 - len2 <- llvmShapeLength sh2 - if (bvLeq len1 len2) then return len2 else - if (bvLeq len2 len1) then return len1 - else Nothing -llvmShapeLength (PExpr_ExShape mb_sh) = - -- The length of an existential cannot depend on the existential variable, or - -- we cannot return it - case mbMatch $ fmap llvmShapeLength mb_sh of - [nuMP| Just mb_len |] -> - partialSubst (emptyPSubst (MNil :>: Proxy)) mb_len - _ -> Nothing -llvmShapeLength PExpr_FalseShape = Just $ bvInt 0 - --- | Adjust the read/write and lifetime modalities of a block permission by --- setting those modalities that are supplied as arguments -llvmBlockAdjustModalities :: Maybe (PermExpr RWModalityType) -> - Maybe (PermExpr LifetimeType) -> - LLVMBlockPerm w -> LLVMBlockPerm w -llvmBlockAdjustModalities maybe_rw maybe_l bp = - let rw = maybe (llvmBlockRW bp) id maybe_rw - l = maybe (llvmBlockLifetime bp) id maybe_l in - bp { llvmBlockRW = rw, llvmBlockLifetime = l } - --- | Convert a block permission of pointer shape to the block permission of --- field shape that it represents. That is, convert the block permission --- --- > [l]memblock(rw,off,w/8,[l2]ptrsh(rw2,sh)) --- --- to --- --- > [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)@ -llvmReadBlockOfShape :: (1 <= w, KnownNat w) => PermExpr (LLVMShapeType w) -> - LLVMBlockPerm w -llvmReadBlockOfShape sh - | Just len <- llvmShapeLength sh = - LLVMBlockPerm { llvmBlockRW = PExpr_Read, - llvmBlockLifetime = PExpr_Always, - llvmBlockOffset = bvInt 0, - llvmBlockLen = len, - llvmBlockShape = sh } -llvmReadBlockOfShape _ = - error "llvmReadBlockOfShape: shape without known length" - --- | Test if an LLVM shape is a sequence of field shapes, and if so, return that --- sequence -matchLLVMFieldShapeSeq :: (1 <= w, KnownNat w) => PermExpr (LLVMShapeType w) -> - Maybe [LLVMFieldShape w] -matchLLVMFieldShapeSeq (PExpr_FieldShape fsh) = Just [fsh] -matchLLVMFieldShapeSeq (PExpr_SeqShape sh1 sh2) = - (++) <$> matchLLVMFieldShapeSeq sh1 <*> matchLLVMFieldShapeSeq sh2 -matchLLVMFieldShapeSeq _ = Nothing - --- | Get all the top-level ranges of offsets potentially covered by a permission --- in any of its disjunctive branches -class GetOffsets f where - getOffsets :: f a -> [MbRangeForType a] - -instance GetOffsets ValuePerm where - getOffsets (ValPerm_Eq _) = [] - getOffsets (ValPerm_Or p1 p2) = getOffsets p1 ++ getOffsets p2 - getOffsets (ValPerm_Exists mb_p) = - map (mbMbRangeForType knownRepr) $ - mbList $ fmap getOffsets mb_p - getOffsets (ValPerm_Named _ _ _) = [] - getOffsets (ValPerm_Var _ _) = [] - getOffsets (ValPerm_Conj ps) = concatMap getOffsets ps - getOffsets ValPerm_False = [] - -instance GetOffsets AtomicPerm where - getOffsets (Perm_LLVMField fp) = - [rangeForLLVMType - (llvmFieldRW fp) (llvmFieldLifetime fp) (llvmFieldRange fp)] - getOffsets (Perm_LLVMArray ap) = - [rangeForLLVMType - (llvmArrayRW ap) (llvmArrayLifetime ap) (llvmArrayRange ap)] - getOffsets (Perm_LLVMBlock bp) = - [rangeForLLVMType - (llvmBlockRW bp) (llvmBlockLifetime bp) (llvmBlockRange bp)] - getOffsets _ = [] - --- | Get the range of offsets potentially covered by a permission in a binding -mbGetOffsets :: GetOffsets f => CruCtx ctx -> Mb ctx (f a) -> [MbRangeForType a] -mbGetOffsets ctx = - map (mbMbRangeForType ctx) . mbList . mbMapCl $(mkClosed [| getOffsets |]) - --- | Add the given read/write and lifetime modalities to all top-level pointer --- permissions or shapes in a permission or shape. Top-level here means we do --- not recurse inside pointer shapes, as pointer shape modalities also apply --- recursively to the contained shapes. If there are any top-level variables in --- the permission or shape, then this fails, since there is no way to modalize a --- variable. --- --- The high-level idea here is that pointer shapes take on the read/write and --- lifetime modalities of the @memblock@ permission containing them, and --- 'modalize' folds these modalities into the shape itself. This is also used to --- compute the least version of a permission when building @lowned@ permissions. -class Modalize a where - modalize :: Maybe (PermExpr RWModalityType) -> - Maybe (PermExpr LifetimeType) -> - a -> Maybe a - -instance Modalize (PermExpr (LLVMShapeType w)) where - modalize Nothing Nothing sh = - -- If neither modality is given, it is a no-op - Just sh - modalize _ _ (PExpr_Var _) = - -- Variables cannot be modalized; NOTE: we could fix this if necessary by - -- adding a modalized variable shape constructor - Nothing - modalize _ _ PExpr_EmptyShape = Just PExpr_EmptyShape - modalize _ _ sh@(PExpr_NamedShape _ _ nmsh _) - | not (namedShapeCanUnfold nmsh) = - -- Opaque shapes are not affected by modalization, because we assume they do - -- not have any top-level pointers in them - Just sh - modalize rw l (PExpr_NamedShape rw' l' nmsh args) = - -- If a named shape already has modalities, they take precedence - Just $ PExpr_NamedShape (rw' <|> rw) (l' <|> l) nmsh args - modalize _ _ sh@(PExpr_EqShape _ _) = Just sh - modalize rw l (PExpr_PtrShape rw' l' sh) = - -- If a pointer shape already has modalities, they take precedence - Just $ PExpr_PtrShape (rw' <|> rw) (l' <|> l) sh - modalize _ _ sh@(PExpr_FieldShape _) = Just sh - modalize _ _ sh@(PExpr_ArrayShape _ _ _) = Just sh - modalize rw l (PExpr_TupShape sh) = PExpr_TupShape <$> modalize rw l sh - modalize rw l (PExpr_SeqShape sh1 sh2) = - PExpr_SeqShape <$> modalize rw l sh1 <*> modalize rw l sh2 - modalize rw l (PExpr_OrShape sh1 sh2) = - PExpr_OrShape <$> modalize rw l sh1 <*> modalize rw l sh2 - modalize rw l (PExpr_ExShape mb_sh) = - PExpr_ExShape <$> mbM (fmap (modalize rw l) mb_sh) - modalize _ _ PExpr_FalseShape = Just PExpr_FalseShape - -instance Modalize (ValuePerm a) where - modalize _ _ p@(ValPerm_Eq _) = Just p - modalize rw l (ValPerm_Or p1 p2) = - ValPerm_Or <$> modalize rw l p1 <*> modalize rw l p2 - modalize rw l (ValPerm_Exists mb_p) = - fmap ValPerm_Exists $ mbMaybe $ fmap (modalize rw l) mb_p - modalize _ _ (ValPerm_Named _ _ _) = - -- Cannot modalize an arbitrary opaque named permission; this would require - -- special-purpose modality arguments to every opaque named permission, so - -- we could be sure that changing these would modalize its unfolding - Nothing - modalize _ _ (ValPerm_Var _ _) = Nothing - modalize rw l (ValPerm_Conj ps) = ValPerm_Conj <$> mapM (modalize rw l) ps - modalize _ _ ValPerm_False = Just ValPerm_False - -instance Modalize (AtomicPerm a) where - modalize rw l (Perm_LLVMField fp) = - Just $ Perm_LLVMField $ - fp { llvmFieldRW = fromMaybe (llvmFieldRW fp) rw, - llvmFieldLifetime = fromMaybe (llvmFieldLifetime fp) l } - modalize rw l (Perm_LLVMArray ap) = - Just $ Perm_LLVMArray $ - ap { llvmArrayRW = fromMaybe (llvmArrayRW ap) rw, - llvmArrayLifetime = fromMaybe (llvmArrayLifetime ap) l } - modalize rw l (Perm_LLVMBlock bp) = - Just $ Perm_LLVMBlock $ - bp { llvmBlockRW = fromMaybe (llvmBlockRW bp) rw, - llvmBlockLifetime = fromMaybe (llvmBlockLifetime bp) l } - modalize _ _ p@(Perm_LLVMFree _) = Just p - modalize _ _ p@(Perm_LLVMFunPtr _ _) = Just p - modalize rw l (Perm_LLVMBlockShape sh) = - Perm_LLVMBlockShape <$> modalize rw l sh - modalize _ _ p@(Perm_IsLLVMPtr) = Just p - modalize _ _ p@(Perm_NamedConj _ _ _) = Just p - modalize _ _ p@(Perm_LLVMFrame _) = Just p - modalize _ _ p@(Perm_LOwned _ _ _ _ _) = Just p - modalize _ _ p@(Perm_LOwnedSimple _ _) = Just p - modalize _ _ p@(Perm_LCurrent _) = Just p - modalize _ _ p@(Perm_LFinished) = Just p - modalize rw l (Perm_Struct ps) = - Perm_Struct <$> traverseRAssign (modalize rw l) ps - modalize _ _ p@(Perm_Fun _) = Just p - modalize _ _ p@(Perm_BVProp _) = Just p - modalize _ _ p@Perm_Any = Just p - -instance Modalize (ExprAndPerm a) where - modalize rw l (ExprAndPerm e p) = - ExprAndPerm e <$> modalize rw l p - -instance Modalize (ExprPerms ctx) where - modalize rw l perms = traverseRAssign (modalize rw l) perms - - --- | Apply 'modalize' to the shape of a block permission, using the --- modalities of that block permission, raising an error if 'modalize' --- cannot be applied -modalizeBlockShape :: LLVMBlockPerm w -> PermExpr (LLVMShapeType w) -modalizeBlockShape (LLVMBlockPerm {..}) = - maybe (error "modalizeBlockShape") id $ - modalize (Just llvmBlockRW) (Just llvmBlockLifetime) llvmBlockShape - --- | Convert an 'ExprPerms' list @ps@ to the input permission list @[l](R)ps@ --- used in a simple @lowned@ permission -lownedPermsSimpleIn :: ExprVar LifetimeType -> ExprPerms ps -> - Maybe (ExprPerms ps) -lownedPermsSimpleIn l = modalize (Just PExpr_Read) (Just $ PExpr_Var l) - -instance Functor SomeTypedMb where - fmap f (SomeTypedMb ctx mb_a) = SomeTypedMb ctx (fmap f mb_a) - -instance Applicative SomeTypedMb where - pure a = SomeTypedMb CruCtxNil $ emptyMb a - liftA2 f (SomeTypedMb ctx1 mb_a1) (SomeTypedMb ctx2 mb_a2) = - SomeTypedMb (appendCruCtx ctx1 ctx2) $ - mbCombine (cruCtxProxies ctx2) $ - flip fmap mb_a1 $ \a1 -> flip fmap mb_a2 $ \a2 -> f a1 a2 - --- | Commute a 'SomeTypedMb' out of a name-binding -mbSomeTypedMb :: NuMatching a => Mb ctx (SomeTypedMb a) -> - SomeTypedMb (Mb ctx a) -mbSomeTypedMb (mbMatch -> [nuMP| SomeTypedMb ctx mb_a |]) = - SomeTypedMb (mbLift ctx) $ mbSwap (cruCtxProxies $ mbLift ctx) mb_a - --- | Generic function to abstract all the read/write and lifetime modalities in --- a permission -class AbstractModalities a where - abstractModalities :: a -> SomeTypedMb a - -instance (NuMatching a, AbstractModalities a) => - AbstractModalities (Mb ctx a) where - abstractModalities mb_a = mbSomeTypedMb $ fmap abstractModalities mb_a - -instance AbstractModalities (ExprAndPerm a) where - abstractModalities (ExprAndPerm e p) = - ExprAndPerm e <$> abstractModalities p - -instance AbstractModalities (RAssign ExprAndPerm a) where - abstractModalities MNil = pure MNil - abstractModalities (eps :>: ep) = - (:>:) <$> abstractModalities eps <*> abstractModalities ep - -instance AbstractModalities (ValuePerm a) where - abstractModalities p@(ValPerm_Eq _) = pure p - abstractModalities (ValPerm_Or p1 p2) = - ValPerm_Or <$> abstractModalities p1 <*> abstractModalities p2 - abstractModalities (ValPerm_Exists mb_p) = - ValPerm_Exists <$> abstractModalities mb_p - abstractModalities p@(ValPerm_Named _ _ _) = - -- Cannot abstract modalities out of an arbitrary named permission; this - -- would require special-purpose modality arguments to every named - -- permission, so we could be sure that abstract these would abstract its - -- unfolding - pure p - abstractModalities p@(ValPerm_Var _ _) = pure p - abstractModalities (ValPerm_Conj ps) = - ValPerm_Conj <$> traverse abstractModalities ps - abstractModalities ValPerm_False = pure ValPerm_False - -instance AbstractModalities (AtomicPerm a) where - abstractModalities (Perm_LLVMField fp) = - SomeTypedMb knownRepr $ - nuMulti (MNil :>: Proxy :>: Proxy) $ \(_ :>: rw :>: l) -> - Perm_LLVMField $ fp { llvmFieldRW = PExpr_Var rw, - llvmFieldLifetime = PExpr_Var l } - abstractModalities (Perm_LLVMArray fp) = - SomeTypedMb knownRepr $ - nuMulti (MNil :>: Proxy :>: Proxy) $ \(_ :>: rw :>: l) -> - Perm_LLVMArray $ fp { llvmArrayRW = PExpr_Var rw, - llvmArrayLifetime = PExpr_Var l } - abstractModalities (Perm_LLVMBlock fp) = - SomeTypedMb knownRepr $ - nuMulti (MNil :>: Proxy :>: Proxy) $ \(_ :>: rw :>: l) -> - Perm_LLVMBlock $ fp { llvmBlockRW = PExpr_Var rw, - llvmBlockLifetime = PExpr_Var l } - abstractModalities p@(Perm_LLVMFree _) = pure p - abstractModalities p@(Perm_LLVMFunPtr _ _) = pure p - abstractModalities p@(Perm_LLVMBlockShape _) = pure p - abstractModalities p@(Perm_IsLLVMPtr) = pure p - abstractModalities p@(Perm_NamedConj _ _ _) = pure p - abstractModalities p@(Perm_LLVMFrame _) = pure p - abstractModalities p@(Perm_LOwned _ _ _ _ _) = pure p - abstractModalities p@(Perm_LOwnedSimple _ _) = pure p - abstractModalities p@(Perm_LCurrent _) = pure p - abstractModalities p@(Perm_LFinished) = pure p - abstractModalities (Perm_Struct ps) = - Perm_Struct <$> traverseRAssign abstractModalities ps - abstractModalities p@(Perm_Fun _) = pure p - abstractModalities p@(Perm_BVProp _) = pure p - abstractModalities p@Perm_Any = pure p - - --- | Extract the shape-in-bindings for an unfoldable shape -namedShapeBodyShape :: KnownNat w => NamedShape 'True args w -> - Mb args (PermExpr (LLVMShapeType w)) -namedShapeBodyShape (NamedShape _ _ (DefinedShapeBody mb_sh)) = mb_sh -namedShapeBodyShape sh@(NamedShape _ _ (RecShapeBody mb_sh _ _)) = - let (prxs :>: _) = mbToProxy mb_sh in - nuMulti prxs $ \ns -> - subst (substOfExprs (namesToExprs ns :>: - PExpr_NamedShape Nothing Nothing sh (namesToExprs ns))) - mb_sh - --- | Unfold a named shape -unfoldNamedShape :: KnownNat w => NamedShape 'True args w -> PermExprs args -> - PermExpr (LLVMShapeType w) -unfoldNamedShape (NamedShape _ _ (DefinedShapeBody mb_sh)) args = - subst (substOfExprs args) mb_sh -unfoldNamedShape sh@(NamedShape _ _ (RecShapeBody mb_sh _ _)) args = - subst (substOfExprs (args :>: PExpr_NamedShape Nothing Nothing sh args)) mb_sh - --- | Unfold a named shape and apply 'modalize' to the result -unfoldModalizeNamedShape :: KnownNat w => Maybe (PermExpr RWModalityType) -> - Maybe (PermExpr LifetimeType) -> - NamedShape 'True args w -> PermExprs args -> - Maybe (PermExpr (LLVMShapeType w)) -unfoldModalizeNamedShape rw l nmsh args = - modalize rw l $ unfoldNamedShape nmsh args - --- | Unfold the shape of a block permission using 'unfoldModalizeNamedShape' if --- it has a named shape -unfoldModalizeNamedShapeBlock :: KnownNat w => LLVMBlockPerm w -> - Maybe (LLVMBlockPerm w) -unfoldModalizeNamedShapeBlock bp - | PExpr_NamedShape rw l nmsh args <- llvmBlockShape bp - , TrueRepr <- namedShapeCanUnfoldRepr nmsh - , Just sh' <- unfoldModalizeNamedShape rw l nmsh args = - Just (bp { llvmBlockShape = sh' }) -unfoldModalizeNamedShapeBlock _ = Nothing - --- | Unfold the shape of a block permission in a binding using --- 'unfoldModalizeNamedShape' if it has a named shape -mbUnfoldModalizeNamedShapeBlock :: KnownNat w => Mb ctx (LLVMBlockPerm w) -> - Maybe (Mb ctx (LLVMBlockPerm w)) -mbUnfoldModalizeNamedShapeBlock = - mbMaybe . mbMapCl $(mkClosed [| unfoldModalizeNamedShapeBlock |]) - --- | Change the shape of a disjunctive block to either its left or right --- disjunct, depending on whether the supplied 'Bool' is 'True' or 'False' -disjBlockToSubShape :: Bool -> LLVMBlockPerm w -> LLVMBlockPerm w -disjBlockToSubShape flag bp - | PExpr_OrShape sh1 sh2 <- llvmBlockShape bp = - bp { llvmBlockShape = if flag then sh1 else sh2 } -disjBlockToSubShape _ _ = error "disjBlockToSubShape" - --- | Change the shape of a disjunctive block in a binding to either its left or --- right disjunct, depending on whether the supplied 'Bool' is 'True' or 'False' -mbDisjBlockToSubShape :: Bool -> Mb ctx (LLVMBlockPerm w) -> - Mb ctx (LLVMBlockPerm w) -mbDisjBlockToSubShape flag = - mbMapCl ($(mkClosed [| disjBlockToSubShape |]) `clApply` toClosed flag) - --- | Match an existential shape with the given bidning type -matchExShape :: TypeRepr a -> PermExpr (LLVMShapeType w) -> - Maybe (Binding a (PermExpr (LLVMShapeType w))) -matchExShape a (PExpr_ExShape (mb_sh :: Binding b (PermExpr (LLVMShapeType w)))) - | Just Refl <- testEquality a (knownRepr :: TypeRepr b) = - Just mb_sh -matchExShape _ _ = Nothing - --- | Change the shape of an existential block to the body of its existential -exBlockToSubShape :: TypeRepr a -> LLVMBlockPerm w -> - Binding a (LLVMBlockPerm w) -exBlockToSubShape a bp - | Just mb_sh <- matchExShape a $ llvmBlockShape bp = - -- NOTE: even when exBlockToSubShape is called inside a binding as part of - -- mbExBlockToSubShape, the existential binding will probably be a fresh - -- function instead of a fresh pair, because it itself has not been - -- mbMatched, so this fmap shouldn't be re-subsituting names - fmap (\sh -> bp { llvmBlockShape = sh }) mb_sh -exBlockToSubShape _ _ = error "exBlockToSubShape" - --- | Change the shape of an existential block in a binding to the body of its --- existential -mbExBlockToSubShape :: TypeRepr a -> Mb ctx (LLVMBlockPerm w) -> - Mb (ctx :> a) (LLVMBlockPerm w) -mbExBlockToSubShape a = - mbCombine RL.typeCtxProxies . - mbMapCl ($(mkClosed [| exBlockToSubShape |]) `clApply` toClosed a) - --- | Split a block permission into portions that are before and after a given --- offset, if possible, assuming the offset is in the block permission. The --- supplied function provides a partial substitution from variables of --- 'LLVMBlockType' to their shapes, in order to split @eqsh@ shapes. -splitLLVMBlockPerm :: - (1 <= w, KnownNat w) => - (ExprVar (LLVMBlockType w) -> Maybe (PermExpr (LLVMShapeType w))) -> - PermExpr (BVType w) -> LLVMBlockPerm w -> - Maybe (LLVMBlockPerm w, LLVMBlockPerm w) -splitLLVMBlockPerm _ off bp - | bvEq off (llvmBlockOffset bp) - = Just (bp { llvmBlockLen = bvInt 0, llvmBlockShape = PExpr_EmptyShape }, - bp) -splitLLVMBlockPerm _ off bp@(llvmBlockShape -> PExpr_EmptyShape) = - Just (bp { llvmBlockLen = bvSub off (llvmBlockOffset bp) }, - bp { llvmBlockOffset = off, - llvmBlockLen = bvSub (llvmBlockEndOffset bp) off }) -splitLLVMBlockPerm blsubst off bp@(LLVMBlockPerm { llvmBlockShape = sh }) - | Just sh_len <- llvmShapeLength sh - , bvLt sh_len (bvSub off (llvmBlockOffset bp)) = - -- If we are splitting after the end of the natural length of a shape, then - -- pad out the block permission to its natural length and fall back to the - -- sequence shape case below - splitLLVMBlockPerm blsubst off (bp { llvmBlockShape = - PExpr_SeqShape sh PExpr_EmptyShape }) -splitLLVMBlockPerm _ _ (llvmBlockShape -> PExpr_Var _) = Nothing -splitLLVMBlockPerm blsubst off bp@(llvmBlockShape -> - PExpr_NamedShape maybe_rw maybe_l nmsh args) - | TrueRepr <- namedShapeCanUnfoldRepr nmsh - , Just sh' <- unfoldModalizeNamedShape maybe_rw maybe_l nmsh args = - splitLLVMBlockPerm blsubst off (bp { llvmBlockShape = sh' }) -splitLLVMBlockPerm _ _ (llvmBlockShape -> PExpr_NamedShape _ _ _ _) = Nothing -splitLLVMBlockPerm blsubst off bp@(llvmBlockShape -> - PExpr_EqShape _len (PExpr_Var b)) - -- FIXME: make sure the returned shape fits into len bytes! - | Just sh <- blsubst b - = splitLLVMBlockPerm blsubst off (bp { llvmBlockShape = sh }) -splitLLVMBlockPerm _ _ (llvmBlockShape -> PExpr_EqShape _ _) = Nothing -splitLLVMBlockPerm _ _ (llvmBlockShape -> PExpr_PtrShape _ _ _) = Nothing -splitLLVMBlockPerm _ _ (llvmBlockShape -> PExpr_FieldShape _) = Nothing -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 sh }, - bp { llvmBlockOffset = off, - llvmBlockLen = bvSub (llvmBlockLen bp) off_diff, - llvmBlockShape = PExpr_ArrayShape (bvSub len ix) stride sh }) -splitLLVMBlockPerm blsubst off bp@(llvmBlockShape -> PExpr_TupShape sh) = - splitLLVMBlockPerm blsubst off (bp { llvmBlockShape = sh }) -splitLLVMBlockPerm blsubst off bp@(llvmBlockShape -> PExpr_SeqShape sh1 sh2) - | Just sh1_len <- llvmShapeLength sh1 - , off_diff <- bvSub off (llvmBlockOffset bp) - , bvLt off_diff sh1_len - = splitLLVMBlockPerm blsubst off (bp { llvmBlockLen = sh1_len, - llvmBlockShape = sh1 }) >>= \(bp1,bp2) -> - Just (bp1, - bp2 { llvmBlockLen = bvSub (llvmBlockLen bp) off_diff, - llvmBlockShape = PExpr_SeqShape (llvmBlockShape bp2) sh2 }) -splitLLVMBlockPerm blsubst off bp@(llvmBlockShape -> PExpr_SeqShape sh1 sh2) - | Just sh1_len <- llvmShapeLength sh1 - = splitLLVMBlockPerm blsubst off - (bp { llvmBlockOffset = bvAdd (llvmBlockOffset bp) sh1_len, - llvmBlockLen = bvSub (llvmBlockLen bp) sh1_len, - llvmBlockShape = sh2 }) >>= \(bp1,bp2) -> - Just (bp1 { llvmBlockOffset = llvmBlockOffset bp, - llvmBlockLen = bvAdd (llvmBlockLen bp1) sh1_len, - llvmBlockShape = PExpr_SeqShape sh1 (llvmBlockShape bp1) }, - bp2) -splitLLVMBlockPerm blsubst off bp@(llvmBlockShape -> PExpr_OrShape sh1 sh2) = - do (bp1_L,bp1_R) <- splitLLVMBlockPerm blsubst off (bp { llvmBlockShape = sh1 }) - (bp2_L,bp2_R) <- splitLLVMBlockPerm blsubst off (bp { llvmBlockShape = sh2 }) - let or_helper bp1 bp2 = - bp1 { llvmBlockShape = - PExpr_OrShape (llvmBlockShape bp1) (llvmBlockShape bp2)} - Just (or_helper bp1_L bp2_L, or_helper bp1_R bp2_R) -splitLLVMBlockPerm blsubst off bp@(llvmBlockShape -> PExpr_ExShape mb_sh) = - case mbMatch $ fmap (\sh -> splitLLVMBlockPerm blsubst off - (bp { llvmBlockShape = sh })) mb_sh of - [nuMP| Just (mb_bp1,mb_bp2) |] -> - let off_diff = bvSub off (llvmBlockOffset bp) in - Just (bp { llvmBlockLen = off_diff, - llvmBlockShape = PExpr_ExShape (fmap llvmBlockShape mb_bp1) }, - bp { llvmBlockOffset = off, - llvmBlockLen = bvSub (llvmBlockLen bp) off_diff, - llvmBlockShape = PExpr_ExShape (fmap llvmBlockShape mb_bp2) }) - _ -> Nothing -splitLLVMBlockPerm _ _ _ = Nothing - --- | Remove a range of offsets from a block permission, if possible, yielding a --- list of block permissions for the remaining offsets -remLLVMBlockPermRange :: (1 <= w, KnownNat w) => BVRange w -> LLVMBlockPerm w -> - Maybe [LLVMBlockPerm w] -remLLVMBlockPermRange rng bp - | bvRangeSubset (llvmBlockRange bp) rng = Just [] -remLLVMBlockPermRange rng bp = - do (bps_l, bp') <- - -- If the beginning of rng lies inside the range of bp, split bp into - -- block permissions before and after the beginning of rng; otherwise, - -- lump all of bp into the \"after\" bucket. The call to splitLLVMBlockPerm - -- uses an empty substitution because remLLVMBlockPermRange itself is - -- assuming an empty substitution - if bvInRange (bvRangeOffset rng) (llvmBlockRange bp) then - do (bp_l,bp') <- splitLLVMBlockPerm (const Nothing) (bvRangeOffset rng) bp - return ([bp_l],bp') - else return ([],bp) - bp_r <- - -- Split bp', the permissions after the beginning of rng, into those - -- before and after the end of rng - if bvInRange (bvRangeEnd rng) (llvmBlockRange bp) then - snd <$> splitLLVMBlockPerm (const Nothing) (bvRangeEnd rng) bp' - else return bp' - return (bps_l ++ [bp_r]) - - --- | Extract the disjunctive shapes from a 'TaggedUnionShape' -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) - --- | Change a block permisison with a tagged union shape to have the @n@th --- disjunct shape of this tagged union -taggedUnionNthDisjBlock :: Int -> LLVMBlockPerm w -> LLVMBlockPerm w -taggedUnionNthDisjBlock 0 bp - | PExpr_OrShape sh1 _ <- llvmBlockShape bp = - bp { llvmBlockShape = sh1 } -taggedUnionNthDisjBlock 0 bp = - -- NOTE: this case happens for the last shape in a tagged union, which is not - -- or-ed with anything, and is guaranteed not to be an or itsef (so it won't - -- match the above case) - bp -taggedUnionNthDisjBlock n bp - | PExpr_OrShape _ sh2 <- llvmBlockShape bp = - taggedUnionNthDisjBlock (n-1) $ bp { llvmBlockShape = sh2 } -taggedUnionNthDisjBlock _ _ = error "taggedUnionNthDisjBlock" - --- | Change the a block permisison in a binding with a tagged union shape to --- have the @n@th disjunct shape of this tagged union -mbTaggedUnionNthDisjBlock :: Int -> Mb ctx (LLVMBlockPerm w) -> - Mb ctx (LLVMBlockPerm w) -mbTaggedUnionNthDisjBlock n = - mbMapCl ($(mkClosed [| taggedUnionNthDisjBlock |]) `clApply` toClosed n) - --- | 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 sz -> PermExpr (LLVMShapeType w) -taggedUnionToShape (TaggedUnionShape disjs) = - foldr1 PExpr_OrShape $ NonEmpty.map snd disjs - --- | A bitvector value of some unknown size -data SomeBV = forall sz. (1 <= sz, KnownNat sz) => SomeBV (BV sz) - --- | Test if a shape is of the form @fieldsh(eq(llvmword(bv)))@ for some @bv@. --- If so, return @bv@. -shapeToTag :: PermExpr (LLVMShapeType w) -> Maybe SomeBV -shapeToTag (PExpr_FieldShape - (LLVMFieldShape - (ValPerm_Eq (PExpr_LLVMWord (PExpr_BV [] bv))))) = - Just (SomeBV bv) -shapeToTag _ = Nothing - --- | Test if a shape begins with an equality permission to a bitvector value and --- return that bitvector value -getShapeBVTag :: PermExpr (LLVMShapeType w) -> Maybe SomeBV -getShapeBVTag sh | Just some_bv <- shapeToTag sh = Just some_bv -getShapeBVTag (PExpr_TupShape sh) = getShapeBVTag sh -getShapeBVTag (PExpr_SeqShape sh1 _) = getShapeBVTag sh1 -getShapeBVTag _ = Nothing - --- | Remove the leading tag from a shape where 'getShapeBVTag' succeeded -shapeRemoveTag :: PermExpr (LLVMShapeType w) -> PermExpr (LLVMShapeType w) -shapeRemoveTag (PExpr_TupShape sh) = shapeRemoveTag sh -shapeRemoveTag (PExpr_SeqShape sh1 sh2) | isJust (shapeToTag sh1) = sh2 -shapeRemoveTag (PExpr_SeqShape sh1 sh2) = - PExpr_SeqShape (shapeRemoveTag sh1) sh2 -shapeRemoveTag sh | isJust (shapeToTag sh) = PExpr_EmptyShape -shapeRemoveTag sh = - error ("shapeRemoveTag: " ++ permPrettyString emptyPPInfo sh) - --- | Extract the disjunctive shapes from a 'TaggedUnionShape' but removing the --- leading tags -taggedUnionDisjsNoTags :: TaggedUnionShape w sz -> [PermExpr (LLVMShapeType w)] -taggedUnionDisjsNoTags = map shapeRemoveTag . taggedUnionDisjs - --- | Test if a shape is a tagged union shape and, if so, convert it to the --- 'TaggedUnionShape' representation -asTaggedUnionShape :: PermExpr (LLVMShapeType w) -> - Maybe (SomeTaggedUnionShape w) -asTaggedUnionShape (PExpr_OrShape sh1 sh2) - | 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 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 @memblock@ permission in a binding with a tagged union shape to a --- field permission with permission @eq(z)@ using evar @z@ for the tag -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 --- some disjunct can be proved, return its index in the list of disjuncts. -findTaggedUnionIndexForPerm :: PermExpr (BVType w) -> - AtomicPerm (LLVMPointerType w) -> - TaggedUnionShape w -> Maybe Int -findTaggedUnionIndexForPerm off p (TaggedUnionShape disjs@((bv1,_) :| _)) - | Just bp <- llvmAtomicPermToBlock p - , bvEq off (llvmBlockOffset bp) - , Just (SomeBV tag_bv) <- getShapeBVTag $ llvmBlockShape bp - , Just Refl <- testEquality (natRepr tag_bv) (natRepr bv1) - , Just i <- findIndex (== tag_bv) $ map fst $ NonEmpty.toList disjs - = Just i -findTaggedUnionIndexForPerm _ _ _ = Nothing - - --- | Find a disjunct in a 'TaggedUnionShape' that could be proven at the given --- offset from the given atomic permissions, by looking for a field or block --- permission containing an equality permission to one of the tags. If some --- disjunct can be proved, return its index in the list of disjuncts. -findTaggedUnionIndexForPerms :: PermExpr (BVType w) -> - [AtomicPerm (LLVMPointerType 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@ -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 -> - BVRange w -> BVRange w -llvmArrayCellsToOffsets ap (BVRange cell num_cells) = - BVRange (llvmArrayCellToOffset ap cell) (llvmArrayCellToOffset ap num_cells) - --- | Convert a range of absolute byte offsets to a range of cell numbers in an --- array permission, if possible -llvmArrayAbsOffsetsToCells :: (1 <= w, KnownNat w) => LLVMArrayPerm w -> - BVRange w -> Maybe (BVRange w) -llvmArrayAbsOffsetsToCells ap rng - | Just cell <- matchLLVMArrayCell ap (bvRangeOffset rng) = - Just $ BVRange cell (bvDiv (bvRangeLength rng) (llvmArrayStride ap)) -llvmArrayAbsOffsetsToCells _ _ = Nothing - --- | Return the clopen range @[0,len)@ of the cells of an array permission -llvmArrayCells :: (1 <= w, KnownNat w) => LLVMArrayPerm w -> BVRange w -llvmArrayCells ap = BVRange (bvInt 0) (llvmArrayLen ap) - --- | Build the 'BVRange' of \"absolute\" offsets @[off,off+len_bytes)@ -llvmArrayAbsOffsets :: (1 <= w, KnownNat w) => LLVMArrayPerm w -> BVRange w -llvmArrayAbsOffsets ap = - BVRange (llvmArrayOffset ap) (llvmArrayCellToOffset ap $ llvmArrayLen ap) - --- | Return the number of bytes per machine word; @w@ is the number of bits -machineWordBytes :: KnownNat w => f w -> Integer -machineWordBytes w - | natVal w `mod` 8 /= 0 = - error "machineWordBytes: word size is not a multiple of 8!" -machineWordBytes w = natVal w `ceil_div` 8 - --- | Convert bytes to machine words, rounded up, i.e., return @ceil(n/W)@, --- where @W@ is the number of bytes per machine word -bytesToMachineWords :: KnownNat w => f w -> Integer -> Integer -bytesToMachineWords w n = n `ceil_div` machineWordBytes w - --- | Return the largest multiple of 'machineWordBytes' less than the input -prevMachineWord :: KnownNat w => f w -> Integer -> Integer -prevMachineWord w n = (bytesToMachineWords w n - 1) * machineWordBytes w - --- | Build the permission that corresponds to a borrow from an array, i.e., that --- would need to be returned in order to remove this borrow. For 'RangeBorrow's, --- 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 cell) = - ValPerm_LLVMBlock $ llvmArrayCellPerm ap cell -permForLLVMArrayBorrow ap (RangeBorrow (BVRange off len)) = - ValPerm_Conj1 $ Perm_LLVMArray $ - ap { llvmArrayOffset = llvmArrayCellToAbsOffset ap off, - llvmArrayLen = len, - llvmArrayBorrows = [] } - --- | Build the borrow corresponding to borrowing a given permission from the array. --- This is a partial function as the permission @p@ must be: --- (1) An array whose offset corresponds to a cell of @ap@ --- (2) A field or block corresponding to an array cell --- TODO: Extend this to allow blocks that span multiple cells -permToLLVMArrayBorrow :: - forall w. (1 <= w, KnownNat w) => - LLVMArrayPerm w -> - AtomicPerm (LLVMPointerType w) -> - Maybe (LLVMArrayBorrow w) -permToLLVMArrayBorrow ap p = - case p of - Perm_LLVMArray ap' - | Just idx <- matchLLVMArrayCell ap (llvmArrayOffset ap') -> - Just (RangeBorrow (BVRange idx n)) - where - n = llvmArrayLen ap' - - Perm_LLVMBlock bp - | PExpr_ArrayShape len bytes _ <- llvmBlockShape bp - , bytes == llvmArrayStride ap - , Just idx <- matchLLVMArrayCell ap (llvmBlockOffset bp) -> - Just (RangeBorrow (BVRange idx len)) - - Perm_LLVMField fp - | intValue (llvmFieldSize fp) /= llvmArrayStrideBits ap -> Nothing - Perm_LLVMBlock bp - | not (bvEq (llvmBlockLen bp) (bvInt (bytesToInteger (llvmArrayStride ap)))) -> Nothing - - - _ | Just r <- llvmAtomicPermRange p - , Just idx <- matchLLVMArrayCell ap (bvRangeOffset r) -> - Just (FieldBorrow idx) - - _ -> Nothing - --- | Get the range of offsets spanned by a borrow relative to the start of an --- array permission -llvmArrayBorrowRange :: (1 <= w, KnownNat w) => - LLVMArrayPerm w -> LLVMArrayBorrow w -> BVRange w -llvmArrayBorrowRange ap borrow = - llvmArrayCellsToOffsets ap (llvmArrayBorrowCells borrow) - --- | Get the \"absolute\" range of offsets spanned by a borrow relative to the --- pointer with this array permission -llvmArrayAbsBorrowRange :: (1 <= w, KnownNat w) => - LLVMArrayPerm w -> LLVMArrayBorrow w -> BVRange w -llvmArrayAbsBorrowRange ap borrow = - range { bvRangeOffset = bvAdd (llvmArrayOffset ap) (bvRangeOffset range) } - where - range = llvmArrayCellsToOffsets ap (llvmArrayBorrowCells borrow) - --- | Get the absolute offset at which an array borrow starts -llvmArrayBorrowAbsOffset :: (1 <= w, KnownNat w) => LLVMArrayPerm w -> - LLVMArrayBorrow w -> PermExpr (BVType w) -llvmArrayBorrowAbsOffset ap b = bvRangeOffset $ llvmArrayAbsBorrowRange ap b - --- | Add a borrow to an 'LLVMArrayPerm' -llvmArrayAddBorrow :: LLVMArrayBorrow w -> LLVMArrayPerm w -> LLVMArrayPerm w -llvmArrayAddBorrow b ap = ap { llvmArrayBorrows = b : llvmArrayBorrows ap } - --- | Add a list of borrows to an 'LLVMArrayPerm' -llvmArrayAddBorrows :: [LLVMArrayBorrow w] -> LLVMArrayPerm w -> LLVMArrayPerm w -llvmArrayAddBorrows bs ap = foldr llvmArrayAddBorrow ap bs - --- | Add all borrows from the second array to the first, assuming the one is an --- offset array as in 'llvmArrayIsOffsetArray' -llvmArrayAddArrayBorrows :: (1 <= w, KnownNat w) => LLVMArrayPerm w -> - LLVMArrayPerm w -> LLVMArrayPerm w -llvmArrayAddArrayBorrows ap sub_ap - | Just cell_num <- llvmArrayIsOffsetArray ap sub_ap = - llvmArrayAddBorrows - (map (cellOffsetLLVMArrayBorrow cell_num) (llvmArrayBorrows sub_ap)) - ap -llvmArrayAddArrayBorrows _ _ = error "llvmArrayAddArrayBorrows" - --- | Find the position in the list of borrows of an 'LLVMArrayPerm' of a --- specific borrow -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 :: 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 :: 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 :: HasCallStack => (1 <= w, KnownNat w) => - LLVMArrayPerm w -> LLVMArrayPerm w -> - LLVMArrayPerm w -llvmArrayRemArrayBorrows ap sub_ap - | Just cell_num <- llvmArrayIsOffsetArray ap sub_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 -llvmArrayBorrowsPermuteTo :: (1 <= w, KnownNat w) => LLVMArrayPerm w -> - [LLVMArrayBorrow w] -> Bool -llvmArrayBorrowsPermuteTo ap bs = - all (flip elem (llvmArrayBorrows ap)) bs && - all (flip elem bs) (llvmArrayBorrows ap) - --- | Add a cell offset to an 'LLVMArrayBorrow', meaning we change the borrow to --- 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 ix) = - FieldBorrow (bvAdd ix off) -cellOffsetLLVMArrayBorrow off (RangeBorrow rng) = - RangeBorrow $ offsetBVRange off rng - --- | Produce a @BVRange@ of borrowed cells from a borrow, which will be either a --- unit range (in the case of a @FieldBorrow@) or just the ranged spanned by the --- given @RangeBorrow@. -llvmArrayBorrowCells :: (KnownNat w, 1 <= w) => LLVMArrayBorrow w -> BVRange w -llvmArrayBorrowCells (FieldBorrow idx) = bvRangeOfIndex idx -llvmArrayBorrowCells (RangeBorrow r) = r - --- FIXME: delete? not used, and should be implementable via bvRangeDelete -{- --- | Given a borrow @borrow@ and range (of borrowed indices) @rng@, --- delete @rng@ from @borrow@, and return the borrows that describe --- the remaining borrowed cells. -llvmArrayBorrowRangeDelete :: - (HasCallStack, 1 <= w, KnownNat w) => - LLVMArrayBorrow w -> - BVRange w -> - [LLVMArrayBorrow w] -llvmArrayBorrowRangeDelete borrow rng = - catMaybes (go <$> bvRangeDelete borrow_range rng) - where - borrow_range = llvmArrayBorrowCells borrow - - go new_range - | bvIsZero (bvRangeLength new_range) = Nothing - | RangeBorrow _ <- borrow = Just $ RangeBorrow new_range - | FieldBorrow idx <- borrow - , bvEq (bvRangeLength new_range) (bvInt 1) = Just $ FieldBorrow idx - | otherwise = - error "llvmArrayBorrowRangeDelete: found non unit new_range for FieldBorrow" --} - --- | Take in a range @rng@ and a list of ranges @rngs@ and try to find a --- sequence of non-overlapping but contiguous ranges in @rngs@ that covers the --- desired range @rng@ -gatherCoveringRanges :: (1 <= w, KnownNat w) => BVRange w -> [BVRange w] -> - Maybe [BVRange w] -gatherCoveringRanges rng _ | bvIsZero (bvRangeLength rng) = Just [] -gatherCoveringRanges rng rngs - | Just i <- findIndex (bvInRange (bvRangeOffset rng)) rngs - , rng' <- rngs!!i = - -- If rng' covers all of rng, then we are done - if bvRangeSubset rng rng' then Just [rng'] else - (rng' :) <$> - gatherCoveringRanges (bvRangeSuffix (bvRangeEnd rng') rng) - (deleteNth i rngs) -gatherCoveringRanges _ _ = Nothing - --- | Test if the borrows in @ap@ cover a given range of offsets. That is, test --- if the ranges of the borrows in @ap@ can be arranged as a sequence of --- non-overlapping but contiguous ranges that extends at least as far as @len@ --- (in the sense of @bvLeq@). -llvmArrayRangeIsBorrowed :: (HasCallStack, 1 <= w, KnownNat w) => - LLVMArrayPerm w -> BVRange w -> Bool -llvmArrayRangeIsBorrowed ap rng = - isJust $ gatherCoveringRanges rng $ - map (llvmArrayBorrowAbsOffsets ap) (llvmArrayBorrows ap) - --- | Test whether the borrows in @ap@ cover the range of cells @[0, len)@. That --- is, test if the ranges of the borrows in @ap@ can be arranged as a sequence --- of non-overlapping but contiguous ranges that extends at least as far as --- @len@ (in the sense of @bvLeq@) -llvmArrayIsBorrowed :: (HasCallStack, 1 <= w, KnownNat w) => LLVMArrayPerm w -> - Bool -llvmArrayIsBorrowed ap = - llvmArrayRangeIsBorrowed ap (llvmArrayAbsOffsets ap) - --- | Test if a byte offset @o@ statically aligns with a statically-known offset --- into some array cell, i.e., whether --- --- > o - off = stride*ix + cell_off --- --- 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. -matchLLVMArrayIndex :: (1 <= w, KnownNat w) => LLVMArrayPerm w -> - PermExpr (BVType w) -> Maybe (LLVMArrayIndex w) -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) = - [bvPropInRange ix (llvmArrayCells ap)] -llvmArrayBorrowInArrayBase ap (RangeBorrow rng) = - bvPropRangeSubset rng (llvmArrayCells ap) - --- | Return a list of 'BVProp's stating that two array borrows are disjoint. The --- empty list is returned if they are trivially disjoint because they refer to --- statically distinct field numbers. -llvmArrayBorrowsDisjoint :: (1 <= w, KnownNat w) => - LLVMArrayBorrow w -> LLVMArrayBorrow w -> [BVProp w] -llvmArrayBorrowsDisjoint (FieldBorrow ix1) (FieldBorrow ix2) = - [BVProp_Neq ix1 ix2] -llvmArrayBorrowsDisjoint (FieldBorrow ix) (RangeBorrow rng) = - [bvPropNotInRange ix rng] -llvmArrayBorrowsDisjoint (RangeBorrow rng) (FieldBorrow ix) = - [bvPropNotInRange ix rng] -llvmArrayBorrowsDisjoint (RangeBorrow rng1) (RangeBorrow rng2) = - bvPropRangesDisjoint rng1 rng2 - --- | 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. -llvmArrayBorrowInArray :: (1 <= w, KnownNat w) => - LLVMArrayPerm w -> LLVMArrayBorrow w -> [BVProp w] -llvmArrayBorrowInArray ap b = - llvmArrayBorrowInArrayBase ap b ++ - concatMap (llvmArrayBorrowsDisjoint b) (llvmArrayBorrows ap) - --- | Shorthand for 'llvmArrayBorrowInArray' with a single index -llvmArrayIndexInArray :: (1 <= w, KnownNat w) => LLVMArrayPerm w -> - LLVMArrayIndex w -> [BVProp w] -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 -llvmArrayCellsInArray :: (1 <= w, KnownNat w) => LLVMArrayPerm w -> - BVRange w -> [BVProp w] -llvmArrayCellsInArray ap rng = llvmArrayBorrowInArray ap (RangeBorrow rng) - --- | Test if an array permission @ap2@ is offset by an even multiple of cell --- sizes from the start of @ap1@, and return that number of cells if so. Note --- that 'llvmArrayIsOffsetArray' @ap1@ @ap2@ returns the negative of --- 'llvmArrayIsOffsetArray' @ap2@ @ap1@ whenever either returns a value. -llvmArrayIsOffsetArray :: (1 <= w, KnownNat w) => LLVMArrayPerm w -> - LLVMArrayPerm w -> Maybe (PermExpr (BVType w)) -llvmArrayIsOffsetArray ap1 ap2 - | llvmArrayStride ap1 == llvmArrayStride ap2 = - matchLLVMArrayCell ap1 (llvmArrayOffset ap2) -llvmArrayIsOffsetArray _ _ = Nothing - --- | Build a 'BVRange' for the cells of a sub-array @ap2@ in @ap1@ -llvmSubArrayRange :: (1 <= w, KnownNat w) => LLVMArrayPerm w -> - LLVMArrayPerm w -> BVRange w -llvmSubArrayRange ap1 ap2 - | Just cell_num <- llvmArrayIsOffsetArray ap1 ap2 = - BVRange cell_num (llvmArrayLen ap2) -llvmSubArrayRange _ _ = error "llvmSubArrayRange" - --- | Build a 'RangeBorrow' for the cells of a sub-array @ap2@ of @ap1@ -llvmSubArrayBorrow :: (1 <= w, KnownNat w) => LLVMArrayPerm w -> - LLVMArrayPerm w -> LLVMArrayBorrow w -llvmSubArrayBorrow ap1 ap2 = RangeBorrow $ llvmSubArrayRange ap1 ap2 - --- | Given atomic permissions ps, filters out any q from ps such that q is --- borrowed from some q' also in ps -filterBorrowedPermissions :: forall w. (1 <= w, KnownNat w) => - [AtomicPerm (LLVMPointerType w)] -> - [AtomicPerm (LLVMPointerType w)] -filterBorrowedPermissions ps = filter (not . isABorrow) ps - where - isABorrow :: AtomicPerm (LLVMPointerType w) -> Bool - isABorrow p = - case p of - (llvmAtomicPermRange -> Just r) -> - r `elem` borrowedRanges - Perm_LLVMArray a -> - llvmArrayAbsOffsets a `elem` borrowedRanges - _ -> False - - borrowedRanges :: [BVRange w] - borrowedRanges = ps >>= go - - go :: AtomicPerm (LLVMPointerType w) -> [BVRange w] - go p = - case p of - Perm_LLVMArray arrayPerm -> - goBorrow arrayPerm <$> llvmArrayBorrows arrayPerm - _ -> [] - - goBorrow :: LLVMArrayPerm w -> LLVMArrayBorrow w -> BVRange w - goBorrow = llvmArrayBorrowOffsets - - --- | Return the propositions stating that the first array permission @ap@ --- contains the second @sub_ap@, meaning that array indices that are in @sub_ap@ --- (in the sense of 'llvmArrayIndexInArray') are in @ap@. This requires that the --- range of @sub_ap@ be a subset of that of @ap@ and that it be disjoint from --- all borrows in @ap@ that aren't also in @sub_ap@, i.e., that after removing --- all borrows in @sub_ap@ from @ap@ we have that the 'llvmArrayCellsInArray' --- propositions hold for the range of @sub_ap@. --- --- NOTE: @sub_ap@ must satisfy 'llvmArrayIsOffsetArray', i.e., have the same --- stride as @ap@ and be at a cell boundary in @ap@, or it is an error -llvmArrayContainsArray :: (1 <= w, KnownNat w) => LLVMArrayPerm w -> - LLVMArrayPerm w -> [BVProp w] -llvmArrayContainsArray ap sub_ap = - llvmArrayCellsInArray - (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 = - map (cellOffsetLLVMArrayBorrow (bvNegate cell)) $ - 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, and whether the propositions definitely hold (as in --- 'bvPropHolds') or only could hold (as in 'bvPropCouldHold'). For fields and --- blocks, the offset must simply be in their range, 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], Bool) -llvmPermContainsOffset off (Perm_LLVMField fp) - | prop <- bvPropInRange off (llvmFieldRange fp) - , bvPropCouldHold prop = - Just ([prop], bvPropHolds prop) -llvmPermContainsOffset off (Perm_LLVMArray ap) - | Just ix <- matchLLVMArrayIndex ap off - , props <- llvmArrayIndexInArray ap ix - , all bvPropCouldHold props = - Just (props, all bvPropHolds props) -llvmPermContainsOffset off (Perm_LLVMBlock bp) - | prop <- bvPropInRange off (llvmBlockRange bp) - , bvPropCouldHold prop = - Just ([prop], bvPropHolds prop) -llvmPermContainsOffset _ _ = Nothing - --- | Test if an atomic LLVM permission definitely contains an offset. This is --- the 'Bool' flag returned by 'llvmPermContainsOffset', or 'False' if that is --- undefined. -llvmPermContainsOffsetBool :: (1 <= w, KnownNat w) => PermExpr (BVType w) -> - AtomicPerm (LLVMPointerType w) -> Bool -llvmPermContainsOffsetBool off p = - maybe False snd $ llvmPermContainsOffset off p - --- | Build the propositions stating that an atomic LLVM permission contains all --- offsets in a given range -llvmAtomicPermContainsRangeProps :: (1 <= w, KnownNat w) => BVRange w -> - AtomicPerm (LLVMPointerType w) -> - Maybe [BVProp w] -llvmAtomicPermContainsRangeProps rng (Perm_LLVMArray ap) - | Just ix1 <- matchLLVMArrayIndex ap (bvRangeOffset rng) - , Just ix2 <- matchLLVMArrayIndex ap (bvRangeEnd rng) - , props <- llvmArrayBorrowInArray ap (RangeBorrow $ BVRange - (llvmArrayIndexCell ix1) - (llvmArrayIndexCell ix2)) = - Just props -llvmAtomicPermContainsRangeProps rng (Perm_LLVMField fp) = - Just $ bvPropRangeSubset rng (llvmFieldRange fp) -llvmAtomicPermContainsRangeProps rng (Perm_LLVMBlock bp) = - Just $ bvPropRangeSubset rng (llvmBlockRange bp) -llvmAtomicPermContainsRangeProps _ _ = Nothing - --- | Test if an atomic LLVM permission contains (in the sense of 'bvPropHolds') --- all offsets in a given range -llvmAtomicPermContainsRange :: (1 <= w, KnownNat w) => BVRange w -> - AtomicPerm (LLVMPointerType w) -> Bool -llvmAtomicPermContainsRange rng p - | Just props <- llvmAtomicPermContainsRangeProps rng p = - all bvPropHolds props -llvmAtomicPermContainsRange _ _ = False - --- | Test if an atomic LLVM permission could contain (in the sense of --- 'bvPropCouldHold') all offsets in a given range -llvmAtomicPermCouldContainRange :: (1 <= w, KnownNat w) => BVRange w -> - AtomicPerm (LLVMPointerType w) -> Bool -llvmAtomicPermCouldContainRange rng p - | Just props <- llvmAtomicPermContainsRangeProps rng p = - all bvPropCouldHold props -llvmAtomicPermCouldContainRange _ _ = False - --- | Test if an atomic LLVM permission has a range that overlaps with (in the --- sense of 'bvPropHolds') the offsets in a given range -llvmAtomicPermOverlapsRange :: (1 <= w, KnownNat w) => BVRange w -> - AtomicPerm (LLVMPointerType w) -> Bool -llvmAtomicPermOverlapsRange rng (Perm_LLVMArray ap) = - bvRangesOverlap rng (llvmArrayAbsOffsets ap) && - not (null $ bvRangesDelete rng $ - map (llvmArrayBorrowOffsets ap) (llvmArrayBorrows ap)) -llvmAtomicPermOverlapsRange rng (Perm_LLVMField fp) = - bvRangesOverlap rng (llvmFieldRange fp) -llvmAtomicPermOverlapsRange rng (Perm_LLVMBlock bp) = - bvRangesOverlap rng (llvmBlockRange bp) -llvmAtomicPermOverlapsRange _ _ = False - --- | Test if an atomic LLVM permission has a range that could overlap with (in the --- sense of 'bvPropCouldHold') the offsets in a given range -llvmAtomicPermCouldOverlapRange :: (1 <= w, KnownNat w) => BVRange w -> - AtomicPerm (LLVMPointerType w) -> Bool -llvmAtomicPermCouldOverlapRange rng (Perm_LLVMArray ap) = - bvRangesCouldOverlap rng (llvmArrayAbsOffsets ap) && - not (null $ bvRangesDelete rng $ - map (llvmArrayBorrowOffsets ap) (llvmArrayBorrows ap)) -llvmAtomicPermCouldOverlapRange rng (Perm_LLVMField fp) = - bvRangesCouldOverlap rng (llvmFieldRange fp) -llvmAtomicPermCouldOverlapRange rng (Perm_LLVMBlock bp) = - bvRangesCouldOverlap rng (llvmBlockRange bp) -llvmAtomicPermCouldOverlapRange _ _ = False - --- | Return the total length of an LLVM array permission in bytes -llvmArrayLengthBytes :: (1 <= w, KnownNat w) => LLVMArrayPerm w -> - PermExpr (BVType w) -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 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) = - BVRange (llvmArrayCellToOffset ap ix) (bvInt $ toInteger $ llvmArrayStride ap) -llvmArrayBorrowOffsets ap (RangeBorrow r) = llvmArrayCellsToOffsets ap r - --- | Get the range of byte offsets represented by an array borrow relative to --- the variable @x@ that has the supplied array permission. This is equivalent --- to the addition of 'llvmArrayOffset' to the range of relative offsets --- returned by 'llvmArrayBorrowOffsets'. -llvmArrayBorrowAbsOffsets :: (1 <= w, KnownNat w) => LLVMArrayPerm w -> - LLVMArrayBorrow w -> BVRange w -llvmArrayBorrowAbsOffsets ap b = - offsetBVRange (llvmArrayOffset ap) (llvmArrayBorrowOffsets ap b) - --- | Divide an array permission @x:array(off, LLVMArrayPerm w -> - PermExpr (BVType w) -> (LLVMArrayPerm w, LLVMArrayPerm w) -llvmArrayPermDivide ap len = - let len_bytes = llvmArrayCellToOffset ap len - borrow_in_first b = - all bvPropHolds (bvPropRangeSubset - (llvmArrayBorrowOffsets ap b) - (BVRange (bvInt 0) len_bytes)) in - (ap { llvmArrayLen = len, - llvmArrayBorrows = filter borrow_in_first (llvmArrayBorrows ap) } - , - ap { llvmArrayOffset = bvAdd (llvmArrayOffset ap) len_bytes - , llvmArrayLen = bvSub (llvmArrayLen ap) len - , llvmArrayBorrows = - filter (not . borrow_in_first) (llvmArrayBorrows ap) }) - - --- | 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 -> - [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 -> Perm_LLVMField $ - (llvmFieldWrite0True @w) { llvmFieldOffset = - bvInt (i * machineWordBytes w) }) - [0 .. bytesToMachineWords w sz - 2] - ++ - [Perm_LLVMField $ - (llvmSizedFieldWrite0True w sz_last) - { llvmFieldOffset = - bvInt ((bytesToMachineWords w sz - 1) * machineWordBytes w) }] - | otherwise = error "impossible (sz_last_int is always >= 8)" - --- | Return the permission built from the field permissions returned by --- 'llvmFieldsOfSize' -llvmFieldsPermOfSize :: (1 <= w, KnownNat w) => f w -> Integer -> - ValuePerm (LLVMPointerType w) -llvmFieldsPermOfSize w n = ValPerm_Conj $ llvmFieldsOfSize w n - --- | Return a memblock permission with empty shape of given size -llvmEmptyBlockPermOfSize :: (1 <= w, KnownNat w) => f w -> Integer -> - ValuePerm (LLVMPointerType w) -llvmEmptyBlockPermOfSize _ n = ValPerm_LLVMBlock $ - LLVMBlockPerm { llvmBlockRW = PExpr_RWModality Write - , llvmBlockLifetime = PExpr_Always - , llvmBlockOffset = bvInt 0 - , llvmBlockLen = bvInt n - , llvmBlockShape = PExpr_EmptyShape - } - --- | 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) => - PermExpr (BVType w) -> PermExpr (BVType w) -> - PermExpr RWModalityType -> PermExpr LifetimeType -> - LLVMArrayPerm w -llvmByteArrayArrayPerm off len rw l = - 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) => - PermExpr (BVType w) -> PermExpr (BVType w) -> - PermExpr RWModalityType -> PermExpr LifetimeType -> - ValuePerm (LLVMPointerType w) -llvmByteArrayPerm off len rw l = - ValPerm_Conj1 $ Perm_LLVMArray $ llvmByteArrayArrayPerm off len rw l - --- | Map an 'LLVMBlockPerm' to a byte array perm with the same components -llvmBlockPermToByteArrayPerm :: (1 <= w, KnownNat w) => LLVMBlockPerm w -> - ValuePerm (LLVMPointerType w) -llvmBlockPermToByteArrayPerm (LLVMBlockPerm {..}) = - llvmByteArrayPerm llvmBlockOffset llvmBlockLen llvmBlockRW llvmBlockLifetime - --- | Create a @memblock(W,0,sz,emptysh)@ permission for a given size @sz@ -llvmBlockPermOfSize :: (1 <= w, KnownNat w) => Integer -> - ValuePerm (LLVMPointerType w) -llvmBlockPermOfSize sz = - ValPerm_Conj1 $ Perm_LLVMBlock $ - LLVMBlockPerm { llvmBlockRW = PExpr_Write, llvmBlockLifetime = PExpr_Always, - llvmBlockOffset = bvInt 0, llvmBlockLen = bvInt sz, - llvmBlockShape = PExpr_EmptyShape } - --- | Add an offset @off@ to an LLVM permission @p@, meaning change @p@ so that --- it indicates that @x+off@ has permission @p@. --- --- FIXME: this should be the general-purpose function 'offsetPerm' that recurses --- through permissions; that would allow other sorts of offsets at other types -offsetLLVMPerm :: (1 <= w, KnownNat w) => PermExpr (BVType w) -> - ValuePerm (LLVMPointerType w) -> ValuePerm (LLVMPointerType w) -offsetLLVMPerm off (ValPerm_Eq e) = ValPerm_Eq $ addLLVMOffset e (bvNegate off) -offsetLLVMPerm off (ValPerm_Or p1 p2) = - ValPerm_Or (offsetLLVMPerm off p1) (offsetLLVMPerm off p2) -offsetLLVMPerm off (ValPerm_Exists mb_p) = - ValPerm_Exists $ fmap (offsetLLVMPerm off) mb_p -offsetLLVMPerm off (ValPerm_Named n args off') = - ValPerm_Named n args (addPermOffsets off' (mkLLVMPermOffset off)) -offsetLLVMPerm off (ValPerm_Var x off') = - ValPerm_Var x $ addPermOffsets off' (mkLLVMPermOffset off) -offsetLLVMPerm off (ValPerm_Conj ps) = - ValPerm_Conj $ mapMaybe (offsetLLVMAtomicPerm off) ps -offsetLLVMPerm _ ValPerm_False = ValPerm_False - --- | Test if an LLVM pointer permission can be offset by the given offset; i.e., --- whether 'offsetLLVMAtomicPerm' returns a value -canOffsetLLVMAtomicPerm :: (1 <= w, KnownNat w) => PermExpr (BVType w) -> - LLVMPtrPerm w -> Bool -canOffsetLLVMAtomicPerm off p = isJust $ offsetLLVMAtomicPerm off p - --- | Add an offset to an LLVM pointer permission, returning 'Nothing' for --- permissions like @free@ and @llvm_funptr@ that cannot be offset -offsetLLVMAtomicPerm :: (1 <= w, KnownNat w) => PermExpr (BVType w) -> - LLVMPtrPerm w -> Maybe (LLVMPtrPerm w) -offsetLLVMAtomicPerm (bvMatchConstInt -> Just 0) p = Just p -offsetLLVMAtomicPerm off (Perm_LLVMField fp) = - Just $ Perm_LLVMField $ offsetLLVMFieldPerm off fp -offsetLLVMAtomicPerm off (Perm_LLVMArray ap) = - Just $ Perm_LLVMArray $ offsetLLVMArrayPerm off ap -offsetLLVMAtomicPerm off (Perm_LLVMBlock bp) = - Just $ Perm_LLVMBlock $ offsetLLVMBlockPerm off bp -offsetLLVMAtomicPerm _ (Perm_LLVMFree _) = Nothing -offsetLLVMAtomicPerm _ (Perm_LLVMFunPtr _ _) = Nothing -offsetLLVMAtomicPerm _ p@Perm_IsLLVMPtr = Just p -offsetLLVMAtomicPerm off (Perm_NamedConj n args off') = - Just $ Perm_NamedConj n args $ addPermOffsets off' (mkLLVMPermOffset off) -offsetLLVMAtomicPerm _ p@(Perm_BVProp _) = Just p -offsetLLVMAtomicPerm _ p@Perm_Any = Just p - --- | Add an offset to a field permission -offsetLLVMFieldPerm :: (1 <= w, KnownNat w) => PermExpr (BVType w) -> - LLVMFieldPerm w sz -> LLVMFieldPerm w sz -offsetLLVMFieldPerm off (LLVMFieldPerm {..}) = - LLVMFieldPerm { llvmFieldOffset = bvAdd llvmFieldOffset off, ..} - --- | Add an offset to an array permission -offsetLLVMArrayPerm :: (1 <= w, KnownNat w) => PermExpr (BVType w) -> - LLVMArrayPerm w -> LLVMArrayPerm w -offsetLLVMArrayPerm off (LLVMArrayPerm {..}) = - LLVMArrayPerm { llvmArrayOffset = bvAdd llvmArrayOffset off, ..} - --- | Add an offset to a block permission -offsetLLVMBlockPerm :: (1 <= w, KnownNat w) => PermExpr (BVType w) -> - LLVMBlockPerm w -> LLVMBlockPerm w -offsetLLVMBlockPerm off (LLVMBlockPerm {..}) = - LLVMBlockPerm { llvmBlockOffset = bvAdd llvmBlockOffset off, ..} - --- | Add a 'PermOffset' to a permission, assuming that it is a conjunctive --- permission, meaning that it is built inductively using only existentials, --- disjunctions, conjunctive named permissions, and conjunctions of atomic --- permissions (though these atomic permissions can contain equality permissions --- in, e.g., LLVM field permissions) -offsetPerm :: PermOffset a -> ValuePerm a -> ValuePerm a -offsetPerm (LLVMPermOffset off) p = offsetLLVMPerm off p -offsetPerm NoPermOffset p = p - --- | Lens for the atomic permissions in a 'ValPerm_Conj'; it is an error to use --- this lens with a value permission not of this form -conjAtomicPerms :: Lens' (ValuePerm a) [AtomicPerm a] -conjAtomicPerms = - lens - (\p -> case p of - ValPerm_Conj ps -> ps - _ -> error "conjAtomicPerms: not a conjuction of atomic permissions") - (\p ps -> - case p of - ValPerm_Conj _ -> ValPerm_Conj ps - _ -> error "conjAtomicPerms: not a conjuction of atomic permissions") - --- | Lens for the @i@th atomic permission in a 'ValPerm_Conj'; it is an error to --- use this lens with a value permission not of this form -conjAtomicPerm :: Int -> Lens' (ValuePerm a) (AtomicPerm a) -conjAtomicPerm i = - lens - (\p -> if i >= length (p ^. conjAtomicPerms) then - error "conjAtomicPerm: index out of bounds" - else (p ^. conjAtomicPerms) !! i) - (\p pp -> - -- FIXME: there has got to be a nicer, more lens-like way to do this - let pps = p ^. conjAtomicPerms in - if i >= length pps then - error "conjAtomicPerm: index out of bounds" - else set conjAtomicPerms (take i pps ++ (pp : drop (i+1) pps)) p) - --- | Add a new atomic permission to the end of the list of those contained in --- the 'conjAtomicPerms' of a permission -addAtomicPerm :: AtomicPerm a -> ValuePerm a -> ValuePerm a -addAtomicPerm pp = over conjAtomicPerms (++ [pp]) - --- | Delete the atomic permission at the given index from the list of those --- contained in the 'conjAtomicPerms' of a permission -deleteAtomicPerm :: Int -> ValuePerm a -> ValuePerm a -deleteAtomicPerm i = - over conjAtomicPerms (\pps -> - if i >= length pps then - error "deleteAtomicPerm: index out of bounds" - else take i pps ++ drop (i+1) pps) - --- | Lens for the LLVM pointer permissions in a 'ValPerm_Conj'; it is an error --- to use this lens with a value permission not of this form -llvmPtrPerms :: Lens' (ValuePerm (LLVMPointerType w)) [LLVMPtrPerm w] -llvmPtrPerms = conjAtomicPerms - --- | Lens for the @i@th LLVM pointer permission of a 'ValPerm_Conj' -llvmPtrPerm :: Int -> Lens' (ValuePerm (LLVMPointerType w)) (LLVMPtrPerm w) -llvmPtrPerm = conjAtomicPerm - --- | Add a new 'LLVMPtrPerm' to the end of the list of those contained in the --- 'llvmPtrPerms' of a permission -addLLVMPtrPerm :: LLVMPtrPerm w -> ValuePerm (LLVMPointerType w) -> - ValuePerm (LLVMPointerType w) -addLLVMPtrPerm pp = over llvmPtrPerms (++ [pp]) - --- | Delete the 'LLVMPtrPerm' at the given index from the list of those --- contained in the 'llvmPtrPerms' of a permission -deleteLLVMPtrPerm :: Int -> ValuePerm (LLVMPointerType w) -> - ValuePerm (LLVMPointerType w) -deleteLLVMPtrPerm i = - over llvmPtrPerms (\pps -> - if i >= length pps then - error "deleteLLVMPtrPerm: index out of bounds" - else take i pps ++ drop (i+1) pps) - --- | Return the index of the last 'LLVMPtrPerm' of a permission -lastLLVMPtrPermIndex :: ValuePerm (LLVMPointerType w) -> Int -lastLLVMPtrPermIndex p = - let len = length (p ^. llvmPtrPerms) in - if len > 0 then len - 1 else error "lastLLVMPtrPerms: no pointer perms!" - --- | Create a list of pointer permissions needed in order to deallocate a frame --- that has the given frame permissions. It is an error if any of the required --- permissions are for LLVM words instead of pointers. -llvmFrameDeletionPerms :: (1 <= w, KnownNat w) => LLVMFramePerm w -> - Some DistPerms -llvmFrameDeletionPerms [] = Some DistPermsNil -llvmFrameDeletionPerms ((asLLVMOffset -> Just (x,_off), sz):fperm') - | Some del_perms <- llvmFrameDeletionPerms fperm' = - Some $ DistPermsCons del_perms x $ llvmBlockPermOfSize sz -llvmFrameDeletionPerms _ = - error "llvmFrameDeletionPerms: unexpected LLVM word allocated in frame" - --- | Build a 'DistPerms' with just one permission -distPerms1 :: ExprVar a -> ValuePerm a -> DistPerms (RNil :> a) -distPerms1 x p = DistPermsCons DistPermsNil x p - --- | Build a 'DistPerms' with two permissions -distPerms2 :: ExprVar a1 -> ValuePerm a1 -> - ExprVar a2 -> ValuePerm a2 -> DistPerms (RNil :> a1 :> a2) -distPerms2 x1 p1 x2 p2 = DistPermsCons (distPerms1 x1 p1) x2 p2 - --- | Build a 'DistPerms' with three permissions -distPerms3 :: ExprVar a1 -> ValuePerm a1 -> ExprVar a2 -> ValuePerm a2 -> - ExprVar a3 -> ValuePerm a3 -> DistPerms (RNil :> a1 :> a2 :> a3) -distPerms3 x1 p1 x2 p2 x3 p3 = DistPermsCons (distPerms2 x1 p1 x2 p2) x3 p3 - --- | Get the first permission in a 'DistPerms' -distPermsHeadPerm :: DistPerms (ps :> a) -> ValuePerm a -distPermsHeadPerm (DistPermsCons _ _ p) = p - --- | Drop the last permission in a 'DistPerms' -distPermsSnoc :: DistPerms (ps :> a) -> DistPerms ps -distPermsSnoc (DistPermsCons ps _ _) = ps - --- | Map a function on permissions across a 'DistPerms' -mapDistPerms :: (forall a. ValuePerm a -> ValuePerm a) -> - DistPerms ps -> DistPerms ps -mapDistPerms _ DistPermsNil = DistPermsNil -mapDistPerms f (DistPermsCons perms x p) = - DistPermsCons (mapDistPerms f perms) x (f p) - - --- | Create a sequence of @true@ permissions -trueValuePerms :: RAssign any ps -> ValuePerms ps -trueValuePerms MNil = ValPerms_Nil -trueValuePerms (ps :>: _) = ValPerms_Cons (trueValuePerms ps) ValPerm_True - --- | Create a list of @eq(xi)@ permissions from a list of variables @x1,x2,...@ -eqValuePerms :: RAssign Name ps -> ValuePerms ps -eqValuePerms MNil = ValPerms_Nil -eqValuePerms (xs :>: x) = - ValPerms_Cons (eqValuePerms xs) (ValPerm_Eq (PExpr_Var x)) - --- | Append two lists of permissions -appendValuePerms :: ValuePerms ps1 -> ValuePerms ps2 -> ValuePerms (ps1 :++: ps2) -appendValuePerms ps1 ValPerms_Nil = ps1 -appendValuePerms ps1 (ValPerms_Cons ps2 p) = - ValPerms_Cons (appendValuePerms ps1 ps2) p - -distPermsToProxies :: DistPerms ps -> RAssign Proxy ps -distPermsToProxies (DistPermsNil) = MNil -distPermsToProxies (DistPermsCons ps _ _) = distPermsToProxies ps :>: Proxy - -mbDistPermsToProxies :: Mb ctx (DistPerms ps) -> RAssign Proxy ps -mbDistPermsToProxies mb_ps = case mbMatch mb_ps of - [nuMP| DistPermsNil |] -> MNil - [nuMP| DistPermsCons ps _ _ |] -> - mbDistPermsToProxies ps :>: Proxy - --- | Extract the variables in a 'DistPerms' -distPermsVars :: DistPerms ps -> RAssign Name ps -distPermsVars DistPermsNil = MNil -distPermsVars (DistPermsCons ps x _) = distPermsVars ps :>: x - --- | Extract the non-bound variables in a 'DistPerms' in context -mbDistPermsVars :: Mb ctx (DistPerms ps) -> [Some ExprVar] -mbDistPermsVars = - concat . RL.mapToList (\case - Compose [nuP| VarAndPerm mb_n _ |] - | Right n <- mbNameBoundP mb_n -> [Some n] - _ -> []) . mbRAssign - --- | Append two lists of distinguished permissions -appendDistPerms :: DistPerms ps1 -> DistPerms ps2 -> DistPerms (ps1 :++: ps2) -appendDistPerms ps1 DistPermsNil = ps1 -appendDistPerms ps1 (DistPermsCons ps2 x p) = - DistPermsCons (appendDistPerms ps1 ps2) x p - --- | Filter a list of distinguished permissions using a predicate -filterDistPerms :: (forall a. Name a -> ValuePerm a -> Bool) -> - DistPerms ps -> Some DistPerms -filterDistPerms _ DistPermsNil = Some DistPermsNil -filterDistPerms pred (DistPermsCons ps x p) - | pred x p - , Some ps' <- filterDistPerms pred ps = Some (DistPermsCons ps' x p) -filterDistPerms pred (DistPermsCons ps _ _) = filterDistPerms pred ps - --- | Build a list of distinguished permissions from a list of variables -buildDistPerms :: (forall a. Name a -> ValuePerm a) -> RAssign Name ps -> - DistPerms ps -buildDistPerms _ MNil = DistPermsNil -buildDistPerms f (ns :>: n) = DistPermsCons (buildDistPerms f ns) n (f n) - --- | Split a list of distinguished permissions into two -splitDistPerms :: f ps1 -> RAssign g ps2 -> DistPerms (ps1 :++: ps2) -> - (DistPerms ps1, DistPerms ps2) -splitDistPerms _ = helper where - helper :: RAssign g ps2 -> DistPerms (ps1 :++: ps2) -> - (DistPerms ps1, DistPerms ps2) - helper MNil perms = (perms, DistPermsNil) - helper (prxs :>: _) (DistPermsCons ps x p) = - let (perms1, perms2) = helper prxs ps in - (perms1, DistPermsCons perms2 x p) - --- | Split a list of value permissions in bindings into two -splitMbValuePerms :: f ps1 -> RAssign g ps2 -> - Mb vars (ValuePerms (ps1 :++: ps2)) -> - (Mb vars (ValuePerms ps1), Mb vars (ValuePerms ps2)) -splitMbValuePerms _ MNil mb_perms = - (mb_perms, fmap (const ValPerms_Nil) mb_perms) -splitMbValuePerms prx (ps2 :>: _) (mbMatch -> [nuMP| ValPerms_Cons mb_perms p |]) = - let (ret1, ret2) = splitMbValuePerms prx ps2 mb_perms in - (ret1, mbMap2 ValPerms_Cons ret2 p) - --- | Lens for the top permission in a 'DistPerms' stack -distPermsHead :: ExprVar a -> Lens' (DistPerms (ps :> a)) (ValuePerm a) -distPermsHead x = - lens (\(DistPermsCons _ y p) -> - if x == y then p else error "distPermsHead: incorrect variable name!") - (\(DistPermsCons pstk y _) p -> - if x == y then DistPermsCons pstk y p else - error "distPermsHead: incorrect variable name!") - --- | The lens for the tail of a 'DistPerms' stack -distPermsTail :: Lens' (DistPerms (ps :> a)) (DistPerms ps) -distPermsTail = - lens (\(DistPermsCons pstk _ _) -> pstk) - (\(DistPermsCons _ x p) pstk -> DistPermsCons pstk x p) - --- | The lens for the nth permission in a 'DistPerms' stack -nthVarPerm :: Member ps a -> ExprVar a -> Lens' (DistPerms ps) (ValuePerm a) -nthVarPerm Member_Base x = distPermsHead x -nthVarPerm (Member_Step memb') x = distPermsTail . nthVarPerm memb' x - --- | Test if a permission can be copied, i.e., whether @p -o p*p@. This is true --- iff @p@ does not contain any 'Write' modalities, any frame permissions, or --- any lifetime ownership permissions. Note that this must be true for all --- substitutions of free (permission or expression) variables, so free variables --- can make a permission not copyable as well. -permIsCopyable :: ValuePerm a -> Bool -permIsCopyable (ValPerm_Eq _) = True -permIsCopyable (ValPerm_Or p1 p2) = permIsCopyable p1 && permIsCopyable p2 -permIsCopyable (ValPerm_Exists mb_p) = mbLift $ fmap permIsCopyable mb_p -permIsCopyable (ValPerm_Named npn args _offset) = - -- FIXME: this is wrong. For transparent perms, should make this just unfold - -- the definition; for opaque perms, look at arguments. For recursive perms, - -- unfold and assume the recursive call is copyable, then see if the unfolded - -- version is still copyable - namedPermArgsAreCopyable (namedPermNameArgs npn) args -permIsCopyable (ValPerm_Var _ _) = False -permIsCopyable (ValPerm_Conj ps) = all atomicPermIsCopyable ps -permIsCopyable ValPerm_False = True - --- | The same as 'permIsCopyable' except for atomic permissions -atomicPermIsCopyable :: AtomicPerm a -> Bool -atomicPermIsCopyable (Perm_LLVMField - (LLVMFieldPerm { llvmFieldRW = PExpr_Read, - llvmFieldContents = p })) = - permIsCopyable p -atomicPermIsCopyable (Perm_LLVMField _) = False -atomicPermIsCopyable (Perm_LLVMArray (LLVMArrayPerm {..})) = - llvmArrayRW == PExpr_Read && shapeIsCopyable llvmArrayRW llvmArrayCellShape -atomicPermIsCopyable (Perm_LLVMBlock (LLVMBlockPerm {..})) = - llvmBlockRW == PExpr_Read && shapeIsCopyable llvmBlockRW llvmBlockShape -atomicPermIsCopyable (Perm_LLVMFree _) = True -atomicPermIsCopyable (Perm_LLVMFunPtr _ _) = True -atomicPermIsCopyable Perm_IsLLVMPtr = True -atomicPermIsCopyable (Perm_LLVMBlockShape sh) = shapeIsCopyable PExpr_Write sh -atomicPermIsCopyable (Perm_LLVMFrame _) = False -atomicPermIsCopyable (Perm_LOwned _ _ _ _ _) = False -atomicPermIsCopyable (Perm_LOwnedSimple _ _) = False -atomicPermIsCopyable (Perm_LCurrent _) = True -atomicPermIsCopyable Perm_LFinished = True -atomicPermIsCopyable (Perm_Struct ps) = and $ RL.mapToList permIsCopyable ps -atomicPermIsCopyable (Perm_Fun _) = True -atomicPermIsCopyable (Perm_BVProp _) = True -atomicPermIsCopyable Perm_Any = True -atomicPermIsCopyable (Perm_NamedConj n args _) = - namedPermArgsAreCopyable (namedPermNameArgs n) args - --- | 'permIsCopyable' for the arguments of a named permission -namedPermArgIsCopyable :: TypeRepr a -> PermExpr a -> Bool -namedPermArgIsCopyable RWModalityRepr PExpr_Read = True -namedPermArgIsCopyable RWModalityRepr _ = False -namedPermArgIsCopyable (ValuePermRepr _) (PExpr_ValPerm p) = permIsCopyable p -namedPermArgIsCopyable (ValuePermRepr _) (PExpr_Var _) = False -namedPermArgIsCopyable _ _ = True - --- | 'permIsCopyable' for an argument of a named permission -namedPermArgsAreCopyable :: CruCtx args -> PermExprs args -> Bool -namedPermArgsAreCopyable CruCtxNil PExprs_Nil = True -namedPermArgsAreCopyable (CruCtxCons tps tp) (PExprs_Cons args arg) = - namedPermArgsAreCopyable tps args && namedPermArgIsCopyable tp arg - --- | Test if an LLVM shape corresponds to a copyable permission relative to the --- given read/write modality -shapeIsCopyable :: PermExpr RWModalityType -> PermExpr (LLVMShapeType w) -> Bool -shapeIsCopyable _ (PExpr_Var _) = False -shapeIsCopyable _ PExpr_EmptyShape = True -shapeIsCopyable rw (PExpr_NamedShape maybe_rw' _ nmsh args) = - case namedShapeBody nmsh of - DefinedShapeBody _ -> - let rw' = maybe rw id maybe_rw' in - shapeIsCopyable rw' $ unfoldNamedShape nmsh args - -- NOTE: we are assuming that opaque shapes are copyable iff their args are - OpaqueShapeBody _ _ _ -> - namedPermArgsAreCopyable (namedShapeArgs nmsh) args - -- HACK: the real computation we want to perform is to assume nmsh is copyable - -- and prove it is under that assumption; to accomplish this, we substitute - -- the empty shape for the recursive shape - RecShapeBody mb_sh _ _ -> - shapeIsCopyable rw $ subst (substOfExprs (args :>: PExpr_EmptyShape)) mb_sh -shapeIsCopyable _ (PExpr_EqShape _ _) = True -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 rw (PExpr_ArrayShape _ _ sh) = shapeIsCopyable rw sh -shapeIsCopyable rw (PExpr_TupShape sh) = shapeIsCopyable rw sh -shapeIsCopyable rw (PExpr_SeqShape sh1 sh2) = - shapeIsCopyable rw sh1 && shapeIsCopyable rw sh2 -shapeIsCopyable rw (PExpr_OrShape sh1 sh2) = - shapeIsCopyable rw sh1 && shapeIsCopyable rw sh2 -shapeIsCopyable rw (PExpr_ExShape mb_sh) = - mbLift $ fmap (shapeIsCopyable rw) mb_sh -shapeIsCopyable _ PExpr_FalseShape = True - - --- | Get the lifetime children of a lifetime permission, returning the empty --- list of children for a non-@lowned@ permission -lownedPermChildren :: ValuePerm LifetimeType -> [PermExpr LifetimeType] -lownedPermChildren (ValPerm_LOwned ls _ _ _ _) = ls -lownedPermChildren _ = [] - --- | Topologically sort a list of lifetimes with their ownership permissions so --- that child lifetimes come before their parents -sortLOwnedPerms :: [(ExprVar LifetimeType, ValuePerm LifetimeType)] -> - [(ExprVar LifetimeType, ValuePerm LifetimeType)] -sortLOwnedPerms ls_ps = - evalState (concat <$> mapM visit ls_ps) NameSet.empty where - visit :: (ExprVar LifetimeType, ValuePerm LifetimeType) -> - State (NameSet CrucibleType) [(ExprVar LifetimeType, - ValuePerm LifetimeType)] - visit (l, p) = - (NameSet.member l <$> get) >>= \case - True -> return [] - False -> - do - -- Mark l as visited - modify (NameSet.insert l) - -- Find all children of (l,p) with a permission in the initial ls_ps - let ls_ps' = - mapMaybe (\case - PExpr_Var l' -> (l',) <$> lookup l' ls_ps - _ -> Nothing) - (lownedPermChildren p) - -- Visit all children of (l,p) and return any of them and their - -- recursive children that have not been visited yet - rec_ret <- concat <$> mapM visit ls_ps' - -- Add (l,p) after all of its children - return (rec_ret ++ [(l,p)]) - --- | Test if a list of permissions that might be in a lifetime ownership --- permission (so not a lifetime permission) could help prove a permission on an --- expression in a binding -lownedPermsCouldProve1 :: CruCtx ctx -> ExprPerms ps_l -> - Mb ctx (ExprAndPerm a) -> Bool -lownedPermsCouldProve1 ctx ps_l (mbMapCl $(mkClosed [| exprPermVarAndPerm |]) -> - [nuP| Just (VarAndPerm mb_x mb_p) |]) - | Right x <- mbNameBoundP mb_x = - mbRangeFTsCouldCoverPart (concatMap getOffsets $ exprPermsForVar x ps_l) $ - mbGetOffsets ctx mb_p -lownedPermsCouldProve1 _ _ _ = False - --- | Test if a list of permissions that might be in a lifetime ownership --- permission (so not a lifetime permission) could help prove any of a list of --- permissions on expressions in a binding -lownedPermsCouldProve :: CruCtx ctx -> ExprPerms ps_l -> - Mb ctx (ExprPerms ps_r) -> Bool -lownedPermsCouldProve ctx lops = - or . RL.mapToList (lownedPermsCouldProve1 ctx lops . getCompose) . mbRAssign - --- | Find all lifetimes with ownership permissions in an 'ExprPerms' -lownedsInExprPerms :: ExprPerms ps -> [ExprVar LifetimeType] -lownedsInExprPerms = - catMaybes . RL.mapToList - (\case - ExprAndPerm (PExpr_Var l) (ValPerm_Conj ps) - | Refl:_ <- mapMaybe isLifetimeOwnershipPerm ps -> Just l - _ -> Nothing) - --- | Find all lifetimes with ownership permissions in an 'ExprPerms' in binding -lownedsInMbExprPerms :: Mb (ctx :: RList CrucibleType) (ExprPerms ps) -> - [ExprVar LifetimeType] -lownedsInMbExprPerms mb_ps = - mapMaybe (\case - (mbNameBoundP -> Right l) -> Just l - _ -> Nothing) $ - mbList $ mbMapCl $(mkClosed [| lownedsInExprPerms |]) mb_ps - --- | Find all lifetimes with ownership permissions in a 'DistPerms' in binding -lownedsInMbDistPerms :: Mb ctx (DistPerms ps) -> [ExprVar LifetimeType] -lownedsInMbDistPerms = - catMaybes . RL.mapToList - (\case - Compose [nuP| VarAndPerm mb_l (ValPerm_Conj1 mb_p) |] - | Just Refl - <- mbLift $ mbMapCl $(mkClosed [| isLifetimeOwnershipPerm |]) mb_p - , Right l <- mbNameBoundP mb_l -> Just l - _ -> Nothing) - . mbRAssign - -{- --- | Convert a 'FunPerm' in a name-binding to a 'FunPerm' that takes those bound --- names as additional ghost arguments with the supplied input permissions and --- no output permissions -mbFunPerm :: CruCtx ctx -> Mb ctx (ValuePerms ctx) -> - Mb ctx (FunPerm ghosts args gouts ret) -> - FunPerm (ctx :++: ghosts) args gouts ret -mbFunPerm ctx mb_ps (mbMatch -> - [nuMP| FunPerm mb_ghosts mb_args - mb_gouts mb_ret ps_in ps_out |]) = - let ghosts = mbLift mb_ghosts - args = mbLift mb_args - ctx_perms = trueValuePerms $ cruCtxToTypes ctx - args_prxs = cruCtxProxies args - ghosts_prxs = cruCtxProxies ghosts - gouts_prxs = cruCtxProxies gouts - prxs_in = RL.append ghosts_prxs args_prxs - prxs_out = - RL.append ghosts_prxs $ RL.append args_prxs gouts_prxs :>: Proxy in - case RL.appendAssoc ctx ghosts arg_types of - Refl -> - FunPerm (appendCruCtx ctx ghosts) args (mbLift mb_gouts) (mbLift mb_ret) - (mbCombine prxs_in $ - mbMap2 (\ps mb_ps_in -> fmap (RL.append ps) mb_ps_in) mb_ps ps_in) - (fmap (RL.append ctx_perms) $ - mbCombine prxs_out ps_out) --} - --- | Substitute ghost and regular arguments into a function permission to get --- its input permissions for those arguments, where ghost arguments are given --- both as variables and expressions to which those variables are instantiated. --- For a 'FunPerm' of the form @(gctx). xs:ps -o xs:ps'@, return --- --- > [gs/gctx]xs : [gexprs/gctx]ps, g1:eq(gexpr1), ..., gm:eq(gexprm) -funPermDistIns :: FunPerm ghosts args gouts ret -> RAssign Name ghosts -> - PermExprs ghosts -> RAssign Name args -> - DistPerms ((ghosts :++: args) :++: ghosts) -funPermDistIns fun_perm ghosts gexprs args = - appendDistPerms - (valuePermsToDistPerms (RL.append ghosts args) $ - subst (appendSubsts (substOfExprs gexprs) (substOfVars args)) $ - funPermIns fun_perm) - (eqDistPerms ghosts gexprs) - --- | Substitute ghost and regular arguments into a function permission to get --- its input permissions for those arguments, where ghost arguments are given --- both as variables and expressions to which those variables are instantiated. --- For a 'FunPerm' of the form @(gctx). xs:ps -o xs:ps'@, return --- --- > [gs/gctx]xs : [gexprs/gctx]ps' -funPermDistOuts :: FunPerm ghosts args gouts ret -> RAssign Name ghosts -> - PermExprs ghosts -> RAssign Name args -> - RAssign Name (gouts :> ret) -> - DistPerms ((ghosts :++: args) :++: gouts :> ret) -funPermDistOuts fun_perm ghosts gexprs args gouts_ret = - valuePermsToDistPerms (RL.append (RL.append ghosts args) gouts_ret) $ - subst (appendSubsts - (appendSubsts (substOfExprs gexprs) (substOfVars args)) - (substOfVars gouts_ret)) $ - funPermOuts fun_perm - --- | Unfold a recursive permission given a 'RecPerm' for it -unfoldRecPerm :: RecPerm b reach args a -> PermExprs args -> PermOffset a -> - ValuePerm a -unfoldRecPerm rp args off = - let p = ValPerm_Named (recPermName rp) args NoPermOffset in - offsetPerm off $ subst (substOfExprs (args :>: PExpr_ValPerm p)) $ - recPermBody rp - --- | Unfold a defined permission given arguments -unfoldDefinedPerm :: DefinedPerm b args a -> PermExprs args -> - PermOffset a -> ValuePerm a -unfoldDefinedPerm dp args off = - offsetPerm off $ subst (substOfExprs args) (definedPermDef dp) - --- | Unfold a named permission as long as it is unfoldable -unfoldPerm :: NameSortCanFold ns ~ 'True => NamedPerm ns args a -> - PermExprs args -> PermOffset a -> ValuePerm a -unfoldPerm (NamedPerm_Defined dp) = unfoldDefinedPerm dp -unfoldPerm (NamedPerm_Rec rp) = unfoldRecPerm rp - --- | Unfold a unfoldable conjunctive named permission to a list of conjuncts -unfoldConjPerm :: NameSortIsConj ns ~ 'True => NameSortCanFold ns ~ 'True => - NamedPerm ns args a -> PermExprs args -> PermOffset a -> - [AtomicPerm a] -unfoldConjPerm npn args off - | ValPerm_Conj conjs <- unfoldPerm npn args off = conjs -unfoldConjPerm npn args off - | ValPerm_Named npn' args' off' <- unfoldPerm npn args off - , TrueRepr <- nameIsConjRepr npn' = - [Perm_NamedConj npn' args' off'] -unfoldConjPerm _ _ _ = - panic "unfoldConjPerm" ["unfoldPerm did not produce a Conj"] - --- | Test if two expressions are definitely unequal -exprsUnequal :: PermExpr a -> PermExpr a -> Bool -exprsUnequal (PExpr_Var _) _ = False -exprsUnequal (PExpr_Bool b1) (PExpr_Bool b2) = b1 /= b2 -exprsUnequal (PExpr_Nat n1) (PExpr_Nat n2) = n1 /= n2 -exprsUnequal (PExpr_String str1) (PExpr_String str2) = str1 /= str2 -exprsUnequal e1@(PExpr_BV _ _) e2 = not $ bvCouldEqual e1 e2 -{- FIXME: we need to prove the types are equal on both sides for this case: -exprsUnequal (PExpr_Struct es1) (PExpr_Struct es2) = - any $ mapToList2 exprsUnequal es1 es2 --} -exprsUnequal _ _ = - -- FIXME: maybe we want more cases for shapes and even function handles, - -- though those shouldn't matter for the current uses of exprsUnequal - False - --- | Generic function to get free variables -class FreeVars a where - freeVars :: a -> NameSet CrucibleType - --- | Get the free variables of an expression as an 'RAssign' -freeVarsRAssign :: FreeVars a => a -> Some (RAssign ExprVar) -freeVarsRAssign = - foldl (\(Some ns) (SomeName n) -> Some (ns :>: n)) (Some MNil) . toList . freeVars - --- | Get the bound variables of an expression or permission -boundVars :: (NuMatching a, FreeVars a) => Mb (ctx :: RList CrucibleType) a -> - [Some @CrucibleType (Member ctx)] -boundVars mb_a = - mapMaybe (\case - [nuP| SomeName mb_n |] - | Left memb <- mbNameBoundP mb_n -> Just (Some memb) - _ -> Nothing) $ - mbList $ mbMapCl $(mkClosed [| toList . freeVars |]) mb_a - -instance FreeVars a => FreeVars (Maybe a) where - freeVars = maybe NameSet.empty freeVars - -instance FreeVars a => FreeVars [a] where - freeVars = foldr (NameSet.union . freeVars) NameSet.empty - -instance (FreeVars a, FreeVars b) => FreeVars (a,b) where - freeVars (a,b) = NameSet.union (freeVars a) (freeVars b) - -instance FreeVars a => FreeVars (Mb ctx a) where - freeVars = NameSet.liftNameSet . fmap freeVars - -instance FreeVars (PermExpr a) where - freeVars (PExpr_Var x) = NameSet.singleton x - freeVars PExpr_Unit = NameSet.empty - freeVars (PExpr_Bool _) = NameSet.empty - freeVars (PExpr_Nat _) = NameSet.empty - freeVars (PExpr_String _) = NameSet.empty - freeVars (PExpr_BV factors _) = freeVars factors - freeVars (PExpr_Struct elems) = freeVars elems - freeVars PExpr_Always = NameSet.empty - freeVars (PExpr_LLVMWord e) = freeVars e - freeVars (PExpr_LLVMOffset ptr off) = - NameSet.insert ptr (freeVars off) - freeVars (PExpr_Fun _) = NameSet.empty - freeVars PExpr_PermListNil = NameSet.empty - freeVars (PExpr_PermListCons _ e p l) = - NameSet.unions [freeVars e, freeVars p, freeVars l] - freeVars (PExpr_RWModality _) = NameSet.empty - freeVars PExpr_EmptyShape = NameSet.empty - freeVars (PExpr_NamedShape rw l nmsh args) = - NameSet.unions [freeVars rw, freeVars l, freeVars nmsh, freeVars args] - freeVars (PExpr_EqShape len b) = NameSet.union (freeVars len) (freeVars b) - 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 _ sh) = - NameSet.union (freeVars len) (freeVars sh) - freeVars (PExpr_TupShape sh) = freeVars sh - freeVars (PExpr_SeqShape sh1 sh2) = - NameSet.union (freeVars sh1) (freeVars sh2) - freeVars (PExpr_OrShape sh1 sh2) = - NameSet.union (freeVars sh1) (freeVars sh2) - freeVars (PExpr_ExShape mb_sh) = NameSet.liftNameSet $ fmap freeVars mb_sh - freeVars PExpr_FalseShape = NameSet.empty - freeVars (PExpr_ValPerm p) = freeVars p - -instance FreeVars (BVFactor w) where - freeVars (BVFactor _ x) = NameSet.singleton x - -instance FreeVars (PermExprs as) where - freeVars PExprs_Nil = NameSet.empty - freeVars (PExprs_Cons es e) = NameSet.union (freeVars es) (freeVars e) - -instance FreeVars (LLVMFieldShape w) where - freeVars (LLVMFieldShape p) = freeVars p - -instance FreeVars (BVRange w) where - freeVars (BVRange off len) = NameSet.union (freeVars off) (freeVars len) - -instance FreeVars (BVProp w) where - freeVars (BVProp_Eq e1 e2) = NameSet.union (freeVars e1) (freeVars e2) - freeVars (BVProp_Neq e1 e2) = NameSet.union (freeVars e1) (freeVars e2) - freeVars (BVProp_ULt e1 e2) = NameSet.union (freeVars e1) (freeVars e2) - freeVars (BVProp_ULeq e1 e2) = NameSet.union (freeVars e1) (freeVars e2) - freeVars (BVProp_ULeq_Diff e1 e2 e3) = - NameSet.unions [freeVars e1, freeVars e2, freeVars e3] - -instance FreeVars (AtomicPerm tp) where - freeVars (Perm_LLVMField fp) = freeVars fp - freeVars (Perm_LLVMArray ap) = freeVars ap - freeVars (Perm_LLVMBlock bp) = freeVars bp - freeVars (Perm_LLVMFree e) = freeVars e - freeVars (Perm_LLVMFunPtr _ fun_perm) = freeVars fun_perm - freeVars Perm_IsLLVMPtr = NameSet.empty - freeVars (Perm_LLVMBlockShape sh) = freeVars sh - freeVars (Perm_LLVMFrame fperms) = freeVars $ map fst fperms - freeVars (Perm_LOwned ls _ _ ps_in ps_out) = - NameSet.unions [freeVars ls, freeVars ps_in, freeVars ps_out] - freeVars (Perm_LOwnedSimple _ lops) = freeVars lops - freeVars (Perm_LCurrent l) = freeVars l - freeVars Perm_LFinished = NameSet.empty - freeVars (Perm_Struct ps) = NameSet.unions $ RL.mapToList freeVars ps - freeVars (Perm_Fun fun_perm) = freeVars fun_perm - freeVars (Perm_BVProp prop) = freeVars prop - freeVars Perm_Any = NameSet.empty - freeVars (Perm_NamedConj _ args off) = - NameSet.union (freeVars args) (freeVars off) - -instance FreeVars (ValuePerm tp) where - freeVars (ValPerm_Eq e) = freeVars e - freeVars (ValPerm_Or p1 p2) = NameSet.union (freeVars p1) (freeVars p2) - freeVars (ValPerm_Exists mb_p) = - NameSet.liftNameSet $ fmap freeVars mb_p - freeVars (ValPerm_Named _ args off) = - NameSet.union (freeVars args) (freeVars off) - freeVars (ValPerm_Var x off) = NameSet.insert x $ freeVars off - freeVars (ValPerm_Conj ps) = freeVars ps - freeVars ValPerm_False = NameSet.empty - -instance FreeVars (ValuePerms tps) where - freeVars ValPerms_Nil = NameSet.empty - freeVars (ValPerms_Cons ps p) = NameSet.union (freeVars ps) (freeVars p) - -instance FreeVars (DistPerms tps) where - freeVars dperms = - NameSet.unions $ - RL.mapToList (\(VarAndPerm x p) -> NameSet.insert x (freeVars p)) dperms - -instance FreeVars (ExprPerms tps) where - freeVars eps = - NameSet.unions $ - RL.mapToList (\(ExprAndPerm e p) -> NameSet.union (freeVars e) (freeVars p)) eps - -instance FreeVars (LLVMFieldPerm w sz) where - freeVars (LLVMFieldPerm {..}) = - NameSet.unions [freeVars llvmFieldRW, freeVars llvmFieldLifetime, - freeVars llvmFieldOffset, freeVars llvmFieldContents] - -instance FreeVars (LLVMArrayPerm w) where - freeVars (LLVMArrayPerm {..}) = - NameSet.unions [freeVars llvmArrayRW, - freeVars llvmArrayLifetime, - freeVars llvmArrayOffset, - freeVars llvmArrayLen, - freeVars llvmArrayCellShape, - freeVars llvmArrayBorrows] - -instance FreeVars (LLVMArrayIndex w) where - freeVars (LLVMArrayIndex cell _) = freeVars cell - -instance FreeVars (LLVMArrayBorrow w) where - freeVars (FieldBorrow ix) = freeVars ix - freeVars (RangeBorrow rng) = freeVars rng - -instance FreeVars (LLVMBlockPerm w) where - freeVars (LLVMBlockPerm rw l off len sh) = - NameSet.unions [freeVars rw, freeVars l, freeVars off, - freeVars len, freeVars sh] - -instance FreeVars (PermOffset tp) where - freeVars NoPermOffset = NameSet.empty - freeVars (LLVMPermOffset e) = freeVars e - -instance FreeVars (FunPerm ghosts args gouts ret) where - freeVars (FunPerm _ _ _ _ perms_in perms_out) = - NameSet.union - (NameSet.liftNameSet $ fmap freeVars perms_in) - (NameSet.liftNameSet $ fmap freeVars perms_out) - -instance FreeVars (NamedShape b args w) where - freeVars (NamedShape _ _ body) = freeVars body - -instance FreeVars (NamedShapeBody b args w) where - freeVars (DefinedShapeBody mb_sh) = freeVars mb_sh - freeVars (OpaqueShapeBody mb_len _ _) = freeVars mb_len - freeVars (RecShapeBody mb_sh _ _) = freeVars mb_sh - - --- | Find all equality permissions @eq(e)@ contained in another permission -class ContainedEqVars a where - containedEqVars :: a -> NameSet CrucibleType - -instance ContainedEqVars (ValuePerm a) where - containedEqVars (ValPerm_Eq e) = freeVars e - containedEqVars (ValPerm_Or p1 p2) = - NameSet.union (containedEqVars p1) (containedEqVars p2) - containedEqVars (ValPerm_Exists mb_p) = - NameSet.liftNameSet $ fmap containedEqVars mb_p - containedEqVars (ValPerm_Named _ _ _) = - -- FIXME: we should probably unfold named permissions here... - NameSet.empty - containedEqVars (ValPerm_Var _ _) = NameSet.empty - containedEqVars (ValPerm_Conj ps) = NameSet.unions $ map containedEqVars ps - containedEqVars ValPerm_False = NameSet.empty - -instance ContainedEqVars (AtomicPerm a) where - containedEqVars (Perm_LLVMField fp) = containedEqVars (llvmFieldContents fp) - containedEqVars (Perm_LLVMArray ap) = containedEqVars (llvmArrayCellShape ap) - containedEqVars (Perm_LLVMBlock bp) = containedEqVars (llvmBlockShape bp) - containedEqVars (Perm_LLVMBlockShape sh) = containedEqVars sh - containedEqVars _ = NameSet.empty - -instance ContainedEqVars (PermExpr (LLVMShapeType w)) where - containedEqVars (PExpr_Var _) = NameSet.empty - containedEqVars PExpr_EmptyShape = NameSet.empty - containedEqVars (PExpr_NamedShape _ _ nmsh@(NamedShape _ _ - (DefinedShapeBody _)) args) = - containedEqVars (unfoldNamedShape nmsh args) - containedEqVars (PExpr_NamedShape _ _ (NamedShape _ _ - (OpaqueShapeBody _ _ _)) _) = - NameSet.empty - containedEqVars (PExpr_NamedShape _ _ (NamedShape _ _ - (RecShapeBody mb_sh _ _)) args) = - -- NOTE: we unfold the shape with the empty shape substituted for recursive - -- occurrences of the shape name, to avoid an infinite loop - containedEqVars $ subst (substOfExprs (args :>: PExpr_EmptyShape)) mb_sh - containedEqVars (PExpr_EqShape _ blk) = freeVars blk - containedEqVars (PExpr_PtrShape _ _ sh) = containedEqVars sh - containedEqVars (PExpr_FieldShape (LLVMFieldShape p)) = containedEqVars p - containedEqVars (PExpr_ArrayShape _ _ sh) = containedEqVars sh - containedEqVars (PExpr_TupShape sh) = containedEqVars sh - containedEqVars (PExpr_SeqShape sh1 sh2) = - NameSet.union (containedEqVars sh1) (containedEqVars sh2) - containedEqVars (PExpr_OrShape sh1 sh2) = - NameSet.union (containedEqVars sh1) (containedEqVars sh2) - containedEqVars (PExpr_ExShape mb_sh) = - NameSet.liftNameSet $ fmap containedEqVars mb_sh - containedEqVars PExpr_FalseShape = NameSet.empty - - --- | Test if an expression @e@ is a /determining/ expression, meaning that --- proving @x:eq(e)@ will necessarily determine the values of the free variables --- of @e@ in the sense of 'determinedVars'. -isDeterminingExpr :: PermExpr a -> Bool -isDeterminingExpr (PExpr_Var _) = True -isDeterminingExpr (PExpr_LLVMWord e) = isDeterminingExpr e -isDeterminingExpr (PExpr_BV [BVFactor _ _] _) = - -- A linear expression N*x + M lets you solve for x when it is possible - True -isDeterminingExpr (PExpr_ValPerm (ValPerm_Eq e)) = isDeterminingExpr e -isDeterminingExpr (PExpr_LLVMOffset _ off) = isDeterminingExpr off -isDeterminingExpr e = - -- If an expression has no free variables then it vacuously determines all of - -- its free variables - NameSet.null $ freeVars e - -- FIXME: consider adding a case for y &+ e - --- | Generic function to compute the /needed/ variables of a permission, meaning --- those whose values must be determined before that permission can be --- proved. This includes, e.g., all the offsets and lengths of field and array --- permissions. -class NeededVars a where - neededVars :: a -> NameSet CrucibleType - -instance NeededVars a => NeededVars [a] where - neededVars as = NameSet.unions $ map neededVars as - -instance NeededVars (PermExpr a) where - -- FIXME: need a better explanation of why this is the right answer... - neededVars e = if isDeterminingExpr e then NameSet.empty else freeVars e - -instance NeededVars (PermExprs args) where - neededVars PExprs_Nil = NameSet.empty - neededVars (PExprs_Cons es e) = NameSet.union (neededVars es) (neededVars e) - -instance NeededVars (ValuePerm a) where - neededVars (ValPerm_Eq e) = neededVars e - neededVars (ValPerm_Or p1 p2) = NameSet.union (neededVars p1) (neededVars p2) - neededVars (ValPerm_Exists mb_p) = NameSet.liftNameSet $ fmap neededVars mb_p - neededVars (ValPerm_Named name args offset) - | OpaqueSortRepr _ <- namedPermNameSort name = - NameSet.union (neededVars args) (freeVars offset) - -- FIXME: for non-opaque named permissions, we currently define the - -- @neededVars@ as all free variables of @p@, but this is incorrect for - -- defined or recursive permissions that do determine their variable arguments - -- when unfolded. - neededVars p@(ValPerm_Named _ _ _) = freeVars p - neededVars p@(ValPerm_Var _ _) = freeVars p - neededVars (ValPerm_Conj ps) = neededVars ps - neededVars ValPerm_False = NameSet.empty - -instance NeededVars (AtomicPerm a) where - neededVars (Perm_LLVMField fp) = neededVars fp - neededVars (Perm_LLVMArray ap) = neededVars ap - neededVars (Perm_LLVMBlock bp) = neededVars bp - neededVars (Perm_LLVMBlockShape _) = NameSet.empty - neededVars p@(Perm_LOwned _ _ _ _ _) = freeVars p - neededVars (Perm_LOwnedSimple _ ps) = neededVars $ RL.map exprAndPermPerm ps - neededVars p = freeVars p - -instance NeededVars (LLVMFieldPerm w sz) where - neededVars (LLVMFieldPerm {..}) = - NameSet.unions [freeVars llvmFieldOffset, neededVars llvmFieldRW, - neededVars llvmFieldLifetime, neededVars llvmFieldContents] - -instance NeededVars (LLVMArrayPerm w) where - neededVars (LLVMArrayPerm {..}) = - NameSet.unions [neededVars llvmArrayRW, neededVars llvmArrayLifetime, - freeVars llvmArrayOffset, freeVars llvmArrayLen, - freeVars llvmArrayBorrows, neededVars llvmArrayCellShape] - -instance NeededVars (LLVMBlockPerm w) where - neededVars (LLVMBlockPerm {..}) = - NameSet.unions [neededVars llvmBlockRW, neededVars llvmBlockLifetime, - freeVars llvmBlockOffset, freeVars llvmBlockLen] - -instance NeededVars (ValuePerms as) where - neededVars = - foldValuePerms (\vars p -> - NameSet.union vars (neededVars p)) NameSet.empty - -instance NeededVars (DistPerms as) where - neededVars = - foldDistPerms (\vars _ p -> - NameSet.union vars (neededVars p)) NameSet.empty - - --- | Change all pointer shapes that are associated with the current lifetime of --- that shape (i.e., that are not inside a pointer shape with an explicit --- lifetime) to 'PExpr_Read'. -readOnlyShape :: PermExpr (LLVMShapeType w) -> PermExpr (LLVMShapeType w) -readOnlyShape e@(PExpr_Var _) = e -readOnlyShape PExpr_EmptyShape = PExpr_EmptyShape -readOnlyShape (PExpr_NamedShape _ l nmsh args) = - PExpr_NamedShape (Just PExpr_Read) l nmsh args -readOnlyShape e@(PExpr_EqShape _ _) = e -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 (PExpr_ArrayShape len stride sh) = - PExpr_ArrayShape len stride $ readOnlyShape sh -readOnlyShape (PExpr_TupShape sh) = PExpr_TupShape (readOnlyShape sh) -readOnlyShape (PExpr_SeqShape sh1 sh2) = - PExpr_SeqShape (readOnlyShape sh1) (readOnlyShape sh2) -readOnlyShape (PExpr_OrShape sh1 sh2) = - PExpr_OrShape (readOnlyShape sh1) (readOnlyShape sh2) -readOnlyShape (PExpr_ExShape mb_sh) = - PExpr_ExShape $ fmap readOnlyShape mb_sh -readOnlyShape PExpr_FalseShape = PExpr_FalseShape - - ----------------------------------------------------------------------- --- * Generalized Substitution ----------------------------------------------------------------------- - --- FIXME: these two EFQ proofs may no longer be needed...? -noTypesInExprCtx :: forall (ctx :: RList CrucibleType) (a :: Type) b. - Member ctx a -> b -noTypesInExprCtx (Member_Step ctx) = noTypesInExprCtx ctx - -noExprsInTypeCtx :: forall (ctx :: RList Type) (a :: CrucibleType) b. - Member ctx a -> b -noExprsInTypeCtx (Member_Step ctx) = noExprsInTypeCtx ctx --- No case for Member_Base - --- | Defines a substitution type @s@ that supports substituting into expression --- and permission variables in a given monad @m@ -class MonadBind m => SubstVar s m | s -> m where - extSubst :: s ctx -> ExprVar a -> s (ctx :> a) - substExprVar :: s ctx -> Mb ctx (ExprVar a) -> m (PermExpr a) - -substPermVar :: SubstVar s m => s ctx -> Mb ctx (PermVar a) -> m (ValuePerm a) -substPermVar s mb_x = - substExprVar s mb_x >>= \e -> - case e of - PExpr_Var x -> return $ ValPerm_Var x NoPermOffset - PExpr_ValPerm p -> return p - --- | Extend a substitution with 0 or more variables -extSubstMulti :: SubstVar s m => s ctx -> RAssign ExprVar ctx' -> - s (ctx :++: ctx') -extSubstMulti s MNil = s -extSubstMulti s (xs :>: x) = extSubst (extSubstMulti s xs) x - --- | Generalized notion of substitution, which says that substitution type @s@ --- supports substituting into type @a@ in monad @m@ --- --- FIXME: the 'Mb' argument should really be a 'MatchedMb', to emphasize that we --- expect it to be in fresh pair form -class SubstVar s m => Substable s a m where - genSubst :: s ctx -> Mb ctx a -> m a - --- | A version of 'Substable' for type functors -class SubstVar s m => Substable1 s f m where - genSubst1 :: s ctx -> Mb ctx (f a) -> m (f a) - -instance SubstVar s m => Substable s Integer m where - genSubst _ mb_i = return $ mbLift mb_i - -instance (NuMatching a, Substable s a m) => Substable s [a] m where - genSubst s as = mapM (genSubst s) (mbList as) - -instance (NuMatching a, Substable s a m) => Substable s (NonEmpty a) m where - genSubst s (mbMatch -> [nuMP| x :| xs |]) = - (:|) <$> genSubst s x <*> genSubst s xs - -instance (NuMatching a, NuMatching b, - Substable s a m, Substable s b m) => Substable s (a,b) m where - genSubst s [nuP| (a,b) |] = (,) <$> genSubst s a <*> genSubst s b - -instance (NuMatching a, NuMatching b, NuMatching c, Substable s a m, - Substable s b m, Substable s c m) => Substable s (a,b,c) m where - genSubst s [nuP| (a,b,c) |] = - (,,) <$> genSubst s a <*> genSubst s b <*> genSubst s c - -instance (NuMatching a, NuMatching b, NuMatching c, NuMatching d, - Substable s a m, Substable s b m, - Substable s c m, Substable s d m) => Substable s (a,b,c,d) m where - genSubst s [nuP| (a,b,c,d) |] = - (,,,) <$> genSubst s a <*> genSubst s b <*> genSubst s c <*> genSubst s d - -instance (NuMatching a, Substable s a m) => Substable s (Maybe a) m where - genSubst s mb_x = case mbMatch mb_x of - [nuMP| Just a |] -> Just <$> genSubst s a - [nuMP| Nothing |] -> return Nothing - -instance {-# INCOHERENT #-} (Given (RAssign Proxy (ctx :: RList CrucibleType)), - Substable s a m, NuMatching a) => - Substable s (Mb ctx a) m where - genSubst = genSubstMb given - -instance {-# INCOHERENT #-} - (Substable s a m, NuMatching a) => - Substable s (Mb (RNil :: RList CrucibleType) a) m where - genSubst = genSubstMb RL.typeCtxProxies - -instance {-# INCOHERENT #-} (Substable s a m, NuMatching a) => - Substable s (Binding (c :: CrucibleType) a) m where - genSubst = genSubstMb RL.typeCtxProxies - -genSubstMb :: - Substable s a m => - NuMatching a => - RAssign Proxy (ctx :: RList CrucibleType) -> - s ctx' -> Mb ctx' (Mb ctx a) -> m (Mb ctx a) -genSubstMb p s mbmb = - mbM $ nuMulti p $ \ns -> genSubst (extSubstMulti s ns) (mbCombine p mbmb) - - -instance {-# INCOHERENT #-} (Given (RAssign Proxy ctx), - Substable s a m, NuMatching a) => - Substable s (NamedMb ctx a) m where - genSubst = genSubstNamedMb given - -instance {-# INCOHERENT #-} (Substable s a m, NuMatching a) => - Substable s (NamedMb RNil a) m where - genSubst = genSubstNamedMb RL.typeCtxProxies - -instance {-# INCOHERENT #-} (Substable s a m, NuMatching a) => - Substable s (NamedBinding c a) m where - genSubst = genSubstNamedMb RL.typeCtxProxies - -genSubstNamedMb :: - Substable s a m => - NuMatching a => - RAssign Proxy ctx -> - s ctx' -> Mb ctx' (NamedMb ctx a) -> m (NamedMb ctx a) -genSubstNamedMb p s mbmb = mbMNamed (fmap (genSubst s) (mbSink p mbmb)) - -instance SubstVar s m => Substable s (Member ctx a) m where - genSubst _ mb_memb = return $ mbLift mb_memb - -instance SubstVar s m => Substable s (TypeRepr a) m where - genSubst _ mb_tp = return $ mbLift mb_tp - -instance SubstVar s m => Substable s (CruCtx ctx) m where - genSubst _ mb_ctx = return $ mbLift mb_ctx - -instance (NuMatchingAny1 f, Substable1 s f m) => - Substable s (RAssign f ctx) m where - genSubst s mb_xs = case mbMatch mb_xs of - [nuMP| MNil |] -> return MNil - [nuMP| xs :>: x |] -> (:>:) <$> genSubst s xs <*> genSubst1 s x - -instance (NuMatchingAny1 f, Substable1 s f m) => - Substable1 s (RAssign f) m where - genSubst1 = genSubst - -instance (NuMatchingAny1 f, Substable1 s f m) => - Substable s (Assignment f ctx) m where - genSubst s mb_assign = - case mbMatch $ fmap viewAssign mb_assign of - [nuMP| AssignEmpty |] -> return $ Ctx.empty - [nuMP| AssignExtend asgn' x |] -> - Ctx.extend <$> genSubst s asgn' <*> genSubst1 s x - -instance SubstVar s m => Substable s (a :~: b) m where - genSubst _ = return . mbLift - -instance SubstVar s m => Substable1 s ((:~:) a) m where - genSubst1 _ = return . mbLift - --- | Helper function to substitute into 'BVFactor's -substBVFactor :: SubstVar s m => s ctx -> Mb ctx (BVFactor w) -> - m (PermExpr (BVType w)) -substBVFactor s (mbMatch -> [nuMP| BVFactor (BV.BV i) x |]) = - bvMult (mbLift i) <$> substExprVar s x - -instance SubstVar s m => - Substable s (NatRepr n) m where - genSubst _ = return . mbLift - -instance SubstVar PermVarSubst m => - Substable PermVarSubst (ExprVar a) m where - genSubst s mb_x = return $ varSubstVar s mb_x - -instance SubstVar PermVarSubst m => Substable1 PermVarSubst ExprVar m where - genSubst1 = genSubst - -instance SubstVar s m => Substable s (PermExpr a) m where - genSubst s mb_expr = case mbMatch mb_expr of - [nuMP| PExpr_Var x |] -> substExprVar s x - [nuMP| PExpr_Unit |] -> return $ PExpr_Unit - [nuMP| PExpr_Bool b |] -> return $ PExpr_Bool $ mbLift b - [nuMP| PExpr_Nat n |] -> return $ PExpr_Nat $ mbLift n - [nuMP| PExpr_String str |] -> return $ PExpr_String $ mbLift str - [nuMP| PExpr_BV factors off |] -> - foldr bvAdd (PExpr_BV [] (mbLift off)) <$> - mapM (substBVFactor s) (mbList factors) - [nuMP| PExpr_Struct args |] -> - PExpr_Struct <$> genSubst s args - [nuMP| PExpr_Always |] -> return PExpr_Always - [nuMP| PExpr_LLVMWord e |] -> - PExpr_LLVMWord <$> genSubst s e - [nuMP| PExpr_LLVMOffset x off |] -> - addLLVMOffset <$> substExprVar s x <*> genSubst s off - [nuMP| PExpr_Fun fh |] -> - return $ PExpr_Fun $ mbLift fh - [nuMP| PExpr_PermListNil |] -> - return $ PExpr_PermListNil - [nuMP| PExpr_PermListCons tp e p l |] -> - PExpr_PermListCons (mbLift tp) <$> genSubst s e <*> genSubst s p - <*> genSubst s l - [nuMP| PExpr_RWModality rw |] -> - return $ PExpr_RWModality $ mbLift rw - [nuMP| PExpr_EmptyShape |] -> return PExpr_EmptyShape - [nuMP| PExpr_NamedShape rw l nmsh args |] -> - PExpr_NamedShape <$> genSubst s rw <*> genSubst s l <*> genSubst s nmsh - <*> genSubst s args - [nuMP| PExpr_EqShape len b |] -> - PExpr_EqShape <$> genSubst s len <*> genSubst s b - [nuMP| PExpr_PtrShape maybe_rw maybe_l sh |] -> - PExpr_PtrShape <$> genSubst s maybe_rw <*> genSubst s maybe_l - <*> genSubst s sh - [nuMP| PExpr_FieldShape sh |] -> - PExpr_FieldShape <$> genSubst s sh - [nuMP| PExpr_ArrayShape len stride sh |] -> - PExpr_ArrayShape <$> genSubst s len <*> return (mbLift stride) - <*> genSubst s sh - [nuMP| PExpr_TupShape sh |] -> PExpr_TupShape <$> genSubst s sh - [nuMP| PExpr_SeqShape sh1 sh2 |] -> - PExpr_SeqShape <$> genSubst s sh1 <*> genSubst s sh2 - [nuMP| PExpr_OrShape sh1 sh2 |] -> - PExpr_OrShape <$> genSubst s sh1 <*> genSubst s sh2 - [nuMP| PExpr_ExShape mb_sh |] -> - PExpr_ExShape <$> genSubstMb RL.typeCtxProxies s mb_sh - [nuMP| PExpr_FalseShape |] -> return PExpr_FalseShape - [nuMP| PExpr_ValPerm p |] -> - PExpr_ValPerm <$> genSubst s p - -instance SubstVar s m => Substable1 s PermExpr m where - genSubst1 = genSubst - -instance SubstVar s m => Substable s (BVRange w) m where - genSubst s (mbMatch -> [nuMP| BVRange e1 e2 |]) = - BVRange <$> genSubst s e1 <*> genSubst s e2 - -instance SubstVar s m => Substable s (MbRangeForType a) m where - genSubst s (mbMatch -> [nuMP| MbRangeForLLVMType vars rw l rng |]) = - MbRangeForLLVMType (mbLift vars) <$> - genSubstMb (cruCtxProxies $ mbLift vars) s rw <*> - genSubstMb (cruCtxProxies $ mbLift vars) s l <*> - genSubstMb (cruCtxProxies $ mbLift vars) s rng - -instance SubstVar s m => Substable s (BVProp w) m where - genSubst s mb_prop = case mbMatch mb_prop of - [nuMP| BVProp_Eq e1 e2 |] -> - BVProp_Eq <$> genSubst s e1 <*> genSubst s e2 - [nuMP| BVProp_Neq e1 e2 |] -> - BVProp_Neq <$> genSubst s e1 <*> genSubst s e2 - [nuMP| BVProp_ULt e1 e2 |] -> - BVProp_ULt <$> genSubst s e1 <*> genSubst s e2 - [nuMP| BVProp_ULeq e1 e2 |] -> - BVProp_ULeq <$> genSubst s e1 <*> genSubst s e2 - [nuMP| BVProp_ULeq_Diff e1 e2 e3 |] -> - BVProp_ULeq_Diff <$> genSubst s e1 <*> genSubst s e2 <*> genSubst s e3 - -instance SubstVar s m => Substable s (AtomicPerm a) m where - genSubst s mb_p = case mbMatch mb_p of - [nuMP| Perm_LLVMField fp |] -> Perm_LLVMField <$> genSubst s fp - [nuMP| Perm_LLVMArray ap |] -> Perm_LLVMArray <$> genSubst s ap - [nuMP| Perm_LLVMBlock bp |] -> Perm_LLVMBlock <$> genSubst s bp - [nuMP| Perm_LLVMFree e |] -> Perm_LLVMFree <$> genSubst s e - [nuMP| Perm_LLVMFunPtr tp p |] -> - Perm_LLVMFunPtr (mbLift tp) <$> genSubst s p - [nuMP| Perm_IsLLVMPtr |] -> return Perm_IsLLVMPtr - [nuMP| Perm_LLVMBlockShape sh |] -> - Perm_LLVMBlockShape <$> genSubst s sh - [nuMP| Perm_LLVMFrame fp |] -> Perm_LLVMFrame <$> genSubst s fp - [nuMP| Perm_LOwned ls tps_in tps_out ps_in ps_out |] -> - Perm_LOwned <$> genSubst s ls <*> return (mbLift tps_in) <*> - return (mbLift tps_out) <*> genSubst s ps_in <*> genSubst s ps_out - [nuMP| Perm_LOwnedSimple tps lops |] -> - Perm_LOwnedSimple (mbLift tps) <$> genSubst s lops - [nuMP| Perm_LCurrent e |] -> Perm_LCurrent <$> genSubst s e - [nuMP| Perm_LFinished |] -> return Perm_LFinished - [nuMP| Perm_Struct tps |] -> Perm_Struct <$> genSubst s tps - [nuMP| Perm_Fun fperm |] -> Perm_Fun <$> genSubst s fperm - [nuMP| Perm_BVProp prop |] -> Perm_BVProp <$> genSubst s prop - [nuMP| Perm_Any |] -> return Perm_Any - [nuMP| Perm_NamedConj n args off |] -> - Perm_NamedConj (mbLift n) <$> genSubst s args <*> genSubst s off - -instance SubstVar s m => Substable s (NamedShape b args w) m where - genSubst s (mbMatch -> [nuMP| NamedShape str args body |]) = - NamedShape (mbLift str) (mbLift args) <$> genSubstNSB (cruCtxProxies (mbLift args)) s body - -genSubstNSB :: - SubstVar s m => - RAssign Proxy args -> - s ctx -> Mb ctx (NamedShapeBody b args w) -> m (NamedShapeBody b args w) -genSubstNSB px s mb_body = case mbMatch mb_body of - [nuMP| DefinedShapeBody mb_sh |] -> - DefinedShapeBody <$> genSubstMb px s mb_sh - [nuMP| OpaqueShapeBody mb_len trans_id desc_id |] -> - OpaqueShapeBody <$> genSubstMb px s mb_len <*> return (mbLift trans_id) - <*> return (mbLift desc_id) - [nuMP| RecShapeBody mb_sh trans_id desc_id |] -> - RecShapeBody <$> genSubstMb (px :>: Proxy) s mb_sh - <*> return (mbLift trans_id) - <*> return (mbLift desc_id) - -instance SubstVar s m => Substable s (NamedPermName ns args a) m where - genSubst _ mb_rpn = return $ mbLift mb_rpn - -instance SubstVar s m => Substable s (PermOffset a) m where - genSubst s mb_off = case mbMatch mb_off of - [nuMP| NoPermOffset |] -> return NoPermOffset - [nuMP| LLVMPermOffset e |] -> mkLLVMPermOffset <$> genSubst s e - -instance SubstVar s m => Substable s (NamedPerm ns args a) m where - genSubst s mb_np = case mbMatch mb_np of - [nuMP| NamedPerm_Opaque p |] -> NamedPerm_Opaque <$> genSubst s p - [nuMP| NamedPerm_Rec p |] -> NamedPerm_Rec <$> genSubst s p - [nuMP| NamedPerm_Defined p |] -> NamedPerm_Defined <$> genSubst s p - -instance SubstVar s m => Substable s (OpaquePerm ns args a) m where - genSubst _ (mbMatch -> [nuMP| OpaquePerm n i1 i2 |]) = - return $ OpaquePerm (mbLift n) (mbLift i1) (mbLift i2) - -instance SubstVar s m => Substable s (RecPerm ns reach args a) m where - genSubst s (mbMatch -> [nuMP| RecPerm rpn dt_i d_i reachMeths body |]) = - let ctx = mbLift (fmap namedPermNameArgs rpn) in - RecPerm (mbLift rpn) (mbLift dt_i) (mbLift d_i) (mbLift reachMeths) <$> - genSubstMb (cruCtxProxies ctx :>: Proxy) s body - -instance SubstVar s m => Substable s (DefinedPerm ns args a) m where - genSubst s (mbMatch -> [nuMP| DefinedPerm n p |]) = - DefinedPerm (mbLift n) <$> genSubstMb (cruCtxProxies (mbLift (fmap namedPermNameArgs n))) s p - -instance SubstVar s m => Substable s (ValuePerm a) m where - genSubst s mb_p = case mbMatch mb_p of - [nuMP| ValPerm_Eq e |] -> ValPerm_Eq <$> genSubst s e - [nuMP| ValPerm_Or p1 p2 |] -> - ValPerm_Or <$> genSubst s p1 <*> genSubst s p2 - [nuMP| ValPerm_Exists p |] -> - -- FIXME: maybe we don't need extSubst at all, but can just use the - -- Substable instance for Mb ctx a from above - ValPerm_Exists <$> genSubstMb RL.typeCtxProxies s p - -- nuM (\x -> genSubst (extSubst s x) $ mbCombine p) - [nuMP| ValPerm_Named n args off |] -> - ValPerm_Named (mbLift n) <$> genSubst s args <*> genSubst s off - [nuMP| ValPerm_Var mb_x mb_off |] -> - offsetPerm <$> genSubst s mb_off <*> substPermVar s mb_x - [nuMP| ValPerm_Conj aps |] -> - ValPerm_Conj <$> mapM (genSubst s) (mbList aps) - [nuMP| ValPerm_False |] -> - pure ValPerm_False - -instance SubstVar s m => Substable1 s ValuePerm m where - genSubst1 = genSubst - -{- -instance SubstVar s m => Substable s (ValuePerms as) m where - genSubst s mb_ps = case mbMatch mb_ps of - [nuMP| ValPerms_Nil |] -> return ValPerms_Nil - [nuMP| ValPerms_Cons ps p |] -> - ValPerms_Cons <$> genSubst s ps <*> genSubst s p --} - -instance SubstVar s m => Substable s RWModality m where - genSubst _ mb_rw = case mbMatch mb_rw of - [nuMP| Write |] -> return Write - [nuMP| Read |] -> return Read - -instance SubstVar s m => Substable s (LLVMFieldPerm w sz) m where - genSubst s (mbMatch -> [nuMP| LLVMFieldPerm rw ls off p |]) = - LLVMFieldPerm <$> genSubst s rw <*> genSubst s ls <*> - genSubst s off <*> genSubst s p - -instance SubstVar s m => Substable s (LLVMArrayPerm w) m where - 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 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 - [nuMP| FieldBorrow ix |] -> FieldBorrow <$> genSubst s ix - [nuMP| RangeBorrow r |] -> RangeBorrow <$> genSubst s r - -instance SubstVar s m => Substable s (LLVMBlockPerm w) m where - genSubst s (mbMatch -> [nuMP| LLVMBlockPerm rw l off len sh |]) = - LLVMBlockPerm <$> genSubst s rw <*> genSubst s l <*> genSubst s off - <*> genSubst s len <*> genSubst s sh - -instance SubstVar s m => Substable s (LLVMFieldShape w) m where - genSubst s (mbMatch -> [nuMP| LLVMFieldShape p |]) = - LLVMFieldShape <$> genSubst s p - -instance SubstVar s m => Substable s (ExprAndPerm a) m where - genSubst s (mbMatch -> [nuMP| ExprAndPerm e p |]) = - ExprAndPerm <$> genSubst s e <*> genSubst s p - -instance SubstVar s m => Substable1 s ExprAndPerm m where - genSubst1 = genSubst - -instance SubstVar s m => Substable s (FunPerm ghosts args gouts ret) m where - genSubst s (mbMatch -> - [nuMP| FunPerm mb_ghosts mb_args mb_gouts - mb_ret perms_in perms_out |]) = - let ghosts = mbLift mb_ghosts - args = mbLift mb_args - gouts = mbLift mb_gouts - ret = mbLift mb_ret - ghosts_args_prxs = - RL.append (cruCtxProxies ghosts) (cruCtxProxies args) - ghosts_args_gouts_ret_prxs = - RL.append ghosts_args_prxs (cruCtxProxies gouts) :>: Proxy in - FunPerm ghosts args gouts ret - <$> genSubstMb ghosts_args_prxs s perms_in - <*> genSubstMb ghosts_args_gouts_ret_prxs s perms_out - -instance SubstVar PermVarSubst m => - Substable PermVarSubst (LifetimeCurrentPerms ps) m where - genSubst s mb_x = case mbMatch mb_x of - [nuMP| AlwaysCurrentPerms |] -> return AlwaysCurrentPerms - [nuMP| LOwnedCurrentPerms l ls tps_in tps_out ps_in ps_out |] -> - LOwnedCurrentPerms <$> genSubst s l <*> genSubst s ls - <*> return (mbLift tps_in) <*> return (mbLift tps_out) - <*> genSubst s ps_in <*> genSubst s ps_out - [nuMP| LOwnedSimpleCurrentPerms l tps ps |] -> - LOwnedSimpleCurrentPerms <$> genSubst s l - <*> return (mbLift tps) <*> genSubst s ps - [nuMP| CurrentTransPerms ps l |] -> - CurrentTransPerms <$> genSubst s ps <*> genSubst s l - -instance SubstVar PermVarSubst m => - Substable PermVarSubst (VarAndPerm a) m where - genSubst s (mbMatch -> [nuMP| VarAndPerm x p |]) = - VarAndPerm <$> genSubst s x <*> genSubst s p - -instance SubstVar PermVarSubst m => Substable1 PermVarSubst VarAndPerm m where - genSubst1 = genSubst - -instance Substable1 s f m => Substable1 s (Typed f) m where - genSubst1 s mb_typed = - Typed (mbLift $ fmap typedType mb_typed) <$> - genSubst1 s (fmap typedObj mb_typed) - -{- -instance SubstVar PermVarSubst m => - Substable PermVarSubst (DistPerms ps) m where - genSubst s mb_dperms = case mbMatch mb_dperms of - [nuMP| DistPermsNil |] -> return DistPermsNil - [nuMP| DistPermsCons dperms' x p |] -> - DistPermsCons <$> genSubst s dperms' <*> - return (varSubstVar s x) <*> genSubst s p --} - -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 - - ----------------------------------------------------------------------- --- * Expression Substitutions ----------------------------------------------------------------------- - --- | A substitution assigns a permission expression to each bound name in a --- name-binding context -newtype PermSubst ctx = - PermSubst { unPermSubst :: RAssign PermExpr ctx } - -emptySubst :: PermSubst RNil -emptySubst = PermSubst RL.empty - -consSubst :: PermSubst ctx -> PermExpr a -> PermSubst (ctx :> a) -consSubst (PermSubst elems) e = PermSubst (elems :>: e) - -singletonSubst :: PermExpr a -> PermSubst (RNil :> a) -singletonSubst e = PermSubst (RL.empty :>: e) - -appendSubsts :: PermSubst ctx1 -> PermSubst ctx2 -> PermSubst (ctx1 :++: ctx2) -appendSubsts (PermSubst es1) (PermSubst es2) = PermSubst $ RL.append es1 es2 - -substOfVars :: RAssign ExprVar ctx -> PermSubst ctx -substOfVars = PermSubst . RL.map PExpr_Var - -substOfExprs :: PermExprs ctx -> PermSubst ctx -substOfExprs = PermSubst - --- FIXME: Maybe PermSubst should just be PermExprs? -exprsOfSubst :: PermSubst ctx -> PermExprs ctx -exprsOfSubst = unPermSubst - -substLookup :: PermSubst ctx -> Member ctx a -> PermExpr a -substLookup (PermSubst m) memb = RL.get memb m - -noPermsInCruCtx :: forall (ctx :: RList CrucibleType) (a :: CrucibleType) b. - Member ctx (ValuePerm a) -> b -noPermsInCruCtx (Member_Step ctx) = noPermsInCruCtx ctx --- No case for Member_Base - -instance SubstVar PermSubst Identity where - extSubst (PermSubst elems) x = PermSubst $ elems :>: PExpr_Var x - substExprVar s x = - case mbNameBoundP x of - Left memb -> return $ substLookup s memb - Right y -> return $ PExpr_Var y - {- - substPermVar s mb_x = - case mbNameBoundP mb_x of - Left memb -> noTypesInExprCtx memb - Right x -> return $ ValPerm_Var x -} - --- | Apply a substitution to an object -subst :: Substable PermSubst a Identity => PermSubst ctx -> Mb ctx a -> a -subst s mb = runIdentity $ genSubst s mb - --- | Substitute a single expression into an object -subst1 :: Substable PermSubst a Identity => PermExpr b -> Binding b a -> a -subst1 e = subst (singletonSubst e) - - ----------------------------------------------------------------------- --- * Variable Substitutions ----------------------------------------------------------------------- - --- FIXME HERE: PermVarSubst and other types should just be instances of a --- RAssign, except it is annoying to build NuMatching instances for RAssign --- because there are different ways one might do it, so we need to use --- OVERLAPPING and/or INCOHERENT pragmas for them - -emptyVarSubst :: PermVarSubst RNil -emptyVarSubst = PermVarSubst_Nil - -singletonVarSubst :: ExprVar a -> PermVarSubst (RNil :> a) -singletonVarSubst x = PermVarSubst_Cons emptyVarSubst x - -consVarSubst :: PermVarSubst ctx -> ExprVar a -> PermVarSubst (ctx :> a) -consVarSubst = PermVarSubst_Cons - -permVarSubstOfNames :: RAssign Name ctx -> PermVarSubst ctx -permVarSubstOfNames MNil = PermVarSubst_Nil -permVarSubstOfNames (ns :>: n) = PermVarSubst_Cons (permVarSubstOfNames ns) n - -permVarSubstToNames :: PermVarSubst ctx -> RAssign Name ctx -permVarSubstToNames PermVarSubst_Nil = MNil -permVarSubstToNames (PermVarSubst_Cons s n) = permVarSubstToNames s :>: n - -varSubstLookup :: PermVarSubst ctx -> Member ctx a -> ExprVar a -varSubstLookup PermVarSubst_Nil m = case m of {} -varSubstLookup (PermVarSubst_Cons _ x) Member_Base = x -varSubstLookup (PermVarSubst_Cons s _) (Member_Step memb) = - varSubstLookup s memb - -appendVarSubsts :: PermVarSubst ctx1 -> PermVarSubst ctx2 -> - PermVarSubst (ctx1 :++: ctx2) -appendVarSubsts es1 PermVarSubst_Nil = es1 -appendVarSubsts es1 (PermVarSubst_Cons es2 x) = - PermVarSubst_Cons (appendVarSubsts es1 es2) x - --- | Convert a 'PermVarSubst' to a 'PermSubst' -permVarSubstToSubst :: PermVarSubst ctx -> PermSubst ctx -permVarSubstToSubst s = PermSubst $ RL.map PExpr_Var $ permVarSubstToNames s - -varSubstVar :: PermVarSubst ctx -> Mb ctx (ExprVar a) -> ExprVar a -varSubstVar s mb_x = - case mbNameBoundP mb_x of - Left memb -> varSubstLookup s memb - Right x -> x - -instance SubstVar PermVarSubst Identity where - extSubst s x = PermVarSubst_Cons s x - substExprVar s x = - case mbNameBoundP x of - Left memb -> return $ PExpr_Var $ varSubstLookup s memb - Right y -> return $ PExpr_Var y - {- - substPermVar s mb_x = - case mbNameBoundP mb_x of - Left memb -> noTypesInExprCtx memb - Right x -> return $ ValPerm_Var x -} - --- | Wrapper function to apply a renamionmg to an expression type -varSubst :: Substable PermVarSubst a Identity => PermVarSubst ctx -> - Mb ctx a -> a -varSubst s mb = runIdentity $ genSubst s mb - --- | Build a list of all possible 'PermVarSubst's of variables in a 'NameMap' --- for variables listed in a 'CruCtx' -allPermVarSubsts :: NameMap TypeRepr -> CruCtx ctx -> [PermVarSubst ctx] -allPermVarSubsts nmap = helper (NameMap.assocs nmap) where - helper :: [NameAndElem TypeRepr] -> CruCtx ctx -> [PermVarSubst ctx] - helper _ CruCtxNil = return emptyVarSubst - helper ns_ts (CruCtxCons ctx tp) = - helper ns_ts ctx >>= \sbst -> - map (consVarSubst sbst) (getVarsOfType ns_ts tp) - getVarsOfType :: [NameAndElem TypeRepr] -> TypeRepr tp -> [Name tp] - getVarsOfType [] _ = [] - getVarsOfType (NameAndElem n tp':ns_ts) tp - | Just Refl <- testEquality tp tp' = n : (getVarsOfType ns_ts tp) - getVarsOfType (_:ns_ts) tp = getVarsOfType ns_ts tp - - ----------------------------------------------------------------------- --- * Partial Substitutions ----------------------------------------------------------------------- - --- | An element of a partial substitution = maybe an expression -newtype PSubstElem a = PSubstElem { unPSubstElem :: Maybe (PermExpr a) } - --- | Partial substitutions assign expressions to some of the bound names in a --- context -newtype PartialSubst ctx = - PartialSubst { unPartialSubst :: RAssign PSubstElem ctx } - --- | Build an empty partial substitution for a given set of variables, i.e., the --- partial substitution that assigns no expressions to those variables -emptyPSubst :: RAssign any ctx -> PartialSubst ctx -emptyPSubst = PartialSubst . RL.map (\_ -> PSubstElem Nothing) - --- | Build a fully-defined partial substitution from a regular substitution -psubstOfSubst :: PermSubst ctx -> PartialSubst ctx -psubstOfSubst = PartialSubst . RL.map (PSubstElem . Just) . unPermSubst - --- | Return the set of variables that have been assigned values by a partial --- substitution inside a binding for all of its variables -psubstMbDom :: PartialSubst ctx -> Mb ctx (NameSet CrucibleType) -psubstMbDom (PartialSubst elems) = - nuMulti (RL.map (\_-> Proxy) elems) $ \ns -> - NameSet.fromList $ catMaybes $ RL.toList $ - RL.map2 (\n (PSubstElem maybe_e) -> - if isJust maybe_e - then Constant (Just $ SomeName n) - else Constant Nothing) ns elems - --- | Return the set of variables that have not been assigned values by a partial --- substitution inside a binding for all of its variables -psubstMbUnsetVars :: PartialSubst ctx -> Mb ctx (NameSet CrucibleType) -psubstMbUnsetVars (PartialSubst elems) = - nuMulti (RL.map (\_ -> Proxy) elems) $ \ns -> - NameSet.fromList $ catMaybes $ RL.toList $ - RL.map2 (\n (PSubstElem maybe_e) -> - if maybe_e == Nothing - then Constant (Just $ SomeName n) - else Constant Nothing) ns elems - --- | Return a list of 'Bool's indicating which of the bound names in context --- @ctx@ are unset in the given partial substitution -psubstUnsetVarsBool :: PartialSubst ctx -> [Bool] -psubstUnsetVarsBool (PartialSubst elems) = - RL.mapToList (\(PSubstElem maybe_e) -> isNothing maybe_e) elems - --- | Set the expression associated with a variable in a partial substitution. It --- is an error if it is already set. -psubstSet :: Member ctx a -> PermExpr a -> PartialSubst ctx -> - PartialSubst ctx -psubstSet memb e (PartialSubst elems) = - PartialSubst $ - RL.modify memb - (\pse -> case pse of - PSubstElem Nothing -> PSubstElem $ Just e - PSubstElem (Just _) -> panic "psubstSet" ["value already set for variable"]) - elems - --- | Extend a partial substitution with an unassigned variable -extPSubst :: PartialSubst ctx -> PartialSubst (ctx :> a) -extPSubst (PartialSubst elems) = PartialSubst $ elems :>: PSubstElem Nothing - --- | Shorten a partial substitution -unextPSubst :: PartialSubst (ctx :> a) -> PartialSubst ctx -unextPSubst (PartialSubst (elems :>: _)) = PartialSubst elems - --- | Complete a partial substitution into a total substitution, filling in zero --- values using 'zeroOfType' if necessary -completePSubst :: CruCtx vars -> PartialSubst vars -> PermSubst vars -completePSubst ctx (PartialSubst pselems) = PermSubst $ helper ctx pselems where - helper :: CruCtx vars -> RAssign PSubstElem vars -> RAssign PermExpr vars - helper _ MNil = MNil - helper (CruCtxCons ctx' tp) (pselems' :>: pse) = - helper ctx' pselems' :>: - (fromMaybe (zeroOfType tp) (unPSubstElem pse)) - --- | Look up an optional expression in a partial substitution -psubstLookup :: PartialSubst ctx -> Member ctx a -> Maybe (PermExpr a) -psubstLookup (PartialSubst m) memb = unPSubstElem $ RL.get memb m - --- | Get 'Proxy's for the domain of a 'PartialSubst' -psubstProxies :: PartialSubst ctx -> RAssign Proxy ctx -psubstProxies (PartialSubst m) = RL.map (const Proxy) m - --- | Append two partial substitutions -psubstAppend :: PartialSubst ctx1 -> PartialSubst ctx2 -> - PartialSubst (ctx1 :++: ctx2) -psubstAppend (PartialSubst elems1) (PartialSubst elems2) = - PartialSubst $ RL.append elems1 elems2 - -instance SubstVar PartialSubst Maybe where - extSubst (PartialSubst elems) x = - PartialSubst $ elems :>: PSubstElem (Just $ PExpr_Var x) - substExprVar s x = - case mbNameBoundP x of - Left memb -> psubstLookup s memb - Right y -> return $ PExpr_Var y - {- - substPermVar s mb_x = - case mbNameBoundP mb_x of - Left memb -> noTypesInExprCtx memb - Right x -> return $ ValPerm_Var x -} - --- | Wrapper function to apply a partial substitution to an expression type -partialSubst :: Substable PartialSubst a Maybe => PartialSubst ctx -> - Mb ctx a -> Maybe a -partialSubst = genSubst - --- | Apply a partial substitution, raising an error (with the given string) if --- this fails -partialSubstForce :: Substable PartialSubst a Maybe => PartialSubst ctx -> - Mb ctx a -> String -> a -partialSubstForce s mb msg = fromMaybe (error msg) $ partialSubst s mb - --- | Try to lift an expression out of a multi-binding by substituting with the --- empty partial substitution -tryLift :: Substable PartialSubst a Maybe => - Mb (ctx :: RList CrucibleType) a -> Maybe a -tryLift mb_a = partialSubst (emptyPSubst $ mbToProxy mb_a) mb_a - - ----------------------------------------------------------------------- --- * Additional functions involving partial substitutions ----------------------------------------------------------------------- - --- | If there is exactly one 'BVFactor' in a list of 'BVFactor's which is --- an unset variable, return the value of its 'BV', the witness that it --- is bound, and the result of adding together the remaining factors -getUnsetBVFactor :: (1 <= w, KnownNat w) => PartialSubst vars -> - Mb vars [BVFactor w] -> - Maybe (Integer, Member vars (BVType w), PermExpr (BVType w)) -getUnsetBVFactor psubst (mbList -> mb_factors) = - case partitionEithers $ mbFactorNameBoundP psubst <$> mb_factors of - ([(n, memb)], xs) -> Just (n, memb, foldl' bvAdd (bvInt 0) xs) - _ -> Nothing - --- | If a 'BVFactor' in a binding is an unset variable, return the value --- of its 'BV' and the witness that it is bound. Otherwise, return the --- constant of the factor multiplied by the variable's value if it is --- a set variable, or the constant of the factor multiplied by the --- variable, if it is an unbound variable -mbFactorNameBoundP :: PartialSubst vars -> - Mb vars (BVFactor w) -> - Either (Integer, Member vars (BVType w)) - (PermExpr (BVType w)) -mbFactorNameBoundP psubst (mbMatch -> [nuMP| BVFactor (BV.BV mb_n) mb_z |]) = - let n = mbLift mb_n in - case mbNameBoundP mb_z of - Left memb -> case psubstLookup psubst memb of - Nothing -> Left (n, memb) - Just e' -> Right (bvMultBV (BV.mkBV knownNat n) e') - Right z -> Right (bvFactorExpr (BV.mkBV knownNat n) z) - - ----------------------------------------------------------------------- --- * Abstracting Out Variables ----------------------------------------------------------------------- - -mbMbApply :: Mb (ctx1 :: RList k1) (Mb (ctx2 :: RList k2) (a -> b)) -> - Mb ctx1 (Mb ctx2 a) -> Mb ctx1 (Mb ctx2 b) -mbMbApply = mbApply . (fmap mbApply) - -clMbMbApplyM :: Monad m => - m (Closed (Mb (ctx1 :: RList k1) - (Mb (ctx2 :: RList k2) (a -> b)))) -> - m (Closed (Mb ctx1 (Mb ctx2 a))) -> - m (Closed (Mb ctx1 (Mb ctx2 b))) -clMbMbApplyM fm am = - (\f a -> $(mkClosed [| mbMbApply |]) `clApply` f `clApply` a) <$> fm <*> am - -absVarsReturnH :: Monad m => RAssign f1 (ctx1 :: RList k1) -> - RAssign f2 (ctx2 :: RList k2) -> - Closed a -> m (Closed (Mb ctx1 (Mb ctx2 a))) -absVarsReturnH fs1 fs2 cl_a = - return ( $(mkClosed [| \prxs1 prxs2 a -> - nuMulti prxs1 (const $ nuMulti prxs2 $ const a) |]) - `clApply` closedProxies fs1 `clApply` closedProxies fs2 - `clApply` cl_a) - --- | Map an 'RAssign' to a 'Closed' 'RAssign' of 'Proxy' objects -closedProxies :: RAssign f args -> Closed (RAssign Proxy args) -closedProxies = toClosed . mapRAssign (const Proxy) - --- | Class for types that support abstracting out all permission and expression --- variables. If the abstraction succeeds, we get a closed element of the type --- inside a binding for those permission and expression variables that are free --- in the original input. --- --- NOTE: if a variable occurs more than once, we associate it with the left-most --- occurrence, i.e., the earliest binding -class AbstractVars a where - abstractPEVars :: RAssign Name (pctx :: RList Type) -> - RAssign Name (ectx :: RList CrucibleType) -> a -> - Maybe (Closed (Mb pctx (Mb ectx a))) - --- | Call 'abstractPEVars' with only variables that have 'CrucibleType's -abstractVars :: AbstractVars a => - RAssign Name (ctx :: RList CrucibleType) -> a -> - Maybe (Closed (Mb ctx a)) -abstractVars ns a = - fmap (clApply $(mkClosed [| elimEmptyMb |])) $ abstractPEVars MNil ns a - --- | An expression or other object which the variables have been abstracted out --- of, along with those variables that were abstracted out of it -data AbsObj a = forall ctx. AbsObj (RAssign ExprVar ctx) (Closed (Mb ctx a)) - --- | Find all free variables of an expression and abstract them out. Note that --- this should always succeed, if 'freeVars' is implemented correctly. -abstractFreeVars :: (AbstractVars a, FreeVars a) => a -> AbsObj a -abstractFreeVars a - | Some ns <- freeVarsRAssign a - , Just cl_mb_a <- abstractVars ns a = AbsObj ns cl_mb_a -abstractFreeVars _ = panic "abstractFreeVars" ["freeVars failed"] - - --- | Try to close an expression by calling 'abstractPEVars' with an empty list --- of expression variables -tryClose :: AbstractVars a => a -> Maybe (Closed a) -tryClose a = - fmap (clApply $(mkClosed [| elimEmptyMb . elimEmptyMb |])) $ - abstractPEVars MNil MNil a - -instance AbstractVars (Name (a :: CrucibleType)) where - abstractPEVars ns1 ns2 (n :: Name a) - | Just memb <- memberElem n ns2 - = return ( $(mkClosed - [| \prxs1 prxs2 memb' -> - nuMulti prxs1 (const $ nuMulti prxs2 (RL.get memb')) |]) - `clApply` closedProxies ns1 `clApply` closedProxies ns2 - `clApply` toClosed memb) - abstractPEVars _ _ _ = Nothing - -instance AbstractVars (Name (a :: Type)) where - abstractPEVars ns1 ns2 (n :: Name a) - | Just memb <- memberElem n ns1 - = return ( $(mkClosed - [| \prxs1 prxs2 memb' -> - nuMulti prxs1 $ \ns -> - nuMulti prxs2 (const $ RL.get memb' ns) |]) - `clApply` closedProxies ns1 `clApply` closedProxies ns2 - `clApply` toClosed memb) - abstractPEVars _ _ _ = Nothing - -instance AbstractVars a => AbstractVars (Mb (ctx :: RList CrucibleType) a) where - abstractPEVars ns1 ns2 mb = - mbLift $ - nuMultiWithElim1 - (\ns a -> - clApply ( $(mkClosed [| \prxs -> fmap (mbSeparate prxs) |]) - `clApply` closedProxies ns) <$> - abstractPEVars ns1 (append ns2 ns) a) - mb - -instance AbstractVars a => AbstractVars (Mb (ctx :: RList Type) a) where - abstractPEVars ns1 ns2 mb = - mbLift $ - nuMultiWithElim1 - (\ns a -> - clApply ( $(mkClosed [| \prxs2 prxs -> fmap (mbSwap prxs2) . mbSeparate prxs |]) - `clApply` closedProxies ns2 - `clApply` closedProxies ns) <$> - abstractPEVars (append ns1 ns) ns2 a) - mb - -instance AbstractVars (RAssign Name (ctx :: RList CrucibleType)) where - abstractPEVars ns1 ns2 MNil = absVarsReturnH ns1 ns2 $(mkClosed [| MNil |]) - abstractPEVars ns1 ns2 (ns :>: n) = - absVarsReturnH ns1 ns2 $(mkClosed [| (:>:) |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 ns - `clMbMbApplyM` abstractPEVars ns1 ns2 n - -instance AbstractVars Integer where - abstractPEVars ns1 ns2 i = absVarsReturnH ns1 ns2 (toClosed i) - -instance AbstractVars (BV w) where - abstractPEVars ns1 ns2 bv = absVarsReturnH ns1 ns2 (toClosed bv) - -instance AbstractVars Bytes where - abstractPEVars ns1 ns2 bytes = absVarsReturnH ns1 ns2 (toClosed bytes) - -instance AbstractVars Natural where - abstractPEVars ns1 ns2 n = absVarsReturnH ns1 ns2 (toClosed n) - -instance AbstractVars Char where - abstractPEVars ns1 ns2 c = absVarsReturnH ns1 ns2 (toClosed c) - -instance AbstractVars Bool where - abstractPEVars ns1 ns2 b = absVarsReturnH ns1 ns2 (toClosed b) - -instance AbstractVars (Member ctx a) where - abstractPEVars ns1 ns2 memb = absVarsReturnH ns1 ns2 (toClosed memb) - -instance AbstractVars a => AbstractVars (Maybe a) where - abstractPEVars ns1 ns2 Nothing = - absVarsReturnH ns1 ns2 $(mkClosed [| Nothing |]) - abstractPEVars ns1 ns2 (Just a) = - absVarsReturnH ns1 ns2 $(mkClosed [| Just |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 a - -instance AbstractVars a => AbstractVars [a] where - abstractPEVars ns1 ns2 [] = - absVarsReturnH ns1 ns2 $(mkClosed [| [] |]) - abstractPEVars ns1 ns2 (a:as) = - absVarsReturnH ns1 ns2 $(mkClosed [| (:) |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 a - `clMbMbApplyM` abstractPEVars ns1 ns2 as - -instance (AbstractVars a, AbstractVars b) => AbstractVars (a,b) where - abstractPEVars ns1 ns2 (a,b) = - absVarsReturnH ns1 ns2 $(mkClosed [| (,) |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 a - `clMbMbApplyM` abstractPEVars ns1 ns2 b - -instance AbstractVars (PermExpr a) where - abstractPEVars ns1 ns2 (PExpr_Var x) = - absVarsReturnH ns1 ns2 $(mkClosed [| PExpr_Var |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 x - abstractPEVars ns1 ns2 PExpr_Unit = - absVarsReturnH ns1 ns2 $(mkClosed [| PExpr_Unit |]) - abstractPEVars ns1 ns2 (PExpr_Bool b) = - absVarsReturnH ns1 ns2 $(mkClosed [| PExpr_Bool |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 b - abstractPEVars ns1 ns2 (PExpr_Nat i) = - absVarsReturnH ns1 ns2 $(mkClosed [| PExpr_Nat |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 i - abstractPEVars ns1 ns2 (PExpr_String str) = - absVarsReturnH ns1 ns2 ($(mkClosed [| PExpr_String |]) - `clApply` toClosed str) - abstractPEVars ns1 ns2 (PExpr_BV factors k) = - absVarsReturnH ns1 ns2 $(mkClosed [| PExpr_BV |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 factors - `clMbMbApplyM` abstractPEVars ns1 ns2 k - abstractPEVars ns1 ns2 (PExpr_Struct es) = - absVarsReturnH ns1 ns2 $(mkClosed [| PExpr_Struct |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 es - abstractPEVars ns1 ns2 PExpr_Always = - absVarsReturnH ns1 ns2 $(mkClosed [| PExpr_Always |]) - abstractPEVars ns1 ns2 (PExpr_LLVMWord e) = - absVarsReturnH ns1 ns2 $(mkClosed [| PExpr_LLVMWord |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 e - abstractPEVars ns1 ns2 (PExpr_LLVMOffset x e) = - absVarsReturnH ns1 ns2 $(mkClosed [| PExpr_LLVMOffset |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 x - `clMbMbApplyM` abstractPEVars ns1 ns2 e - abstractPEVars ns1 ns2 (PExpr_Fun fh) = - absVarsReturnH ns1 ns2 ($(mkClosed [| PExpr_Fun |]) `clApply` toClosed fh) - abstractPEVars ns1 ns2 PExpr_PermListNil = - absVarsReturnH ns1 ns2 ($(mkClosed [| PExpr_PermListNil |])) - abstractPEVars ns1 ns2 (PExpr_PermListCons tp e p l) = - absVarsReturnH ns1 ns2 ($(mkClosed [| PExpr_PermListCons |]) - `clApply` toClosed tp) - `clMbMbApplyM` abstractPEVars ns1 ns2 e - `clMbMbApplyM` abstractPEVars ns1 ns2 p - `clMbMbApplyM` abstractPEVars ns1 ns2 l - abstractPEVars ns1 ns2 (PExpr_RWModality rw) = - absVarsReturnH ns1 ns2 ($(mkClosed [| PExpr_RWModality |]) - `clApply` toClosed rw) - abstractPEVars ns1 ns2 PExpr_EmptyShape = - absVarsReturnH ns1 ns2 $(mkClosed [| PExpr_EmptyShape |]) - abstractPEVars ns1 ns2 (PExpr_NamedShape rw l nmsh args) = - absVarsReturnH ns1 ns2 $(mkClosed [| PExpr_NamedShape |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 rw - `clMbMbApplyM` abstractPEVars ns1 ns2 l - `clMbMbApplyM` abstractPEVars ns1 ns2 nmsh - `clMbMbApplyM` abstractPEVars ns1 ns2 args - abstractPEVars ns1 ns2 (PExpr_EqShape len b) = - absVarsReturnH ns1 ns2 ($(mkClosed [| PExpr_EqShape |])) - `clMbMbApplyM` abstractPEVars ns1 ns2 len - `clMbMbApplyM` abstractPEVars ns1 ns2 b - abstractPEVars ns1 ns2 (PExpr_PtrShape maybe_rw maybe_l sh) = - absVarsReturnH ns1 ns2 ($(mkClosed [| PExpr_PtrShape |])) - `clMbMbApplyM` abstractPEVars ns1 ns2 maybe_rw - `clMbMbApplyM` abstractPEVars ns1 ns2 maybe_l - `clMbMbApplyM` abstractPEVars ns1 ns2 sh - abstractPEVars ns1 ns2 (PExpr_FieldShape fsh) = - absVarsReturnH ns1 ns2 ($(mkClosed [| PExpr_FieldShape |])) - `clMbMbApplyM` abstractPEVars ns1 ns2 fsh - 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 sh - abstractPEVars ns1 ns2 (PExpr_TupShape sh) = - absVarsReturnH ns1 ns2 $(mkClosed [| PExpr_TupShape |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 sh - abstractPEVars ns1 ns2 (PExpr_SeqShape sh1 sh2) = - absVarsReturnH ns1 ns2 $(mkClosed [| PExpr_SeqShape |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 sh1 - `clMbMbApplyM` abstractPEVars ns1 ns2 sh2 - abstractPEVars ns1 ns2 (PExpr_OrShape sh1 sh2) = - absVarsReturnH ns1 ns2 $(mkClosed [| PExpr_OrShape |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 sh1 - `clMbMbApplyM` abstractPEVars ns1 ns2 sh2 - abstractPEVars ns1 ns2 (PExpr_ExShape mb_sh) = - absVarsReturnH ns1 ns2 $(mkClosed [| PExpr_ExShape |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 mb_sh - abstractPEVars ns1 ns2 PExpr_FalseShape = - absVarsReturnH ns1 ns2 $(mkClosed [| PExpr_FalseShape |]) - abstractPEVars ns1 ns2 (PExpr_ValPerm p) = - absVarsReturnH ns1 ns2 ($(mkClosed [| PExpr_ValPerm |])) - `clMbMbApplyM` abstractPEVars ns1 ns2 p - -instance AbstractVars (PermExprs as) where - abstractPEVars ns1 ns2 PExprs_Nil = - absVarsReturnH ns1 ns2 $(mkClosed [| PExprs_Nil |]) - abstractPEVars ns1 ns2 (PExprs_Cons es e) = - absVarsReturnH ns1 ns2 $(mkClosed [| PExprs_Cons |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 es - `clMbMbApplyM` abstractPEVars ns1 ns2 e - -instance AbstractVars (BVFactor w) where - abstractPEVars ns1 ns2 (BVFactor i x) = - absVarsReturnH ns1 ns2 $(mkClosed [| BVFactor |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 i - `clMbMbApplyM` abstractPEVars ns1 ns2 x - -instance AbstractVars (BVRange w) where - abstractPEVars ns1 ns2 (BVRange e1 e2) = - absVarsReturnH ns1 ns2 $(mkClosed [| BVRange |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 e1 - `clMbMbApplyM` abstractPEVars ns1 ns2 e2 - -instance AbstractVars (BVProp w) where - abstractPEVars ns1 ns2 (BVProp_Eq e1 e2) = - absVarsReturnH ns1 ns2 $(mkClosed [| BVProp_Eq |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 e1 - `clMbMbApplyM` abstractPEVars ns1 ns2 e2 - abstractPEVars ns1 ns2 (BVProp_Neq e1 e2) = - absVarsReturnH ns1 ns2 $(mkClosed [| BVProp_Neq |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 e1 - `clMbMbApplyM` abstractPEVars ns1 ns2 e2 - abstractPEVars ns1 ns2 (BVProp_ULt e1 e2) = - absVarsReturnH ns1 ns2 $(mkClosed [| BVProp_ULt |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 e1 - `clMbMbApplyM` abstractPEVars ns1 ns2 e2 - abstractPEVars ns1 ns2 (BVProp_ULeq e1 e2) = - absVarsReturnH ns1 ns2 $(mkClosed [| BVProp_ULeq |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 e1 - `clMbMbApplyM` abstractPEVars ns1 ns2 e2 - abstractPEVars ns1 ns2 (BVProp_ULeq_Diff e1 e2 e3) = - absVarsReturnH ns1 ns2 $(mkClosed [| BVProp_ULeq_Diff |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 e1 - `clMbMbApplyM` abstractPEVars ns1 ns2 e2 - `clMbMbApplyM` abstractPEVars ns1 ns2 e3 - -instance AbstractVars (AtomicPerm a) where - abstractPEVars ns1 ns2 (Perm_LLVMField fp) = - absVarsReturnH ns1 ns2 $(mkClosed [| Perm_LLVMField |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 fp - abstractPEVars ns1 ns2 (Perm_LLVMArray ap) = - absVarsReturnH ns1 ns2 $(mkClosed [| Perm_LLVMArray |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 ap - abstractPEVars ns1 ns2 (Perm_LLVMBlock bp) = - absVarsReturnH ns1 ns2 $(mkClosed [| Perm_LLVMBlock |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 bp - abstractPEVars ns1 ns2 (Perm_LLVMFree e) = - absVarsReturnH ns1 ns2 $(mkClosed [| Perm_LLVMFree |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 e - abstractPEVars ns1 ns2 (Perm_LLVMFunPtr tp p) = - absVarsReturnH ns1 ns2 - ($(mkClosed [| Perm_LLVMFunPtr |]) `clApply` toClosed tp) - `clMbMbApplyM` abstractPEVars ns1 ns2 p - abstractPEVars ns1 ns2 Perm_IsLLVMPtr = - absVarsReturnH ns1 ns2 $(mkClosed [| Perm_IsLLVMPtr |]) - abstractPEVars ns1 ns2 (Perm_LLVMBlockShape sh) = - absVarsReturnH ns1 ns2 $(mkClosed [| Perm_LLVMBlockShape |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 sh - abstractPEVars ns1 ns2 (Perm_LLVMFrame fp) = - absVarsReturnH ns1 ns2 $(mkClosed [| Perm_LLVMFrame |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 fp - abstractPEVars ns1 ns2 (Perm_LOwned ls tps_in tps_out ps_in ps_out) = - absVarsReturnH ns1 ns2 $(mkClosed [| Perm_LOwned |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 ls - `clMbMbApplyM` (absVarsReturnH ns1 ns2 $ toClosed tps_in) - `clMbMbApplyM` (absVarsReturnH ns1 ns2 $ toClosed tps_out) - `clMbMbApplyM` abstractPEVars ns1 ns2 ps_in - `clMbMbApplyM` abstractPEVars ns1 ns2 ps_out - abstractPEVars ns1 ns2 (Perm_LOwnedSimple tps lops) = - absVarsReturnH ns1 ns2 ($(mkClosed [| Perm_LOwnedSimple |]) - `clApply` toClosed tps) - `clMbMbApplyM` abstractPEVars ns1 ns2 lops - abstractPEVars ns1 ns2 (Perm_LCurrent e) = - absVarsReturnH ns1 ns2 $(mkClosed [| Perm_LCurrent |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 e - abstractPEVars ns1 ns2 Perm_LFinished = - absVarsReturnH ns1 ns2 $(mkClosed [| Perm_LFinished |]) - abstractPEVars ns1 ns2 (Perm_Struct ps) = - absVarsReturnH ns1 ns2 $(mkClosed [| Perm_Struct |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 ps - abstractPEVars ns1 ns2 (Perm_Fun fperm) = - absVarsReturnH ns1 ns2 $(mkClosed [| Perm_Fun |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 fperm - abstractPEVars ns1 ns2 (Perm_BVProp prop) = - absVarsReturnH ns1 ns2 $(mkClosed [| Perm_BVProp |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 prop - abstractPEVars ns1 ns2 Perm_Any = - absVarsReturnH ns1 ns2 $(mkClosed [| Perm_Any |]) - abstractPEVars ns1 ns2 (Perm_NamedConj n args off) = - absVarsReturnH ns1 ns2 $(mkClosed [| Perm_NamedConj |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 n - `clMbMbApplyM` abstractPEVars ns1 ns2 args - `clMbMbApplyM` abstractPEVars ns1 ns2 off - -instance AbstractVars (ValuePerm a) where - abstractPEVars ns1 ns2 (ValPerm_Var x off) = - absVarsReturnH ns1 ns2 $(mkClosed [| ValPerm_Var |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 x - `clMbMbApplyM` abstractPEVars ns1 ns2 off - abstractPEVars ns1 ns2 (ValPerm_Eq e) = - absVarsReturnH ns1 ns2 $(mkClosed [| ValPerm_Eq |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 e - abstractPEVars ns1 ns2 (ValPerm_Or p1 p2) = - absVarsReturnH ns1 ns2 $(mkClosed [| ValPerm_Or |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 p1 - `clMbMbApplyM` abstractPEVars ns1 ns2 p2 - abstractPEVars ns1 ns2 (ValPerm_Exists p) = - absVarsReturnH ns1 ns2 $(mkClosed [| ValPerm_Exists |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 p - abstractPEVars ns1 ns2 (ValPerm_Named n args off) = - absVarsReturnH ns1 ns2 $(mkClosed [| ValPerm_Named |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 n - `clMbMbApplyM` abstractPEVars ns1 ns2 args - `clMbMbApplyM` abstractPEVars ns1 ns2 off - abstractPEVars ns1 ns2 (ValPerm_Conj ps) = - absVarsReturnH ns1 ns2 $(mkClosed [| ValPerm_Conj |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 ps - abstractPEVars ns1 ns2 ValPerm_False = - absVarsReturnH ns1 ns2 $(mkClosed [| ValPerm_False |]) - -instance AbstractVars (ValuePerms as) where - abstractPEVars ns1 ns2 ValPerms_Nil = - absVarsReturnH ns1 ns2 $(mkClosed [| ValPerms_Nil |]) - abstractPEVars ns1 ns2 (ValPerms_Cons ps p) = - absVarsReturnH ns1 ns2 $(mkClosed [| ValPerms_Cons |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 ps - `clMbMbApplyM` abstractPEVars ns1 ns2 p - -instance AbstractVars RWModality where - abstractPEVars ns1 ns2 Write = - absVarsReturnH ns1 ns2 $(mkClosed [| Write |]) - abstractPEVars ns1 ns2 Read = - absVarsReturnH ns1 ns2 $(mkClosed [| Read |]) - -instance AbstractVars (LLVMFieldPerm w sz) where - abstractPEVars ns1 ns2 (LLVMFieldPerm rw ls off p) = - absVarsReturnH ns1 ns2 $(mkClosed [| LLVMFieldPerm |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 rw - `clMbMbApplyM` abstractPEVars ns1 ns2 ls - `clMbMbApplyM` abstractPEVars ns1 ns2 off - `clMbMbApplyM` abstractPEVars ns1 ns2 p - -instance AbstractVars (LLVMArrayPerm w) where - 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 - `clMbMbApplyM` abstractPEVars ns1 ns2 flds - `clMbMbApplyM` abstractPEVars ns1 ns2 bs - -instance AbstractVars (LLVMArrayIndex w) where - abstractPEVars ns1 ns2 (LLVMArrayIndex ix off) = - absVarsReturnH ns1 ns2 $(mkClosed [| LLVMArrayIndex |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 ix - `clMbMbApplyM` abstractPEVars ns1 ns2 off - -instance AbstractVars (PermOffset a) where - abstractPEVars ns1 ns2 NoPermOffset = - absVarsReturnH ns1 ns2 $(mkClosed [| NoPermOffset |]) - abstractPEVars ns1 ns2 (LLVMPermOffset off) = - absVarsReturnH ns1 ns2 $(mkClosed [| LLVMPermOffset |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 off - -instance AbstractVars (LLVMArrayBorrow w) where - abstractPEVars ns1 ns2 (FieldBorrow ix) = - absVarsReturnH ns1 ns2 $(mkClosed [| FieldBorrow |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 ix - abstractPEVars ns1 ns2 (RangeBorrow r) = - absVarsReturnH ns1 ns2 $(mkClosed [| RangeBorrow |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 r - -instance AbstractVars (LLVMFieldShape w) where - abstractPEVars ns1 ns2 (LLVMFieldShape p) = - absVarsReturnH ns1 ns2 $(mkClosed [| LLVMFieldShape |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 p - -instance AbstractVars (LLVMBlockPerm w) where - abstractPEVars ns1 ns2 (LLVMBlockPerm rw l off len sh) = - absVarsReturnH ns1 ns2 $(mkClosed [| LLVMBlockPerm |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 rw - `clMbMbApplyM` abstractPEVars ns1 ns2 l - `clMbMbApplyM` abstractPEVars ns1 ns2 off - `clMbMbApplyM` abstractPEVars ns1 ns2 len - `clMbMbApplyM` abstractPEVars ns1 ns2 sh - -instance AbstractVars (DistPerms ps) where - abstractPEVars ns1 ns2 DistPermsNil = - absVarsReturnH ns1 ns2 $(mkClosed [| DistPermsNil |]) - abstractPEVars ns1 ns2 (DistPermsCons perms x p) = - absVarsReturnH ns1 ns2 $(mkClosed [| DistPermsCons |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 perms - `clMbMbApplyM` abstractPEVars ns1 ns2 x `clMbMbApplyM` abstractPEVars ns1 ns2 p - -instance AbstractVars (ExprAndPerm a) where - abstractPEVars ns1 ns2 (ExprAndPerm e p) = - absVarsReturnH ns1 ns2 $(mkClosed [| ExprAndPerm |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 e - `clMbMbApplyM` abstractPEVars ns1 ns2 p - -instance AbstractVars (ExprPerms a) where - abstractPEVars ns1 ns2 MNil = - absVarsReturnH ns1 ns2 $(mkClosed [| MNil |]) - abstractPEVars ns1 ns2 (ps :>: p) = - absVarsReturnH ns1 ns2 $(mkClosed [| (:>:) |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 ps - `clMbMbApplyM` abstractPEVars ns1 ns2 p - -instance AbstractVars (FunPerm ghosts args gouts ret) where - abstractPEVars ns1 ns2 (FunPerm ghosts args gouts ret perms_in perms_out) = - absVarsReturnH ns1 ns2 - ($(mkClosed [| FunPerm |]) - `clApply` toClosed ghosts `clApply` toClosed args - `clApply` toClosed gouts `clApply` toClosed ret) - `clMbMbApplyM` abstractPEVars ns1 ns2 perms_in - `clMbMbApplyM` abstractPEVars ns1 ns2 perms_out - -instance AbstractVars (NamedShape b args w) where - abstractPEVars ns1 ns2 (NamedShape nm args body) = - absVarsReturnH ns1 ns2 ($(mkClosed [| NamedShape |]) - `clApply` toClosed nm `clApply` toClosed args) - `clMbMbApplyM` abstractPEVars ns1 ns2 body - -instance AbstractVars (NamedShapeBody b args w) where - abstractPEVars ns1 ns2 (DefinedShapeBody mb_sh) = - absVarsReturnH ns1 ns2 $(mkClosed [| DefinedShapeBody |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 mb_sh - abstractPEVars ns1 ns2 (OpaqueShapeBody mb_len trans_id desc_id) = - absVarsReturnH ns1 ns2 ($(mkClosed [| \i1 i2 l -> OpaqueShapeBody l i1 i2 |]) - `clApply` toClosed trans_id - `clApply` toClosed desc_id) - `clMbMbApplyM` abstractPEVars ns1 ns2 mb_len - abstractPEVars ns1 ns2 (RecShapeBody mb_sh trans_id desc_id) = - absVarsReturnH ns1 ns2 ($(mkClosed - [| \i1 i2 l -> RecShapeBody l i1 i2 |]) - `clApply` toClosed trans_id - `clApply` toClosed desc_id) - `clMbMbApplyM` abstractPEVars ns1 ns2 mb_sh - -instance AbstractVars (NamedPermName ns args a) where - abstractPEVars ns1 ns2 (NamedPermName n tp args ns reachConstr) = - absVarsReturnH ns1 ns2 - ($(mkClosed [| NamedPermName |]) - `clApply` toClosed n `clApply` toClosed tp `clApply` toClosed args - `clApply` toClosed ns`clApply` toClosed reachConstr) - - ----------------------------------------------------------------------- --- * Abstracting out named shapes ----------------------------------------------------------------------- - --- | An existentially quantified LLVM shape with a name, but that is considered --- \"partial\" because it has not been added to the environment yet -data SomePartialNamedShape w where - NonRecShape :: String -> CruCtx args -> Mb args (PermExpr (LLVMShapeType w)) - -> SomePartialNamedShape w - RecShape :: String -> CruCtx args - -> Mb (args :> LLVMShapeType w) (PermExpr (LLVMShapeType w)) - -> SomePartialNamedShape w - --- | An existentially quantified LLVM shape applied to some arguments -data SomeNamedShapeApp w where - SomeNamedShapeApp :: String -> CruCtx args -> PermExprs args -> - NatRepr w -> SomeNamedShapeApp w - -class AbstractNamedShape w a where - abstractNSM :: a -> ReaderT (SomeNamedShapeApp w) Maybe - (Binding (LLVMShapeType w) a) - -abstractNS :: (KnownNat w, AbstractNamedShape w a) => - String -> CruCtx args -> PermExprs args -> - a -> Maybe (Binding (LLVMShapeType w) a) -abstractNS nsh args_ctx args x = runReaderT (abstractNSM x) nshApp - where nshApp = SomeNamedShapeApp nsh args_ctx args knownNat - -pureBindingM :: Monad m => b -> m (Binding a b) -pureBindingM = pure . nu . const - -instance (NuMatching a, AbstractNamedShape w a) => - AbstractNamedShape w (Mb ctx a) where - abstractNSM = fmap (mbSwap RL.typeCtxProxies) . mbM . fmap abstractNSM - -instance AbstractNamedShape w Integer where - abstractNSM = pureBindingM - -instance AbstractNamedShape w a => AbstractNamedShape w (Maybe a) where - abstractNSM (Just x) = fmap Just <$> abstractNSM x - abstractNSM Nothing = pureBindingM Nothing - -instance AbstractNamedShape w a => AbstractNamedShape w [a] where - abstractNSM [] = pureBindingM [] - abstractNSM (x:xs) = mbMap2 (:) <$> abstractNSM x <*> abstractNSM xs - -instance (AbstractNamedShape w a, AbstractNamedShape w b) => - AbstractNamedShape w (a, b) where - abstractNSM (x,y) = mbMap2 (,) <$> abstractNSM x <*> abstractNSM y - -instance AbstractNamedShape w (PermExpr a) where - abstractNSM (PExpr_Var x) = pureBindingM (PExpr_Var x) - abstractNSM PExpr_Unit = pureBindingM PExpr_Unit - abstractNSM (PExpr_Bool b) = pureBindingM (PExpr_Bool b) - abstractNSM (PExpr_Nat n) = pureBindingM (PExpr_Nat n) - abstractNSM (PExpr_String s) = pureBindingM (PExpr_String s) - abstractNSM (PExpr_BV fs c) = pureBindingM (PExpr_BV fs c) - abstractNSM (PExpr_Struct es) = fmap PExpr_Struct <$> abstractNSM es - abstractNSM PExpr_Always = pureBindingM PExpr_Always - abstractNSM (PExpr_LLVMWord e) = fmap PExpr_LLVMWord <$> abstractNSM e - abstractNSM (PExpr_LLVMOffset x e) = fmap (PExpr_LLVMOffset x) <$> abstractNSM e - abstractNSM (PExpr_Fun fh) = pureBindingM (PExpr_Fun fh) - abstractNSM PExpr_PermListNil = pureBindingM PExpr_PermListNil - abstractNSM (PExpr_PermListCons tp e p l) = - mbMap3 (PExpr_PermListCons tp) <$> abstractNSM e <*> abstractNSM p <*> abstractNSM l - abstractNSM (PExpr_RWModality rw) = pureBindingM (PExpr_RWModality rw) - abstractNSM PExpr_EmptyShape = pureBindingM PExpr_EmptyShape - abstractNSM e@(PExpr_NamedShape maybe_rw maybe_l nmsh args) = - do SomeNamedShapeApp nm_abs args_ctx_abs args_abs w_abs <- ask - case namedShapeName nmsh == nm_abs of - True | Just Refl <- testEquality (namedShapeArgs nmsh) args_ctx_abs - , True <- args == args_abs - , Nothing <- maybe_rw, Nothing <- maybe_l - , Just Refl <- testEquality w_abs (shapeLLVMTypeWidth e) - -> pure $ nu PExpr_Var - True -> fail "named shape not applied to its arguments" - False -> pureBindingM (PExpr_NamedShape maybe_rw maybe_l nmsh args) - abstractNSM (PExpr_EqShape len b) = - mbMap2 PExpr_EqShape <$> abstractNSM len <*> abstractNSM b - 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 sh) = - mbMap3 PExpr_ArrayShape <$> abstractNSM len <*> pureBindingM s <*> abstractNSM sh - abstractNSM (PExpr_TupShape sh) = fmap PExpr_TupShape <$> abstractNSM sh - abstractNSM (PExpr_SeqShape sh1 sh2) = - mbMap2 PExpr_SeqShape <$> abstractNSM sh1 <*> abstractNSM sh2 - abstractNSM (PExpr_OrShape sh1 sh2) = - mbMap2 PExpr_OrShape <$> abstractNSM sh1 <*> abstractNSM sh2 - abstractNSM (PExpr_ExShape mb_sh) = fmap PExpr_ExShape <$> abstractNSM mb_sh - abstractNSM PExpr_FalseShape = pureBindingM PExpr_FalseShape - abstractNSM (PExpr_ValPerm p) = fmap PExpr_ValPerm <$> abstractNSM p - -instance AbstractNamedShape w (PermExprs as) where - abstractNSM PExprs_Nil = pureBindingM PExprs_Nil - abstractNSM (PExprs_Cons es e) = - mbMap2 PExprs_Cons <$> abstractNSM es <*> abstractNSM e - -instance AbstractNamedShape w' (LLVMFieldShape w) where - abstractNSM (LLVMFieldShape p) = fmap LLVMFieldShape <$> abstractNSM p - -instance AbstractNamedShape w (ValuePerm a) where - abstractNSM (ValPerm_Eq e) = fmap ValPerm_Eq <$> abstractNSM e - abstractNSM (ValPerm_Or p1 p2) = - mbMap2 ValPerm_Or <$> abstractNSM p1 <*> abstractNSM p2 - abstractNSM (ValPerm_Exists p) = fmap ValPerm_Exists <$> abstractNSM p - abstractNSM (ValPerm_Named n args off) = - mbMap2 (ValPerm_Named n) <$> abstractNSM args <*> abstractNSM off - abstractNSM (ValPerm_Var x off) = - fmap (ValPerm_Var x) <$> abstractNSM off - abstractNSM (ValPerm_Conj aps) = fmap ValPerm_Conj <$> abstractNSM aps - abstractNSM ValPerm_False = (pure . pure) ValPerm_False - -instance AbstractNamedShape w (PermOffset a) where - abstractNSM NoPermOffset = pureBindingM NoPermOffset - abstractNSM (LLVMPermOffset e) = fmap LLVMPermOffset <$> abstractNSM e - -instance AbstractNamedShape w (AtomicPerm a) where - abstractNSM (Perm_LLVMField fp) = fmap Perm_LLVMField <$> abstractNSM fp - abstractNSM (Perm_LLVMArray ap) = fmap Perm_LLVMArray <$> abstractNSM ap - abstractNSM (Perm_LLVMBlock bp) = fmap Perm_LLVMBlock <$> abstractNSM bp - abstractNSM (Perm_LLVMFree e) = fmap Perm_LLVMFree <$> abstractNSM e - abstractNSM (Perm_LLVMFunPtr tp p) = fmap (Perm_LLVMFunPtr tp) <$> abstractNSM p - abstractNSM (Perm_LLVMBlockShape sh) = fmap Perm_LLVMBlockShape <$> abstractNSM sh - abstractNSM Perm_IsLLVMPtr = pureBindingM Perm_IsLLVMPtr - abstractNSM (Perm_NamedConj n args off) = - mbMap2 (Perm_NamedConj n) <$> abstractNSM args <*> abstractNSM off - abstractNSM (Perm_LLVMFrame fp) = fmap Perm_LLVMFrame <$> abstractNSM fp - abstractNSM (Perm_LOwned ls tps_in tps_out ps_in ps_out) = - mbMap3 (\ls' -> Perm_LOwned ls' tps_in tps_out) <$> - abstractNSM ls <*> abstractNSM ps_in <*> abstractNSM ps_out - abstractNSM (Perm_LOwnedSimple tps lops) = - fmap (Perm_LOwnedSimple tps) <$> abstractNSM lops - abstractNSM (Perm_LCurrent e) = fmap Perm_LCurrent <$> abstractNSM e - abstractNSM Perm_LFinished = pureBindingM Perm_LFinished - abstractNSM (Perm_Struct ps) = fmap Perm_Struct <$> abstractNSM ps - abstractNSM (Perm_Fun fp) = fmap Perm_Fun <$> abstractNSM fp - abstractNSM (Perm_BVProp prop) = pureBindingM (Perm_BVProp prop) - abstractNSM Perm_Any = pureBindingM Perm_Any - -instance AbstractNamedShape w' (LLVMFieldPerm w sz) where - abstractNSM (LLVMFieldPerm rw l off p) = - mbMap4 LLVMFieldPerm <$> abstractNSM rw <*> abstractNSM l - <*> abstractNSM off <*> abstractNSM p - --- | 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' (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 ix) = fmap FieldBorrow <$> abstractNSM ix - abstractNSM (RangeBorrow rng) = pureBindingM (RangeBorrow rng) - -instance AbstractNamedShape w' (LLVMBlockPerm w) where - abstractNSM (LLVMBlockPerm rw l off len sh) = - mbMap5 LLVMBlockPerm <$> abstractNSM rw <*> abstractNSM l - <*> abstractNSM off <*> abstractNSM len - <*> abstractNSM sh - -instance AbstractNamedShape w (ExprPerms ps) where - abstractNSM MNil = pureBindingM MNil - abstractNSM (p :>: ps) = mbMap2 (:>:) <$> abstractNSM p <*> abstractNSM ps - -instance AbstractNamedShape w (ExprAndPerm a) where - abstractNSM (ExprAndPerm e p) = - mbMap2 ExprAndPerm <$> abstractNSM e <*> abstractNSM p - -instance AbstractNamedShape w (ValuePerms as) where - abstractNSM ValPerms_Nil = pureBindingM ValPerms_Nil - abstractNSM (ValPerms_Cons ps p) = - mbMap2 ValPerms_Cons <$> abstractNSM ps <*> abstractNSM p - -instance AbstractNamedShape w (FunPerm ghosts args gouts ret) where - abstractNSM (FunPerm ghosts args gouts ret perms_in perms_out) = - mbMap2 (FunPerm ghosts args gouts ret) <$> abstractNSM perms_in - <*> abstractNSM perms_out - - -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 ----------------------------------------------------------------------- - --- | Get the 'BlockHintSort' for a 'BlockHint' -blockHintSort :: BlockHint blocks init ret args -> BlockHintSort args -blockHintSort (BlockHint _ _ _ sort) = sort - --- | Test if a 'BlockHintSort' is a block entry hint -isBlockEntryHint :: BlockHintSort args -> Bool -isBlockEntryHint (BlockEntryHintSort _ _ _) = True -isBlockEntryHint _ = False - --- | Test if a 'BlockHintSort' is a generalization hint -isGenPermsHint :: BlockHintSort args -> Bool -isGenPermsHint GenPermsHintSort = True -isGenPermsHint _ = False - --- | Test if a 'BlockHintSort' is a generalization hint -isJoinPointHint :: BlockHintSort args -> Bool -isJoinPointHint JoinPointHintSort = True -isJoinPointHint _ = False - --- FIXME: all the per-block hints - --- | The empty 'PermEnv' -emptyPermEnv :: PermEnv -emptyPermEnv = PermEnv [] [] [] [] [] defaultSpecMEventType - --- | Add a 'NamedPerm' to a permission environment -permEnvAddNamedPerm :: PermEnv -> NamedPerm ns args a -> PermEnv -permEnvAddNamedPerm env np = - env { permEnvNamedPerms = SomeNamedPerm np : permEnvNamedPerms env } - --- | Add a 'NamedShape' to a permission environment -permEnvAddNamedShape :: (1 <= w, KnownNat w) => - PermEnv -> NamedShape b args w -> PermEnv -permEnvAddNamedShape env ns = - env { permEnvNamedShapes = SomeNamedShape ns : permEnvNamedShapes env } - --- | Add an opaque named permission to a 'PermEnv' -permEnvAddOpaquePerm :: PermEnv -> String -> CruCtx args -> TypeRepr a -> - Ident -> Ident -> PermEnv -permEnvAddOpaquePerm env str args tp trans_id d_id = - let n = NamedPermName str tp args (OpaqueSortRepr - TrueRepr) NameNonReachConstr in - permEnvAddNamedPerm env $ NamedPerm_Opaque $ OpaquePerm n trans_id d_id - --- | Add a recursive named permission to a 'PermEnv', given a 'String' name for --- the permission, its argument types and permission type, identifiers for its --- 'recPermTransType' and 'recPermTransDesc' fields, its body, and optional --- reachability constraints and methods. The last two of these can depend on the --- @b@ flag computed for the body, and the last can take in the name being --- created and a temporary 'PermEnv' with this name added in order to construct --- the 'ReachMethods', which can be constructed in an arbitrary monad. -permEnvAddRecPermM :: Monad m => PermEnv -> String -> CruCtx args -> - TypeRepr a -> Ident -> Ident -> - Mb (args :> ValuePermType a) (ValuePerm a) -> - (forall b. NameReachConstr (RecursiveSort b reach) args a) -> - (forall b. NamedPermName (RecursiveSort b reach) args a -> - PermEnv -> m (ReachMethods args a reach)) -> - m PermEnv -permEnvAddRecPermM env nm args tp trans_ident d_ident body reachC reachMethsF - | Some b <- someBool $ mbLift $ fmap isConjPerm body = - do let reach = nameReachConstrBool reachC - let npn = NamedPermName nm tp args (RecursiveSortRepr b reach) reachC - let tmp_env = - permEnvAddNamedPerm env $ NamedPerm_Rec $ - RecPerm npn trans_ident d_ident - (error "Using reachability methods for recursive perm before it is defined!") - body - reachMeths <- reachMethsF npn tmp_env - return $ - permEnvAddNamedPerm env $ NamedPerm_Rec $ - RecPerm npn trans_ident d_ident reachMeths body - --- | Add a defined named permission to a 'PermEnv' -permEnvAddDefinedPerm :: PermEnv -> String -> CruCtx args -> TypeRepr a -> - Mb args (ValuePerm a) -> PermEnv -permEnvAddDefinedPerm env str args tp p = - case someBool $ mbLift $ fmap isConjPerm p of - Some b -> - let n = NamedPermName str tp args (DefinedSortRepr b) NameNonReachConstr - np = NamedPerm_Defined (DefinedPerm n p) in - env { permEnvNamedPerms = SomeNamedPerm np : permEnvNamedPerms env } - --- | Add a defined LLVM shape to a permission environment -permEnvAddDefinedShape :: (1 <= w, KnownNat w) => PermEnv -> String -> - CruCtx args -> Mb args (PermExpr (LLVMShapeType w)) -> - PermEnv -permEnvAddDefinedShape env nm args mb_sh = - env { permEnvNamedShapes = - SomeNamedShape (NamedShape nm args $ - DefinedShapeBody mb_sh) : permEnvNamedShapes env } - --- | Add an opaque LLVM shape to a permission environment -permEnvAddOpaqueShape :: (1 <= w, KnownNat w) => PermEnv -> String -> - CruCtx args -> Mb args (PermExpr (BVType w)) -> - Ident -> Ident -> PermEnv -permEnvAddOpaqueShape env nm args mb_len tp_id d_id = - env { permEnvNamedShapes = - SomeNamedShape (NamedShape nm args $ - OpaqueShapeBody mb_len tp_id d_id) - : permEnvNamedShapes env } - --- | Add a global symbol with a function permission along with its translation --- to a spec function to a 'PermEnv' -permEnvAddGlobalSymFun :: (1 <= w, KnownNat w) => PermEnv -> GlobalSymbol -> - f w -> FunPerm ghosts args gouts ret -> - OpenTerm -> PermEnv -permEnvAddGlobalSymFun env sym (w :: f w) fun_perm t = - let p = ValPerm_Conj1 $ mkPermLLVMFunPtr w fun_perm in - env { permEnvGlobalSyms = - PermEnvGlobalEntry sym p (GlobalTrans [t]) - : permEnvGlobalSyms env } - --- | Add a global symbol with 0 or more function permissions to a 'PermEnv' -permEnvAddGlobalSymFunMulti :: (1 <= w, KnownNat w) => PermEnv -> - GlobalSymbol -> f w -> - [(SomeFunPerm args ret, OpenTerm)] -> PermEnv -permEnvAddGlobalSymFunMulti env sym (w :: f w) ps_ts = - let p = ValPerm_Conj1 $ mkPermLLVMFunPtrs w $ map fst ps_ts in - env { permEnvGlobalSyms = - PermEnvGlobalEntry sym p (GlobalTrans $ map snd ps_ts) - : permEnvGlobalSyms env } - --- | Add some 'PermEnvGlobalEntry's to a 'PermEnv' -permEnvAddGlobalSyms :: PermEnv -> [PermEnvGlobalEntry] -> PermEnv -permEnvAddGlobalSyms env entries = env { permEnvGlobalSyms = - entries ++ permEnvGlobalSyms env } - --- | Add a 'Hint' to a 'PermEnv' -permEnvAddHint :: PermEnv -> Hint -> PermEnv -permEnvAddHint env hint = env { permEnvHints = hint : permEnvHints env } - --- | Look up a 'FnHandle' by name in a 'PermEnv' -lookupFunHandle :: PermEnv -> String -> Maybe SomeHandle -lookupFunHandle env str = - case find (\(PermEnvFunEntry h _ _) -> - handleName h == fromString str) (permEnvFunPerms env) of - Just (PermEnvFunEntry h _ _) -> Just (SomeHandle h) - Nothing -> Nothing - --- | Look up the function permission and SAW translation for a 'FnHandle' -lookupFunPerm :: PermEnv -> FnHandle cargs ret -> - Maybe (SomeFunPerm (CtxToRList cargs) ret, Ident) -lookupFunPerm env = helper (permEnvFunPerms env) where - helper :: [PermEnvFunEntry] -> FnHandle cargs ret -> - Maybe (SomeFunPerm (CtxToRList cargs) ret, Ident) - helper [] _ = Nothing - helper ((PermEnvFunEntry h' fun_perm ident):_) h - | Just Refl <- testEquality (handleType h') (handleType h) - , h' == h - = Just (SomeFunPerm fun_perm, ident) - helper (_:entries) h = helper entries h - --- | Look up a 'NamedPermName' by name in a 'PermEnv' -lookupNamedPermName :: PermEnv -> String -> Maybe SomeNamedPermName -lookupNamedPermName env str = - case find (\(SomeNamedPerm np) -> - namedPermNameName (namedPermName np) == str) (permEnvNamedPerms env) of - Just (SomeNamedPerm np) -> Just (SomeNamedPermName (namedPermName np)) - Nothing -> Nothing - --- | Look up a conjunctive 'NamedPermName' by name in a 'PermEnv' -lookupNamedConjPermName :: PermEnv -> String -> Maybe SomeNamedConjPermName -lookupNamedConjPermName env str = - case find (\(SomeNamedPerm np) -> - namedPermNameName (namedPermName np) == str) - (permEnvNamedPerms env) of - Just (SomeNamedPerm np) - | TrueRepr <- nameIsConjRepr $ namedPermName np -> - Just (SomeNamedConjPermName (namedPermName np)) - _ -> Nothing - --- | Look up the 'NamedPerm' for a 'NamedPermName' in a 'PermEnv' -lookupNamedPerm :: PermEnv -> NamedPermName ns args a -> - Maybe (NamedPerm ns args a) -lookupNamedPerm env = helper (permEnvNamedPerms env) where - helper :: [SomeNamedPerm] -> NamedPermName ns args a -> - Maybe (NamedPerm ns args a) - helper [] _ = Nothing - helper (SomeNamedPerm rp:_) rpn - | Just (Refl, Refl, Refl) <- testNamedPermNameEq (namedPermName rp) rpn - = Just rp - helper (_:rps) rpn = helper rps rpn - --- | Look up the 'NamedPerm' for a 'NamedPermName' in a 'PermEnv' or raise an --- error if it does not exist -requireNamedPerm :: PermEnv -> NamedPermName ns args a -> NamedPerm ns args a -requireNamedPerm env npn - | Just np <- lookupNamedPerm env npn = np -requireNamedPerm _ npn = - panic "requireNamedPerm" [ - "Named perm does not exist: " ++ namedPermNameName npn - ] - --- | Look up an LLVM shape by name in a 'PermEnv' and cast it to a given width -lookupNamedShape :: PermEnv -> String -> Maybe SomeNamedShape -lookupNamedShape env nm = - find (\case SomeNamedShape nmsh -> - nm == namedShapeName nmsh) (permEnvNamedShapes env) - --- | Look up the permissions and translation for a 'GlobalSymbol' at a --- particular machine word width -lookupGlobalSymbol :: PermEnv -> GlobalSymbol -> NatRepr w -> - Maybe (ValuePerm (LLVMPointerType w), GlobalTrans) -lookupGlobalSymbol env = helper (permEnvGlobalSyms env) where - helper :: [PermEnvGlobalEntry] -> GlobalSymbol -> NatRepr w -> - Maybe (ValuePerm (LLVMPointerType w), GlobalTrans) - helper (PermEnvGlobalEntry sym' - (p :: ValuePerm (LLVMPointerType w')) tr:_) sym w - | sym' == sym - , Just Refl <- testEquality w (knownNat :: NatRepr w') = - Just (p, tr) - helper (_:entries) sym w = helper entries sym w - helper [] _ _ = Nothing - --- | Look up all hints associated with a 'BlockID' in a function -lookupBlockHints :: PermEnv -> FnHandle init ret -> Assignment CtxRepr blocks -> - BlockID blocks args -> [BlockHintSort args] -lookupBlockHints env h blocks blkID = - mapMaybe (\hint -> case hint of - Hint_Block (BlockHint h' blocks' blkID' sort) - | Just Refl <- testEquality (handleID h') (handleID h) - , Just Refl <- testEquality blocks' blocks - , Just Refl <- testEquality blkID blkID' -> - return sort - _ -> Nothing) $ - permEnvHints env - --- | Look up all hints with sort 'BlockEntryHintSort' for a given function -lookupBlockEntryHints :: PermEnv -> FnHandle init ret -> - Assignment CtxRepr blocks -> - [Some (BlockHint blocks init ret)] -lookupBlockEntryHints env h blocks = - mapMaybe (\hint -> case hint of - Hint_Block blk_hint@(BlockHint h' blocks' _blkID' - (BlockEntryHintSort _ _ _)) - | Just Refl <- testEquality (handleID h') (handleID h) - , Just Refl <- testEquality blocks' blocks -> - return $ Some blk_hint - _ -> Nothing) $ - permEnvHints env - --- | Test if a 'BlockID' in a 'CFG' has a hint with sort 'GenPermsHintSort' -lookupBlockGenPermsHint :: PermEnv -> FnHandle init ret -> - Assignment CtxRepr blocks -> BlockID blocks args -> - Bool -lookupBlockGenPermsHint env h blocks blkID = - any (\case GenPermsHintSort -> True - _ -> False) $ - lookupBlockHints env h blocks blkID - --- | Test if a 'BlockID' in a 'CFG' has a hint with sort 'JoinPointHintSort' -lookupBlockJoinPointHint :: PermEnv -> FnHandle init ret -> - Assignment CtxRepr blocks -> BlockID blocks args -> - Bool -lookupBlockJoinPointHint env h blocks blkID = - any (\case JoinPointHintSort -> True - _ -> False) $ - lookupBlockHints env h blocks blkID - - ----------------------------------------------------------------------- --- * Permission Sets ----------------------------------------------------------------------- - --- FIXME: revisit all the operations in this section and remove those that we no --- longer need - --- | A permission set associates permissions with expression variables, and also --- has a stack of \"distinguished permissions\" that are used for intro rules -data PermSet ps = PermSet { _varPermMap :: NameMap ValuePerm, - _distPerms :: DistPerms ps } - -makeLenses ''PermSet - --- | Get all variables that have permissions set in a 'PermSet' -permSetVars :: PermSet ps -> [SomeName CrucibleType] -permSetVars = - map (\case (NameAndElem n _) -> - SomeName n) . NameMap.assocs . view varPermMap - --- | Build a 'PermSet' with only distinguished permissions -distPermSet :: DistPerms ps -> PermSet ps -distPermSet perms = PermSet NameMap.empty perms - --- | The lens for the permissions associated with a given variable -varPerm :: ExprVar a -> Lens' (PermSet ps) (ValuePerm a) -varPerm x = - lens - (\(PermSet nmap _) -> - case NameMap.lookup x nmap of - Just p -> p - Nothing -> ValPerm_True) - (\(PermSet nmap ps) p -> PermSet (NameMap.insert x p nmap) ps) - --- | Set the primary permission for a variable, assuming it is currently the --- trivial permission @true@ -setVarPerm :: ExprVar a -> ValuePerm a -> PermSet ps -> PermSet ps -setVarPerm x p = - over (varPerm x) $ \p' -> - case p' of - ValPerm_True -> p - _ -> panic "setVarPerm" ["permission for variable already set!"] - --- | Get a permission list for multiple variables -varPermsMulti :: RAssign Name ns -> PermSet ps -> DistPerms ns -varPermsMulti MNil _ = DistPermsNil -varPermsMulti (ns :>: n) ps = - DistPermsCons (varPermsMulti ns ps) n (ps ^. varPerm n) - --- | Get a permission list for all variable permissions -permSetAllVarPerms :: PermSet ps -> Some DistPerms -permSetAllVarPerms perm_set = - foldr (\(NameAndElem x p) (Some perms) -> Some (DistPermsCons perms x p)) - (Some DistPermsNil) (NameMap.assocs $ _varPermMap perm_set) - --- | A determined vars clause says that the variable on the right-hand side is --- determined (as in the description of 'determinedVars') if all those on the --- left-hand side are. Note that this is an if and not an iff, as there may be --- other ways to mark that RHS variable determined. -data DetVarsClause = - DetVarsClause (NameSet CrucibleType) (SomeName CrucibleType) - --- | Union a 'NameSet' to the left-hand side of a 'DetVarsClause' -detVarsClauseAddLHS :: NameSet CrucibleType -> DetVarsClause -> DetVarsClause -detVarsClauseAddLHS names (DetVarsClause lhs rhs) = - DetVarsClause (NameSet.union lhs names) rhs - --- | Add a single variable to the left-hand side of a 'DetVarsClause' -detVarsClauseAddLHSVar :: ExprVar a -> DetVarsClause -> DetVarsClause -detVarsClauseAddLHSVar n (DetVarsClause lhs rhs) = - DetVarsClause (NameSet.insert n lhs) rhs - -newtype SeenDetVarsClauses :: CrucibleType -> Type where - SeenDetVarsClauses :: [DetVarsClause] -> SeenDetVarsClauses tp - --- | Generic function to compute the 'DetVarsClause's for a permission -class GetDetVarsClauses a where - getDetVarsClauses :: - a -> ReaderT (PermSet ps) (State (NameMap SeenDetVarsClauses)) - [DetVarsClause] - -instance GetDetVarsClauses a => GetDetVarsClauses [a] where - getDetVarsClauses l = concat <$> mapM getDetVarsClauses l - -instance GetDetVarsClauses (ExprVar a) where - -- If x has not been visited yet, then return a clause stating that x is - -- determined and add all variables that are potentially determined by the - -- current permissions on x - getDetVarsClauses x = - do seen_vars <- get - perms <- ask - perm_clauses <- case NameMap.lookup x seen_vars of - Just (SeenDetVarsClauses perm_clauses) -> return perm_clauses - Nothing -> do perm_clauses <- getDetVarsClauses (perms ^. varPerm x) - modify (NameMap.insert x (SeenDetVarsClauses perm_clauses)) - return perm_clauses - return (DetVarsClause NameSet.empty (SomeName x) : - map (detVarsClauseAddLHSVar x) perm_clauses) - -instance GetDetVarsClauses (PermExpr a) where - getDetVarsClauses e - | isDeterminingExpr e = - concat <$> mapM (\(SomeName n) -> - getDetVarsClauses n) (NameSet.toList $ freeVars e) - getDetVarsClauses _ = return [] - - -instance GetDetVarsClauses (PermExprs as) where - getDetVarsClauses PExprs_Nil = return [] - getDetVarsClauses (PExprs_Cons es e) = - (++) <$> getDetVarsClauses es <*> getDetVarsClauses e - -instance GetDetVarsClauses (ValuePerm a) where - getDetVarsClauses (ValPerm_Eq e) = getDetVarsClauses e - getDetVarsClauses (ValPerm_Conj ps) = concat <$> mapM getDetVarsClauses ps - -- FIXME: For named perms, we currently require the offset to have no free - -- vars, as a simplification, but this could maybe be loosened...? - getDetVarsClauses (ValPerm_Named _ args off) - | NameSet.null (freeVars off) = getDetVarsClauses args - getDetVarsClauses _ = return [] - -instance GetDetVarsClauses (ValuePerms as) where - getDetVarsClauses ValPerms_Nil = return [] - getDetVarsClauses (ValPerms_Cons ps p) = - (++) <$> getDetVarsClauses ps <*> getDetVarsClauses p - -instance GetDetVarsClauses (AtomicPerm a) where - getDetVarsClauses (Perm_LLVMField fp) = getDetVarsClauses fp - getDetVarsClauses (Perm_LLVMArray ap) = getDetVarsClauses ap - getDetVarsClauses (Perm_LLVMBlock bp) = getDetVarsClauses bp - getDetVarsClauses (Perm_LLVMBlockShape sh) = getDetVarsClauses sh - getDetVarsClauses (Perm_LLVMFrame frame_perm) = - concat <$> mapM (getDetVarsClauses . fst) frame_perm - getDetVarsClauses (Perm_LOwned _ _ _ _ _) = return [] - getDetVarsClauses (Perm_LOwnedSimple _ lops) = - getDetVarsClauses $ RL.map exprAndPermPerm lops - getDetVarsClauses _ = return [] - -instance (1 <= w, KnownNat w, 1 <= sz, KnownNat sz) => - GetDetVarsClauses (LLVMFieldPerm w sz) where - getDetVarsClauses (LLVMFieldPerm {..}) = - map (detVarsClauseAddLHS (freeVars llvmFieldOffset)) <$> concat <$> - sequence [getDetVarsClauses llvmFieldRW, - getDetVarsClauses llvmFieldLifetime, - getDetVarsClauses llvmFieldContents] - -instance (1 <= w, KnownNat w) => GetDetVarsClauses (LLVMArrayPerm w) where - getDetVarsClauses (LLVMArrayPerm {..}) = - map (detVarsClauseAddLHS $ - NameSet.unions [freeVars llvmArrayOffset, freeVars llvmArrayLen, - freeVars llvmArrayBorrows]) <$> concat <$> - sequence [getDetVarsClauses llvmArrayRW, - getDetVarsClauses llvmArrayLifetime, - getDetVarsClauses llvmArrayCellShape] - -instance (1 <= w, KnownNat w) => GetDetVarsClauses (LLVMBlockPerm w) where - getDetVarsClauses (LLVMBlockPerm {..}) = - map (detVarsClauseAddLHS $ - NameSet.unions [freeVars llvmBlockOffset, freeVars llvmBlockLen]) <$> - concat <$> sequence [getDetVarsClauses llvmBlockRW, - getDetVarsClauses llvmBlockLifetime, - getShapeDetVarsClauses llvmBlockShape] - -instance GetDetVarsClauses (LLVMFieldShape w) where - getDetVarsClauses (LLVMFieldShape p) = getDetVarsClauses p - --- | Compute the 'DetVarsClause's for a block permission with the given shape -getShapeDetVarsClauses :: - (1 <= w, KnownNat w) => PermExpr (LLVMShapeType w) -> - ReaderT (PermSet ps) (State (NameMap SeenDetVarsClauses)) [DetVarsClause] -getShapeDetVarsClauses (PExpr_Var x) = - getDetVarsClauses x -getShapeDetVarsClauses (PExpr_NamedShape _ _ _ args) = - -- FIXME: maybe also include the variables determined by the modalities? - getDetVarsClauses args -getShapeDetVarsClauses (PExpr_EqShape len e) = - map (detVarsClauseAddLHS (freeVars len)) <$> getDetVarsClauses e -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 _ sh) = - map (detVarsClauseAddLHS (freeVars len)) <$> getDetVarsClauses sh -getShapeDetVarsClauses (PExpr_TupShape sh) = getShapeDetVarsClauses sh -getShapeDetVarsClauses (PExpr_SeqShape sh1 sh2) - | isJust $ llvmShapeLength sh1 = - (++) <$> getDetVarsClauses sh1 <*> getDetVarsClauses sh2 -getShapeDetVarsClauses _ = return [] - - --- | Compute all the variables whose values are /determined/ by the permissions --- on the given input variables, other than those variables themselves. The --- intuitive idea is that permission @x:p@ determines the value of @y@ iff there --- is always a uniquely determined value of @y@ for any proof of @exists y.x:p@. -determinedVars :: PermSet ps -> RAssign ExprVar ns -> [SomeName CrucibleType] -determinedVars top_perms vars = - let vars_map = NameMap.fromList $ - mapToList (\v -> NameAndElem v (SeenDetVarsClauses [])) vars - vars_set = NameSet.fromList $ mapToList SomeName vars - multigraph = - evalState (runReaderT (getDetVarsClauses (distPermsToValuePerms $ - varPermsMulti vars top_perms)) - top_perms) - vars_map in - evalState (determinedVarsForGraph multigraph) vars_set - where - -- Find all variables that are not already marked as determined in our - -- NameSet state but that are determined given the current determined - -- variables, mark these variables as determined, and then repeat, returning - -- all variables that are found in order - determinedVarsForGraph :: [DetVarsClause] -> - State (NameSet CrucibleType) - [SomeName CrucibleType] - determinedVarsForGraph graph = - do det_vars <- concat <$> mapM determinedVarsForClause graph - if det_vars == [] then return [] else - (det_vars ++) <$> determinedVarsForGraph graph - - -- If the LHS of a clause has become determined but its RHS is not, return - -- its RHS, otherwise return nothing - determinedVarsForClause :: DetVarsClause -> - State (NameSet CrucibleType) - [SomeName CrucibleType] - determinedVarsForClause (DetVarsClause lhs_vars (SomeName rhs_var)) = - do det_vars <- get - if not (NameSet.member rhs_var det_vars) && - nameSetIsSubsetOf lhs_vars det_vars - then modify (NameSet.insert rhs_var) >> return [SomeName rhs_var] - else return [] - --- | Compute the transitive free variables of the permissions on some input list --- @ns@ of variables, which includes all variables @ns1@ that are free in the --- permissions associated with @ns@, all the variables @ns2@ free in the --- permissions of @ns1@, etc. Every variable in the returned list is guaranteed --- to be listed /after/ (i.e., to the right of where) it is used. -varPermsTransFreeVars :: RAssign ExprVar ns -> PermSet ps -> - Some (RAssign ExprVar) -varPermsTransFreeVars = - helper NameSet.empty . mapToList SomeName - where - helper :: NameSet CrucibleType -> [SomeName CrucibleType] -> PermSet ps -> - Some (RAssign ExprVar) - helper seen_vars ns perms = - let seen_vars' = - foldr (\(SomeName n) -> NameSet.insert n) seen_vars ns - free_vars = - NameSet.unions $ - map (\(SomeName n) -> freeVars (perms ^. varPerm n)) ns - new_vars = NameSet.difference free_vars seen_vars' in - case toList new_vars of - [] -> Some MNil - new_ns -> - case (namesListToNames new_ns, helper seen_vars' new_ns perms) of - (SomeRAssign ns', Some rest) -> - Some $ append ns' rest - - --- | Initialize the primary permission of a variable to the given permission if --- the variable is not yet set -initVarPermWith :: ExprVar a -> ValuePerm a -> PermSet ps -> PermSet ps -initVarPermWith x p = - over varPermMap $ \nmap -> - if NameMap.member x nmap then nmap else NameMap.insert x p nmap - --- | Initialize the primary permission of a variable to @true@ if it is not set -initVarPerm :: ExprVar a -> PermSet ps -> PermSet ps -initVarPerm x = - initVarPermWith x ValPerm_True - --- | Set the primary permissions for a sequence of variables to @true@ -initVarPerms :: RAssign Name (as :: RList CrucibleType) -> PermSet ps -> - PermSet ps -initVarPerms MNil perms = perms -initVarPerms (ns :>: n) perms = initVarPerms ns $ initVarPerm n perms - --- | The lens for a particular distinguished perm, checking that it is indeed --- associated with the given variable -distPerm :: Member ps a -> ExprVar a -> Lens' (PermSet ps) (ValuePerm a) -distPerm memb x = distPerms . nthVarPerm memb x - --- | The lens for the distinguished perm at the top of the stack, checking that --- it has the given variable -topDistPerm :: ExprVar a -> Lens' (PermSet (ps :> a)) (ValuePerm a) -topDistPerm x = distPerms . distPermsHead x - --- | Modify the distinguished permission stack of a 'PermSet' -modifyDistPerms :: (DistPerms ps1 -> DistPerms ps2) -> - PermSet ps1 -> PermSet ps2 -modifyDistPerms f (PermSet perms dperms) = PermSet perms $ f dperms - --- | Get all the permissions in the permission set as a sequence of --- distinguished permissions -getAllPerms :: PermSet ps -> Some DistPerms -getAllPerms perms = helper (NameMap.assocs $ perms ^. varPermMap) where - helper :: [NameAndElem ValuePerm] -> Some DistPerms - helper [] = Some DistPermsNil - helper (NameAndElem x p : xps) = - case helper xps of - Some ps -> Some $ DistPermsCons ps x p - --- | Delete permission @x:p@ from the permission set, assuming @x@ has precisely --- permissions @p@, replacing it with @x:true@ -deletePerm :: ExprVar a -> ValuePerm a -> PermSet ps -> PermSet ps -deletePerm x p = - over (varPerm x) $ \p' -> - if p' == p then ValPerm_True else panic "deletePerm" ["Permission didn't match"] - --- | Push a new distinguished permission onto the top of the stack -pushPerm :: ExprVar a -> ValuePerm a -> PermSet ps -> PermSet (ps :> a) -pushPerm x p (PermSet nmap ps) = PermSet nmap (DistPermsCons ps x p) - --- | Pop the top distinguished permission off of the stack -popPerm :: ExprVar a -> PermSet (ps :> a) -> (PermSet ps, ValuePerm a) -popPerm x (PermSet nmap pstk) = - (PermSet nmap (pstk ^. distPermsTail), pstk ^. distPermsHead x) - --- | Drop the top distinguished permission on the stack -dropPerm :: ExprVar a -> PermSet (ps :> a) -> PermSet ps -dropPerm x = fst . popPerm x diff --git a/heapster/src/Heapster/README.md b/heapster/src/Heapster/README.md deleted file mode 100644 index 0dbebd1154..0000000000 --- a/heapster/src/Heapster/README.md +++ /dev/null @@ -1,20 +0,0 @@ - -# Heapster Developer Documentation - -This directory contains an implementation of the Heapster portion of SAW. - -## Overall Code Structure - -The central components of Heapster are in the following files: - -* Permissions.hs: This file defines the language of _permissions_, which are the types in Heapster. Heapster permissions are defined by the `ValuePerm` datatype, which is defined mutually with the type `PermExpr` of Heapster expressions. See [here](../../../../doc/Permissions.md) for more detail on the Heapster permission langauge. - -* Implication.hs: This file defines the concept of _permission implication_ in Heapster, which is a form of subtyping on the Heapster permission types. Permission implication is defined by the `PermImpl` type, which represents a proof that one permission implies, or is a subtype of, another. This file also contains the implication prover, which is the algorithm that attempts to build permission implication proofs. The implication rules are described [here](../../../../doc/Rules.md), while the implication prover is described [here](../../../../doc/ImplProver.md). - -* TypedCrucible.hs: This file defines a version of Crucible control-flow graphs (CFGs) that have been type-checked by Heapster. Each Crucible data type used to define CFGs, including the type `CFG` itself, has a corresponding data type in TypedCrucible.hs with `"Typed"` prefixed to its name. This includes the `TypedCFG` type used to represent an entire typed-checked CFG. This file also contains the function `tcCFG` that performs type-checking on a Crucible CFG, along with helper functions used to type-check the various component pieces of Crucible CFGs. - -* SAWTranslation.hs: This file defines the translation from type-checked Crucible CFGs to SAW core terms that represent their specifications. - -* RustTypes.hs: This file translates Rust types into Heapster types, using a process described [here](../../../../doc/RustTrans.md). - -[comment]: <> (FIXME: describe the other files) diff --git a/heapster/src/Heapster/RustTypes.hs b/heapster/src/Heapster/RustTypes.hs deleted file mode 100644 index ce15056ea5..0000000000 --- a/heapster/src/Heapster/RustTypes.hs +++ /dev/null @@ -1,1593 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE EmptyCase #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} --- {-# OPTIONS_GHC -freduction-depth=0 #-} - -module Heapster.RustTypes where - -import Prelude hiding (span) - -import Data.Maybe -import Data.List (delete, find, findIndex, intersperse) -import GHC.TypeLits -import qualified Data.BitVector.Sized as BV -import Data.Functor.Constant -import Data.Functor.Product -import qualified Control.Applicative as App -import Control.Monad (MonadPlus(..)) -import Control.Monad.Except (Except, MonadError(..), runExcept) -import Control.Monad.Reader (MonadReader(..), ReaderT(..), asks) -import Control.Monad.Trans.Class (MonadTrans(..)) -import Control.Monad.Trans.Maybe -import qualified Control.Monad.Fail as Fail - -import Data.Parameterized.BoolRepr -import Data.Parameterized.Some -import Data.Parameterized.Context (Assignment, IsAppend(..), - incSize, zeroSize, sizeInt, - size, generate, extend) -import qualified Data.Parameterized.Context as Ctx -import Data.Parameterized.TraversableF - -import Data.Binding.Hobbits -import Data.Binding.Hobbits.MonadBind -import qualified Data.Type.RList as RL -import qualified Data.Binding.Hobbits.NameSet as NameSet - -import Language.Rust.Syntax -import Language.Rust.Parser -import qualified Language.Rust.Pretty as RustPP -import Language.Rust.Data.Ident (Ident(..), name) - -import Prettyprinter as PP - -import Lang.Crucible.Types -import Lang.Crucible.LLVM.Bytes -import Lang.Crucible.LLVM.MemModel hiding (Mutability(..)) - -import Heapster.CruUtil -import Heapster.Permissions - - ----------------------------------------------------------------------- --- * Data types and related types ----------------------------------------------------------------------- - --- | A permission of some llvm pointer type -data SomeLLVMPerm = - forall w. (1 <= w, KnownNat w) => SomeLLVMPerm (ValuePerm (LLVMPointerType w)) - --- | An 'ArgLayoutPerm' is a set of permissions on a sequence of 0 or more --- arguments, given by the @tps@ type-level argument. These permissions are --- similar to the language of permissions on a Crucible struct, except that the --- langauge is restricted to ensure that they can always be appended. --- --- FIXME: add support for shapes like bool whose size is smaller than a byte, --- with the constraint that the end result should only have fields whose sizes --- are whole numbers of bytes. The idea would be to allow sub-byte-sized fields --- be appended, but to then round their sizes up to whole numbers of bytes at --- disjunctions and at the top level. -data ArgLayoutPerm ctx where - ALPerm :: RAssign ValuePerm (CtxToRList ctx) -> ArgLayoutPerm ctx - ALPerm_Or :: ArgLayoutPerm ctx -> ArgLayoutPerm ctx -> ArgLayoutPerm ctx - ALPerm_Exists :: KnownRepr TypeRepr a => - Binding a (ArgLayoutPerm ctx) -> ArgLayoutPerm ctx - --- | An argument layout captures how argument values are laid out as a Crucible --- struct of 0 or more machine words / fields -data ArgLayout where - ArgLayout :: CtxRepr ctx -> ArgLayoutPerm ctx -> ArgLayout - --- | Like an 'ArgLayout' but with output permissions on arguments as well -data ArgLayoutIO where - ArgLayoutIO :: CtxRepr ctx -> ArgLayoutPerm ctx -> - RAssign ValuePerm (CtxToRList ctx) -> ArgLayoutIO - --- | Function permission that is existential over all types (note that there --- used to be 3 type variables instead of 4 for 'FunPerm', thus the name) -data Some3FunPerm = - forall ghosts args gouts ret. Some3FunPerm (FunPerm ghosts args gouts ret) - - ----------------------------------------------------------------------- --- * Template Haskell–generated instances ----------------------------------------------------------------------- - -$(mkNuMatching [t| SomeLLVMPerm |]) -$(mkNuMatching [t| forall ctx. ArgLayoutPerm ctx |]) -$(mkNuMatching [t| ArgLayout |]) -$(mkNuMatching [t| Some3FunPerm |]) - - ----------------------------------------------------------------------- --- * Helper Definitions ----------------------------------------------------------------------- - --- | A version of 'mbSeparate' that takes in an explicit phantom argument for --- the first context -mbSeparatePrx :: prx1 ctx1 -> RAssign prx2 ctx2 -> Mb (ctx1 :++: ctx2) a -> - Mb ctx1 (Mb ctx2 a) -mbSeparatePrx _ = mbSeparate - --- | Reassociate a binding list -mbAssoc :: prx1 ctx1 -> RAssign prx2 ctx2 -> RAssign prx3 ctx3 -> - Mb (ctx1 :++: (ctx2 :++: ctx3)) a -> - Mb ((ctx1 :++: ctx2) :++: ctx3) a -mbAssoc ctx1 ctx2 ctx3 mb_a | Refl <- RL.appendAssoc ctx1 ctx2 ctx3 = mb_a - --- | Reassociate a binding list in the reverse direction of 'mbAssoc' -mbUnAssoc :: prx1 ctx1 -> RAssign prx2 ctx2 -> RAssign prx3 ctx3 -> - Mb ((ctx1 :++: ctx2) :++: ctx3) a -> - Mb (ctx1 :++: (ctx2 :++: ctx3)) a -mbUnAssoc ctx1 ctx2 ctx3 mb_a | Refl <- RL.appendAssoc ctx1 ctx2 ctx3 = mb_a - --- | Prove type-level equality by reassociating four type lists -appendAssoc4 :: RAssign Proxy ctx1 -> RAssign Proxy ctx2 -> - RAssign Proxy ctx3 -> RAssign Proxy ctx4 -> - ctx1 :++: ((ctx2 :++: ctx3) :++: ctx4) :~: - ((ctx1 :++: ctx2) :++: ctx3) :++: ctx4 -appendAssoc4 ctx1 ctx2 ctx3 ctx4 - | Refl <- RL.appendAssoc ctx1 (RL.append ctx2 ctx3) ctx4 - , Refl <- RL.appendAssoc ctx1 ctx2 ctx3 - = Refl - --- | Reassociate a binding list of four contexts -mbAssoc4 :: RAssign Proxy ctx1 -> RAssign Proxy ctx2 -> - RAssign Proxy ctx3 -> RAssign Proxy ctx4 -> - Mb (ctx1 :++: ((ctx2 :++: ctx3) :++: ctx4)) a -> - Mb (((ctx1 :++: ctx2) :++: ctx3) :++: ctx4) a -mbAssoc4 ctx1 ctx2 ctx3 ctx4 mb_a - | Refl <- appendAssoc4 ctx1 ctx2 ctx3 ctx4 = mb_a - --- | Combine bindings lists using 'mbCombine' and reassociate them -mbCombineAssoc :: - prx1 ctx1 -> - RAssign prx2 ctx2 -> - RAssign prx3 ctx3 -> - Mb ctx1 (Mb (ctx2 :++: ctx3) a) -> - Mb ((ctx1 :++: ctx2) :++: ctx3) a -mbCombineAssoc _ ctx2 ctx3 - = mbCombine (RL.mapRAssign (const Proxy) ctx3) - . mbCombine (RL.mapRAssign (const Proxy) ctx2) - . fmap (mbSeparatePrx ctx2 ctx3) - --- | Combine bindings lists using 'mbCombine' and reassociate them -mbCombineAssoc4 :: - RAssign Proxy ctx1 -> RAssign Proxy ctx2 -> - RAssign Proxy ctx3 -> RAssign Proxy ctx4 -> - Mb ctx1 (Mb ((ctx2 :++: ctx3) :++: ctx4) a) -> - Mb (((ctx1 :++: ctx2) :++: ctx3) :++: ctx4) a -mbCombineAssoc4 ctx1 ctx2 ctx3 ctx4 mb_mb_a - | Refl <- appendAssoc4 ctx1 ctx2 ctx3 ctx4 - = mbCombine ((ctx2 `RL.append` ctx3) `RL.append` ctx4) mb_mb_a - --- | Prepend and reassociate an 'RAssign' -assocAppend :: RAssign f ctx1 -> prx2 ctx2 -> RAssign prx3 ctx3 -> - RAssign f (ctx2 :++: ctx3) -> - RAssign f ((ctx1 :++: ctx2) :++: ctx3) -assocAppend fs1 ctx2 ctx3 fs23 = - let (fs2, fs3) = RL.split ctx2 ctx3 fs23 in - RL.append (RL.append fs1 fs2) fs3 - --- | Prepend and reassociate an 'RAssign' to get one with four type contexts -assocAppend4 :: RAssign f ctx1 -> prx2 ctx2 -> RAssign prx3 ctx3 -> - RAssign prx4 ctx4 -> - RAssign f ((ctx2 :++: ctx3) :++: ctx4) -> - RAssign f (((ctx1 :++: ctx2) :++: ctx3) :++: ctx4) -assocAppend4 fs1 ctx2 ctx3 ctx4 fs234 = - let (fs2, fs3, fs4) = rlSplit3 ctx2 ctx3 ctx4 fs234 in - RL.append (RL.append (RL.append fs1 fs2) fs3) fs4 - --- | Info used for converting Rust types to shapes --- NOTE: @rciRecType@ should probably have some info about lifetimes -data RustConvInfo = - RustConvInfo { rciPermEnv :: PermEnv, - rciCtx :: [(String, TypedName)], - rciRecType :: Maybe (RustName, [RustName], TypedName) } - --- | The default, top-level 'RustConvInfo' for a given 'PermEnv' -mkRustConvInfo :: PermEnv -> RustConvInfo -mkRustConvInfo env = - RustConvInfo { rciPermEnv = env, rciCtx = [], rciRecType = Nothing } - --- | The Rust conversion monad is just a state-error monad -newtype RustConvM a = - RustConvM { unRustConvM :: ReaderT RustConvInfo (Except String) a } - deriving (Functor, Applicative, Monad, - MonadError String, MonadReader RustConvInfo) - -instance Fail.MonadFail RustConvM where - fail = RustConvM . throwError - -instance MonadBind RustConvM where - mbM mb_m = RustConvM $ mbM $ fmap unRustConvM mb_m - --- | Prefix any error message with location information -atSpan :: Span -> RustConvM a -> RustConvM a -atSpan span m = - catchError m (\msg -> fail ("At " ++ show span ++ ": " ++ msg)) - --- | Run a Rust conversion computation with the given 'RustConvInfo', lifting --- any errors into the outer monad -runLiftRustConvM :: Fail.MonadFail m => RustConvInfo -> RustConvM a -> m a -runLiftRustConvM info (RustConvM m) = - case runExcept (runReaderT m info) of - Left err -> fail err - Right x -> return x - --- | Look up the 'TypedName' associated with a 'String' name -lookupTypedName :: String -> RustConvM TypedName -lookupTypedName str = - fmap (lookup str) (rciCtx <$> ask) >>= \case - Just n -> return n - Nothing -> fail ("Could not find variable: " ++ show str) - --- | Look up a 'Name' with a given type -lookupName :: String -> TypeRepr a -> RustConvM (Name a) -lookupName str tp = - lookupTypedName str >>= \n -> castTypedM "variable" tp n - --- | Build a 'PPInfo' structure for the names currently in scope -rsPPInfo :: RustConvM PPInfo -rsPPInfo = - foldr (\(str, Some (Typed _ n)) -> ppInfoAddExprName str n) emptyPPInfo <$> - rciCtx <$> ask - --- | The conversion of a context of Rust type and lifetime variables -type RustCtx = RAssign (Product (Constant String) TypeRepr) - --- | Build a 'RustCtx' for a single variable -rustCtx1 :: String -> TypeRepr a -> RustCtx (RNil :> a) -rustCtx1 name tp = MNil :>: Pair (Constant name) tp - --- | Extract a 'CruCtx' from a 'RustCtx' -rustCtxCtx :: RustCtx ctx -> CruCtx ctx -rustCtxCtx = cruCtxOfTypes . RL.map (\(Pair _ tp) -> tp) - --- | Extend a 'RustCtx' with a single binding on the right -rustCtxCons :: RustCtx ctx -> String -> TypeRepr a -> RustCtx (ctx :> a) -rustCtxCons ctx nm tp = ctx :>: Pair (Constant nm) tp - --- | Build a 'RustCtx' from the given variable names, all having the same type -rustCtxOfNames :: TypeRepr a -> [String] -> Some RustCtx -rustCtxOfNames tp = - foldl (\(Some ctx) name -> Some (ctx :>: Pair (Constant name) tp)) (Some MNil) - --- | Run a 'RustConvM' computation in a context of bound type-level variables, --- where the bound names are passed to the computation -inRustCtxF :: NuMatching a => RustCtx ctx -> (RAssign Name ctx -> RustConvM a) -> - RustConvM (Mb ctx a) -inRustCtxF ctx m = - mbM $ nuMulti (RL.map (\_ -> Proxy) ctx) $ \ns -> - let ns_ctx = - RL.toList $ RL.map2 (\n (Pair (Constant str) tp) -> - Constant (str, Some (Typed tp n))) ns ctx in - local (\info -> info { rciCtx = ns_ctx ++ rciCtx info }) (m ns) - --- | Run a 'RustConvM' computation in a context of bound type-level variables -inRustCtx :: NuMatching a => RustCtx ctx -> RustConvM a -> - RustConvM (Mb ctx a) -inRustCtx ctx m = inRustCtxF ctx (const m) - --- | Class for a generic \"conversion from Rust\" function, given the bit width --- of the pointer type -class RsConvert w a b | w a -> b where - rsConvert :: (1 <= w, KnownNat w) => prx w -> a -> RustConvM b - - ----------------------------------------------------------------------- --- * Converting Named Rust Types ----------------------------------------------------------------------- - --- | A function that builds a shape from a sequence of 'PermExpr' arguments and --- a 'String' representation of them for printing errors -type ShapeFun w = - Some TypedPermExprs -> String -> RustConvM (PermExpr (LLVMShapeType w)) - --- | A sequence of 'PermExprs' along with their types -type TypedPermExprs = RAssign (Typed PermExpr) - --- | The empty sequence of typed permission expressions -emptyTypedPermExprs :: Some TypedPermExprs -emptyTypedPermExprs = Some MNil - -appendTypedExprs :: Some TypedPermExprs -> Some TypedPermExprs -> - Some TypedPermExprs -appendTypedExprs (Some exprs1) (Some exprs2) = Some (RL.append exprs1 exprs2) - --- | Extract a type context from a 'TypedPermExprs' -typedPermExprsCtx :: TypedPermExprs ctx -> CruCtx ctx -typedPermExprsCtx = cruCtxOfTypes . RL.map typedType - --- | Extract the expressions from a 'TypedPermExprs' -typedPermExprsExprs :: TypedPermExprs ctx -> PermExprs ctx -typedPermExprsExprs = rassignToExprs . RL.map typedObj - --- | Convert a list of epxressions of a given type to a TypedPermExprs -typedExprsOfList :: TypeRepr a -> [PermExpr a] -> Some TypedPermExprs -typedExprsOfList tp = - foldl (\(Some es) e -> Some (es :>: Typed tp e)) (Some MNil) - --- | Build a 'ShapeFun' for the given 'RustName' from a function on permission --- expressions of the supplied types -mkShapeFun :: RustName -> CruCtx ctx -> - (PermExprs ctx -> PermExpr (LLVMShapeType w)) -> ShapeFun w -mkShapeFun nm ctx f = \some_exprs exprs_str -> case some_exprs of - Some exprs - | Just Refl <- testEquality ctx (typedPermExprsCtx exprs) -> - return $ f (typedPermExprsExprs exprs) - _ -> - fail $ renderDoc $ fillSep - [ pretty "Converting application of type:" <+> pretty (show nm) - , pretty "To arguments:" <+> pretty exprs_str - , pretty "Arguments not of expected types:" <+> pretty ctx ] - --- | Build a 'ShapeFun' with no arguments -constShapeFun :: RustName -> PermExpr (LLVMShapeType w) -> ShapeFun w -constShapeFun nm sh = mkShapeFun nm CruCtxNil (const sh) - --- | Test if a shape is \"option-like\", meaning it is a tagged union shape with --- two tags, one of which has contents and one which has no contents; i.e., it --- is of the form --- --- > (fieldsh(eq(llvmword(bv1)));sh) orsh (fieldsh(eq(llvmword(bv2)))) --- --- or --- --- > (fieldsh(eq(llvmword(bv1)))) orsh (fieldsh(eq(llvmword(bv2)));sh) --- --- where @sh@ is non-empty. If so, return the non-empty shape @sh@, called the --- \"payload\" shape. -matchOptionLikeShape :: PermExpr (LLVMShapeType w) -> - Maybe (PermExpr (LLVMShapeType w)) -matchOptionLikeShape top_sh = case asTaggedUnionShape top_sh of - Just (SomeTaggedUnionShape (taggedUnionDisjsNoTags -> - [PExpr_EmptyShape, PExpr_EmptyShape])) -> Nothing - Just (SomeTaggedUnionShape (taggedUnionDisjsNoTags -> - [PExpr_EmptyShape, sh])) -> Just sh - Just (SomeTaggedUnionShape (taggedUnionDisjsNoTags -> - [sh, PExpr_EmptyShape])) -> Just sh - _ -> Nothing - --- | Test if a shape-in-binding is \"option-like\" as per 'matchOptionLikeShape' -matchMbOptionLikeShape :: Mb ctx (PermExpr (LLVMShapeType w)) -> - Maybe (Mb ctx (PermExpr (LLVMShapeType w))) -matchMbOptionLikeShape = - mbMaybe . mbMapCl $(mkClosed [| matchOptionLikeShape |]) - --- | Test if a shape is a sum type where one branch is empty, i.e., a tagged --- union shape with two tags, one of which has the false shape as contents. If --- so, return the non-false shape @sh@. -matchSumFalseShape :: PermExpr (LLVMShapeType w) -> - Maybe (PermExpr (LLVMShapeType w)) -matchSumFalseShape top_sh = case asTaggedUnionShape $ simplifyShape top_sh of - Just (SomeTaggedUnionShape (taggedUnionDisjsNoTags -> [sh1, sh2])) - | PExpr_FalseShape <- simplifyShape sh1 -> Just sh2 - Just (SomeTaggedUnionShape (taggedUnionDisjsNoTags -> [sh1, sh2])) - | PExpr_FalseShape <- simplifyShape sh2 -> Just sh1 - _ -> Nothing - - --- | Build a `ShapeFun` from a `SomeNamedShape` -namedShapeShapeFun :: (1 <= w, KnownNat w) => RustName -> NatRepr w -> - SomeNamedShape -> RustConvM (ShapeFun w) --- For an option-like shape, try to do discriminant elision -namedShapeShapeFun nm w (SomeNamedShape nmsh) - | Just Refl <- testEquality w (natRepr nmsh) - , DefinedShapeBody mb_sh <- namedShapeBody nmsh - , Just mb_payload_sh <- matchMbOptionLikeShape mb_sh = - return $ mkShapeFun nm (namedShapeArgs nmsh) $ \exprs -> - case simplifyShape (subst (substOfExprs exprs) mb_payload_sh) of - - -- If the payload is a pointer shape, return payload orsh eq(0) - payload_sh@(isLLVMPointerShape -> True) -> - PExpr_OrShape payload_sh $ llvmEqWordShape w 0 - - -- If the payload is a tagged union shape, add an extra tag with an empty - -- shape for its argument - (asTaggedUnionShape -> Just (SomeTaggedUnionShape tag_u)) -> - let new_tag = - foldr max 0 $ map ((1+) . BV.asUnsigned) $ - taggedUnionTags tag_u in - taggedUnionToShape $ - taggedUnionCons (BV.mkBV knownNat new_tag) (llvmEqWordShape w new_tag) - tag_u - - -- Otherwise, just use the named shape itself - _ -> PExpr_NamedShape Nothing Nothing nmsh exprs - -namedShapeShapeFun nm w (SomeNamedShape nmsh) - | Just Refl <- testEquality w (natRepr nmsh) = - return $ mkShapeFun nm (namedShapeArgs nmsh) $ \exprs -> - case namedShapeBody nmsh of - -- Test if nmsh applied to exprs unfolds to a sum with false, and if so, - -- return just the non-false payload shape - DefinedShapeBody mb_sh - | unfolded_sh <- simplifyShape (subst (substOfExprs exprs) mb_sh) - , Just sh <- matchSumFalseShape unfolded_sh -> - sh - -- Otherwise just return the named shape applied to exprs - _ -> PExpr_NamedShape Nothing Nothing nmsh exprs - -namedShapeShapeFun _ w (SomeNamedShape nmsh) = - fail $ renderDoc $ fillSep - [pretty "Incorrect size of shape" <+> pretty (namedShapeName nmsh), - pretty "Expected:" <+> pretty (intValue w), - pretty "Actual:" <+> pretty (intValue (natRepr nmsh))] - --- | 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) - --- | Convert a 'RustName' to a string by interspersing @"::"@ -flattenRustName :: RustName -> String -flattenRustName (RustName ids) = concat $ intersperse "::" $ map name ids - -instance Show RustName where - show = show . flattenRustName - -instance RsConvert w RustName (ShapeFun w) where - rsConvert w nm = - do let str = flattenRustName nm - env <- rciPermEnv <$> ask - case lookupNamedShape env str of - Just nmsh -> namedShapeShapeFun nm (natRepr w) nmsh - Nothing -> - do n <- lookupName str (LLVMShapeRepr (natRepr w)) - return $ constShapeFun nm (PExpr_Var n) - --- | Get the \"name\" = sequence of identifiers out of a Rust path -rsPathName :: Path a -> RustName -rsPathName (Path _ segments _) = - RustName $ map (\(PathSegment rust_id _ _) -> rust_id) segments - --- | Get all the parameters out of a Rust path -rsPathParams :: Path a -> [PathParameters a] -rsPathParams (Path _ segments _) = - mapMaybe (\(PathSegment _ maybe_params _) -> maybe_params) segments - --- | Get the 'RustName' of a type, if it's a 'PathTy' -tyName :: Ty a -> Maybe RustName -tyName (PathTy _ path _) = Just $ rsPathName path -tyName _ = Nothing - --- | Decide whether a Rust type is named (i.e. a 'PathTy') -isNamedType :: Ty a -> Bool -isNamedType (PathTy _ _ _) = True -isNamedType _ = False - --- | Decide whether 'PathParameters' are all named types (angle-bracketed only) -isNamedParams :: PathParameters a -> Bool -isNamedParams (AngleBracketed _ tys _ _) = all isNamedType tys -isNamedParams _ = error "Parenthesized types not supported" - --- | Decide whether a Rust type definition is polymorphic and \"Option-like\"; --- that is, it contains only one data-bearing variant, and the data is of the --- polymorphic type -isPolyOptionLike :: Item Span -> Bool -isPolyOptionLike (Enum _ _ _ variants (Generics _ [TyParam _ t _ _ _] _ _) _) = - -- Short-circuit if no variant carries the type parameter. Otherwise check - -- that all other variants carry nothing - case find containsT variants of - Nothing -> False - Just v -> all isUnitVariant (delete v variants) - where - containsT (Variant _ _ (TupleD [StructField _ _ (PathTy _ (Path _ [PathSegment t' _ _] _) _) _ _] _) _ _) = - name t == name t' - containsT (Variant _ _ (StructD [StructField _ _ (PathTy _ (Path _ [PathSegment t' _ _] _) _) _ _] _) _ _) = - name t == name t' - containsT _ = False - - isUnitVariant (Variant _ _ (UnitD _) _ _) = True - isUnitVariant _ = False -isPolyOptionLike _ = False - --- | Get all of the 'RustName's of path parameters, if they're angle-bracketed -pParamNames :: PathParameters a -> [RustName] -pParamNames (AngleBracketed _ tys _ _) = mapMaybe tyName tys -pParamNames _ = error "Parenthesized types not supported" - --- | Modify a 'RustConvM' to be run with a recursive type -withRecType :: (1 <= w, KnownNat w) => RustName -> [RustName] -> Name (LLVMShapeType w) -> - RustConvM a -> RustConvM a -withRecType rust_n rust_ns rec_n = local (\info -> info { rciRecType = Just (rust_n, rust_ns, Some (Typed knownRepr rec_n)) }) - - ----------------------------------------------------------------------- --- * Converting Rust Types to Heapster Shapes ----------------------------------------------------------------------- - --- | Test if a shape matches the translation of a slice type, and, if so, return --- 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) (PermExpr (LLVMShapeType w))) -matchSliceShape (PExpr_ExShape - [nuP| PExpr_ArrayShape (PExpr_Var len) stride mb_sh |]) - | Left Member_Base <- mbNameBoundP len = - Just (mbLift stride, mb_sh) -matchSliceShape (PExpr_NamedShape _ _ nmsh@(NamedShape _ _ - (DefinedShapeBody _)) args) = - matchSliceShape (unfoldNamedShape nmsh args) -matchSliceShape _ = Nothing - --- Convert a 'Mutability' to a modality override for a 'PExpr_PtrShape'; mutable --- references inherit the modality of the container they are in, so they --- translate to 'Nothing' -instance RsConvert w Mutability (Maybe (PermExpr RWModalityType)) where - rsConvert _ Mutable = return Nothing - rsConvert _ Immutable = return (Just PExpr_Read) - -instance RsConvert w (Lifetime Span) (PermExpr LifetimeType) where - rsConvert _ (Lifetime "static" _) = return PExpr_Always - rsConvert _ (Lifetime l span) = - PExpr_Var <$> atSpan span (lookupName l knownRepr) - -instance RsConvert w (PathParameters Span) (Some TypedPermExprs) where - rsConvert w (AngleBracketed rust_ls rust_tps [] _) = - do ls <- mapM (rsConvert w) rust_ls - shs <- mapM (rsConvert w) rust_tps - return $ appendTypedExprs - (typedExprsOfList knownRepr ls) (typedExprsOfList knownRepr shs) - rsConvert _ (AngleBracketed _ _ (_:_) _) = - error "rsConvert: angle-bracketed arguments not supported" - rsConvert _ (Parenthesized _ _ _) = - error "rsConvert: parenthesized types not supported" - -instance RsConvert w [PathParameters Span] (Some TypedPermExprs) where - rsConvert w paramss = - foldr appendTypedExprs emptyTypedPermExprs <$> mapM (rsConvert w) paramss - -instance RsConvert w (Ty Span) (PermExpr (LLVMShapeType w)) where - rsConvert w (Slice tp _) = - do sh <- rsConvert w tp - case llvmShapeLength sh of - Just (bvMatchConstInt -> Just stride) -> - return (PExpr_ExShape $ nu $ \n -> - PExpr_ArrayShape (PExpr_Var n) (fromInteger stride) sh) - _ -> - rsPPInfo >>= \ppInfo -> - fail ("rsConvert: slices not supported for dynamically-sized type: " - ++ show (RustPP.pretty tp) ++ " with translation:\n" - ++ renderDoc (permPretty ppInfo sh)) - rsConvert _ (Rptr Nothing _ _ _) = - fail "rsConvert: lifetimes must be supplied for reference types" - rsConvert w (Rptr (Just rust_l) mut tp' _) = - do l <- rsConvert w rust_l - sh <- rsConvert w tp' - rw <- rsConvert w mut - case sh of - -- Test if sh is a slice type = an array of existential length - (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 (Just l) $ - PExpr_ArrayShape (PExpr_Var n) stride $ - subst1 (PExpr_Var n) mb_sh) - (PExpr_FieldShape $ LLVMFieldShape $ ValPerm_Eq $ - PExpr_LLVMWord $ PExpr_Var n) - - -- If it's not a slice, make sure it has a known size - _ | Just len <- llvmShapeLength sh - , isJust (bvMatchConst len) -> - return $ PExpr_PtrShape rw (Just l) sh - - -- Otherwise, it's a non-standard dynamically-sized type, which we - -- don't quite know how to handle yet... - _ -> fail "rsConvert: pointer to non-slice dynamically-sized type" - rsConvert w (PathTy Nothing path _) = - do mrec <- asks rciRecType - case mrec of - Just (rec_n, rec_arg_ns, sh_nm) - | rec_n == rsPathName path && - all isNamedParams (rsPathParams path) && - rec_arg_ns == concatMap pParamNames (rsPathParams path) -> - PExpr_Var <$> castTypedM "TypedName" (LLVMShapeRepr (natRepr w)) sh_nm - Just (rec_n, _, _) - | rec_n == rsPathName path -> fail "Arguments do not match" - _ -> - do shapeFn <- rsConvert w (rsPathName path) - someTypedArgs <- rsConvert w (rsPathParams path) - shapeFn someTypedArgs $ show (RustPP.prettyUnresolved path) - rsConvert (w :: prx w) (BareFn _ abi rust_ls2 fn_tp span) = - do Some3FunPerm fun_perm <- rsConvertMonoFun w span abi rust_ls2 fn_tp - let args = funPermArgs fun_perm - case cruCtxToReprEq args of - Refl -> - return $ PExpr_FieldShape $ LLVMFieldShape @w @w $ ValPerm_Conj1 $ - Perm_LLVMFunPtr - (FunctionHandleRepr (cruCtxToRepr args) (funPermRet fun_perm)) $ - ValPerm_Conj1 $ Perm_Fun fun_perm - rsConvert w (TupTy tys _) = - do tyShs <- mapM (rsConvert w) tys - return $ foldr PExpr_SeqShape PExpr_EmptyShape tyShs - rsConvert _ (Never _) = - return $ PExpr_FalseShape - rsConvert _ tp = fail ("Rust type not supported: " ++ show tp) - -instance RsConvert w (Arg Span) (PermExpr (LLVMShapeType w)) where - rsConvert w (Arg _ tp _) = rsConvert w tp - rsConvert _ _ = error "rsConvert (Arg): argument form not yet handled" - -instance RsConvert w (Generics Span) (Some RustCtx) where - rsConvert w (Generics ltdefs tyvars _ _) = - return $ foldl addTyVar (foldl addLt (Some MNil) ltdefs) tyvars - where - addLt (Some ctx) ltdef = - Some (ctx :>: Pair (Constant (lifetimeDefName ltdef)) LifetimeRepr) - - addTyVar (Some ctx) tyvar = - Some (ctx :>: Pair (Constant (tyParamName tyvar)) (LLVMShapeRepr (natRepr w))) - --- | Return true if and only if the provided Rust type definition is recursive -isRecursiveDef :: Item Span -> Bool -isRecursiveDef item = - case item of - Enum _ _ n variants _ _ -> any (containsName n . getVD) variants - StructItem _ _ n vd _ _ -> containsName n vd - _ -> False - - where - tyContainsName :: Ident -> Ty Span -> Bool - tyContainsName i ty = - case ty of - Slice t _ -> tyContainsName i t - Language.Rust.Syntax.Array t _ _ -> tyContainsName i t - Ptr _ t _ -> tyContainsName i t - Rptr _ _ t _ -> tyContainsName i t - TupTy ts _ -> any (tyContainsName i) ts - PathTy _ (Path _ segs _) _ -> any (segContainsName i) segs - ParenTy t _ -> tyContainsName i t - _ -> False - - segContainsName :: Ident -> PathSegment Span -> Bool - segContainsName i (PathSegment i' mParams _) = - i == i' || case mParams of - Nothing -> False - Just params -> paramsContainName i params - - paramsContainName :: Ident -> PathParameters Span -> Bool - paramsContainName i (AngleBracketed _ tys _ _) = any (tyContainsName i) tys - paramsContainName _ (Parenthesized _ _ _) = error "Parenthesized types not supported" - - typeOf :: StructField Span -> Ty Span - typeOf (StructField _ _ t _ _) = t - - getVD :: Variant Span -> VariantData Span - getVD (Variant _ _ vd _ _) = vd - - containsName :: Ident -> VariantData Span -> Bool - containsName i (StructD fields _) = any (tyContainsName i) $ typeOf <$> fields - containsName i (TupleD fields _) = any (tyContainsName i) $ typeOf <$> fields - containsName _ (UnitD _) = False - --- | NOTE: The translation of recursive types ignores lifetime parameters for now -instance RsConvert w (Item Span) (SomePartialNamedShape w) where - rsConvert w s@(StructItem _ _ ident vd generics@(Generics _ tys _ _) _) - | isRecursiveDef s = - do Some ctx <- rsConvert w generics - let ctx' = rustCtxCons ctx (name ident) (LLVMShapeRepr $ natRepr w) - tyIdents = (\(TyParam _ i _ _ _) -> [i]) <$> tys - sh <- inRustCtxF ctx' $ \(_ :>: rec_n) -> withRecType (RustName [ident]) (RustName <$> tyIdents) rec_n $ rsConvert w vd - return $ RecShape (name ident) (rustCtxCtx ctx) sh - | otherwise = - do Some ctx <- rsConvert w generics - sh <- inRustCtx ctx $ rsConvert w vd - return $ NonRecShape (name ident) (rustCtxCtx ctx) sh - rsConvert w e@(Enum _ _ ident variants generics@(Generics _ tys _ _) _) - | isRecursiveDef e = - do Some ctx <- rsConvert w generics - let ctx' = rustCtxCons ctx (name ident) (LLVMShapeRepr $ natRepr w) - tyIdents = (\(TyParam _ i _ _ _) -> [i]) <$> tys - sh <- inRustCtxF ctx' $ \(_ :>: rec_n) -> withRecType (RustName [ident]) (RustName <$> tyIdents) rec_n $ rsConvert w variants - return $ RecShape (name ident) (rustCtxCtx ctx) sh - | otherwise = - do Some ctx <- rsConvert w generics - sh <- inRustCtx ctx $ rsConvert w variants - return $ NonRecShape (name ident) (rustCtxCtx ctx) sh - rsConvert _ item = fail ("Top-level item not supported: " ++ show item) - -instance RsConvert w [Variant Span] (PermExpr (LLVMShapeType w)) where - rsConvert _ [] = fail "Uninhabited types not supported" - rsConvert w variants = - do vshs <- mapM (rsConvert w) variants - return $ foldr1 PExpr_OrShape (zipWith PExpr_SeqShape tags vshs) - where - buildTagShape = - PExpr_FieldShape . LLVMFieldShape . ValPerm_Eq . PExpr_LLVMWord . bvIntOfSize w - - tags = map buildTagShape [0..] - -instance RsConvert w (Variant Span) (PermExpr (LLVMShapeType w)) where - rsConvert w (Variant _ _ vd _ _) = rsConvert w vd - -instance RsConvert w (VariantData Span) (PermExpr (LLVMShapeType w)) where - rsConvert w (StructD sfs _) = - do shs <- mapM (rsConvert w) sfs - return $ foldr PExpr_SeqShape PExpr_EmptyShape shs - rsConvert w (TupleD sfs _) = - do shs <- mapM (rsConvert w) sfs - return $ foldr PExpr_SeqShape PExpr_EmptyShape shs - rsConvert _ (UnitD _) = return PExpr_EmptyShape - -instance RsConvert w (StructField Span) (PermExpr (LLVMShapeType w)) where - rsConvert w (StructField _ _ t _ _) = rsConvert w t - ----------------------------------------------------------------------- --- * Computing the ABI-Specific Layout of Rust Types ----------------------------------------------------------------------- - --- | Build an 'ArgLayoutPerm' that just assigns @true@ to every field -trueArgLayoutPerm :: Assignment prx ctx -> ArgLayoutPerm ctx -trueArgLayoutPerm ctx = ALPerm (RL.map (const ValPerm_True) $ assignToRList ctx) - --- | Build an 'ArgLayoutPerm' for 0 fields -argLayoutPerm0 :: ArgLayoutPerm EmptyCtx -argLayoutPerm0 = ALPerm MNil - --- | Build an 'ArgLayoutPerm' for a single field -argLayoutPerm1 :: ValuePerm a -> ArgLayoutPerm (EmptyCtx '::> a) -argLayoutPerm1 p = ALPerm (MNil :>: p) - --- | Convert an 'ArgLayoutPerm' to a permission on a struct -argLayoutPermToPerm :: ArgLayoutPerm ctx -> ValuePerm (StructType ctx) -argLayoutPermToPerm (ALPerm ps) = ValPerm_Conj1 $ Perm_Struct ps -argLayoutPermToPerm (ALPerm_Or p1 p2) = - ValPerm_Or (argLayoutPermToPerm p1) (argLayoutPermToPerm p2) -argLayoutPermToPerm (ALPerm_Exists mb_p) = - ValPerm_Exists $ fmap argLayoutPermToPerm mb_p - --- | Convert an 'ArgLayoutPerm' on a single field to a permission on single --- values of the type of that field -argLayoutPerm1ToPerm :: ArgLayoutPerm (EmptyCtx '::> a) -> ValuePerm a -argLayoutPerm1ToPerm (ALPerm (_ :>: p)) = p -argLayoutPerm1ToPerm (ALPerm_Or p1 p2) = - ValPerm_Or (argLayoutPerm1ToPerm p1) (argLayoutPerm1ToPerm p2) -argLayoutPerm1ToPerm (ALPerm_Exists mb_p) = - ValPerm_Exists $ fmap argLayoutPerm1ToPerm mb_p - --- | Append the field types @ctx1@ and @ctx2@ of two 'ArgLayoutPerm's to get a --- combined 'ArgLayoutPerm' over the combined fields -appendArgLayoutPerms :: Assignment prx1 ctx1 -> Assignment prx2 ctx2 -> - ArgLayoutPerm ctx1 -> ArgLayoutPerm ctx2 -> - ArgLayoutPerm (ctx1 <+> ctx2) -appendArgLayoutPerms ctx1 ctx2 (ALPerm_Or p1 p2) q = - ALPerm_Or (appendArgLayoutPerms ctx1 ctx2 p1 q) - (appendArgLayoutPerms ctx1 ctx2 p2 q) -appendArgLayoutPerms ctx1 ctx2 p (ALPerm_Or q1 q2) = - ALPerm_Or (appendArgLayoutPerms ctx1 ctx2 p q1) - (appendArgLayoutPerms ctx1 ctx2 p q2) -appendArgLayoutPerms ctx1 ctx2 (ALPerm_Exists mb_p) q = - ALPerm_Exists $ fmap (\p -> appendArgLayoutPerms ctx1 ctx2 p q) mb_p -appendArgLayoutPerms ctx1 ctx2 p (ALPerm_Exists mb_q) = - ALPerm_Exists $ fmap (\q -> appendArgLayoutPerms ctx1 ctx2 p q) mb_q -appendArgLayoutPerms ctx1 ctx2 (ALPerm ps) (ALPerm qs) = - ALPerm $ assignToRListAppend ctx1 ctx2 ps qs - --- | Count the number of fields of an 'ArgLayout' -argLayoutNumFields :: ArgLayout -> Int -argLayoutNumFields (ArgLayout ctx _) = sizeInt $ size ctx - --- | Construct an 'ArgLayout' for 0 arguments -argLayout0 :: ArgLayout -argLayout0 = ArgLayout Ctx.empty (ALPerm MNil) - --- | Construct an 'ArgLayout' for a single argument -argLayout1 :: KnownRepr TypeRepr a => ValuePerm a -> ArgLayout -argLayout1 p = ArgLayout (extend Ctx.empty knownRepr) (ALPerm (MNil :>: p)) - --- | Append two 'ArgLayout's, if possible -appendArgLayout :: ArgLayout -> ArgLayout -> ArgLayout -appendArgLayout (ArgLayout ctx1 p1) (ArgLayout ctx2 p2) = - ArgLayout (ctx1 Ctx.<++> ctx2) (appendArgLayoutPerms ctx1 ctx2 p1 p2) - --- | Test if @ctx2@ is an extension of @ctx1@ -ctxIsAppend :: CtxRepr ctx1 -> CtxRepr ctx2 -> - Maybe (IsAppend ctx1 ctx2) -ctxIsAppend ctx1 ctx2 - | Just Refl <- testEquality ctx1 ctx2 - = Just $ IsAppend zeroSize -ctxIsAppend ctx1 (ctx2' Ctx.:> _) - | Just (IsAppend sz) <- ctxIsAppend ctx1 ctx2' - = Just (IsAppend (incSize sz)) -ctxIsAppend _ _ = Nothing - --- | Take the disjunction of two 'ArgLayout's, if possible -disjoinArgLayouts :: ArgLayout -> ArgLayout -> Maybe ArgLayout -disjoinArgLayouts (ArgLayout ctx1 p1) (ArgLayout ctx2 p2) - | Just (IsAppend sz') <- ctxIsAppend ctx1 ctx2 = - let ps' = generate sz' (const ValPerm_True) in - Just $ ArgLayout ctx2 $ - ALPerm_Or - (appendArgLayoutPerms ctx1 ps' p1 (ALPerm $ assignToRList ps')) - p2 -disjoinArgLayouts (ArgLayout ctx1 p1) (ArgLayout ctx2 p2) - | Just (IsAppend sz') <- ctxIsAppend ctx2 ctx1 = - let ps' = generate sz' (const ValPerm_True) in - Just $ ArgLayout ctx1 $ - ALPerm_Or - p1 - (appendArgLayoutPerms ctx2 ps' p2 (ALPerm $ assignToRList ps')) -disjoinArgLayouts _ _ = Nothing - --- | Make an existential 'ArgLayout' -existsArgLayout :: KnownRepr TypeRepr a => Binding a ArgLayout -> ArgLayout -existsArgLayout [nuP| ArgLayout mb_ctx mb_p |] = - ArgLayout (mbLift mb_ctx) (ALPerm_Exists mb_p) - -{- --- | Convert an 'ArgLayout' to a permission on a @struct@ of its arguments -argLayoutStructPerm :: ArgLayout -> Some (Typed ValuePerm) -argLayoutStructPerm (ArgLayout ghosts (MNil :>: KnownReprObj) mb_perms) = - Some $ Typed knownRepr $ - valPermExistsMulti ghosts $ fmap (\(_ :>: perm) -> perm) mb_perms -argLayoutStructPerm (ArgLayout ghosts args mb_perms) - | args_repr <- cruCtxToRepr (knownCtxToCruCtx args) - , Refl <- cruCtxToReprEq (knownCtxToCruCtx args) = - Some $ Typed (StructRepr args_repr) $ - valPermExistsMulti ghosts $ fmap (ValPerm_Conj1 . Perm_Struct) mb_perms --} - --- | Append two 'ArgLayoutIO's, if possible -appendArgLayoutIO :: ArgLayoutIO -> ArgLayoutIO -> ArgLayoutIO -appendArgLayoutIO (ArgLayoutIO ctx1 p1 ps1) (ArgLayoutIO ctx2 p2 ps2) = - ArgLayoutIO (ctx1 Ctx.<++> ctx2) (appendArgLayoutPerms ctx1 ctx2 p1 p2) - (assignToRListAppend ctx1 ctx2 ps1 ps2) - --- | Convert an 'ArgLayout' to an 'ArgLayoutIO' by adding @true@ output perms -argLayoutAddTrueOuts :: ArgLayout -> ArgLayoutIO -argLayoutAddTrueOuts (ArgLayout ctx p) = - ArgLayoutIO ctx p $ trueValuePerms $ assignToRList ctx - --- | Construct an 'ArgLayoutIO' for 0 arguments -argLayoutIO0 :: ArgLayoutIO -argLayoutIO0 = ArgLayoutIO Ctx.empty (ALPerm MNil) MNil - --- | Create an 'ArgLayoutIO' from a single input and output perm -argLayoutIO1 :: KnownRepr TypeRepr a => ValuePerm a -> ValuePerm a -> - ArgLayoutIO -argLayoutIO1 p_in p_out = - ArgLayoutIO (extend Ctx.empty knownRepr) (ALPerm - (MNil :>: p_in)) (MNil :>: p_out) - --- | Convert a shape to a writeable block permission with that shape, or fail if --- the length of the shape is not defined --- --- FIXME: maybe this goes in the 'Permissions' module? -shapeToBlock :: (1 <= w, KnownNat w) => PermExpr (LLVMShapeType w) -> - Maybe (LLVMBlockPerm w) -shapeToBlock sh - | Just len <- llvmShapeLength sh = - Just $ LLVMBlockPerm - { llvmBlockRW = PExpr_Write, llvmBlockLifetime = PExpr_Always, - llvmBlockOffset = bvInt 0, llvmBlockLen = len, llvmBlockShape = sh } -shapeToBlock _ = Nothing - --- | Convert a shape to a writeable @memblock@ permission with that shape, or --- fail if the length of the shape is not defined --- --- FIXME: maybe this goes in the 'Permissions' module? -shapeToBlockPerm :: (1 <= w, KnownNat w) => PermExpr (LLVMShapeType w) -> - Maybe (ValuePerm (LLVMPointerType w)) -shapeToBlockPerm = fmap ValPerm_LLVMBlock . shapeToBlock - -instance PermPretty Some3FunPerm where - permPrettyM (Some3FunPerm fun_perm) = permPrettyM fun_perm - --- | Try to convert a 'Some3FunPerm' to a 'SomeFunPerm' at a specific type -un3SomeFunPerm :: (Fail.MonadFail m) => CruCtx args -> TypeRepr ret -> Some3FunPerm -> - m (SomeFunPerm args ret) -un3SomeFunPerm args ret (Some3FunPerm fun_perm) - | Just Refl <- testEquality args (funPermArgs fun_perm) - , Just Refl <- testEquality ret (funPermRet fun_perm) = - return $ SomeFunPerm fun_perm -un3SomeFunPerm args ret (Some3FunPerm fun_perm) = - let ppInfo = emptyPPInfo in - fail $ renderDoc $ vsep - [ pretty "Unexpected LLVM type for function permission:" - , permPretty ppInfo fun_perm - , pretty "Actual LLVM type of function:" - <+> PP.group (permPretty ppInfo args) <+> pretty "=>" - <+> PP.group (permPretty ppInfo ret) - , pretty "Expected LLVM type of function:" - <+> PP.group (permPretty ppInfo (funPermArgs fun_perm)) - <+> pretty "=>" - <+> PP.group (permPretty ppInfo (funPermRet fun_perm)) ] - --- | This is the more general form of 'funPerm3FromArgLayout, where there can be --- ghost variables in the 'ArgLayout' -funPerm3FromMbArgLayout :: CtxRepr ctx -> - MatchedMb ghosts (ArgLayoutPerm ctx) -> - ValuePerms (CtxToRList ctx) -> - CruCtx ghosts -> CtxRepr args -> - ValuePerms (CtxToRList args) -> - ValuePerms (CtxToRList args) -> - TypeRepr ret -> ValuePerm ret -> - RustConvM Some3FunPerm - --- Special case: if the argument perms are just a sequence of permissions on the --- individual arguments, make a function perm with those argument perms, that --- is, we build the function permission --- --- (ghosts). arg1:p1, ..., argn:pn -o ret:ret_perm -funPerm3FromMbArgLayout ctx [nuMP| ALPerm mb_ps_in |] ps_out - ghosts ctx1 ps1_in ps1_out ret_tp ret_perm - | ctx_args <- mkCruCtx (ctx1 Ctx.<++> ctx) - , ctx_all <- appendCruCtx ghosts ctx_args - , ghost_perms <- trueValuePerms $ cruCtxProxies ghosts - , mb_ps_in_all <- - mbCombine (cruCtxProxies ctx_args) $ - fmap (\ps_in -> - nuMulti (cruCtxProxies ctx_args) $ const $ - RL.append ghost_perms - (assignToRListAppend ctx1 ctx ps1_in ps_in)) mb_ps_in - , ps_out_all <- - RL.append ghost_perms (assignToRListAppend - ctx1 ctx ps1_out ps_out) :>: ret_perm = - return $ Some3FunPerm $ - FunPerm ghosts ctx_args CruCtxNil ret_tp mb_ps_in_all - (nuMulti (cruCtxProxies ctx_all :>: Proxy) $ \_ -> ps_out_all) -funPerm3FromMbArgLayout ctx [nuMP| ALPerm_Exists mb_p |] ps_out - ghosts ctx1 ps1_in ps1_out ret_tp ret_perm = - funPerm3FromMbArgLayout ctx (mbMatch $ mbCombine (MNil :>: Proxy) mb_p) ps_out - (CruCtxCons ghosts knownRepr) ctx1 ps1_in ps1_out ret_tp ret_perm -funPerm3FromMbArgLayout _ctx [nuMP| ALPerm_Or _ _ |] _ps_out - _ghosts _ctx1 _ps1_in _ps1_out _ret_tp _ret_perm = - fail "Cannot (yet) handle Rust enums or other disjunctive types in functions" - - --- | Build a function permission from an 'ArgLayoutIO' that describes the --- arguments and their input and output permissions and a return permission that --- describes the output permissions on the return value. The caller also --- specifies additional arguments to be prepended to the argument list that do --- have output permissions as a struct of 0 or more fields along with input and --- output permissions on those arguments. -funPerm3FromArgLayout :: ArgLayoutIO -> CtxRepr args -> - ValuePerms (CtxToRList args) -> - ValuePerms (CtxToRList args) -> - TypeRepr ret -> ValuePerm ret -> - RustConvM Some3FunPerm -funPerm3FromArgLayout (ArgLayoutIO - ctx p_in ps_out) ctx1 ps1_in ps1_out ret_tp ret_perm = - funPerm3FromMbArgLayout ctx (mbMatch $ emptyMb p_in) ps_out CruCtxNil - ctx1 ps1_in ps1_out ret_tp ret_perm - --- | Like 'funPerm3FromArgLayout' but with no additional arguments -funPerm3FromArgLayoutNoArgs :: ArgLayoutIO -> TypeRepr ret -> ValuePerm ret -> - RustConvM Some3FunPerm -funPerm3FromArgLayoutNoArgs layout ret ret_perm = - funPerm3FromArgLayout layout Ctx.empty MNil MNil ret ret_perm - - --- | Add ghost variables with the supplied permissions for the bound names in a --- 'FunPerm' in a binding -mbGhostsFunPerm :: - CruCtx new_ghosts -> - Mb ((new_ghosts :++: ghosts) :++: args) (ValuePerms new_ghosts) -> - Mb new_ghosts (FunPerm ghosts args gouts ret) -> - FunPerm (new_ghosts :++: ghosts) args gouts ret -mbGhostsFunPerm new_ghosts mb_new_ps (mbMatch -> - [nuMP| FunPerm ghosts args - gouts ret ps_in ps_out |]) = - let new_prxs = cruCtxProxies new_ghosts - ghosts_prxs = cruCtxProxies $ mbLift ghosts - rets_prxs = cruCtxProxies (mbLift gouts) :>: Proxy - args_prxs = cruCtxProxies $ mbLift args in - FunPerm (appendCruCtx new_ghosts $ mbLift ghosts) - (mbLift args) (mbLift gouts) (mbLift ret) - (mbMap2 (\new_ps ps -> assocAppend new_ps ghosts_prxs args_prxs ps) mb_new_ps $ - mbAssoc new_prxs ghosts_prxs args_prxs $ - mbCombine (RL.append ghosts_prxs args_prxs) ps_in) - (mbAssoc4 new_prxs ghosts_prxs args_prxs rets_prxs $ - fmap (assocAppend4 (RL.map (const ValPerm_True) new_prxs) - ghosts_prxs args_prxs rets_prxs) $ - mbCombine (RL.append - (RL.append ghosts_prxs args_prxs) rets_prxs) ps_out) - --- | Add ghost variables with no permissions for the bound names in a --- 'Some3FunPerm' in a binding -mbGhostsFunPerm3 :: CruCtx new_ghosts -> Mb new_ghosts Some3FunPerm -> - Some3FunPerm -mbGhostsFunPerm3 new_ghosts (mbMatch -> [nuMP| Some3FunPerm fun_perm |]) = - let new_ps = - nuMulti (cruCtxProxies - ((new_ghosts - `appendCruCtx` mbLift (fmap funPermGhosts fun_perm)) - `appendCruCtx` mbLift (fmap funPermArgs fun_perm))) $ - const $ RL.map (const ValPerm_True) (cruCtxProxies new_ghosts) in - Some3FunPerm $ mbGhostsFunPerm new_ghosts new_ps fun_perm - - --- | Try to compute the layout of a structure of the given shape as a value, --- over 1 or more registers, if this is possible -layoutArgShapeByVal :: (1 <= w, KnownNat w) => Abi -> - PermExpr (LLVMShapeType w) -> - MaybeT RustConvM ArgLayout - --- The empty shape --> no values -layoutArgShapeByVal Rust PExpr_EmptyShape = return argLayout0 - --- Named shapes that unfold --> layout their unfoldings -layoutArgShapeByVal Rust (PExpr_NamedShape rw l nmsh args) - | TrueRepr <- namedShapeCanUnfoldRepr nmsh - , Just sh' <- unfoldModalizeNamedShape rw l nmsh args = - layoutArgShapeByVal Rust sh' - --- Opaque named shapes that are bigger than 16 bytes --> not laid out by value --- --- FIXME: if an opaque named shape somehow corresponds to > 2 fields, it is also --- not laid out by value -layoutArgShapeByVal Rust sh@(PExpr_NamedShape _ _ nmsh _) - | not (namedShapeCanUnfold nmsh) - , Just len <- llvmShapeLength sh - , bvLt (bvInt 16) len = - mzero - --- Opaque named shapes that could potentially be laid out by value are an error, --- because we do not know their representation -layoutArgShapeByVal Rust (PExpr_NamedShape _ _ nmsh _) - | not (namedShapeCanUnfold nmsh) = - lift $ fail $ renderDoc - (pretty "layoutArgShapeByVal: Cannot lay out opaque named shape by value:" - <+> pretty (namedShapeName nmsh)) - --- The ptr shape --> a single pointer value, if we know its length -layoutArgShapeByVal Rust (PExpr_PtrShape maybe_rw maybe_l sh) - | Just bp <- llvmBlockAdjustModalities maybe_rw maybe_l <$> shapeToBlock sh = - return $ argLayout1 $ ValPerm_LLVMBlock bp - --- If we don't know the length of our pointer, we can't lay it out at all -layoutArgShapeByVal Rust (PExpr_PtrShape _ _ sh) = - lift rsPPInfo >>= \ppInfo -> - lift $ fail $ renderDoc $ fillSep - [pretty "layoutArgShapeByVal: Shape with unknown length:", - permPretty ppInfo sh] - --- A field shape --> the contents of the field -layoutArgShapeByVal Rust (PExpr_FieldShape (LLVMFieldShape p)) = - return $ argLayout1 p - --- Array shapes have unknown length, and so are never passed by value -layoutArgShapeByVal Rust (PExpr_ArrayShape _ _ _) = mzero - --- Sequence shapes are only laid out as values in the Rust ABI if the result has --- at most two fields -layoutArgShapeByVal Rust (PExpr_SeqShape sh1 sh2) = - do layout1 <- layoutArgShapeByVal Rust sh1 - layout2 <- layoutArgShapeByVal Rust sh2 - let layout = appendArgLayout layout1 layout2 - if argLayoutNumFields layout <= 2 then return layout else mzero - --- Disjunctive shapes are only laid out as values in the Rust ABI if both sides --- can be laid out as values that we can coerce to have the same number of type --- of fields. --- --- FIXME: The check for whether we can do this coercion is currently done by --- disjoinArgLayouts, but it is probably ABI-specific, so should be performed by --- a function that knows how to join two lists of field types depending on the --- ABI -layoutArgShapeByVal Rust (PExpr_OrShape sh1 sh2) = - do layout1 <- layoutArgShapeByVal Rust sh1 - layout2 <- layoutArgShapeByVal Rust sh2 - case disjoinArgLayouts layout1 layout2 of - Just layout -> return layout - Nothing -> mzero - --- For existential shapes, just add the existential variable to the ghosts -layoutArgShapeByVal Rust (PExpr_ExShape mb_sh) = - existsArgLayout <$> mbM (fmap (layoutArgShapeByVal Rust) mb_sh) - --- False shape is like the empty shape --> no values -layoutArgShapeByVal Rust PExpr_FalseShape = return argLayout0 - -layoutArgShapeByVal Rust sh = - lift rsPPInfo >>= \ppInfo -> - lift $ fail $ renderDoc $ fillSep - [pretty "layoutArgShapeByVal: Unsupported shape:", permPretty ppInfo sh] -layoutArgShapeByVal abi _ = - lift $ fail ("layoutArgShapeByVal: Unsupported ABI: " ++ show abi) - - --- | Try to compute the layout of a structure of the given shape as a value, --- over 1 or more registers, if this is possible. Otherwise convert the shape to --- an LLVM block permission. -layoutArgShapeOrBlock :: (1 <= w, KnownNat w) => Abi -> - PermExpr (LLVMShapeType w) -> - RustConvM (Either (LLVMBlockPerm w) ArgLayout) -layoutArgShapeOrBlock abi sh = - runMaybeT (layoutArgShapeByVal abi sh) >>= \case - Just layout -> return $ Right layout - Nothing | Just bp <- shapeToBlock sh -> return $ Left bp - _ -> - rsPPInfo >>= \ppInfo -> - fail $ renderDoc $ fillSep - [pretty "layoutArgShapeOrBlock: Could not layout shape with unknown size:", - permPretty ppInfo sh] - --- | Compute the layout of an argument with the given shape as 1 or more --- register arguments of a function. If the argument is laid out as a value, --- then it has no output permissions, but if it is laid out as a pointer, the --- memory occupied by that pointer is returned with an empty shape. -layoutArgShape :: (1 <= w, KnownNat w) => Abi -> - PermExpr (LLVMShapeType w) -> RustConvM ArgLayoutIO -layoutArgShape abi sh = - layoutArgShapeOrBlock abi sh >>= \case - Right layout -> return $ argLayoutAddTrueOuts layout - Left bp -> - return (argLayoutIO1 (ValPerm_LLVMBlock bp) - (ValPerm_LLVMBlock $ bp { llvmBlockShape = PExpr_EmptyShape })) - --- | Compute the layout for the inputs and outputs of a function with the given --- shapes as arguments and return value as a function permission -layoutFun :: (1 <= w, KnownNat w) => Abi -> - [PermExpr (LLVMShapeType w)] -> PermExpr (LLVMShapeType w) -> - RustConvM Some3FunPerm -layoutFun abi arg_shs ret_sh = - do args_layout <- - foldr appendArgLayoutIO argLayoutIO0 <$> mapM (layoutArgShape abi) arg_shs - ret_layout_eith <- layoutArgShapeOrBlock abi ret_sh - case ret_layout_eith of - - -- Special case: if the return type is empty, use the unit type as the - -- return type - Right (ArgLayout Ctx.Empty _) -> - funPerm3FromArgLayoutNoArgs args_layout UnitRepr ValPerm_True - - -- Special case: if the return type is a single field, remove the struct - -- type and just use the type of that single field - Right (ArgLayout (Ctx.Empty Ctx.:> ret_tp) - (argLayoutPerm1ToPerm -> ret_p)) -> - funPerm3FromArgLayoutNoArgs args_layout ret_tp ret_p - - -- If the return type can be laid out as a struct type, then do so - Right (ArgLayout ret_ctx ret_p) -> - funPerm3FromArgLayoutNoArgs args_layout (StructRepr ret_ctx) - (argLayoutPermToPerm ret_p) - - -- Otherwise add an extra pointer argument used as an out variable - Left bp -> - funPerm3FromArgLayout args_layout - (extend Ctx.empty knownRepr) - (MNil :>: ValPerm_LLVMBlock (bp { llvmBlockShape = - PExpr_EmptyShape})) - (MNil :>: ValPerm_LLVMBlock bp) - UnitRepr ValPerm_True - - ----------------------------------------------------------------------- --- * Converting Function Types ----------------------------------------------------------------------- - --- | An 'ExprPerms' with types for the expressions -data TypedExprPerms ctx = TypedExprPerms (CruCtx ctx) (ExprPerms ctx) - --- | Convert a 'TypedDistPerms' to a 'TypedExprPerms' -typedDistToExprPerms :: TypedDistPerms ctx -> TypedExprPerms ctx -typedDistToExprPerms perms = - TypedExprPerms (typedDistPermsCtx perms) (distPermsToExprPerms $ - unTypeDistPerms perms) - --- | Find all portions of an atomic permission containing a lifetime, returning --- 'Nothing' if it does not contain the lifetime -atomicPermForLifetime :: ExprVar LifetimeType -> AtomicPerm a -> - Maybe (AtomicPerm a) -atomicPermForLifetime l p | not $ NameSet.member l $ freeVars p = Nothing -atomicPermForLifetime l (Perm_Struct ps) = - Just $ Perm_Struct $ - RL.map (\p -> fromMaybe ValPerm_True (permForLifetime l p)) ps -atomicPermForLifetime _ p = Just p - --- | Find all portions of a permission containing a lifetime, returning --- 'Nothing' if it does not contain the lifetime -permForLifetime :: ExprVar LifetimeType -> ValuePerm a -> Maybe (ValuePerm a) -permForLifetime l p | not $ NameSet.member l $ freeVars p = Nothing -permForLifetime l (ValPerm_Conj ps) = - Just $ ValPerm_Conj $ mapMaybe (atomicPermForLifetime l) ps -permForLifetime _ p = Just p - --- | Find all permissions containing lifetime @l@ and return just those portions --- of the these permissions that contain @l@ -lownedPermsForLifetime :: CruCtx ctx -> ExprVar LifetimeType -> DistPerms ctx -> - Some TypedExprPerms -lownedPermsForLifetime tps l ps = - fmapF typedDistToExprPerms $ concatSomeRAssign $ - RL.mapToList (\case - (Typed tp (VarAndPerm x p)) - | Just p' <- permForLifetime l p -> - Some (MNil :>: Typed tp (VarAndPerm x p')) - _ -> Some MNil) - (RL.map2 Typed (cruCtxToTypes tps) ps) - --- | Get the 'String' name defined by a 'LifetimeDef' -lifetimeDefName :: LifetimeDef a -> String -lifetimeDefName (LifetimeDef _ (Lifetime name _) _ _) = name - --- | Get the 'String' name defined by a 'TyParam' -tyParamName :: TyParam a -> String -tyParamName (TyParam _ ident _ _ _) = name ident - -extMbOuter :: RAssign Proxy ctx1 -> Mb ctx2 a -> Mb (ctx1 :++: ctx2) a -extMbOuter prxs mb_a = mbCombine (mbToProxy mb_a) $ nuMulti prxs $ const mb_a - -extMbAppInner :: NuMatching a => any ctx1 -> - RAssign Proxy ctx2 -> RAssign Proxy ctx3 -> - Mb (ctx1 :++: ctx2) a -> Mb (ctx1 :++: ctx2 :++: ctx3) a -extMbAppInner (_ :: any ctx1) ctx2 ctx3 mb_a = - mbCombine (RL.append ctx2 ctx3) $ - mbMapCl ($(mkClosed [| extMbMulti |]) `clApply` toClosed ctx3) $ - mbSeparate @_ @ctx1 ctx2 mb_a - --- | Add a lifetime described by a 'LifetimeDef' to a 'Some3FunPerm' -mbLifetimeFunPerm :: LifetimeDef Span -> Binding LifetimeType Some3FunPerm -> - RustConvM Some3FunPerm -mbLifetimeFunPerm (LifetimeDef _ _ [] _) - (mbMatch -> [nuMP| Some3FunPerm fun_perm |]) = - do let ghosts = mbLift $ fmap funPermGhosts fun_perm - let ghosts_prxs = cruCtxProxies ghosts - let gouts = mbLift $ fmap funPermGouts fun_perm - let rets_prxs = cruCtxProxies gouts :>: Proxy - let args = mbLift $ fmap funPermArgs fun_perm - let args_prxs = cruCtxProxies args - let ret = mbLift $ fmap funPermRet fun_perm - let l_prxs = MNil :>: (Proxy :: Proxy LifetimeType) - let fp_outs = mbLift $ fmap funPermOutCtx fun_perm - let mb_ps_in = - mbCombineAssoc l_prxs ghosts_prxs args_prxs $ - fmap (mbValuePermsToDistPerms . funPermIns) fun_perm - let mb_ps_out = - mbCombineAssoc4 l_prxs ghosts_prxs args_prxs rets_prxs $ - fmap (mbValuePermsToDistPerms . funPermOuts) fun_perm - let mb_l = extMbMulti args_prxs $ extMbMulti ghosts_prxs $ nu id - let mb_l_out = - extMbMulti rets_prxs $ extMbMulti args_prxs $ - extMbMulti ghosts_prxs $ nu id - [nuMP| Some (TypedExprPerms mb_tps_in mb_lops_in) |] <- - return $ mbMatch $ mbMap2 (lownedPermsForLifetime - (appendCruCtx ghosts args)) mb_l mb_ps_in - [nuMP| Some (TypedExprPerms mb_tps_out mb_lops_out) |] <- - return $ mbMatch $ - mbMap2 (lownedPermsForLifetime fp_outs) mb_l_out mb_ps_out - let tps_in = mbLift mb_tps_in - let tps_out = mbLift mb_tps_out - case abstractModalities mb_lops_in of - SomeTypedMb ghosts' mb_mb_lops_in_abs -> - return $ mbGhostsFunPerm3 ghosts' $ - flip fmap mb_mb_lops_in_abs $ \mb_lops_in_abs -> - Some3FunPerm $ - FunPerm (appendCruCtx - (singletonCruCtx LifetimeRepr) ghosts) args gouts ret - (mbMap2 (\ps_in lops_in_abs -> - assocAppend (MNil :>: ValPerm_LOwnedSimple tps_in lops_in_abs) - ghosts args_prxs $ distPermsToValuePerms ps_in) - mb_ps_in mb_lops_in_abs) - (mbMap3 (\ps_out lops_out lops_in_abs -> - let (ps_ghosts, ps_args, ps_rets) = - rlSplit3 ghosts_prxs args_prxs rets_prxs $ - distPermsToValuePerms ps_out in - (((MNil :>: ValPerm_LOwned [] tps_out tps_in lops_out lops_in_abs) - `RL.append` ps_ghosts) `RL.append` ps_args) - `RL.append` ps_rets) - mb_ps_out mb_lops_out (extMbMulti rets_prxs mb_lops_in_abs)) -mbLifetimeFunPerm (LifetimeDef _ _ _bounds _) _ = - fail "Rust lifetime bounds not yet supported!" - --- | Run a computation of a function permission in the context of a list of --- Rust lifetime definitions -withLifetimes :: [LifetimeDef Span] -> RustConvM Some3FunPerm -> - RustConvM Some3FunPerm -withLifetimes [] m = m -withLifetimes (ldef : ldefs) m = - inRustCtx (rustCtx1 (lifetimeDefName ldef) - LifetimeRepr) (withLifetimes ldefs m) >>= - mbLifetimeFunPerm ldef - --- | An object of type @a@ inside some name-binding context where each bound --- name is assigned its own permission -data SomeMbWithPerms a where - SomeMbWithPerms :: CruCtx ctx -> MbValuePerms ctx -> Mb ctx a -> - SomeMbWithPerms a - -instance Functor SomeMbWithPerms where - fmap f (SomeMbWithPerms ctx ps mb_a) = SomeMbWithPerms ctx ps (fmap f mb_a) - -instance App.Applicative SomeMbWithPerms where - pure a = SomeMbWithPerms CruCtxNil (emptyMb MNil) $ emptyMb a - liftA2 f (SomeMbWithPerms ctx1 mb_ps1 mb_a1) (SomeMbWithPerms ctx2 mb_ps2 mb_a2) = - SomeMbWithPerms (appendCruCtx ctx1 ctx2) - (mbCombine (cruCtxProxies ctx2) $ flip fmap mb_ps1 $ \ps1 -> - flip fmap mb_ps2 $ \ps2 -> RL.append ps1 ps2) - (mbCombine (cruCtxProxies ctx2) $ - flip fmap mb_a1 $ \a1 -> flip fmap mb_a2 $ \a2 -> f a1 a2) - --- NOTE: the Monad instance fails here because it requires the output type of f --- to satisfy NuMatching. That is, it is a \"restricted monad\", that is only a --- monad over types that satisfy the NuMatching restriction. Thus we define --- bindSomeMbWithPerms to add this restriction. -{- -instance Monad SomeMbWithPerms where - return = pure - (SomeMbWithPerms ctx1 mb_ps1 mb_a) >>= f = - case mbMatch (fmap f mb_a) of - [nuMP| SomeMbWithPerms ctx2 mb_mb_ps2 mb_mb_b |] -> - let ctx2_prxs = cruCtxProxies $ mbLift ctx2 in - SomeMbWithPerms (appendCruCtx ctx1 $ mbLift ctx2) - (mbCombine ctx2_prxs $ - mbMap2 (\ps1 mb_ps2 -> fmap (RL.append ps1) mb_ps2) mb_ps1 mb_mb_ps2) - (mbCombine ctx2_prxs mb_mb_b) --} - --- | A monadic bind for 'SomeMbWithPerms', which requires a 'NuMatching' --- instance for the output type -bindSomeMbWithPerms :: NuMatching b => SomeMbWithPerms a -> - (a -> SomeMbWithPerms b) -> SomeMbWithPerms b -bindSomeMbWithPerms (SomeMbWithPerms ctx1 mb_ps1 mb_a) f = - case mbMatch (fmap f mb_a) of - [nuMP| SomeMbWithPerms ctx2 mb_mb_ps2 mb_mb_b |] -> - let ctx2_prxs = cruCtxProxies $ mbLift ctx2 in - SomeMbWithPerms (appendCruCtx ctx1 $ mbLift ctx2) - (mbCombine ctx2_prxs $ - mbMap2 (\ps1 mb_ps2 -> fmap (RL.append ps1) mb_ps2) mb_ps1 mb_mb_ps2) - (mbCombine ctx2_prxs mb_mb_b) - --- | Make a 'SomeMbWithPerms' with a single bound variable -someMbWithPermsVar1 :: TypeRepr a -> ValuePerm a -> SomeMbWithPerms (ExprVar a) -someMbWithPermsVar1 tp p = - SomeMbWithPerms (singletonCruCtx tp) (nu $ const (MNil :>: p)) (nu id) - --- | Move a 'SomeMbWithPerms' out of a binding by adding the bound variables as --- variables that are bound with @true@ permissions by the 'SomeMbWithPerms' -mbSomeMbWithPerms :: NuMatching a => CruCtx ctx -> Mb ctx (SomeMbWithPerms a) -> - SomeMbWithPerms a -mbSomeMbWithPerms ctx (mbMatch -> [nuMP| SomeMbWithPerms ctx' mb_ps' mb_a |]) = - let ctx'_prxs = cruCtxProxies $ mbLift ctx' in - SomeMbWithPerms (appendCruCtx ctx $ mbLift ctx') - (fmap (RL.append $ trueValuePerms (cruCtxProxies ctx)) $ - mbCombine ctx'_prxs mb_ps') - (mbCombine ctx'_prxs mb_a) - --- | Add additional gnost output variables to a 'FunPerm' -mbGoutsFunPerm :: - out_ctx ~ ((ghosts :++: args) :++: gouts :> ret) => - CruCtx ghosts -> CruCtx args -> CruCtx gouts -> TypeRepr ret -> - MbValuePerms (ghosts :++: args) -> CruCtx new_gouts -> - Mb new_gouts (Mb out_ctx (ValuePerms new_gouts)) -> - Mb new_gouts (Mb out_ctx (ValuePerms out_ctx)) -> - FunPerm ghosts args (gouts :++: new_gouts) ret -mbGoutsFunPerm ghosts args gouts ret ps_in gouts' mb_gps' mb_ps_out' - | ga_prxs <- cruCtxProxies $ appendCruCtx ghosts args - , gouts_prxs <- cruCtxProxies gouts - , gag_prxs <- RL.append ga_prxs gouts_prxs - , ret_prxs <- cruCtxProxies $ singletonCruCtx ret - , gouts'_prxs <- cruCtxProxies gouts' - , Refl <- RL.appendAssoc ga_prxs gouts_prxs gouts'_prxs = - FunPerm ghosts args (appendCruCtx gouts gouts') ret ps_in $ - mbCombine ret_prxs $ mbCombine gouts'_prxs $ - mbSwap gag_prxs $ fmap (mbSeparate ret_prxs) $ - mbMap2 - (mbMap2 - (\gps' ps_out' -> - let (ga_perms, gouts_perms, MNil :>: ret_perm) = - rlSplit3 ga_prxs gouts_prxs ret_prxs ps_out' in - RL.append ga_perms (RL.append gouts_perms gps') :>: ret_perm)) - mb_gps' mb_ps_out' - --- | Find each subterm of the input that is a field, array, or block permission --- with a different lifetime than the supplied one. Abstract out these --- permissions by replacing each such permission @p@ with an @eq(x)@ permission --- for a fresh variable @x@ which is itself assigned permission @p@. Only do --- this abstraction, though, at locations where @x@ in the resulting permission --- is a determined variable. When the supplied lifetime is omitted, i.e., is --- 'Nothing', only perform this abstraction at strict subterms. -class AbstractVarsForLifetimes a where - abstractVarsForLifetimes :: Maybe (PermExpr LifetimeType) -> a -> - SomeMbWithPerms a - -instance AbstractVarsForLifetimes (ValuePerms ps) where - abstractVarsForLifetimes l = traverseRAssign (abstractVarsForLifetimes l) - --- | Return the type of an atomic permission if we can compute it, specifically --- if it is a field, array, or block permission -atomicPermType :: AtomicPerm a -> Maybe (TypeRepr a) -atomicPermType (Perm_LLVMField _) = Just knownRepr -atomicPermType (Perm_LLVMArray _) = Just knownRepr -atomicPermType (Perm_LLVMBlock _) = Just knownRepr -atomicPermType _ = Nothing - -instance AbstractVarsForLifetimes (ValuePerm a) where - abstractVarsForLifetimes (Just l) p@(ValPerm_Conj ps) - | any (/= l) (mapMaybe atomicPermLifetime ps) - , tp:_ <- mapMaybe atomicPermType ps = - bindSomeMbWithPerms (abstractVarsForLifetimes Nothing p) $ \p' -> - ValPerm_Eq <$> PExpr_Var <$> someMbWithPermsVar1 tp p' - abstractVarsForLifetimes l (ValPerm_Conj ps) = - ValPerm_Conj <$> traverse (abstractVarsForLifetimes l) ps - abstractVarsForLifetimes l (ValPerm_Exists mb_p) = - -- Any existentials also become abstracted variables, so they can be bound - -- as ghosts or gouts (depending on whether they occur in the input or - -- output permissions) - mbSomeMbWithPerms knownRepr $ fmap (abstractVarsForLifetimes l) mb_p - abstractVarsForLifetimes _ p = pure p - --- NOTE: for AtomicPerms, we don't ever replace the permission itself, since we --- don't want to replace each individual permission pi in a conjunction p1*..*pn --- with an equality perm, but instead want to replace the entire conjunction all --- at once. This is handled in the above case for ValPerm_Conj. -instance AbstractVarsForLifetimes (AtomicPerm a) where - abstractVarsForLifetimes _ (Perm_LLVMField fp) = - (\p -> Perm_LLVMField $ fp { llvmFieldContents = p }) <$> - abstractVarsForLifetimes (Just $ llvmFieldLifetime fp) (llvmFieldContents fp) - -- FIXME: we can't yet abstract array permissions, because shapes in arrays - -- could be repeated multiple times and thus we would have to somehow abstract - -- over multiple copies of the same variable for that to work... - abstractVarsForLifetimes _ (Perm_LLVMBlock bp) = - (\sh -> Perm_LLVMBlock $ bp { llvmBlockShape = sh }) <$> - abstractVarsForLifetimesSh (llvmBlockRW bp) (llvmBlockLifetime bp) - (llvmBlockShape bp) - abstractVarsForLifetimes _ (Perm_Struct ps) = - -- NOTE: for struct perms we want to abstract any permission with any - -- non-always lifetime, so we set l to always - Perm_Struct <$> - traverseRAssign (abstractVarsForLifetimes (Just PExpr_Always)) ps - abstractVarsForLifetimes _ p = pure p - --- | Like 'abstractVarsForLifetimes' but for an LLVM shape inside a @memblock@ --- with the given modalities -abstractVarsForLifetimesSh :: (1 <= w, KnownNat w) => PermExpr RWModalityType -> - PermExpr LifetimeType -> - PermExpr (LLVMShapeType w) -> - SomeMbWithPerms (PermExpr (LLVMShapeType w)) -abstractVarsForLifetimesSh _ l (PExpr_FieldShape (LLVMFieldShape p)) = - PExpr_FieldShape <$> LLVMFieldShape <$> abstractVarsForLifetimes (Just l) p -abstractVarsForLifetimesSh rw l (PExpr_PtrShape maybe_rw (Just l') sh) - | l /= l' - , rw' <- maybe rw id maybe_rw - , Just len <- llvmShapeLength sh = - -- NOTE: abstracting a shape should return one with the same length - bindSomeMbWithPerms (abstractVarsForLifetimesSh rw' l' sh) $ \sh' -> - PExpr_FieldShape <$> LLVMFieldShape <$> ValPerm_Eq <$> PExpr_Var <$> - someMbWithPermsVar1 knownRepr (ValPerm_LLVMBlock $ - LLVMBlockPerm rw' l' (bvInt 0) len sh') -abstractVarsForLifetimesSh rw l (PExpr_PtrShape maybe_rw maybe_l sh) = - let rw' = maybe rw id maybe_rw in - PExpr_PtrShape maybe_rw maybe_l <$> abstractVarsForLifetimesSh rw' l sh -abstractVarsForLifetimesSh rw l (PExpr_SeqShape sh1 sh2) = - PExpr_SeqShape <$> abstractVarsForLifetimesSh rw l sh1 <*> - abstractVarsForLifetimesSh rw l sh2 -abstractVarsForLifetimesSh rw l (PExpr_ExShape mb_sh) = - mbSomeMbWithPerms knownRepr $ fmap (abstractVarsForLifetimesSh rw l) mb_sh -abstractVarsForLifetimesSh _ _ sh = pure sh - --- | A 'SomeMbWithPerms' in a binding -data MbSomeMbWithPerms ctx a where - MbSomeMbWithPerms :: CruCtx ctx' -> Mb ctx' (Mb ctx (ValuePerms ctx')) -> - Mb ctx' (Mb ctx a) -> - MbSomeMbWithPerms ctx a - -mbAbstractVarsForLifetimes :: Mb ctx (ValuePerms ps) -> - MbSomeMbWithPerms ctx (ValuePerms ps) -mbAbstractVarsForLifetimes mb_ps - | [nuMP| SomeMbWithPerms ctx' mb_ctx_ps' mb_ps' |] <- - mbMatch (fmap (abstractVarsForLifetimes Nothing) mb_ps) - , ctx'_prxs <- cruCtxProxies $ mbLift ctx' = - MbSomeMbWithPerms (mbLift ctx') (mbSwap ctx'_prxs mb_ctx_ps') - (mbSwap ctx'_prxs mb_ps') - --- | For both the input and output permissions of a function permission, find --- all permissions @p@ in with a lifetime that are contained inside a struct --- permission or a field or block permission with a different lifetime, and --- replace each such permission with an @eq(z)@ permission for a fresh ghost --- variable @z@ that is itself assigned permissions @p@. -abstractFunVarsForLifetimes :: Some3FunPerm -> Some3FunPerm -abstractFunVarsForLifetimes (Some3FunPerm - (FunPerm ghosts args gouts ret ps_in ps_out)) - | MbSomeMbWithPerms ghosts' mb_gps' mb_ps_in' <- - mbAbstractVarsForLifetimes ps_in - , MbSomeMbWithPerms gouts' mb_gops' mb_ps_out' <- - mbAbstractVarsForLifetimes ps_out - , ghosts_prxs <- cruCtxProxies ghosts - , args_prxs <- cruCtxProxies args = - Some3FunPerm $ mbGhostsFunPerm ghosts' - (mbCombineAssoc ghosts' ghosts_prxs args_prxs mb_gps') $ - flip fmap mb_ps_in' $ \ps_in' -> - mbGoutsFunPerm ghosts args gouts ret ps_in' gouts' mb_gops' mb_ps_out' - --- | Convert a monomorphic function type, i.e., one with no type arguments -rsConvertMonoFun :: (1 <= w, KnownNat w) => prx w -> Span -> Abi -> - [LifetimeDef Span] -> FnDecl Span -> - RustConvM Some3FunPerm -rsConvertMonoFun w span abi ls fn_tp = - rsConvertFun w abi (Generics ls [] (WhereClause [] span) span) fn_tp - --- | Convert a Rust polymorphic function type to a Heapster function permission -rsConvertFun :: (1 <= w, KnownNat w) => prx w -> - Abi -> Generics Span -> FnDecl Span -> RustConvM Some3FunPerm -rsConvertFun w abi (Generics ldefs _tparams@[] - (WhereClause [] _) _) (FnDecl args maybe_ret_tp False _) = - -- fmap (\ret -> - -- tracePretty (pretty "rsConvertFun returning:" <+> - -- permPretty emptyPPInfo ret) ret) $ - withLifetimes ldefs $ - do arg_shapes <- mapM (rsConvert w) args - ret_shape <- maybe (return PExpr_EmptyShape) (rsConvert w) maybe_ret_tp - abstractFunVarsForLifetimes <$> layoutFun abi arg_shapes ret_shape -rsConvertFun _ _ _ _ = fail "rsConvertFun: unsupported Rust function type" - - ----------------------------------------------------------------------- --- * Top-level Entrypoints ----------------------------------------------------------------------- - --- | Parse a polymorphic Rust function type of the form --- --- > (T1,...,Tn) -> T --- --- and convert it to a Heapster function permission -parseFunPermFromRust :: (Fail.MonadFail m, 1 <= w, KnownNat w) => - PermEnv -> prx w -> CruCtx args -> TypeRepr ret -> - String -> m (SomeFunPerm args ret) -parseFunPermFromRust env w args ret str = - do get3SomeFunPerm <- parseSome3FunPermFromRust env w str - un3SomeFunPerm args ret get3SomeFunPerm - - --- | Just like `parseFunPermFromRust`, but returns a `Some3FunPerm` -parseSome3FunPermFromRust :: (Fail.MonadFail m, 1 <= w, KnownNat w) => - PermEnv -> prx w -> - String -> m Some3FunPerm -parseSome3FunPermFromRust env w str - | Just i <- findIndex (== '>') str - , (gen_str, fn_str) <- splitAt (i+1) str - , Right (Generics rust_ls1 rust_tvars wc span) <- - parse (inputStreamFromString gen_str) - , Right (BareFn _ abi rust_ls2 fn_tp _) <- - parse (inputStreamFromString fn_str) = - runLiftRustConvM (mkRustConvInfo env) $ - rsConvertFun w abi (Generics (rust_ls1 ++ rust_ls2) rust_tvars wc span) fn_tp - - | Just i <- findIndex (== '>') str - , (gen_str, _) <- splitAt (i+1) str - , Left err <- parse @(Generics Span) (inputStreamFromString gen_str) = - fail ("Error parsing generics: " ++ show err) - - | Just i <- findIndex (== '>') str - , (_, fn_str) <- splitAt (i+1) str - , Left err <- parse @(Ty Span) (inputStreamFromString fn_str) = - fail ("Error parsing generics: " ++ show err) -parseSome3FunPermFromRust _ _ str = - fail ("Malformed Rust type: " ++ str) - --- | Parse a polymorphic Rust type declaration and convert it to a Heapster --- shape --- Note: No CruCtx / TypeRepr as arguments for now -parseNamedShapeFromRustDecl :: (Fail.MonadFail m, 1 <= w, KnownNat w) => - PermEnv -> prx w -> String -> - m (SomePartialNamedShape w) -parseNamedShapeFromRustDecl env w str = - case parse @(Item Span) (inputStreamFromString str) of - Right item -> runLiftRustConvM (mkRustConvInfo env) $ rsConvert w item - Left err -> fail ("Error parsing top-level item: " ++ show err) diff --git a/heapster/src/Heapster/SAWTranslation.hs b/heapster/src/Heapster/SAWTranslation.hs deleted file mode 100644 index 2cde9bf1e2..0000000000 --- a/heapster/src/Heapster/SAWTranslation.hs +++ /dev/null @@ -1,6624 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ImplicitParams #-} -{-# Language DeriveFunctor #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -{-# HLINT ignore "Move brackets to avoid $" #-} - -module Heapster.SAWTranslation where - -import Prelude hiding (pi) - -import Data.Maybe -import Numeric.Natural -import Data.List (delete, find, intersperse) -import Data.Text (pack) -import GHC.TypeLits (KnownNat, natVal) -import Data.BitVector.Sized (BV) -import qualified Data.BitVector.Sized as BV -import Data.Functor.Constant -import qualified Control.Applicative as App -import Control.Lens hiding ((:>), Index, ix, op, getting) -import qualified Control.Monad as Monad -import Control.Monad (MonadPlus(..), zipWithM) -import Control.Monad.Reader (MonadReader(..), Reader, runReader, withReader, - ReaderT(..), mapReaderT, ask) -import Control.Monad.State (MonadState(..), StateT(..)) -import Control.Monad.Trans.Class (MonadTrans(..)) -import Control.Monad.Trans.Maybe -import Control.Monad.Writer (MonadWriter(..), WriterT(..)) -import qualified Control.Monad.Fail as Fail - -import What4.ProgramLoc -import What4.Interface (StringLiteral(..)) - -import qualified Data.Type.RList as RL -import Data.Binding.Hobbits hiding (sym, trans) -import Data.Binding.Hobbits.Liftable () - -import Prettyprinter as PP -import Prettyprinter.Render.String - -import Data.Parameterized.TraversableF - -import Lang.Crucible.Types -import Lang.Crucible.LLVM.Extension -import Lang.Crucible.LLVM.MemModel -import Lang.Crucible.LLVM.DataLayout -import Lang.Crucible.CFG.Expr -import qualified Lang.Crucible.CFG.Expr as Expr -import Lang.Crucible.CFG.Core - -import SAWCore.Name hiding (Name) -import SAWCore.OpenTerm -import SAWCore.Term.Functor hiding (Constant) -import SAWCore.SharedTerm hiding (Constant) - -import Heapster.Panic --- import Heapster.GenMonad -import Heapster.CruUtil -import Heapster.Permissions -import Heapster.Implication -import Heapster.TypedCrucible -import Heapster.NamedMb - -import GHC.Stack - - --- | FIXME: document and move to Hobbits -suffixMembers :: prx1 ctx1 -> RAssign prx2 ctx2 -> - RAssign (Member (ctx1 :++: ctx2)) ctx2 -suffixMembers _ MNil = MNil -suffixMembers ctx1 (ctx2 :>: _) = - RL.map Member_Step (suffixMembers ctx1 ctx2) :>: Member_Base - --- | Weaken a 'Member' proof by appending another context to the context it --- proves membership in -weakenMemberR :: RAssign any ctx2 -> Member ctx1 a -> Member (ctx1 :++: ctx2) a -weakenMemberR MNil memb = memb -weakenMemberR (ctx1 :>: _) memb = Member_Step (weakenMemberR ctx1 memb) - --- | Test if a 'Member' of the append of two contexts is a 'Member' of the first --- or the second context -appendMemberCase :: prx1 ctx1 -> RAssign prx2 ctx2 -> - Member (ctx1 :++: ctx2) a -> - Either (Member ctx1 a) (Member ctx2 a) -appendMemberCase _ MNil memb = Left memb -appendMemberCase _ (_ :>: _) Member_Base = Right Member_Base -appendMemberCase ctx1 (ctx2 :>: _) (Member_Step memb) = - case appendMemberCase ctx1 ctx2 memb of - Left memb1 -> Left memb1 - Right memb2 -> Right (Member_Step memb2) - --- | Get the length of a 'Member' proof, thereby converting a 'Member' of a --- context into a deBruijn index -memberLength :: Member ctx a -> Natural -memberLength Member_Base = 0 -memberLength (Member_Step memb) = 1 + memberLength memb - - ----------------------------------------------------------------------- --- * Type Translations ----------------------------------------------------------------------- - --- | Call 'prettyCallStack' and insert a newline in front -nlPrettyCallStack :: CallStack -> String -nlPrettyCallStack = ("\n" ++) . prettyCallStack - --- | The result of translating a type-like construct such as a 'TypeRepr' or a --- permission, parameterized by the (Haskell) type of the translations of the --- elements of that type. This are translated to 0 or more SAW types, along with --- a (Haskell) function for mapping elements of those types their translation --- construct in Haskell. -data TypeTrans tr = TypeTrans - { typeTransTypes :: [OpenTerm], - typeTransFun :: [OpenTerm] -> tr } - --- | Apply the 'typeTransFun' of a 'TypeTrans' to a list of SAW core terms -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) - -instance Applicative TypeTrans where - pure = mkTypeTrans0 - liftA2 f (TypeTrans tps1 f1) (TypeTrans tps2 f2) = - TypeTrans (tps1 ++ tps2) - (\ts -> f (f1 $ take (length tps1) ts) (f2 $ drop (length tps1) ts)) - --- | Build a 'TypeTrans' represented by 0 SAW types -mkTypeTrans0 :: tr -> TypeTrans tr -mkTypeTrans0 tr = TypeTrans [] $ \case - [] -> tr - _ -> error "mkTypeTrans0: incorrect number of terms" - --- | Build a 'TypeTrans' represented by 1 SAW type -mkTypeTrans1 :: OpenTerm -> (OpenTerm -> tr) -> TypeTrans tr -mkTypeTrans1 tp f = TypeTrans [tp] $ \case - [t] -> f t - _ -> error "mkTypeTrans1: incorrect number of terms" - --- | Build a 'TypeTrans' for an 'OpenTerm' of a given type -openTermTypeTrans :: OpenTerm -> TypeTrans OpenTerm -openTermTypeTrans tp = mkTypeTrans1 tp id - --- | Build a 'TypeTrans' for a list of 'OpenTerm's of 0 or more types -openTermsTypeTrans :: [OpenTerm] -> TypeTrans [OpenTerm] -openTermsTypeTrans tps = TypeTrans tps id - --- | Extract out the single SAW type associated with a 'TypeTrans', or the unit --- type if it has 0 SAW types. It is an error if it has 2 or more SAW types. -typeTransType1 :: HasCallStack => TypeTrans tr -> OpenTerm -typeTransType1 (TypeTrans [] _) = unitTypeOpenTerm -typeTransType1 (TypeTrans [tp] _) = tp -typeTransType1 _ = - panic "typeTransType1" ["found multiple types where at most 1 was expected"] - --- | Map the 'typeTransTypes' field of a 'TypeTrans' to a single type, where a --- single type is mapped to itself, an empty list of types is mapped to @unit@, --- and a list of 2 or more types is mapped to a tuple of the types -typeTransTupleType :: TypeTrans tr -> OpenTerm -typeTransTupleType = tupleTypeOpenTerm' . typeTransTypes - --- | Convert a 'TypeTrans' over 0 or more types to one over a tuple of those --- types -tupleTypeTrans :: TypeTrans tr -> TypeTrans tr -tupleTypeTrans ttrans = - let tps = typeTransTypes ttrans in - TypeTrans [tupleTypeOpenTerm' tps] - (\case - [t] -> - let len = fromIntegral $ length tps in - typeTransF ttrans $ map (\i -> projTupleOpenTerm' len i t) $ - take (length tps) [0..] - _ -> panic "tupleTypeTrans" ["incorrect number of terms"]) - --- | Build a type translation for a list of translations -listTypeTrans :: [TypeTrans tr] -> TypeTrans [tr] -listTypeTrans [] = pure [] -listTypeTrans (trans:transs) = App.liftA2 (:) trans $ listTypeTrans transs - --- | Tuple all the terms in a list into a single term, or return the empty list --- if the input list is empty -tupleOpenTermList :: [OpenTerm] -> [OpenTerm] -tupleOpenTermList [] = [] -tupleOpenTermList ts = [tupleOpenTerm' ts] - --- | Tuple all the type descriptions in a list, or return the empty list if the --- input list is empty -tupleTpDescList :: [OpenTerm] -> [OpenTerm] -tupleTpDescList [] = [] -tupleTpDescList ds = [tupleTpDesc ds] - - ----------------------------------------------------------------------- --- * Expression Translations ----------------------------------------------------------------------- - --- | The result of translating a 'PermExpr' at 'CrucibleType' @a@. This is a --- form of partially static data in the sense of partial evaluation. -data ExprTrans (a :: CrucibleType) where - -- | LLVM pointers have their translations dictated by their permissions, so - -- the translations of their expressions have no computational content - ETrans_LLVM :: ExprTrans (LLVMPointerType w) - - -- | LLVM blocks also have no computational content - ETrans_LLVMBlock :: ExprTrans (LLVMBlockType w) - - -- | Frames also have no computational content - ETrans_LLVMFrame :: ExprTrans (LLVMFrameType w) - - -- | Lifetimes also have no computational content - ETrans_Lifetime :: ExprTrans LifetimeType - - -- | Read-write modalities also have no computational content - ETrans_RWModality :: ExprTrans RWModalityType - - -- | Structs are translated as a sequence of translations of the fields - ETrans_Struct :: ExprTransCtx (CtxToRList ctx) -> ExprTrans (StructType ctx) - - -- | The computational content of functions is in their FunPerms, so functions - -- themselves have no computational content - ETrans_Fun :: ExprTrans (FunctionHandleType args ret) - - -- | The unit type has no computational content - ETrans_Unit :: ExprTrans UnitType - - -- | The translation of Vectors of the Crucible any type have no content - ETrans_AnyVector :: ExprTrans (VectorType AnyType) - - -- | The translation of a shape is an optional pair of a type description - -- along with the type it represents, where 'Nothing' represents a shape with - -- no computational content in its translation - ETrans_Shape :: Maybe (OpenTerm, OpenTerm) -> ExprTrans (LLVMShapeType w) - - -- | The translation of a permission is a list of 0 or more type descriptions - -- along with the translations to the types they represent, in that order - ETrans_Perm :: [OpenTerm] -> [OpenTerm] -> ExprTrans (ValuePermType a) - - -- | The translation for every other expression type is just a SAW term. Note - -- that this construct should not be used for the types handled above. - ETrans_Term :: TypeRepr a -> OpenTerm -> ExprTrans a - --- | A context mapping bound names to their type-level SAW translations -type ExprTransCtx = RAssign ExprTrans - - --- | Destruct an 'ExprTrans' of shape type to the optional type description and --- type it represents, in that order -unETransShape :: ExprTrans (LLVMShapeType w) -> Maybe (OpenTerm, OpenTerm) -unETransShape (ETrans_Shape maybe_d_tp) = maybe_d_tp -unETransShape (ETrans_Term _ _) = - panic "unETransShape" ["Incorrect translation of a shape expression"] - --- | Destruct an 'ExprTrans' of shape type to a type description type and type --- it represents, using the unit type in place of a 'Nothing' -unETransShapeTuple :: ExprTrans (LLVMShapeType w) -> (OpenTerm, OpenTerm) -unETransShapeTuple = - fromMaybe (unitTpDesc, unitTypeOpenTerm) . unETransShape - --- | Destruct an 'ExprTrans' of permission type to a list of type descriptions --- and the types they represent, in that order -unETransPerm :: ExprTrans (ValuePermType a) -> ([OpenTerm], [OpenTerm]) -unETransPerm (ETrans_Perm ds tps) = (ds, tps) -unETransPerm (ETrans_Term _ _) = - panic "unETransPerm" ["Incorrect translation of a shape expression"] - --- | Describes a Haskell type that represents the translation of a term-like --- construct that corresponds to 0 or more SAW terms -class IsTermTrans tr where - transTerms :: HasCallStack => tr -> [OpenTerm] - --- | Build a tuple of the terms contained in a translation, with 0 terms mapping --- to the unit term and one term mapping to itself. If @ttrans@ is a 'TypeTrans' --- describing the SAW types associated with a @tr@ translation, then this --- function returns an element of the type @'tupleTypeTrans' ttrans@. -transTupleTerm :: IsTermTrans tr => tr -> OpenTerm -transTupleTerm = tupleOpenTerm' . transTerms - --- | Convert a list of at most 1 SAW core terms to a single term, that is either --- the sole term in the list or the unit value, raising an error if the list has --- more than one term in it -termsExpect1 :: [OpenTerm] -> OpenTerm -termsExpect1 [] = unitOpenTerm -termsExpect1 [t] = t -termsExpect1 ts = panic "termsExpect1" ["Expected at most one term, but found " - ++ show (length ts)] - --- | Like 'transTupleTerm' but raise an error if there are more than 1 terms -transTerm1 :: HasCallStack => IsTermTrans tr => tr -> OpenTerm -transTerm1 = termsExpect1 . transTerms - -instance (IsTermTrans tr1, IsTermTrans tr2) => IsTermTrans (tr1,tr2) where - transTerms (tr1, tr2) = transTerms tr1 ++ transTerms tr2 - -instance IsTermTrans tr => IsTermTrans [tr] where - transTerms = concatMap transTerms - -instance IsTermTrans (TypeTrans tr) where - transTerms = typeTransTypes - -instance IsTermTrans (ExprTrans tp) where - transTerms ETrans_LLVM = [] - transTerms ETrans_LLVMBlock = [] - transTerms ETrans_LLVMFrame = [] - transTerms ETrans_Lifetime = [] - transTerms ETrans_RWModality = [] - transTerms (ETrans_Struct etranss) = - concat $ RL.mapToList transTerms etranss - transTerms ETrans_Fun = [] - transTerms ETrans_Unit = [] - transTerms ETrans_AnyVector = [] - transTerms (ETrans_Shape (Just (d, _))) = [d] - transTerms (ETrans_Shape Nothing) = [unitTpDesc] - transTerms (ETrans_Perm ds _) = [tupleTpDesc ds] - transTerms (ETrans_Term _ t) = [t] - -instance IsTermTrans (ExprTransCtx ctx) where - transTerms = concat . RL.mapToList transTerms - - --- | Map a context of expression translations to a list of 'OpenTerm's -exprCtxToTerms :: ExprTransCtx tps -> [OpenTerm] -exprCtxToTerms = transTerms - --- | Map an 'ExprTrans' to its type translation -exprTransType :: (?ev :: EventType) => ExprTrans tp -> TypeTrans (ExprTrans tp) -exprTransType ETrans_LLVM = mkTypeTrans0 ETrans_LLVM -exprTransType ETrans_LLVMBlock = mkTypeTrans0 ETrans_LLVMBlock -exprTransType ETrans_LLVMFrame = mkTypeTrans0 ETrans_LLVMFrame -exprTransType ETrans_Lifetime = mkTypeTrans0 ETrans_Lifetime -exprTransType ETrans_RWModality = mkTypeTrans0 ETrans_RWModality -exprTransType (ETrans_Struct etranss) = ETrans_Struct <$> exprCtxType etranss -exprTransType ETrans_Fun = mkTypeTrans0 ETrans_Fun -exprTransType ETrans_Unit = mkTypeTrans0 ETrans_Unit -exprTransType ETrans_AnyVector = mkTypeTrans0 ETrans_AnyVector -exprTransType (ETrans_Shape _) = - mkTypeTrans1 tpDescTypeOpenTerm $ \d -> - ETrans_Shape (Just (d, tpElemTypeOpenTerm ?ev d)) -exprTransType (ETrans_Perm _ _) = - mkTypeTrans1 tpDescTypeOpenTerm $ \d -> - ETrans_Perm [d] [tpElemTypeOpenTerm ?ev d] -exprTransType (ETrans_Term tp t) = - mkTypeTrans1 (openTermType t) (ETrans_Term tp) - --- | Map a context of expression translation to a list of the SAW core types of --- all the terms it contains -exprCtxType :: (?ev :: EventType) => ExprTransCtx ctx -> - TypeTrans (ExprTransCtx ctx) -exprCtxType MNil = mkTypeTrans0 MNil -exprCtxType (ectx :>: e) = (:>:) <$> exprCtxType ectx <*> exprTransType e - - --- | Convert an 'ExprTrans' to a list of SAW core terms of type @kindExpr K@, --- one for each kind description @K@ returned by 'translateType' for the type of --- the 'ExprTrans' -exprTransDescs :: (?ev :: EventType) => ExprTrans a -> [OpenTerm] -exprTransDescs ETrans_LLVM = [] -exprTransDescs ETrans_LLVMBlock = [] -exprTransDescs ETrans_LLVMFrame = [] -exprTransDescs ETrans_Lifetime = [] -exprTransDescs ETrans_RWModality = [] -exprTransDescs (ETrans_Struct etranss) = - concat $ RL.mapToList exprTransDescs etranss -exprTransDescs ETrans_Fun = [] -exprTransDescs ETrans_Unit = [] -exprTransDescs ETrans_AnyVector = [] -exprTransDescs (ETrans_Shape (Just (d, _))) = [d] -exprTransDescs (ETrans_Shape Nothing) = [] -exprTransDescs (ETrans_Perm ds _) = ds -exprTransDescs (ETrans_Term tp t) = - case translateKindDescs tp of - [d] -> [constKindExpr d t] - _ -> panic "exprTransDescs" ["ETrans_Term type has incorrect number of kinds"] - --- | A \"proof\" that @ctx2@ is an extension of @ctx1@, i.e., that @ctx2@ equals --- @ctx1 :++: ctx3@ for some @ctx3@ -data CtxExt ctx1 ctx2 where - CtxExt :: RAssign Proxy ctx3 -> CtxExt ctx1 (ctx1 :++: ctx3) - --- | Build a context extension proof to an appended context -mkCtxExt :: RAssign prx ctx3 -> CtxExt ctx1 (ctx1 :++: ctx3) -mkCtxExt prxs = CtxExt $ RL.map (const Proxy) prxs - --- | Reflexivity of 'CtxExt' -reflCtxExt :: CtxExt ctx ctx -reflCtxExt = CtxExt MNil - --- | Transitively combine two context extensions -transCtxExt :: CtxExt ctx1 ctx2 -> CtxExt ctx2 ctx3 -> - CtxExt ctx1 ctx3 -transCtxExt ((CtxExt ectx2') :: CtxExt ctx1 ctx2) (CtxExt ectx3') - | Refl <- RL.appendAssoc (Proxy :: Proxy ctx1) ectx2' ectx3' - = CtxExt (RL.append ectx2' ectx3') - -extCtxExt :: Proxy ctx1 -> RAssign Proxy ctx2 -> CtxExt (ctx1 :++: ctx2) ctx3 -> - CtxExt ctx1 ctx3 -extCtxExt ctx1 ctx2 (CtxExt ctx4) - | Refl <- RL.appendAssoc ctx1 ctx2 ctx4 - = CtxExt (RL.append ctx2 ctx4) - -ctxExtToExprExt :: CtxExt ctx1 ctx2 -> ExprTransCtx ctx2 -> - ExprCtxExt ctx1 ctx2 -ctxExtToExprExt ((CtxExt ctx3) :: CtxExt ctx1 ctx2) ectx = - ExprCtxExt $ snd $ RL.split (Proxy :: Proxy ctx1) ctx3 ectx - - --- | An extension of expression context @ctx1@ to @ctx2@, which is just an --- 'ExprTransCtx' for the suffix @ctx3@ such that @ctx1:++:ctx3 = ctx2@ -data ExprCtxExt ctx1 ctx2 where - ExprCtxExt :: ExprTransCtx ctx3 -> ExprCtxExt ctx1 (ctx1 :++: ctx3) - --- | The reflexive context extension, proving that any context extends itself -reflExprCtxExt :: ExprCtxExt ctx ctx -reflExprCtxExt = ExprCtxExt MNil - --- | Transitively combine two context extensions -transExprCtxExt :: ExprCtxExt ctx1 ctx2 -> ExprCtxExt ctx2 ctx3 -> - ExprCtxExt ctx1 ctx3 -transExprCtxExt ((ExprCtxExt ectx2') - :: ExprCtxExt ctx1 ctx2) (ExprCtxExt ectx3') - | Refl <- RL.appendAssoc (Proxy :: Proxy ctx1) ectx2' ectx3' - = ExprCtxExt (RL.append ectx2' ectx3') - --- | Use any 'RAssign' object to extend a multi-binding -extMbAny :: RAssign any ctx2 -> Mb ctx1 a -> Mb (ctx1 :++: ctx2) a -extMbAny ctx2 = extMbMulti (RL.map (const Proxy) ctx2) - --- | Use a 'CtxExt' to extend a multi-binding -extMbExt :: ExprCtxExt ctx1 ctx2 -> Mb ctx1 a -> Mb ctx2 a -extMbExt (ExprCtxExt ctx2) = extMbAny ctx2 - -{- FIXME: keeping this in case we need it later --- | Un-extend the left-hand context of an expression context extension -extExprCtxExt :: ExprTrans tp -> ExprCtxExt (ctx1 :> tp) ctx2 -> - ExprCtxExt ctx1 ctx2 -extExprCtxExt etrans ((ExprCtxExt ctx3) :: ExprCtxExt (ctx1 :> tp) ctx2) = - case RL.appendRNilConsEq (Proxy :: Proxy ctx1) etrans ctx3 of - Refl -> ExprCtxExt (RL.append (MNil :>: etrans) ctx3) --} - --- | Use an 'ExprCtxExt' to extend an 'ExprTransCtx' -extExprTransCtx :: ExprCtxExt ctx1 ctx2 -> ExprTransCtx ctx1 -> - ExprTransCtx ctx2 -extExprTransCtx (ExprCtxExt ectx2) ectx1 = RL.append ectx1 ectx2 - --- | Use an 'ExprCtxExt' to \"un-extend\" an 'ExprTransCtx' -unextExprTransCtx :: ExprCtxExt ctx1 ctx2 -> ExprTransCtx ctx2 -> - ExprTransCtx ctx1 -unextExprTransCtx ((ExprCtxExt ectx3) :: ExprCtxExt ctx1 ctx2) ectx2 = - fst $ RL.split (Proxy :: Proxy ctx1) ectx3 ectx2 - - ----------------------------------------------------------------------- --- * Translation Monads ----------------------------------------------------------------------- - --- | Class for valid translation info types, which must contain at least a --- context of expression translations -class TransInfo info where - infoCtx :: info ctx -> ExprTransCtx ctx - infoEnv :: info ctx -> PermEnv - infoChecksFlag :: info ctx -> ChecksFlag - extTransInfo :: ExprTrans tp -> info ctx -> info (ctx :> tp) - --- | A 'TransInfo' that additionally contains a monadic return type for the --- current computation being built, allowing the use of monadic bind -class TransInfo info => TransInfoM info where - infoRetType :: info ctx -> OpenTerm - --- | Get the event type stored in a 'TransInfo' -infoEvType :: TransInfo info => info ctx -> EventType -infoEvType = permEnvEventType . infoEnv - --- | A \"translation monad\" is a 'Reader' monad with some info type that is --- parameterized by a translation context -newtype TransM info (ctx :: RList CrucibleType) a = - TransM { unTransM :: Reader (info ctx) a } - deriving (Functor, Applicative, Monad, OpenTermLike) - -instance Fail.MonadFail (TransM info ctx) where - fail = error - --- | The run function for the 'TransM' monad -runTransM :: TransM info ctx a -> info ctx -> a -runTransM (TransM m) = runReader m - -instance MonadReader (info ctx) (TransM info ctx) where - ask = TransM ask - local f (TransM m) = TransM $ local f m - --- | Run a translation computation with a modified info object -withInfoM :: (info ctx -> info' ctx') -> TransM info' ctx' a -> - TransM info ctx a -withInfoM f (TransM m) = TransM $ withReader f m - --- | Run a translation computation in an extended context -inExtTransM :: TransInfo info => ExprTrans tp -> TransM info (ctx :> tp) a -> - TransM info ctx a -inExtTransM etrans (TransM m) = TransM $ withReader (extTransInfo etrans) m - --- | Run a translation computation in a context extended with multiple types -inExtMultiTransM :: TransInfo info => ExprTransCtx ctx2 -> - TransM info (ctx :++: ctx2) a -> - TransM info ctx a -inExtMultiTransM MNil m = m -inExtMultiTransM (ctx :>: etrans) m = - inExtMultiTransM ctx $ inExtTransM etrans m - --- | Build a @sawLet@-binding in a translation monad that binds a pure variable -sawLetTransM :: String -> OpenTerm -> OpenTerm -> OpenTerm -> - (OpenTerm -> TransM info ctx OpenTerm) -> - TransM info ctx OpenTerm -sawLetTransM x tp tp_ret rhs body_m = - do r <- ask - return $ - sawLetOpenTerm (pack x) tp tp_ret rhs $ \x' -> - runTransM (body_m x') r - --- | Build 0 or more sawLet-bindings in a translation monad, using the same --- variable name -sawLetTransMultiM :: String -> [OpenTerm] -> OpenTerm -> [OpenTerm] -> - ([OpenTerm] -> TransM info ctx OpenTerm) -> - TransM info ctx OpenTerm -sawLetTransMultiM _ [] _ [] f = f [] -sawLetTransMultiM x (tp:tps) ret_tp (rhs:rhss) f = - sawLetTransM x tp ret_tp rhs $ \var_tm -> - sawLetTransMultiM x tps ret_tp rhss (\var_tms -> f (var_tm:var_tms)) -sawLetTransMultiM _ _ _ _ _ = - panic "sawLetTransMultiM" ["numbers of types and right-hand sides disagree"] - --- | Run a translation computation in an extended context, where we sawLet-bind any --- term in the supplied expression translation -inExtTransSAWLetBindM :: TransInfo info => TypeTrans (ExprTrans tp) -> - OpenTerm -> ExprTrans tp -> - TransM info (ctx :> tp) OpenTerm -> - TransM info ctx OpenTerm -inExtTransSAWLetBindM tp_trans tp_ret etrans m = - sawLetTransMultiM "z" (map openTermLike $ - typeTransTypes tp_trans) tp_ret (transTerms etrans) $ - \var_tms -> inExtTransM (typeTransF tp_trans var_tms) m - --- | Run a translation computation in context @(ctx1 :++: ctx2) :++: ctx2@ by --- copying the @ctx2@ portion of the current context -inExtMultiTransCopyLastM :: TransInfo info => prx ctx1 -> RAssign any ctx2 -> - TransM info ((ctx1 :++: ctx2) :++: ctx2) a -> - TransM info (ctx1 :++: ctx2) a -inExtMultiTransCopyLastM ctx1 ctx2 m = - do ectx <- infoCtx <$> ask - let (_,ectx2) = RL.split ctx1 ctx2 ectx - inExtMultiTransM ectx2 m - --- | Run a translation computation in a specific context -inCtxTransM :: TransInfo info => ExprTransCtx ctx -> - TransM info ctx a -> TransM info RNil a -inCtxTransM MNil m = m -inCtxTransM (ctx :>: etrans) m = inCtxTransM ctx $ inExtTransM etrans m - --- | Build a multi-binding for the current context -nuMultiTransM :: TransInfo info => (RAssign Name ctx -> b) -> - TransM info ctx (Mb ctx b) -nuMultiTransM f = - do info <- ask - return $ nuMulti (RL.map (\_ -> Proxy) (infoCtx info)) f - --- | Apply the result of a translation to that of another -applyTransM :: TransM info ctx OpenTerm -> TransM info ctx OpenTerm -> - TransM info ctx OpenTerm -applyTransM m1 m2 = applyOpenTerm <$> m1 <*> m2 - --- | Apply the result of a translation to the results of multiple translations -applyMultiTransM :: TransM info ctx OpenTerm -> - [TransM info ctx OpenTerm] -> - TransM info ctx OpenTerm -applyMultiTransM m ms = foldl applyTransM m ms - --- | Apply an identifier to the results of multiple translations -applyGlobalTransM :: Ident -> [TransM info ctx OpenTerm] -> - TransM info ctx OpenTerm -applyGlobalTransM ident ms = applyGlobalOpenTerm ident <$> sequence ms - --- | Build a nested lambda-abstraction --- --- > \x1:tp1 -> ... -> \xn:tpn -> body --- --- over the types in a 'TypeTrans', using the 'String' as a variable name prefix --- for the @xi@ variables -lambdaTrans :: String -> TypeTrans tr -> (tr -> OpenTerm) -> OpenTerm -lambdaTrans x (TypeTrans tps tr_f) body_f = - lambdaOpenTermMulti - (zipWith (\i tp -> (pack (x ++ show (i :: Integer)), tp)) [0..] tps) - (body_f . tr_f) - --- | Build a nested lambda-abstraction --- --- > \x1:tp1 -> ... -> \xn:tpn -> body --- --- over the types in a 'TypeTrans' inside a translation monad, using the --- 'String' as a variable name prefix for the @xi@ variables -lambdaTransM :: String -> TypeTrans tr -> (tr -> TransM info ctx OpenTerm) -> - TransM info ctx OpenTerm -lambdaTransM x tp body_f = - ask >>= \info -> return (lambdaTrans x tp (flip runTransM info . body_f)) - --- | Build a lambda-abstraction --- --- > \x1:(tp1, ..., tpn) -> body --- --- over a tuple of the types in a 'TypeTrans'. Note that this always builds --- exactly one lambda-abstraction, even if there are 0 types. -lambdaTupleTransM :: String -> TypeTrans tr -> (tr -> TransM info ctx OpenTerm) -> - TransM info ctx OpenTerm -lambdaTupleTransM x ttrans body_f = - lambdaTransM x (tupleTypeTrans ttrans) body_f - --- | Build a pi-abstraction over the types in a 'TypeTrans' inside a --- translation monad, using the 'String' as a variable name prefix -piTransM :: String -> TypeTrans tr -> (tr -> TransM info ctx OpenTerm) -> - TransM info ctx OpenTerm -piTransM x tps body_f = - ask >>= \info -> - return (piOpenTermMulti - (zipWith (\i tp -> (pack (x ++ show (i :: Integer)), tp)) - [0..] (typeTransTypes tps)) - (\ts -> runTransM (body_f $ typeTransF tps ts) info)) - -{- --- | Build a pi-abstraction inside the 'TransM' monad -piOpenTermTransM :: String -> OpenTerm -> - (OpenTerm -> TransM info ctx OpenTerm) -> - TransM info ctx OpenTerm -piOpenTermTransM x tp body_f = - ask >>= \info -> - return (piOpenTerm (pack x) tp $ \t -> runTransM (body_f t) info) --} - --- | Build a let-binding in a translation monad -letTransM :: String -> OpenTerm -> TransM info ctx OpenTerm -> - (OpenTerm -> TransM info ctx OpenTerm) -> - TransM info ctx OpenTerm -letTransM x tp rhs_m body_m = - do r <- ask - return $ - letOpenTerm (pack x) tp (runTransM rhs_m r) $ \x' -> - runTransM (body_m x') r - --- | Build a bitvector type in a translation monad -bitvectorTransM :: TransM info ctx OpenTerm -> TransM info ctx OpenTerm -bitvectorTransM m = bitvectorTypeOpenTerm <$> m - --- | Build an @Either@ type in SAW from the 'typeTransTupleType's of the left --- and right types -eitherTypeTrans :: TypeTrans trL -> TypeTrans trR -> OpenTerm -eitherTypeTrans tp_l tp_r = - eitherTypeOpenTerm (typeTransTupleType tp_l) (typeTransTupleType tp_r) - --- | Apply the @Left@ constructor of the @Either@ type in SAW to the --- 'transTupleTerm' of the input -leftTrans :: TypeTrans trL -> TypeTrans trR -> OpenTerm -> OpenTerm -leftTrans tp_l tp_r t = - ctorOpenTerm "Prelude.Left" [typeTransTupleType tp_l, - typeTransTupleType tp_r, t] - --- | Apply the @Right@ constructor of the @Either@ type in SAW to the --- 'transTupleTerm' of the input -rightTrans :: TypeTrans trL -> TypeTrans trR -> OpenTerm -> OpenTerm -rightTrans tp_l tp_r t = - ctorOpenTerm "Prelude.Right" [typeTransTupleType tp_l, - typeTransTupleType tp_r, t] - --- | Eliminate a SAW @Either@ type -eitherElimTransM :: TypeTrans trL -> TypeTrans trR -> - TypeTrans tr -> (trL -> TransM info ctx OpenTerm) -> - (trR -> TransM info ctx OpenTerm) -> OpenTerm -> - TransM info ctx OpenTerm -eitherElimTransM tp_l tp_r tp_ret fl fr eith = - do fl_trans <- lambdaTupleTransM "x_left" tp_l fl - fr_trans <- lambdaTupleTransM "x_right" tp_r fr - return $ applyGlobalOpenTerm "Prelude.either" - [ typeTransTupleType tp_l, typeTransTupleType tp_r, - typeTransTupleType tp_ret, fl_trans, fr_trans, eith ] - --- | Eliminate a multi-way SAW @Eithers@ type, taking in: a list of the --- translations of the types in the @Eithers@ type; the translation of the --- output type; a list of functions for the branches of the @Eithers@ --- elimination; and the term of @Eithers@ type being eliminated -eithersElimTransM :: [TypeTrans tr_in] -> TypeTrans tr_out -> - [tr_in -> TransM info ctx OpenTerm] -> OpenTerm -> - TransM info ctx OpenTerm -eithersElimTransM tps tp_ret fs eith = - foldr (\(tp,f) restM -> - do f_trans <- lambdaTupleTransM "x_eith_elim" tp f - rest <- restM - return (ctorOpenTerm "Prelude.FunsTo_Cons" - [typeTransTupleType tp_ret, - typeTransTupleType tp, f_trans, rest])) - (return $ ctorOpenTerm "Prelude.FunsTo_Nil" [typeTransTupleType tp_ret]) - (zip tps fs) - >>= \elims_trans -> - return (applyGlobalOpenTerm "Prelude.eithers" - [typeTransTupleType tp_ret, elims_trans, eith]) - - --- | Build the right-nested dependent pair type whose sequence of left-hand --- projections have the types of the supplied 'TypeTrans' and whose right-hand --- projection is the 'typeTransTupleType' of the supplied monadic function -sigmaTypeTransM :: LocalName -> TypeTrans trL -> - (trL -> TransM info ctx (TypeTrans trR)) -> - TransM info ctx OpenTerm -sigmaTypeTransM x tptrans tp_f = - ask >>= \info -> - return (sigmaTypeOpenTermMulti x (typeTransTypes tptrans) - (typeTransTupleType . flip runTransM info . tp_f . typeTransF tptrans)) - --- | Like 'sigmaTypeTransM', but translates @exists x.eq(y)@ into the tuple of --- types of @x@, omitting the right-hand projection type -sigmaTypePermTransM :: TransInfo info => LocalName -> - TypeTrans (ExprTrans trL) -> - Mb (ctx :> trL) (ValuePerm trR) -> - TransM info ctx OpenTerm -sigmaTypePermTransM x ttrans mb_p = case mbMatch mb_p of - [nuMP| ValPerm_Eq _ |] -> return $ typeTransTupleType ttrans - _ -> - sigmaTypeTransM x ttrans $ \etrans -> - inExtTransM etrans (translate mb_p) - --- | Build a nested dependent pair of the type returned by 'sigmaTypeTransM'. --- Note that the 'TypeTrans' returned by the type-level function will in general --- be in a larger context than that of the right-hand projection argument, so we --- allow the representation types to be different to accommodate for this. -sigmaTransM :: (IsTermTrans trL, IsTermTrans trR2) => - LocalName -> TypeTrans trL -> - (trL -> TransM info ctx (TypeTrans trR1)) -> - trL -> TransM info ctx trR2 -> - TransM info ctx OpenTerm -sigmaTransM _ (typeTransTypes -> []) _ _ rhs_m = transTupleTerm <$> rhs_m -sigmaTransM x tp_l tp_r lhs rhs_m = - do info <- ask - rhs <- rhs_m - return (sigmaOpenTermMulti x (typeTransTypes tp_l) - (typeTransTupleType . flip runTransM info . tp_r . typeTransF tp_l) - (transTerms lhs) - (transTupleTerm rhs)) - --- | Like `sigmaTransM`, but translates `exists x.eq(y)` into just `x` -sigmaPermTransM :: (TransInfo info, IsTermTrans trR2) => - LocalName -> TypeTrans (ExprTrans trL) -> - Mb (ctx :> trL) (ValuePerm trR1) -> - ExprTrans trL -> TransM info ctx trR2 -> - TransM info ctx OpenTerm -sigmaPermTransM x ttrans mb_p etrans rhs_m = case mbMatch mb_p of - [nuMP| ValPerm_Eq _ |] -> return $ transTupleTerm etrans - _ -> sigmaTransM x ttrans (flip inExtTransM $ translate mb_p) etrans rhs_m - - --- | Eliminate a dependent pair of the type returned by 'sigmaTypeTransM' -sigmaElimTransM :: LocalName -> TypeTrans trL -> - (trL -> TransM info ctx (TypeTrans trR)) -> - TransM info ctx (TypeTrans trRet) -> - (trL -> trR -> TransM info ctx OpenTerm) -> - OpenTerm -> - TransM info ctx OpenTerm -sigmaElimTransM _ tp_l@(typeTransTypes -> []) tp_r _ f sigma = - do let proj_l = typeTransF tp_l [] - proj_r <- flip (typeTransF . tupleTypeTrans) [sigma] <$> tp_r proj_l - f proj_l proj_r -sigmaElimTransM x tp_l tp_r_mF _tp_ret_m f sigma = - do info <- ask - let tp_r_f = flip runTransM info . tp_r_mF . typeTransF tp_l - return $ - sigmaElimOpenTermMulti x (typeTransTypes tp_l) - (typeTransTupleType . tp_r_f) - sigma - (\ts -> let (ts_l, ts_r) = splitAt (length (typeTransTypes tp_l)) ts - trL = typeTransF tp_l ts_l - tp_r = tupleTypeTrans $ tp_r_f ts_l in - flip runTransM info $ f trL (typeTransF tp_r ts_r)) - - --- | Like `sigmaElimTransM`, but translates `exists x.eq(y)` into just `x` -sigmaElimPermTransM :: (TransInfo info) => - LocalName -> TypeTrans (ExprTrans trL) -> - Mb (ctx :> trL) (ValuePerm trR) -> - TransM info ctx (TypeTrans trRet) -> - (ExprTrans trL -> PermTrans (ctx :> trL) trR -> - TransM info ctx OpenTerm) -> - OpenTerm -> - TransM info ctx OpenTerm -sigmaElimPermTransM x tp_l mb_p tp_ret_m f sigma = case mbMatch mb_p of - [nuMP| ValPerm_Eq e |] -> - f (typeTransF (tupleTypeTrans tp_l) [sigma]) (PTrans_Eq e) - _ -> - sigmaElimTransM x tp_l (flip inExtTransM $ translate mb_p) tp_ret_m f sigma - --- FIXME: consider using applyEventOpM and friends in the translation below - --- | Apply an 'OpenTerm' to the current event type @E@ and to a --- list of other arguments -applyEventOpM :: TransInfo info => OpenTerm -> [OpenTerm] -> - TransM info ctx OpenTerm -applyEventOpM f args = - do evType <- evTypeTerm <$> infoEvType <$> ask - return $ applyOpenTermMulti f (evType : args) - --- | Apply a named operator to the current event type @E@ and to a list of other --- arguments -applyNamedEventOpM :: TransInfo info => Ident -> [OpenTerm] -> - TransM info ctx OpenTerm -applyNamedEventOpM f args = applyEventOpM (globalOpenTerm f) args - --- | The current non-monadic return type -returnTypeM :: TransInfoM info => TransM info ctx OpenTerm -returnTypeM = infoRetType <$> ask - --- | Build the monadic return type @SpecM E ret@, where @ret@ is the current --- return type in 'itiReturnType' -compReturnTypeM :: TransInfoM info => TransM info ctx OpenTerm -compReturnTypeM = - do ev <- infoEvType <$> ask - ret_tp <- returnTypeM - return $ specMTypeOpenTerm ev ret_tp - --- | Like 'compReturnTypeM' but build a 'TypeTrans' -compReturnTypeTransM :: TransInfoM info => TransM info ctx (TypeTrans OpenTerm) -compReturnTypeTransM = openTermTypeTrans <$> compReturnTypeM - --- | Build a term @bindS m k@ with the given @m@ of type @m_tp@ and where @k@ --- is build as a lambda with the given variable name and body -bindTransM :: TransInfoM info => OpenTerm -> TypeTrans tr -> String -> - (tr -> TransM info ctx OpenTerm) -> - TransM info ctx OpenTerm -bindTransM m m_tptrans str f = - do ev <- infoEvType <$> ask - ret_tp <- returnTypeM - k_tm <- lambdaTupleTransM str m_tptrans f - let m_tp = typeTransTupleType m_tptrans - return $ bindSOpenTerm ev m_tp ret_tp m k_tm - --- | This type turns any type satisfying 'TransInfo' into one satisfying --- 'TransInfoM' by adding a monadic return type -data SpecMTransInfo info ctx = SpecMTransInfo (info ctx) OpenTerm - -instance TransInfo info => TransInfo (SpecMTransInfo info) where - infoCtx (SpecMTransInfo info _) = infoCtx info - infoEnv (SpecMTransInfo info _) = infoEnv info - infoChecksFlag (SpecMTransInfo info _) = infoChecksFlag info - extTransInfo etrans (SpecMTransInfo info ret_tp) = - SpecMTransInfo (extTransInfo etrans info) ret_tp - -instance TransInfo info => TransInfoM (SpecMTransInfo info) where - infoRetType (SpecMTransInfo _ ret_tp) = ret_tp - --- | Build a monadic @SpecM@ computation using a particular return type -specMTransM :: OpenTerm -> TransM (SpecMTransInfo info) ctx OpenTerm -> - TransM info ctx OpenTerm -specMTransM ret_tp m = withInfoM (flip SpecMTransInfo ret_tp) m - --- | The class for translating to SAW -class Translate info ctx a tr | ctx a -> tr where - translate :: Mb ctx a -> TransM info ctx tr - --- | Translate to SAW and then convert to a single SAW term, raising an error if --- the result has 0 or more than 1 terms -translate1 :: (IsTermTrans tr, Translate info ctx a tr, HasCallStack) => - Mb ctx a -> TransM info ctx OpenTerm -translate1 a = translate a >>= \tr -> case transTerms tr of - [t] -> return t - ts -> error ("translate1: expected 1 term, found " ++ show (length ts) - ++ nlPrettyCallStack callStack) - --- | Translate a \"closed\" term, that is not in a binding -translateClosed :: (TransInfo info, Translate info ctx a tr) => - a -> TransM info ctx tr -translateClosed a = nuMultiTransM (const a) >>= translate - -instance (Translate info ctx a tr, NuMatching a) => - Translate info ctx [a] [tr] where - translate = mapM translate . mbList - - ----------------------------------------------------------------------- --- * Translating Types ----------------------------------------------------------------------- - --- | A flag for whether or not to perform checks in the translation. We use this --- type, rather than just 'Bool', for documentation purposes. -newtype ChecksFlag = ChecksFlag { checksFlagSet :: Bool } - --- | The 'ChecksFlag' specifying not to perform any translation checks -noChecks :: ChecksFlag -noChecks = ChecksFlag False - --- | The 'ChecksFlag' specifying to perform all translation checks -doChecks :: ChecksFlag -doChecks = ChecksFlag True - --- | Translation info for translating types and pure expressions -data TypeTransInfo ctx = - TypeTransInfo - { - ttiExprCtx :: ExprTransCtx ctx, - ttiPermEnv :: PermEnv, - ttiChecksFlag :: ChecksFlag - } - --- | Build an empty 'TypeTransInfo' from a 'PermEnv' -emptyTypeTransInfo :: PermEnv -> ChecksFlag -> TypeTransInfo RNil -emptyTypeTransInfo = TypeTransInfo MNil - -instance TransInfo TypeTransInfo where - infoCtx (TypeTransInfo ctx _ _) = ctx - infoEnv (TypeTransInfo _ env _) = env - infoChecksFlag (TypeTransInfo _ _ cflag) = cflag - extTransInfo etrans (TypeTransInfo ctx env checks) = - TypeTransInfo (ctx :>: etrans) env checks - --- | The translation monad specific to translating types and pure expressions -type TypeTransM = TransM TypeTransInfo - --- | Any 'TransM' can run a 'TypeTransM' -tpTransM :: TransInfo info => TypeTransM ctx a -> TransM info ctx a -tpTransM = - withInfoM $ \info -> - TypeTransInfo (infoCtx info) (infoEnv info) (infoChecksFlag info) - --- | Run a 'TypeTransM' computation in the empty translation context -runNilTypeTransM :: PermEnv -> ChecksFlag -> TypeTransM RNil a -> a -runNilTypeTransM env checks m = runTransM m (emptyTypeTransInfo env checks) - --- | Convert a 'TypeTransM' computation into a pure function that takes in an --- 'ExprTransCtx' -ctxFunTypeTransM :: TypeTransM ctx a -> TypeTransM ctx' (ExprTransCtx ctx -> a) -ctxFunTypeTransM m = - do TypeTransInfo {..} <- ask - return $ \ectx -> runTransM m $ TypeTransInfo { ttiExprCtx = ectx, .. } - --- | Run a translation computation in an empty expression translation context -inEmptyCtxTransM :: TypeTransM RNil a -> TypeTransM ctx a -inEmptyCtxTransM = - withInfoM (\(TypeTransInfo _ env checks) -> TypeTransInfo MNil env checks) - -instance TransInfo info => Translate info ctx (NatRepr n) OpenTerm where - translate mb_n = return $ natOpenTerm $ mbLift $ fmap natValue mb_n - --- | Make a type translation that uses a single term of the given type -mkTermType1 :: KnownRepr TypeRepr a => OpenTerm -> TypeTrans (ExprTrans a) -mkTermType1 tp = mkTypeTrans1 tp (ETrans_Term knownRepr) - --- | Make a type translation that uses a single term of the given type using an --- explicit 'TypeRepr' for the Crucible type -mkTermType1Repr :: TypeRepr a -> OpenTerm -> TypeTrans (ExprTrans a) -mkTermType1Repr repr tp = mkTypeTrans1 tp (ETrans_Term repr) - - --- | Translate a permission expression type to a 'TypeTrans' and to a list of --- kind descriptions that describe the types in the 'TypeTrans' -translateType :: (?ev :: EventType) => TypeRepr a -> - (TypeTrans (ExprTrans a), [OpenTerm]) -translateType UnitRepr = (mkTypeTrans0 ETrans_Unit, []) -translateType BoolRepr = - (mkTermType1 (globalOpenTerm "Prelude.Bool"), [boolKindDesc]) -translateType NatRepr = - (mkTermType1 (dataTypeOpenTerm "Prelude.Nat" []), [natKindDesc]) -translateType (BVRepr w) = - withKnownNat w - (mkTermType1 (bitvectorTypeOpenTerm (natOpenTerm $ natValue w)), - [bvKindDesc (natValue w)]) -translateType (VectorRepr AnyRepr) = (mkTypeTrans0 ETrans_AnyVector, []) - --- Our special-purpose intrinsic types, whose translations do not have --- computational content -translateType (LLVMPointerRepr _) = (mkTypeTrans0 ETrans_LLVM, []) -translateType (LLVMBlockRepr _) = (mkTypeTrans0 ETrans_LLVMBlock, []) -translateType (LLVMFrameRepr _) = (mkTypeTrans0 ETrans_LLVMFrame, []) -translateType LifetimeRepr = (mkTypeTrans0 ETrans_Lifetime, []) -translateType PermListRepr = - panic "translateType" ["PermList type no longer supported!"] -translateType RWModalityRepr = (mkTypeTrans0 ETrans_RWModality, []) - --- Permissions and LLVM shapes translate to type descriptions -translateType (ValuePermRepr _) = - (mkTypeTrans1 tpDescTypeOpenTerm (\d -> - ETrans_Perm [d] [tpElemTypeOpenTerm ?ev d]), - [tpKindDesc]) -translateType (LLVMShapeRepr _) = - (mkTypeTrans1 tpDescTypeOpenTerm (\d -> ETrans_Shape - (Just (d, tpElemTypeOpenTerm ?ev d))), - [tpKindDesc]) - -translateType tp@(FloatRepr _) = - (mkTermType1Repr tp $ dataTypeOpenTerm "Prelude.Float" [], - panic "translateType" ["Type descriptions of floats not yet supported"]) - -translateType (StringRepr UnicodeRepr) = - (mkTermType1 stringTypeOpenTerm, - panic "translateType" ["Type descriptions of strings not yet supported"]) -translateType (StringRepr _) = - panic "translateType" ["Non-unicode strings not supported"] -translateType (FunctionHandleRepr _ _) = - -- NOTE: function permissions translate to the SAW function, but the function - -- handle itself has no SAW translation - (mkTypeTrans0 ETrans_Fun, []) - -translateType (StructRepr tps) = - let (tp_transs, ds) = translateCruCtx (mkCruCtx tps) in - (fmap ETrans_Struct tp_transs, ds) - --- Default case is to panic for unsupported types -translateType tp = - panic "translateType" ["Type not supported: " ++ show tp] - - --- | Translate a 'CruCtx' to a 'TypeTrans' and to a list of kind descriptions --- that describe the types in the 'TypeTrans' -translateCruCtx :: (?ev :: EventType) => CruCtx ctx -> - (TypeTrans (ExprTransCtx ctx), [OpenTerm]) -translateCruCtx CruCtxNil = (mkTypeTrans0 MNil, []) -translateCruCtx (CruCtxCons ctx tp) = - let (ctx_trans, ds1) = translateCruCtx ctx - (tp_trans, ds2) = translateType tp in - ((:>:) <$> ctx_trans <*> tp_trans, ds1 ++ ds2) - --- | Translate a permission expression type to a list of kind descriptions -translateKindDescs :: (?ev :: EventType) => TypeRepr a -> [OpenTerm] -translateKindDescs = snd . translateType - --- Translate an expression type to a 'TypeTrans', which both gives a list of 0 --- or more SAW core types and also gives a function to create an expression --- translation from SAW core terms of those types -instance TransInfo info => - Translate info ctx (TypeRepr a) (TypeTrans (ExprTrans a)) where - translate tp = - do ev <- infoEvType <$> ask - return $ fst $ let ?ev = ev in translateType $ mbLift tp - -instance TransInfo info => - Translate info ctx (CruCtx as) (TypeTrans (ExprTransCtx as)) where - translate ctx = - do ev <- infoEvType <$> ask - return $ fst $ let ?ev = ev in translateCruCtx $ mbLift ctx - --- | Translate all types in a Crucible context and lambda-abstract over them -lambdaExprCtx :: TransInfo info => CruCtx ctx -> TransM info ctx OpenTerm -> - TransM info RNil OpenTerm -lambdaExprCtx ctx m = - translateClosed ctx >>= \tptrans -> - lambdaTransM "e" tptrans (\ectx -> inCtxTransM ectx m) - --- | Translate all types in a Crucible context and lambda-abstract over them, --- appending them to the existing context -lambdaExprCtxApp :: TransInfo info => CruCtx ctx2 -> - TransM info (ctx1 :++: ctx2) OpenTerm -> - TransM info ctx1 OpenTerm -lambdaExprCtxApp ctx m = - translateClosed ctx >>= \tptrans -> - lambdaTransM "e" tptrans (\ectx -> inExtMultiTransM ectx m) - --- | Translate all types in a Crucible context and pi-abstract over them -piExprCtx :: TransInfo info => CruCtx ctx -> TransM info ctx OpenTerm -> - TransM info RNil OpenTerm -piExprCtx ctx m = - translateClosed ctx >>= \tptrans -> - piTransM "e" tptrans (\ectx -> inCtxTransM ectx m) - --- | Like 'piExprCtx' but append the newly bound variables to the current --- context, rather than running in the empty context -piExprCtxApp :: TransInfo info => CruCtx ctx2 -> - TransM info (ctx1 :++: ctx2) OpenTerm -> - TransM info ctx1 OpenTerm -piExprCtxApp ctx m = - translateClosed ctx >>= \tptrans -> - piTransM "e" tptrans (\ectx -> inExtMultiTransM ectx m) - - ----------------------------------------------------------------------- --- * Translating to Type Descriptions ----------------------------------------------------------------------- - --- | Translation info for translating to type descriptions, which contains an --- 'ExprTransCtx' for some prefix of @ctx@. The remainder of @ctx@ are variables --- that each translate to zero or more deBruijn indices in type-level --- expressions of the given kind descriptions. Note that this type does not --- satisfy 'TransInfo', because that class requires an 'ExprTransCtx' for all of --- @ctx@. -data DescTransInfo ctx where - DescTransInfo :: - ExprTransCtx ctx1 -> RAssign (Constant [OpenTerm]) ctx2 -> PermEnv -> - ChecksFlag -> DescTransInfo (ctx1 :++: ctx2) - --- | Extract the 'PermEnv' from a 'DescTransInfo' -dtiEnv :: DescTransInfo ctx -> PermEnv -dtiEnv (DescTransInfo _ _ env _) = env - --- | Extract the event type from a 'DescTransInfo' -dtiEvType :: DescTransInfo ctx -> EventType -dtiEvType = permEnvEventType . dtiEnv - --- | Build a sequence of 'Proxy's for the context of a 'DescTransInfo' -dtiProxies :: DescTransInfo ctx -> RAssign Proxy ctx -dtiProxies (DescTransInfo ectx1 ctx2 _ _) = - RL.append (RL.map (const Proxy) ectx1) (RL.map (const Proxy) ctx2) - --- | Translate a 'Member' proof representing a variable in a 'DescTransInfo' --- context into either an 'ExprTrans', if the variable is bound in the --- 'ExprTransCtx' portion of the context, or a 'Natural' that gives the deBruijn --- index associated with the variable plus a list of its kind descriptions -dtiTranslateMemb :: DescTransInfo ctx -> Member ctx a -> - Either (ExprTrans a) (Natural, [OpenTerm]) -dtiTranslateMemb (DescTransInfo ectx MNil _ _) memb = - Left $ RL.get memb ectx -dtiTranslateMemb (DescTransInfo _ (_ :>: Constant ds) _ _) Member_Base = - Right (0, ds) -dtiTranslateMemb (DescTransInfo ectx1 (ctx2 :>: Constant kds) - checks env) (Member_Step memb) = - case dtiTranslateMemb (DescTransInfo ectx1 ctx2 checks env) memb of - Left etrans -> Left etrans - Right (i, ds) -> Right (i + fromIntegral (length kds), ds) - --- | Extend the context of a 'DescTransInfo' with free deBruijn variables for a --- list of kind descriptions -extDescTransInfo :: [OpenTerm] -> DescTransInfo ctx -> DescTransInfo (ctx :> tp) -extDescTransInfo ds (DescTransInfo ctx1 ctx2 env checks) = - DescTransInfo ctx1 (ctx2 :>: Constant ds) env checks - --- | The translation monad specific to translating type descriptions -type DescTransM = TransM DescTransInfo - --- | Run a 'DescTransM' computation with an additional deBruijn variable -inExtDescTransM :: [OpenTerm] -> DescTransM (ctx :> tp) a -> DescTransM ctx a -inExtDescTransM ds = withInfoM (extDescTransInfo ds) - --- | Run a 'DescTransM' computation with a set of additional deBruijn variables -inExtDescTransMultiM :: RAssign (Constant [OpenTerm]) ctx2 -> - DescTransM (ctx1 :++: ctx2) a -> DescTransM ctx1 a -inExtDescTransMultiM MNil m = m -inExtDescTransMultiM (ctx :>: Constant tp) m = - inExtDescTransMultiM ctx $ inExtDescTransM tp m - --- | Run a 'DescTransM' computation in an extended expression context that binds --- all the newly-bound variables to deBruijn indices. Pass the concatenated list --- of all the kind descriptions of those variables to the sub-computation. -inExtCtxDescTransM :: CruCtx ctx2 -> - ([OpenTerm] -> DescTransM (ctx1 :++: ctx2) a) -> - DescTransM ctx1 a -inExtCtxDescTransM ctx m = - do ev <- dtiEvType <$> ask - let kdesc_ctx = - let ?ev = ev in - RL.map (Constant . translateKindDescs) $ cruCtxToTypes ctx - kdescs = concat $ RL.toList kdesc_ctx - inExtDescTransMultiM kdesc_ctx $ m kdescs - --- | Run a 'DescTransM' computation in an expression context that binds a --- context of deBruijn indices. Pass the concatenated list of all the kind --- descriptions of those variables to the sub-computation. -inCtxDescTransM :: CruCtx ctx -> ([OpenTerm] -> DescTransM ctx a) -> - DescTransM RNil a -inCtxDescTransM ctx m = - case RL.prependRNilEq (cruCtxProxies ctx) of - Refl -> inExtCtxDescTransM ctx m - --- | Run a 'DescTransM' computation in any 'TransM' monad satifying 'TransInfo' -descTransM :: TransInfo info => DescTransM ctx a -> TransM info ctx a -descTransM = - withInfoM $ \info -> - DescTransInfo (infoCtx info) MNil (infoEnv info) (infoChecksFlag info) - --- | The class for translating to type descriptions or type-level expressions. --- This should hold for any type that has a 'Translate' instance to a --- 'TypeTrans'. The type descriptions returned in this case should describe --- exactly the types in the 'TypeTrans' returned by the 'Translate' instance, --- though 'translateDesc' is allowed to 'panic' in some cases where 'translate' --- succeeds, meaning that some of the types cannot be described in type --- descriptions. This also holds for the 'PermExpr' type, where the return --- values are type-level expressions for each of the kind descriptions returned --- by 'translateType'. -class TranslateDescs a where - translateDescs :: Mb ctx a -> DescTransM ctx [OpenTerm] - -instance (NuMatching a, TranslateDescs a) => TranslateDescs [a] where - translateDescs l = concat <$> mapM translateDescs (mbList l) - --- | Translate to a single type description by tupling all the descriptions --- return by 'translateDescs' -translateDesc :: TranslateDescs a => Mb ctx a -> DescTransM ctx OpenTerm -translateDesc mb_a = tupleTpDesc <$> translateDescs mb_a - --- | Translate to a single type description or type expression, raising an error --- if the given construct translates to 0 or more than 1 SAW core term -translateDesc1 :: TranslateDescs a => Mb ctx a -> DescTransM ctx OpenTerm -translateDesc1 mb_a = translateDescs mb_a >>= \case - [d] -> return d - ds -> panic "translateDesc1" ["Expected one type-level expression, found " - ++ show (length ds)] - --- | Translate a variable to either a SAW core value, if it is bound to a value, --- or a natural number deBruijn index for the the first of the 0 or more --- deBruijn indices that the variable translates to along with their kind --- descriptions if not -translateVarDesc :: Mb ctx (ExprVar a) -> - DescTransM ctx (Either (ExprTrans a) (Natural, [OpenTerm])) -translateVarDesc mb_x = flip dtiTranslateMemb (translateVar mb_x) <$> ask - --- | A type translation with type descriptions for its types -data DescTypeTrans tr = DescTypeTrans { descTypeTrans :: TypeTrans tr, - descTypeTransDescs :: [OpenTerm] } - -instance Functor DescTypeTrans where - fmap f (DescTypeTrans ttr ds) = DescTypeTrans (fmap f ttr) ds - -instance Applicative DescTypeTrans where - pure x = DescTypeTrans (mkTypeTrans0 x) [] - liftA2 f (DescTypeTrans tr1 ds1) (DescTypeTrans tr2 ds2) = - DescTypeTrans (App.liftA2 f tr1 tr2) (ds1 ++ ds2) - --- | Apply the 'typeTransFun' of a 'TypeTrans' in a 'DescTypeTrans' -descTypeTransF :: HasCallStack => DescTypeTrans tr -> [OpenTerm] -> tr -descTypeTransF dtp_trans = typeTransF (descTypeTrans dtp_trans) - --- | Build the type description of the multi-arity arrow type from the types in --- order in the first type translation to the tuple of the types in the second -arrowDescTrans :: DescTypeTrans tr1 -> DescTypeTrans tr2 -> OpenTerm -arrowDescTrans tp1 tp2 = - funTpDesc (descTypeTransDescs tp1) (tupleTpDesc $ - descTypeTransDescs tp2) - --- | Translate a type-like object to a type translation and type descriptions -translateDescType :: TransInfo info => Translate info ctx a (TypeTrans tr) => - TranslateDescs a => - Mb ctx a -> TransM info ctx (DescTypeTrans tr) -translateDescType mb_a = - DescTypeTrans <$> translate mb_a <*> descTransM (translateDescs mb_a) - - ----------------------------------------------------------------------- --- * Translating Permission Expressions ----------------------------------------------------------------------- - --- FIXME HERE: move these OpenTerm operations to OpenTerm.hs - --- | Build a bitvector literal from a 'BV' value -bvBVOpenTerm :: NatRepr w -> BV w -> OpenTerm -bvBVOpenTerm w bv = bvLitOpenTerm (BV.asBitsBE w bv) - -bvNatOpenTerm :: Natural -> Natural -> OpenTerm -bvNatOpenTerm w n = - applyOpenTermMulti (globalOpenTerm "Prelude.bvNat") - [natOpenTerm w, natOpenTerm (n `mod` 2 ^ w)] - -bvAddOpenTerm :: Natural -> OpenTerm -> OpenTerm -> OpenTerm -bvAddOpenTerm n x y = - applyOpenTermMulti (globalOpenTerm "Prelude.bvAdd") - [natOpenTerm n, x, y] - -bvMulOpenTerm :: Natural -> OpenTerm -> OpenTerm -> OpenTerm -bvMulOpenTerm n x y = - applyOpenTermMulti (globalOpenTerm "Prelude.bvMul") - [natOpenTerm n, x, y] - -bvSplitOpenTerm :: EndianForm -> OpenTerm -> OpenTerm -> OpenTerm -> - (OpenTerm, OpenTerm) -bvSplitOpenTerm BigEndian sz1 sz2 e = - (applyGlobalOpenTerm "Prelude.take" [boolTypeOpenTerm, sz1, sz2, e], - applyGlobalOpenTerm "Prelude.drop" [boolTypeOpenTerm, sz1, sz2, e]) -bvSplitOpenTerm LittleEndian sz1 sz2 e = - (applyGlobalOpenTerm "Prelude.drop" [boolTypeOpenTerm, sz2, sz1, e], - applyGlobalOpenTerm "Prelude.take" [boolTypeOpenTerm, sz2, sz1, e]) - -bvConcatOpenTerm :: EndianForm -> OpenTerm -> OpenTerm -> - OpenTerm -> OpenTerm -> OpenTerm -bvConcatOpenTerm BigEndian sz1 sz2 e1 e2 = - applyGlobalOpenTerm "Prelude.append" [sz1, sz2, boolTypeOpenTerm, e1, e2] -bvConcatOpenTerm LittleEndian sz1 sz2 e1 e2 = - applyGlobalOpenTerm "Prelude.append" [sz2, sz1, boolTypeOpenTerm, e2, e1] - --- | Translate a variable to a 'Member' proof, raising an error if the variable --- is unbound -translateVar :: Mb ctx (ExprVar a) -> Member ctx a -translateVar mb_x | Left memb <- mbNameBoundP mb_x = memb -translateVar _ = panic "translateVar" ["unbound variable!"] - --- | Get the 'TypeRepr' of an expression -mbExprType :: KnownRepr TypeRepr a => Mb ctx (PermExpr a) -> TypeRepr a -mbExprType _ = knownRepr - --- | Get the 'TypeRepr' of an expression -mbVarType :: KnownRepr TypeRepr a => Mb ctx (ExprVar a) -> TypeRepr a -mbVarType _ = knownRepr - --- | Get the 'TypeRepr' bound by a binding -mbBindingType :: KnownRepr TypeRepr tp => Mb ctx (Binding tp a) -> TypeRepr tp -mbBindingType _ = knownRepr - - -instance TransInfo info => - Translate info ctx (ExprVar a) (ExprTrans a) where - translate mb_x = RL.get (translateVar mb_x) <$> infoCtx <$> ask - -instance TransInfo info => - Translate info ctx (RAssign ExprVar as) (ExprTransCtx as) where - translate mb_exprs = case mbMatch mb_exprs of - [nuMP| MNil |] -> return MNil - [nuMP| ns :>: n |] -> - (:>:) <$> translate ns <*> translate n - -instance TransInfo info => - Translate info ctx (PermExpr a) (ExprTrans a) where - translate mb_e = case mbMatch mb_e of - [nuMP| PExpr_Var x |] -> translate x - [nuMP| PExpr_Unit |] -> return ETrans_Unit - [nuMP| PExpr_Bool True |] -> - return $ ETrans_Term knownRepr $ globalOpenTerm "Prelude.True" - [nuMP| PExpr_Bool False |] -> - return $ ETrans_Term knownRepr $ globalOpenTerm "Prelude.False" - [nuMP| PExpr_Nat i |] -> - return $ ETrans_Term knownRepr $ natOpenTerm $ mbLift i - [nuMP| PExpr_String str |] -> - return $ ETrans_Term knownRepr $ stringLitOpenTerm $ pack $ mbLift str - [nuMP| PExpr_BV bvfactors@[] off |] -> - let w = natRepr3 bvfactors in - return $ ETrans_Term knownRepr $ bvBVOpenTerm w $ mbLift off - [nuMP| PExpr_BV bvfactors (BV.BV 0) |] -> - let w = natVal3 bvfactors in - ETrans_Term knownRepr <$> foldr1 (bvAddOpenTerm w) <$> translate bvfactors - [nuMP| PExpr_BV bvfactors off |] -> - do let w = natRepr3 bvfactors - bv_transs <- translate bvfactors - return $ ETrans_Term knownRepr $ - foldr (bvAddOpenTerm $ natValue w) (bvBVOpenTerm w $ mbLift off) bv_transs - [nuMP| PExpr_Struct args |] -> - ETrans_Struct <$> translate args - [nuMP| PExpr_Always |] -> - return ETrans_Lifetime - [nuMP| PExpr_LLVMWord _ |] -> return ETrans_LLVM - [nuMP| PExpr_LLVMOffset _ _ |] -> return ETrans_LLVM - [nuMP| PExpr_Fun _ |] -> return ETrans_Fun - [nuMP| PExpr_PermListNil |] -> return $ ETrans_Term knownRepr unitTypeOpenTerm - [nuMP| PExpr_PermListCons _ _ p l |] -> - ETrans_Term knownRepr <$> (pairTypeOpenTerm <$> - (typeTransTupleType <$> translate p) <*> - (translate1 l)) - [nuMP| PExpr_RWModality _ |] -> return ETrans_RWModality - - -- LLVM shapes are translated to type descriptions by translateDescs - [nuMP| PExpr_EmptyShape |] -> - return $ ETrans_Shape Nothing - [nuMP| PExpr_NamedShape _ _ nmsh args |] -> - case mbMatch $ fmap namedShapeBody nmsh of - [nuMP| DefinedShapeBody _ |] -> - translate (mbMap2 unfoldNamedShape nmsh args) - [nuMP| OpaqueShapeBody _ tp_id desc_id |] -> - do ev <- infoEvType <$> ask - let (_, k_ds) = - let ?ev = ev in - translateCruCtx (mbLift $ fmap namedShapeArgs nmsh) - args_terms <- transTerms <$> translate args - args_ds <- descTransM $ translateDescs args - return $ - ETrans_Shape - (Just (substIndIdTpDescMulti (mbLift desc_id) k_ds args_ds, - applyGlobalOpenTerm (mbLift tp_id) args_terms)) - [nuMP| RecShapeBody _ tp_id desc_id |] -> - do ev <- infoEvType <$> ask - let (_, k_ds) = - let ?ev = ev in - translateCruCtx (mbLift $ fmap namedShapeArgs nmsh) - args_terms <- transTerms <$> translate args - args_ds <- descTransM $ translateDescs args - return $ - ETrans_Shape - (Just (substIdTpDescMulti (mbLift desc_id) k_ds args_ds, - applyGlobalOpenTerm (mbLift tp_id) args_terms)) - [nuMP| PExpr_EqShape _ _ |] -> return $ ETrans_Shape Nothing - [nuMP| PExpr_PtrShape _ _ sh |] -> translate sh - [nuMP| PExpr_FieldShape fsh |] -> - do ds <- descTransM (translateDescs fsh) - tps <- translate fsh - return $ case (ds, tps) of - ([], []) -> ETrans_Shape Nothing - _ -> ETrans_Shape $ Just (tupleTpDesc ds, tupleTypeOpenTerm' tps) - [nuMP| PExpr_ArrayShape mb_len _ mb_sh |] -> - do let w = natVal4 mb_len - let w_term = natOpenTerm w - len_d <- descTransM $ translateBVDesc mb_len - len_term <- translate1 mb_len - (elem_d, elem_tp) <- unETransShapeTuple <$> translate mb_sh - return $ - ETrans_Shape - (Just (bvVecTpDesc w_term len_d elem_d, - bvVecTypeOpenTerm w_term len_term elem_tp)) - [nuMP| PExpr_TupShape sh |] -> - ETrans_Shape <$> Just <$> unETransShapeTuple <$> translate sh - [nuMP| PExpr_SeqShape sh1 sh2 |] -> - do shtr1 <- unETransShape <$> translate sh1 - shtr2 <- unETransShape <$> translate sh2 - return $ ETrans_Shape $ case (shtr1, shtr2) of - (Nothing, _) -> shtr2 - (_, Nothing) -> shtr1 - (Just (d1,tp1), Just (d2,tp2)) -> - Just (pairTpDesc d1 d2, pairTypeOpenTerm tp1 tp2) - [nuMP| PExpr_OrShape sh1 sh2 |] -> - do (d1, tp1) <- unETransShapeTuple <$> translate sh1 - (d2, tp2) <- unETransShapeTuple <$> translate sh2 - return $ - ETrans_Shape (Just (sumTpDesc d1 d2, eitherTypeOpenTerm tp1 tp2)) - [nuMP| PExpr_ExShape mb_mb_sh |] -> - do let tp_repr = mbLift $ fmap bindingType mb_mb_sh - let mb_sh = mbCombine RL.typeCtxProxies mb_mb_sh - ev <- infoEvType <$> ask - let (tptrans, _) = let ?ev = ev in translateType tp_repr - d <- descTransM $ - inExtCtxDescTransM (singletonCruCtx tp_repr) $ \kdescs -> - sigmaTpDescMulti kdescs <$> translateDesc mb_sh - -- NOTE: we are explicitly using laziness of the ETrans_Shape - -- constructor so that the following recursive call does not generate - -- the type description a second time and then throw it away. The - -- reason we don't use that result is that that recursive call is in - -- the context of SAW core variables for tp (bound by sigmaTypeTransM), - -- whereas the description of the sigma type requires binding deBruijn - -- index for that sigma type variable - tp <- sigmaTypeTransM "x_exsh" tptrans $ \e -> - inExtTransM e (openTermTypeTrans <$> snd <$> - unETransShapeTuple <$> translate mb_sh) - return $ ETrans_Shape $ Just (d, tp) - [nuMP| PExpr_FalseShape |] -> - return $ - ETrans_Shape $ Just (voidTpDesc, dataTypeOpenTerm "Prelude.Void" []) - - [nuMP| PExpr_ValPerm p |] -> - ETrans_Perm <$> descTransM (translateDescs p) <*> (typeTransTypes <$> - translate p) - - --- LLVM field shapes translate to the list of type descriptions that the --- permission they contain translates to -instance TransInfo info => - Translate info ctx (LLVMFieldShape w) [OpenTerm] where - translate (mbMatch -> [nuMP| LLVMFieldShape p |]) = - typeTransTypes <$> translate p - --- The TranslateDescs instance for LLVM field shapes returns the type --- descriptions associated with the contained permission -instance TranslateDescs (LLVMFieldShape w) where - translateDescs (mbMatch -> [nuMP| LLVMFieldShape p |]) = - translateDescs p - --- A sequence of expressions translates to an ExprTransCtx -instance TransInfo info => - Translate info ctx (PermExprs as) (ExprTransCtx as) where - translate mb_exprs = case mbMatch mb_exprs of - [nuMP| PExprs_Nil |] -> return MNil - [nuMP| PExprs_Cons es e |] -> - (:>:) <$> translate es <*> translate e - --- A BVFactor translates to a SAW core term of bitvector type -instance TransInfo info => Translate info ctx (BVFactor w) OpenTerm where - translate mb_f = case mbMatch mb_f of - [nuMP| BVFactor (BV.BV 1) x |] -> translate1 (fmap PExpr_Var x) - [nuMP| BVFactor i x |] -> - let w = natRepr4 x in - bvMulOpenTerm (natValue w) (bvBVOpenTerm w $ mbLift i) <$> - translate1 (fmap PExpr_Var x) - --- | Translate a bitvector constant value to a type-level expression -translateBVConstDesc :: NatRepr w -> BV w -> OpenTerm -translateBVConstDesc w bv = - bvConstTpExpr (natValue w) (bvBVOpenTerm w bv) - --- | Translate a bitvector variable to a type-level expression -translateBVVarDesc :: NatRepr w -> Mb ctx (ExprVar (BVType w)) -> - DescTransM ctx OpenTerm -translateBVVarDesc w mb_x = translateVarDesc mb_x >>= \case - Left bv -> return $ bvConstTpExpr (natValue w) (transTerm1 bv) - Right (ix, [_]) -> return $ varTpExpr (bvExprKind $ natValue w) ix - Right (_, ds) -> - panic "translateBVVarDesc" ["Expected one kind for variable, found " - ++ show (length ds)] - --- | Translate a 'BVFactor' to a type-level expression -translateBVFactorDesc :: Mb ctx (BVFactor w) -> DescTransM ctx OpenTerm -translateBVFactorDesc mb_f = - case mbMatch mb_f of - [nuMP| BVFactor (BV.BV 1) mb_x |] -> - translateBVVarDesc (natRepr4 mb_x) mb_x - [nuMP| BVFactor mb_i mb_x |] -> - let w = natRepr4 mb_x in - bvMulTpExpr (natValue w) (translateBVConstDesc w $ mbLift mb_i) <$> - translateBVVarDesc w mb_x - --- | Translate an expression of bitvector type to a type-level expression -translateBVDesc :: KnownNat w => Mb ctx (PermExpr (BVType w)) -> - DescTransM ctx OpenTerm -translateBVDesc mb_e = - let w = mbExprBVTypeWidth mb_e in - case mbMatch mb_e of - [nuMP| PExpr_Var mb_x |] -> translateBVVarDesc w mb_x - [nuMP| PExpr_BV [] mb_off |] -> - return $ translateBVConstDesc w $ mbLift mb_off - [nuMP| PExpr_BV mb_factors (BV.BV 0) |] -> - bvSumTpExprs (natValue w) <$> - mapM translateBVFactorDesc (mbList mb_factors) - [nuMP| PExpr_BV mb_factors mb_off |] -> - do fs_exprs <- mapM translateBVFactorDesc $ mbList mb_factors - let i_expr = translateBVConstDesc w $ mbLift mb_off - return $ bvSumTpExprs (natValue w) (fs_exprs ++ [i_expr]) - --- translateDescs on a variable translates to a list of variable kind exprs -instance TranslateDescs (ExprVar a) where - translateDescs mb_x = - (dtiEvType <$> ask) >>= \ev -> - translateVarDesc mb_x >>= \case - Left etrans -> return $ let ?ev = ev in exprTransDescs etrans - Right (ix, ds) -> return $ zipWith varKindExpr ds [ix..] - --- translateDescs on permission expressions yield a list of SAW core terms of --- types @kindExpr K1@, @kindExpr K2@, etc., one for each kind @K@ in the list --- of kind descriptions returned by translateType -instance TranslateDescs (PermExpr a) where - translateDescs mb_e = case mbMatch mb_e of - [nuMP| PExpr_Var mb_x |] -> translateDescs mb_x - [nuMP| PExpr_Unit |] -> return [] - [nuMP| PExpr_Bool b |] -> - return [constTpExpr boolExprKind $ boolOpenTerm $ mbLift b] - [nuMP| PExpr_Nat n |] -> - return [constTpExpr natExprKind $ natOpenTerm $ mbLift n] - [nuMP| PExpr_String _ |] -> - panic "translateDescs" - ["Cannot (yet?) translate strings to type-level expressions"] - [nuMP| PExpr_BV _ _ |] -> (:[]) <$> translateBVDesc mb_e - [nuMP| PExpr_Struct es |] -> translateDescs es - [nuMP| PExpr_Always |] -> return [] - [nuMP| PExpr_LLVMWord _ |] -> return [] - [nuMP| PExpr_LLVMOffset _ _ |] -> return [] - [nuMP| PExpr_Fun _ |] -> return [] - [nuMP| PExpr_PermListNil |] -> - panic "translateDescs" ["PermList type no longer supported!"] - [nuMP| PExpr_PermListCons _ _ _ _ |] -> - panic "translateDescs" ["PermList type no longer supported!"] - [nuMP| PExpr_RWModality _ |] -> return [] - - -- NOTE: the cases for the shape expressions here overlap significantly with - -- those in the Translate instance for PermExpr. The difference is that - -- these cases can handle some of the expression context being deBruijn - -- indices instead of ExprTranss, by virtue of the fact that here we only - -- return the type descriptions and not the types. - -- - -- Also note that shapes translate to 0 or 1 types and type descriptions, so - -- translateDescs will always return an empty or one-element list for shpaes - [nuMP| PExpr_EmptyShape |] -> return [] - [nuMP| PExpr_NamedShape _ _ nmsh args |] -> - case mbMatch $ fmap namedShapeBody nmsh of - [nuMP| DefinedShapeBody _ |] -> - translateDescs (mbMap2 unfoldNamedShape nmsh args) - [nuMP| OpaqueShapeBody _ _ desc_id |] -> - do ev <- dtiEvType <$> ask - let (_, k_ds) = - let ?ev = ev in - translateCruCtx (mbLift $ fmap namedShapeArgs nmsh) - args_ds <- translateDescs args - return [substIdTpDescMulti (mbLift desc_id) k_ds args_ds] - [nuMP| RecShapeBody _ _ desc_id |] -> - do ev <- dtiEvType <$> ask - let (_, k_ds) = - let ?ev = ev in - translateCruCtx (mbLift $ fmap namedShapeArgs nmsh) - args_ds <- translateDescs args - return [substIndIdTpDescMulti (mbLift desc_id) k_ds args_ds] - [nuMP| PExpr_EqShape _ _ |] -> return [] - [nuMP| PExpr_PtrShape _ _ sh |] -> translateDescs sh - [nuMP| PExpr_FieldShape fsh |] -> tupleTpDescList <$> translateDescs fsh - [nuMP| PExpr_ArrayShape mb_len _ mb_sh |] -> - do let w = natVal4 mb_len - let w_term = natOpenTerm w - len_term <- translateBVDesc mb_len - elem_d <- translateDesc mb_sh - return [bvVecTpDesc w_term len_term elem_d] - [nuMP| PExpr_TupShape sh |] -> - (:[]) <$> tupleTpDesc <$> translateDescs sh - [nuMP| PExpr_SeqShape sh1 sh2 |] -> - do ds1 <- translateDescs sh1 - ds2 <- translateDescs sh2 - -- Since both ds1 and ds2 have length at most 1, the below is the same - -- as choosing one list if the other is empty and pairing the two if - -- they both have 1 element - return $ tupleTpDescList (ds1 ++ ds2) - [nuMP| PExpr_OrShape sh1 sh2 |] -> - (\d -> [d]) <$> (sumTpDesc <$> translateDesc sh1 <*> translateDesc sh2) - [nuMP| PExpr_ExShape mb_sh |] -> - let tp = mbLift $ fmap bindingType mb_sh in - inExtCtxDescTransM (singletonCruCtx tp) $ \kdescs -> - (\d -> [d]) <$> sigmaTpDescMulti kdescs <$> - translateDesc (mbCombine RL.typeCtxProxies mb_sh) - [nuMP| PExpr_FalseShape |] -> return [voidTpDesc] - - [nuMP| PExpr_ValPerm mb_p |] -> translateDescs mb_p - - -instance TranslateDescs (PermExprs tps) where - translateDescs mb_es = case mbMatch mb_es of - [nuMP| MNil |] -> return [] - [nuMP| es :>: e |] -> (++) <$> translateDescs es <*> translateDescs e - - --- | Build the type description that substitutes the translations of the --- supplied arguments into a type description for the body of an inductive type --- description. That is, for inductive type description @Tp_Ind T@, return the --- substitution instance @[args/xs]T@. Note that @T@ is expected to have --- deBruijn index 0 free, to represent resursive occurrences of the inductive --- type, and this substitution should preserve that, leaving index 0 free. -substNamedIndTpDesc :: TransInfo info => Ident -> - CruCtx tps -> Mb ctx (PermExprs tps) -> - TransM info ctx OpenTerm -substNamedIndTpDesc d_id tps args = - do ev <- infoEvType <$> ask - let ks = let ?ev = ev in snd $ translateCruCtx tps - args_exprs <- descTransM $ translateDescs args - return $ substEnvTpDesc 1 (zip ks args_exprs) (globalOpenTerm d_id) - - ----------------------------------------------------------------------- --- * Permission Translations ----------------------------------------------------------------------- - --- | The result of translating a \"proof element\" of a permission of type --- @'ValuePerm' a@. The idea here is that, for a permission implication or typed --- statement that consumes or emits permission @p@, the translation consumes or --- emits an element of the SAW type @'translate' p@. --- --- Another way to look at a @'PermTrans'@ for permission @p@ is that it is a --- partially static representation (in the sense of the partial evaluation --- literature) of a SAW expression of type @'translate' p@. Note that we do --- not include special representations for disjunctions, existentials, or --- recursive permissions, however, because our type-checker does not --- generally introduce these forms as intermediate values. -data PermTrans (ctx :: RList CrucibleType) (a :: CrucibleType) where - -- | An @eq(e)@ permission has no computational content - PTrans_Eq :: Mb ctx (PermExpr a) -> PermTrans ctx a - - -- | A conjuction of atomic permission translations - PTrans_Conj :: [AtomicPermTrans ctx a] -> PermTrans ctx a - - -- | The translation of a defined permission is a wrapper around the - -- translation of what it is defined as - PTrans_Defined :: NamedPermName (DefinedSort b) args a -> - Mb ctx (PermExprs args) -> Mb ctx (PermOffset a) -> - PermTrans ctx a -> PermTrans ctx a - - -- | The translation for disjunctive, existential, and named permissions - PTrans_Term :: Mb ctx (ValuePerm a) -> OpenTerm -> PermTrans ctx a - - --- | The 'PermTrans' type for atomic permissions -data AtomicPermTrans ctx a where - - -- | The translation of an LLVM field permission is just the translation of - -- its contents - APTrans_LLVMField :: (1 <= w, KnownNat w, 1 <= sz, KnownNat sz) => - Mb ctx (LLVMFieldPerm w sz) -> - PermTrans ctx (LLVMPointerType sz) -> - AtomicPermTrans ctx (LLVMPointerType w) - - -- | LLVM array permisions are translated to an 'LLVMArrayPermTrans' - APTrans_LLVMArray :: (1 <= w, KnownNat w) => - LLVMArrayPermTrans ctx w -> - AtomicPermTrans ctx (LLVMPointerType w) - - -- | The translation of an LLVM block permission is an element of the - -- translation of its shape to a type or 'Nothing' if the shape translates to - -- no types - APTrans_LLVMBlock :: (1 <= w, KnownNat w) => - Mb ctx (LLVMBlockPerm w) -> Maybe OpenTerm -> - AtomicPermTrans ctx (LLVMPointerType w) - - -- | LLVM free permissions have no computational content - APTrans_LLVMFree :: (1 <= w, KnownNat w) => - Mb ctx (PermExpr (BVType w)) -> - AtomicPermTrans ctx (LLVMPointerType w) - - -- | LLVM function pointer permissions have the same computational content as - -- a function permission - APTrans_LLVMFunPtr :: (1 <= w, KnownNat w) => - TypeRepr (FunctionHandleType cargs ret) -> - PermTrans ctx (FunctionHandleType cargs ret) -> - AtomicPermTrans ctx (LLVMPointerType w) - - -- | IsLLVMPtr permissions have no computational content - APTrans_IsLLVMPtr :: (1 <= w, KnownNat w) => - AtomicPermTrans ctx (LLVMPointerType w) - - -- | The translation of an LLVMBlockShape permission is an element of the - -- translation of its shape to a type or 'Nothing' if the shape translates to - -- no types - APTrans_LLVMBlockShape :: (1 <= w, KnownNat w) => - Mb ctx (PermExpr (LLVMShapeType w)) -> - Maybe OpenTerm -> - AtomicPermTrans ctx (LLVMBlockType w) - - -- | Perm_NamedConj permissions are a permission + a term - APTrans_NamedConj :: NameSortIsConj ns ~ 'True => - NamedPermName ns args a -> Mb ctx (PermExprs args) -> - Mb ctx (PermOffset a) -> OpenTerm -> - AtomicPermTrans ctx a - - -- | Defined Perm_NamedConj permissions are just a wrapper around the - -- translation of the permission definition - APTrans_DefinedNamedConj :: NamedPermName (DefinedSort 'True) args a -> - Mb ctx (PermExprs args) -> - Mb ctx (PermOffset a) -> - PermTrans ctx a -> - AtomicPermTrans ctx a - - -- | LLVM frame permissions have no computational content - APTrans_LLVMFrame :: (1 <= w, KnownNat w) => - Mb ctx (LLVMFramePerm w) -> - AtomicPermTrans ctx (LLVMFrameType w) - - -- | @lowned@ permissions translate to a monadic function from (the - -- translation of) the input permissions to the output permissions - APTrans_LOwned :: - Mb ctx [PermExpr LifetimeType] -> CruCtx ps_in -> CruCtx ps_out -> - Mb ctx (ExprPerms ps_in) -> Mb ctx (ExprPerms ps_out) -> - LOwnedTrans ctx ps_extra ps_in ps_out -> - AtomicPermTrans ctx LifetimeType - - -- | Simple @lowned@ permissions have no translation, because they represent - -- @lowned@ permissions whose translations are just the identity function - APTrans_LOwnedSimple :: CruCtx ps -> Mb ctx (ExprPerms ps) -> - AtomicPermTrans ctx LifetimeType - - -- | LCurrent permissions have no computational content - APTrans_LCurrent :: Mb ctx (PermExpr LifetimeType) -> - AtomicPermTrans ctx LifetimeType - - -- | LFinished permissions have no computational content - APTrans_LFinished :: AtomicPermTrans ctx LifetimeType - - -- | The translation of a struct permission is sequence of the translations of - -- the permissions in the struct permission - APTrans_Struct :: PermTransCtx ctx (CtxToRList args) -> - AtomicPermTrans ctx (StructType args) - - -- | The translation of functional permission is a SAW term of @specFun@ type - APTrans_Fun :: Mb ctx (FunPerm ghosts (CtxToRList cargs) gouts ret) -> - FunTrans -> AtomicPermTrans ctx (FunctionHandleType cargs ret) - - -- | Propositional permissions are represented by a SAW term - APTrans_BVProp :: (1 <= w, KnownNat w) => BVPropTrans ctx w -> - AtomicPermTrans ctx (LLVMPointerType w) - - -- | Any permissions have no SAW terms - APTrans_Any :: AtomicPermTrans ctx a - - --- | The translation of a proof of a 'BVProp' -data BVPropTrans ctx w = BVPropTrans (Mb ctx (BVProp w)) OpenTerm - --- | Build the translation of a 'BVProp' permission from a proof of it -bvPropPerm :: (1 <= w, KnownNat w) => BVPropTrans ctx w -> - PermTrans ctx (LLVMPointerType w) -bvPropPerm prop = PTrans_Conj [APTrans_BVProp prop] - --- | The translation of a 'BVRange' is the translation of its two elements -data BVRangeTrans ctx w = - BVRangeTrans (Mb ctx (BVRange w)) - (ExprTrans (BVType w)) (ExprTrans (BVType w)) - --- | Extract the translation of the offset from the translation of a 'BVRange' -bvRangeTransOff :: BVRangeTrans ctx w -> ExprTrans (BVType w) -bvRangeTransOff (BVRangeTrans _ off _) = off - --- | Extract the translation of the length from the translation of a 'BVRange' -bvRangeTransLen :: BVRangeTrans ctx w -> ExprTrans (BVType w) -bvRangeTransLen (BVRangeTrans _ _ len) = len - --- | The translation of the vacuously true permission -pattern PTrans_True :: PermTrans ctx a -pattern PTrans_True = PTrans_Conj [] - --- | A single @lowned@ permission translation -pattern PTrans_LOwned :: - () => (a ~ LifetimeType) => - Mb ctx [PermExpr LifetimeType] -> CruCtx ps_in -> CruCtx ps_out -> - Mb ctx (ExprPerms ps_in) -> Mb ctx (ExprPerms ps_out) -> - LOwnedTrans ctx ps_extra ps_in ps_out -> - PermTrans ctx a -pattern PTrans_LOwned mb_ls tps_in tps_out mb_ps_in mb_ps_out t = - PTrans_Conj [APTrans_LOwned mb_ls tps_in tps_out mb_ps_in mb_ps_out t] - --- | A single function permission -pattern PTrans_Fun :: () => (a ~ FunctionHandleType cargs ret) => - Mb ctx (FunPerm ghosts (CtxToRList cargs) gouts ret) -> - FunTrans -> PermTrans ctx a -pattern PTrans_Fun mb_fun_perm tr = PTrans_Conj [APTrans_Fun mb_fun_perm tr] - --- | The translation of a function permission to a term of type @specFun E T@ --- for some type description @T@ --- --- FIXME: do we even need the type description or event type? -data FunTrans = - FunTrans { funTransEv :: EventType, - funTransTpDesc :: OpenTerm, - funTransTerm :: OpenTerm } - --- | Apply a 'FunTransTerm' to a list of arguments -applyFunTrans :: FunTrans -> [OpenTerm] -> OpenTerm -applyFunTrans f = applyOpenTermMulti (funTransTerm f) - --- | Build a type translation for a disjunctive, existential, or named --- permission that uses the 'PTrans_Term' constructor -mkPermTypeTrans1 :: Mb ctx (ValuePerm a) -> OpenTerm -> - TypeTrans (PermTrans ctx a) -mkPermTypeTrans1 mb_p tp = mkTypeTrans1 tp (PTrans_Term mb_p) - --- | Extract the body of a conjunction or raise an error -unPTransConj :: String -> PermTrans ctx a -> [AtomicPermTrans ctx a] -unPTransConj _ (PTrans_Conj ps) = ps -unPTransConj str _ = error (str ++ ": not a conjunction") - --- | Extract the body of a conjunction, which should have exactly one conjunct, --- or raise an error -unPTransConj1 :: String -> PermTrans ctx a -> AtomicPermTrans ctx a -unPTransConj1 str ptrans = - case unPTransConj str ptrans of - [aptrans] -> aptrans - _ -> error (str ++ ": not a single-element conjunction") - --- | Extract out a list of proofs of 'BVProp's from a proof of a conjunction -unPTransBVProps :: String -> PermTrans ctx (LLVMPointerType w) -> - [BVPropTrans ctx w] -unPTransBVProps _ ptrans - | PTrans_Conj ps <- ptrans - , Just transs <- mapM (\ap -> case ap of - APTrans_BVProp p -> Just p - _ -> Nothing) ps - = transs -unPTransBVProps str _ = error (str ++ ": not a list of BVProp permissions") - --- | Extract the body of a conjunction of a single field permission -unPTransLLVMField :: String -> NatRepr sz -> - PermTrans ctx (LLVMPointerType w) -> - (Mb ctx (LLVMFieldPerm w sz), - PermTrans ctx (LLVMPointerType sz)) -unPTransLLVMField _ sz (PTrans_Conj [APTrans_LLVMField mb_fp ptrans]) - | Just Refl <- testEquality sz (mbLift $ fmap llvmFieldSize mb_fp) - = (mb_fp, ptrans) -unPTransLLVMField str _ _ = - error (str ++ ": not an LLVM field permission of the required size") - --- | Extract the body of a conjunction of a single array permission -unPTransLLVMArray :: String -> PermTrans ctx (LLVMPointerType w) -> - LLVMArrayPermTrans ctx w -unPTransLLVMArray _ (PTrans_Conj [APTrans_LLVMArray aptrans]) = aptrans -unPTransLLVMArray str _ = error (str ++ ": not an LLVM array permission") - -data SomeLOwnedTrans ctx ps_in ps_out = - forall ps_extra. SomeLOwnedTrans (LOwnedTrans ctx ps_extra ps_in ps_out) - --- | Extract the 'LOwnedTrans' of a conjunction of a single @lowned@ permission --- with the specified input and output types -unPTransLOwned :: String -> Mb ctx (CruCtx ps_in) -> Mb ctx (CruCtx ps_out) -> - PermTrans ctx LifetimeType -> - SomeLOwnedTrans ctx ps_in ps_out -unPTransLOwned _ tps_in tps_out - (PTrans_LOwned _ (testEquality (mbLift tps_in) -> Just Refl) - (testEquality (mbLift tps_out) -> Just Refl) _ _ lotr) - = SomeLOwnedTrans lotr -unPTransLOwned fname _ _ _ = - panic fname ["Expected lowned permission"] - --- | A context mapping bound names to their perm translations -type PermTransCtx ctx ps = RAssign (PermTrans ctx) ps - --- | A 'DescTypeTrans' yielding a single 'PermTrans' -type Desc1PermTpTrans ctx a = DescTypeTrans (PermTrans ctx a) - --- | A 'DescTypeTrans' yielding a 'PermTransCtx' -type DescPermsTpTrans ctx ps = DescTypeTrans (PermTransCtx ctx ps) - --- | Prepand an empty list of permissions to a 'DescPermsTpTrans' -preNilDescPermsTpTrans :: DescPermsTpTrans ctx ps -> - DescPermsTpTrans ctx (RNil :++: ps) -preNilDescPermsTpTrans = App.liftA2 RL.append (pure MNil) - --- | Build a permission translation context with just @true@ permissions -truePermTransCtx :: CruCtx ps -> PermTransCtx ctx ps -truePermTransCtx CruCtxNil = MNil -truePermTransCtx (CruCtxCons ctx _) = truePermTransCtx ctx :>: PTrans_True - --- | Build a permission translation context with equality permissions -eqPermTransCtx :: forall (ctx :: RList CrucibleType) (ps :: RList CrucibleType) any. - RAssign any ctx -> RAssign (Member ctx) ps -> - PermTransCtx ctx ps -eqPermTransCtx ns = - RL.map (\memb -> PTrans_Eq $ nuMulti (RL.map (\_-> Proxy) ns) (PExpr_Var . RL.get memb)) - - -instance IsTermTrans (PermTrans ctx a) where - transTerms (PTrans_Eq _) = [] - transTerms (PTrans_Conj aps) = transTerms aps - transTerms (PTrans_Defined _ _ _ ptrans) = transTerms ptrans - transTerms (PTrans_Term _ t) = [t] - -instance IsTermTrans (PermTransCtx ctx ps) where - transTerms = concat . RL.mapToList transTerms - -instance IsTermTrans (AtomicPermTrans ctx a) where - transTerms (APTrans_LLVMField _ ptrans) = transTerms ptrans - transTerms (APTrans_LLVMArray arr_trans) = transTerms arr_trans - transTerms (APTrans_LLVMBlock _ ts) = maybeToList ts - transTerms (APTrans_LLVMFree _) = [] - transTerms (APTrans_LLVMFunPtr _ trans) = transTerms trans - transTerms APTrans_IsLLVMPtr = [] - transTerms (APTrans_LLVMBlockShape _ ts) = maybeToList ts - transTerms (APTrans_NamedConj _ _ _ t) = [t] - transTerms (APTrans_DefinedNamedConj _ _ _ ptrans) = transTerms ptrans - transTerms (APTrans_LLVMFrame _) = [] - transTerms (APTrans_LOwned _ _ _ eps_in _ lotr) = - [lownedTransTerm eps_in lotr] - transTerms (APTrans_LOwnedSimple _ _) = [] - transTerms (APTrans_LCurrent _) = [] - transTerms APTrans_LFinished = [] - transTerms (APTrans_Struct pctx) = transTerms pctx - transTerms (APTrans_Fun _ f) = [funTransTerm f] - transTerms (APTrans_BVProp prop) = transTerms prop - transTerms APTrans_Any = [] - -instance IsTermTrans (BVPropTrans ctx w) where - transTerms (BVPropTrans _ t) = [t] - -instance IsTermTrans (BVRangeTrans ctx w) where - transTerms (BVRangeTrans _ trans1 trans2) = - transTerms trans1 ++ transTerms trans2 - -instance IsTermTrans (LLVMArrayPermTrans ctx a) where - transTerms arr_trans = - [llvmArrayTransTerm arr_trans] -- : transTerms (llvmArrayTransBorrows arr_trans) - -{- -instance IsTermTrans (LLVMArrayBorrowTrans ctx w) where - transTerms (LLVMArrayBorrowTrans _ prop_transs) = transTerms prop_transs --} - - --- | Extract out the permission of a permission translation result -permTransPerm :: RAssign Proxy ctx -> PermTrans ctx a -> Mb ctx (ValuePerm a) -permTransPerm _ (PTrans_Eq e) = fmap ValPerm_Eq e -permTransPerm prxs (PTrans_Conj ts) = - fmap ValPerm_Conj $ foldr (mbMap2 (:)) (nuMulti prxs $ const []) $ - map (atomicPermTransPerm prxs) ts -permTransPerm _ (PTrans_Defined npn mb_args mb_off _) = - mbMap2 (ValPerm_Named npn) mb_args mb_off -permTransPerm _ (PTrans_Term p _) = p - --- | Extract out the atomic permission of an atomic permission translation result -atomicPermTransPerm :: RAssign Proxy ctx -> AtomicPermTrans ctx a -> - Mb ctx (AtomicPerm a) -atomicPermTransPerm _ (APTrans_LLVMField fld _) = fmap Perm_LLVMField fld -atomicPermTransPerm _ (APTrans_LLVMArray arr_trans) = - fmap Perm_LLVMArray $ llvmArrayTransPerm arr_trans -atomicPermTransPerm _ (APTrans_LLVMBlock mb_bp _) = fmap Perm_LLVMBlock mb_bp -atomicPermTransPerm _ (APTrans_LLVMFree e) = fmap Perm_LLVMFree e -atomicPermTransPerm prxs (APTrans_LLVMFunPtr tp ptrans) = - fmap (Perm_LLVMFunPtr tp) (permTransPerm prxs ptrans) -atomicPermTransPerm prxs APTrans_IsLLVMPtr = nuMulti prxs $ const Perm_IsLLVMPtr -atomicPermTransPerm _ (APTrans_LLVMBlockShape mb_sh _) = - fmap Perm_LLVMBlockShape mb_sh -atomicPermTransPerm _ (APTrans_NamedConj npn args off _) = - mbMap2 (Perm_NamedConj npn) args off -atomicPermTransPerm _ (APTrans_DefinedNamedConj npn args off _) = - mbMap2 (Perm_NamedConj npn) args off -atomicPermTransPerm _ (APTrans_LLVMFrame fp) = fmap Perm_LLVMFrame fp -atomicPermTransPerm _ (APTrans_LOwned - mb_ls tps_in tps_out mb_ps_in mb_ps_out _) = - mbMap3 (\ls -> Perm_LOwned ls tps_in tps_out) mb_ls mb_ps_in mb_ps_out -atomicPermTransPerm _ (APTrans_LOwnedSimple tps mb_lops) = - fmap (Perm_LOwnedSimple tps) mb_lops -atomicPermTransPerm _ (APTrans_LCurrent l) = fmap Perm_LCurrent l -atomicPermTransPerm prxs APTrans_LFinished = nus prxs $ const Perm_LFinished -atomicPermTransPerm prxs (APTrans_Struct ps) = - fmap Perm_Struct $ permTransCtxPerms prxs ps -atomicPermTransPerm _ (APTrans_Fun fp _) = fmap Perm_Fun fp -atomicPermTransPerm _ (APTrans_BVProp (BVPropTrans prop _)) = - fmap Perm_BVProp prop -atomicPermTransPerm prxs APTrans_Any = nuMulti prxs $ const $ Perm_Any - --- | Extract out the permissions from a context of permission translations -permTransCtxPerms :: RAssign Proxy ctx -> PermTransCtx ctx ps -> - Mb ctx (ValuePerms ps) -permTransCtxPerms prxs MNil = nuMulti prxs $ const ValPerms_Nil -permTransCtxPerms prxs (ptranss :>: ptrans) = - mbMap2 ValPerms_Cons (permTransCtxPerms prxs ptranss) (permTransPerm prxs ptrans) - --- | Extract out the LLVM borrow from its translation -{- -borrowTransMbBorrow :: LLVMArrayBorrowTrans ctx w -> Mb ctx (LLVMArrayBorrow w) -borrowTransMbBorrow (LLVMArrayBorrowTrans mb_b _) = mb_b --} - --- | Test that a permission equals that of a permission translation -permTransPermEq :: PermTrans ctx a -> Mb ctx (ValuePerm a) -> Bool -permTransPermEq ptrans mb_p = - permTransPerm (mbToProxy mb_p) ptrans == mb_p - --- | Extend the context of a 'PermTrans' with a single type -extPermTrans :: ExtPermTrans f => ExprTrans tp -> f ctx a -> f (ctx :> tp) a -extPermTrans e = extPermTransMulti (MNil :>: e) - --- | Extend the context of a permission translation using a 'CtxExt' -extPermTransExt :: ExprCtxExt ctx1 ctx2 -> - PermTrans ctx1 a -> PermTrans ctx2 a -extPermTransExt (ExprCtxExt ctx) ptrans = - extPermTransMulti ctx ptrans - --- | Extend the context of a 'PermTransCtx' using a 'CtxExt' -extPermTransCtxExt :: ExprCtxExt ctx1 ctx2 -> - PermTransCtx ctx1 ps -> PermTransCtx ctx2 ps -extPermTransCtxExt cext = RL.map (extPermTransExt cext) - - --- | Generic function to extend the context of the translation of a permission -class ExtPermTrans f where - extPermTransMulti :: ExprTransCtx ctx2 -> f ctx1 a -> f (ctx1 :++: ctx2) a - -instance ExtPermTrans PermTrans where - extPermTransMulti ectx (PTrans_Eq e) = - PTrans_Eq $ extMbAny ectx e - extPermTransMulti ectx (PTrans_Conj aps) = - PTrans_Conj (map (extPermTransMulti ectx) aps) - extPermTransMulti ectx (PTrans_Defined n args a ptrans) = - PTrans_Defined n (extMbAny ectx args) (extMbAny ectx a) - (extPermTransMulti ectx ptrans) - extPermTransMulti ectx (PTrans_Term p t) = PTrans_Term (extMbAny ectx p) t - -instance ExtPermTrans AtomicPermTrans where - extPermTransMulti ectx (APTrans_LLVMField fld ptrans) = - APTrans_LLVMField (extMbAny ectx fld) (extPermTransMulti ectx ptrans) - extPermTransMulti ectx (APTrans_LLVMArray arr_trans) = - APTrans_LLVMArray $ extPermTransMulti ectx arr_trans - extPermTransMulti ectx (APTrans_LLVMBlock mb_bp ts) = - APTrans_LLVMBlock (extMbAny ectx mb_bp) ts - extPermTransMulti ectx (APTrans_LLVMFree e) = - APTrans_LLVMFree $ extMbAny ectx e - extPermTransMulti ectx (APTrans_LLVMFunPtr tp ptrans) = - APTrans_LLVMFunPtr tp (extPermTransMulti ectx ptrans) - extPermTransMulti _ APTrans_IsLLVMPtr = APTrans_IsLLVMPtr - extPermTransMulti ectx (APTrans_LLVMBlockShape mb_sh ts) = - APTrans_LLVMBlockShape (extMbAny ectx mb_sh) ts - extPermTransMulti ectx (APTrans_NamedConj npn args off t) = - APTrans_NamedConj npn (extMbAny ectx args) (extMbAny ectx off) t - extPermTransMulti ectx (APTrans_DefinedNamedConj npn args off ptrans) = - APTrans_DefinedNamedConj npn (extMbAny ectx args) (extMbAny ectx off) - (extPermTransMulti ectx ptrans) - extPermTransMulti ectx (APTrans_LLVMFrame fp) = - APTrans_LLVMFrame $ extMbAny ectx fp - extPermTransMulti ectx (APTrans_LOwned ls tps_in tps_out ps_in ps_out lotr) = - APTrans_LOwned (extMbAny ectx ls) tps_in tps_out - (extMbAny ectx ps_in) (extMbAny ectx ps_out) - (extLOwnedTransMulti ectx lotr) - extPermTransMulti ectx (APTrans_LOwnedSimple tps lops) = - APTrans_LOwnedSimple tps (extMbAny ectx lops) - extPermTransMulti ectx (APTrans_LCurrent p) = - APTrans_LCurrent $ extMbAny ectx p - extPermTransMulti _ APTrans_LFinished = APTrans_LFinished - extPermTransMulti ectx (APTrans_Struct ps) = - APTrans_Struct $ RL.map (extPermTransMulti ectx) ps - extPermTransMulti ectx (APTrans_Fun fp trans) = - APTrans_Fun (extMbAny ectx fp) trans - extPermTransMulti ectx (APTrans_BVProp prop_trans) = - APTrans_BVProp $ extPermTransMulti ectx prop_trans - extPermTransMulti _ APTrans_Any = APTrans_Any - -instance ExtPermTrans LLVMArrayPermTrans where - extPermTransMulti ectx (LLVMArrayPermTrans ap len sh {- bs -} t) = - LLVMArrayPermTrans (extMbAny ectx ap) len - (fmap (extPermTransMulti ectx) sh) {- (map extPermTrans bs) -} t - -{- -instance ExtPermTrans LLVMArrayBorrowTrans where - extPermTrans (LLVMArrayBorrowTrans mb_b prop_transs) = - LLVMArrayBorrowTrans (extMb mb_b) (map extPermTrans prop_transs) --} - -instance ExtPermTrans BVPropTrans where - extPermTransMulti ectx (BVPropTrans prop t) = - BVPropTrans (extMbAny ectx prop) t - -instance ExtPermTrans BVRangeTrans where - extPermTransMulti ectx (BVRangeTrans rng t1 t2) = - BVRangeTrans (extMbAny ectx rng) t1 t2 - --- | Extend the context of a permission translation context -extPermTransCtx :: ExprTrans tp -> PermTransCtx ctx ps -> - PermTransCtx (ctx :> tp) ps -extPermTransCtx e = RL.map (extPermTrans e) - --- | Extend the context of a permission translation context -extPermTransCtxMulti :: ExprTransCtx ctx2 -> PermTransCtx ctx1 ps -> - PermTransCtx (ctx1 :++: ctx2) ps -extPermTransCtxMulti ectx2 = RL.map (extPermTransMulti ectx2) - --- | Add another permission translation to a permission translation context -consPermTransCtx :: PermTransCtx ctx ps -> PermTrans ctx a -> - PermTransCtx ctx (ps :> a) -consPermTransCtx = (:>:) - --- | Apply 'offsetLLVMAtomicPerm' to the permissions associated with an atomic --- permission translation, returning 'Nothing' if the offset does not exist -offsetLLVMAtomicPermTrans :: (1 <= w, KnownNat w) => Mb ctx (PermExpr (BVType w)) -> - AtomicPermTrans ctx (LLVMPointerType w) -> - Maybe (AtomicPermTrans ctx (LLVMPointerType w)) -offsetLLVMAtomicPermTrans mb_off ptrans - | [nuMP| Just 0 |] <- mbMatch $ fmap bvMatchConstInt mb_off = Just 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 sh {- bs -} t)) = - Just $ APTrans_LLVMArray $ - LLVMArrayPermTrans (mbMap2 offsetLLVMArrayPerm mb_off ap) len sh {- bs -} t -offsetLLVMAtomicPermTrans mb_off (APTrans_LLVMBlock mb_bp ts) = - Just $ APTrans_LLVMBlock - (mbMap2 (\off bp -> - bp { llvmBlockOffset = - bvAdd (llvmBlockOffset bp) off } ) mb_off mb_bp) - ts -offsetLLVMAtomicPermTrans _ (APTrans_LLVMFree _) = Nothing -offsetLLVMAtomicPermTrans _ (APTrans_LLVMFunPtr _ _) = Nothing -offsetLLVMAtomicPermTrans _ p@APTrans_IsLLVMPtr = Just p -offsetLLVMAtomicPermTrans off (APTrans_NamedConj npn args off' t) = - Just $ APTrans_NamedConj npn args (mbMap2 addPermOffsets off' $ - fmap mkLLVMPermOffset off) t -offsetLLVMAtomicPermTrans off (APTrans_DefinedNamedConj npn args off' ptrans) = - Just $ APTrans_DefinedNamedConj npn args (mbMap2 addPermOffsets off' $ - fmap mkLLVMPermOffset off) - (offsetLLVMPermTrans off ptrans) -offsetLLVMAtomicPermTrans _ _ = Nothing - --- | Apply 'offsetLLVMPerm' to the permissions associated with a permission --- translation -offsetLLVMPermTrans :: (1 <= w, KnownNat w) => Mb ctx (PermExpr (BVType w)) -> - PermTrans ctx (LLVMPointerType w) -> - PermTrans ctx (LLVMPointerType w) -offsetLLVMPermTrans mb_off (PTrans_Eq mb_e) = - PTrans_Eq $ mbMap2 (\off e -> addLLVMOffset e (bvNegate off)) mb_off mb_e -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)) $ - offsetLLVMPermTrans mb_off ptrans -offsetLLVMPermTrans mb_off (PTrans_Term mb_p t) = - PTrans_Term (mbMap2 offsetLLVMPerm mb_off mb_p) t - --- | Apply 'offsetPerm' to the permissions associated with a permission --- translation -offsetPermTrans :: Mb ctx (PermOffset a) -> PermTrans ctx a -> PermTrans ctx a -offsetPermTrans mb_off = case mbMatch mb_off of - [nuMP| NoPermOffset |] -> id - [nuMP| LLVMPermOffset off |] -> offsetLLVMPermTrans off - - ----------------------------------------------------------------------- --- * Translations of Array Permissions ----------------------------------------------------------------------- - --- | The translation of an LLVM array permission is a SAW term of @BVVec@ 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, - llvmArrayTransHeadCell :: TypeTrans (AtomicPermTrans ctx (LLVMPointerType w)), - -- llvmArrayTransBorrows :: [LLVMArrayBorrowTrans ctx w], - llvmArrayTransTerm :: OpenTerm - } - --- | Get the SAW type of the cells of the translation of an array permission -llvmArrayTransCellType :: LLVMArrayPermTrans ctx w -> OpenTerm -llvmArrayTransCellType = typeTransTupleType . llvmArrayTransHeadCell - - --- | The translation of an 'LLVMArrayBorrow' is an element / proof of the --- translation of the the 'BVProp' returned by 'llvmArrayBorrowInArrayBase' -{- -data LLVMArrayBorrowTrans ctx w = - LLVMArrayBorrowTrans - { llvmArrayBorrowTransBorrow :: Mb ctx (LLVMArrayBorrow w), - llvmArrayBorrowTransProps :: [BVPropTrans ctx w] } --} - -{- --- | Add a borrow to an LLVM array permission translation -llvmArrayTransAddBorrow :: LLVMArrayBorrowTrans ctx w -> - LLVMArrayPermTrans ctx w -> - LLVMArrayPermTrans ctx w -llvmArrayTransAddBorrow b arr_trans = - arr_trans { llvmArrayTransPerm = - mbMap2 llvmArrayAddBorrow (llvmArrayBorrowTransBorrow b) - (llvmArrayTransPerm arr_trans) - , llvmArrayTransBorrows = b : llvmArrayTransBorrows arr_trans } - --- | Find the index in the list of borrows of a specific borrow -llvmArrayTransFindBorrowIx :: Mb ctx (LLVMArrayBorrow w) -> - LLVMArrayPermTrans ctx w -> Int -llvmArrayTransFindBorrowIx b arr_trans = - mbLift $ mbMap2 llvmArrayFindBorrow b (llvmArrayTransPerm arr_trans) - --- | Find the index in the list of borrows of a specific borrow -llvmArrayTransFindBorrow :: Mb ctx (LLVMArrayBorrow w) -> - LLVMArrayPermTrans ctx w -> - LLVMArrayBorrowTrans ctx w -llvmArrayTransFindBorrow b arr_trans = - llvmArrayTransBorrows arr_trans !! llvmArrayTransFindBorrowIx b arr_trans - --- | Remove a borrow from an LLVM array permission translation -llvmArrayTransRemBorrow :: LLVMArrayBorrowTrans ctx w -> - LLVMArrayPermTrans ctx w -> - LLVMArrayPermTrans ctx w -llvmArrayTransRemBorrow b_trans arr_trans = - let b = llvmArrayBorrowTransBorrow b_trans in - arr_trans { llvmArrayTransPerm = - mbMap2 llvmArrayRemBorrow b (llvmArrayTransPerm arr_trans) - , llvmArrayTransBorrows = - deleteNth (llvmArrayTransFindBorrowIx b arr_trans) - (llvmArrayTransBorrows arr_trans) } --} - --- | 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 -> - 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 - fromJust $ - -- FIXME: remove offsetLLVMAtomicPermTrans, as it requires changing all - -- name-bindings in the PermTrans it is applied to back to FreshFuns, i.e., it - -- substitutes for all the names - offsetLLVMAtomicPermTrans (mbMap2 llvmArrayCellToOffset - (llvmArrayTransPerm arr_trans) mb_cell) $ - typeTransF (tupleTypeTrans (llvmArrayTransHeadCell arr_trans)) - [applyGlobalOpenTerm "Prelude.atBVVec" - [natOpenTerm w, llvmArrayTransLen arr_trans, - llvmArrayTransCellType arr_trans, llvmArrayTransTerm arr_trans, - cell_tm, in_rng_pf]] -getLLVMArrayTransCell _ _ _ _ = - error "getLLVMArrayTransCell: malformed arguments" - - --- | Write an array cell of the translation of an LLVM array permission at a --- given index -setLLVMArrayTransCell :: (1 <= w, KnownNat w) => - LLVMArrayPermTrans ctx w -> - OpenTerm -> AtomicPermTrans ctx (LLVMPointerType w) -> - LLVMArrayPermTrans ctx w -setLLVMArrayTransCell arr_trans cell_ix_tm cell_value = - let w = fromInteger $ natVal arr_trans in - arr_trans { - llvmArrayTransTerm = - applyGlobalOpenTerm "Prelude.updBVVec" - [natOpenTerm w, llvmArrayTransLen arr_trans, - llvmArrayTransCellType arr_trans, llvmArrayTransTerm arr_trans, - cell_ix_tm, transTupleTerm cell_value] } - - --- | 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 --- and proofs of the propositions that the 'BVRange' is in the array as returned --- by 'llvmArrayCellsInArray'. Note that the first two of these propositions are --- those returned by 'bvPropRangeSubset'. -getLLVMArrayTransSlice :: (1 <= w, KnownNat w) => LLVMArrayPermTrans ctx w -> - TypeTrans (LLVMArrayPermTrans ctx w) -> - BVRangeTrans ctx w -> [BVPropTrans ctx w] -> - LLVMArrayPermTrans ctx w -getLLVMArrayTransSlice arr_trans sub_arr_tp rng_trans prop_transs = - let w = fromInteger $ natVal arr_trans - elem_tp = llvmArrayTransCellType arr_trans - len_tm = llvmArrayTransLen arr_trans - v_tm = llvmArrayTransTerm arr_trans - off_tm = transTerm1 $ bvRangeTransOff rng_trans - len'_tm = transTerm1 $ bvRangeTransLen rng_trans - (p1_trans, p2_trans) = case prop_transs of - t1:t2:_ -> (t1,t2) - _ -> panic "getLLVMArrayTransSlice" ["Malformed input BVPropTrans list"] - BVPropTrans _ p1_tm = p1_trans - BVPropTrans _ p2_tm = p2_trans in - typeTransF sub_arr_tp - [applyGlobalOpenTerm "Prelude.sliceBVVec" - [natOpenTerm w, len_tm, elem_tp, off_tm, len'_tm, p1_tm, p2_tm, v_tm]] - --- | Write a slice (= a sub-array) of the translation of an LLVM array --- permission given the translation of the slice and of the offset of that slice --- in the larger array -setLLVMArrayTransSlice :: (1 <= w, KnownNat w) => LLVMArrayPermTrans ctx w -> - LLVMArrayPermTrans ctx w -> OpenTerm -> - LLVMArrayPermTrans ctx w -setLLVMArrayTransSlice arr_trans sub_arr_trans off_tm = - let w = fromInteger $ natVal arr_trans - elem_tp = llvmArrayTransCellType arr_trans - len_tm = llvmArrayTransLen arr_trans - arr_tm = llvmArrayTransTerm arr_trans - len'_tm = llvmArrayTransLen sub_arr_trans - sub_arr_tm = llvmArrayTransTerm sub_arr_trans in - arr_trans - { llvmArrayTransTerm = - applyGlobalOpenTerm "Prelude.updSliceBVVec" - [natOpenTerm w, len_tm, elem_tp, arr_tm, off_tm, len'_tm, sub_arr_tm] } - - ----------------------------------------------------------------------- --- * Translations of Lifetime Ownership Permissions ----------------------------------------------------------------------- - --- | An 'LOwnedInfo' is essentially a set of translations of \"proof objects\" --- of permission list @ps@, in a variable context @ctx@, along with additional --- information (the @SpecM@ event type and the eventual return type of the --- overall computation) required to apply @bindS@ -data LOwnedInfo ps ctx = - LOwnedInfo { lownedInfoECtx :: ExprTransCtx ctx, - lownedInfoPCtx :: PermTransCtx ctx ps, - lownedInfoPVars :: RAssign (Member ctx) ps, - lownedInfoEvType :: EventType, - lownedInfoRetType :: OpenTerm } - --- NOTE: LOwnedInfo does not satisfy TransInfo because it doesn't have a --- PermEnv; this is probably more of a limitation of the TransInfo interface, --- which should be refactored if we want this -{- -instance TransInfo (LOwnedInfo ps) where - infoCtx = lownedInfoECtx - infoEnv = ?? - infoChecksFlag _ = noChecks - extTransInfo = extLOwnedInfo - -instance TransInfoM (LOwnedInfo ps) where - infoRetType = lownedInfoRetType --} - --- | Convert the permission translations in an 'LOwnedInfo' to SAW core terms -lownedInfoPCtxTerms :: LOwnedInfo ps ctx -> [OpenTerm] -lownedInfoPCtxTerms = transTerms . lownedInfoPCtx - --- | Convert an 'ImpTransInfo' to an 'LOwnedInfo' -impInfoToLOwned :: ImpTransInfo ext blocks tops rets ps ctx -> LOwnedInfo ps ctx -impInfoToLOwned (ImpTransInfo {..}) = - LOwnedInfo { lownedInfoECtx = itiExprCtx, - lownedInfoPCtx = itiPermStack, - lownedInfoPVars = itiPermStackVars, - lownedInfoEvType = permEnvEventType itiPermEnv, - lownedInfoRetType = itiReturnType } - --- | Convert an 'LOwnedInfo' to an 'ImpTransInfo' using an existing --- 'ImpTransInfo', throwing away all permissions in the 'ImpTransInfo' -lownedInfoToImp :: LOwnedInfo ps ctx -> - ImpTransInfo ext blocks tops rets ps' ctx' -> - ImpTransInfo ext blocks tops rets ps ctx -lownedInfoToImp (LOwnedInfo {..}) (ImpTransInfo {..}) = - ImpTransInfo { itiExprCtx = lownedInfoECtx, itiPermStack = lownedInfoPCtx, - itiPermStackVars = lownedInfoPVars, - itiPermCtx = RL.map (const PTrans_True) lownedInfoECtx, - itiReturnType = lownedInfoRetType, .. } - -loInfoSetPerms :: PermTransCtx ctx ps' -> RAssign (Member ctx) ps' -> - LOwnedInfo ps ctx -> LOwnedInfo ps' ctx -loInfoSetPerms ps' vars' (LOwnedInfo {..}) = - LOwnedInfo { lownedInfoPCtx = ps', lownedInfoPVars = vars', ..} - -loInfoSplit :: prx ps1 -> RAssign any ps2 -> - LOwnedInfo (ps1 :++: ps2) ctx -> - (LOwnedInfo ps1 ctx, LOwnedInfo ps2 ctx) -loInfoSplit (_ :: prx ps1) prx2 (LOwnedInfo {..}) = - let prx1 :: Proxy ps1 = Proxy - (ps1, ps2) = RL.split prx1 prx2 lownedInfoPCtx - (vars1, vars2) = RL.split prx1 prx2 lownedInfoPVars in - (LOwnedInfo { lownedInfoPCtx = ps1, lownedInfoPVars = vars1, .. }, - LOwnedInfo { lownedInfoPCtx = ps2, lownedInfoPVars = vars2, .. }) - -loInfoAppend :: LOwnedInfo ps1 ctx -> LOwnedInfo ps2 ctx -> - LOwnedInfo (ps1 :++: ps2) ctx -loInfoAppend info1 info2 = - LOwnedInfo { lownedInfoECtx = lownedInfoECtx info1 - , lownedInfoPCtx = - RL.append (lownedInfoPCtx info1) (lownedInfoPCtx info2) - , lownedInfoPVars = - RL.append (lownedInfoPVars info1) (lownedInfoPVars info2) - , lownedInfoEvType = lownedInfoEvType info1 - , lownedInfoRetType = lownedInfoRetType info1 } - -extLOwnedInfoExt :: ExprCtxExt ctx1 ctx2 -> LOwnedInfo ps ctx1 -> - LOwnedInfo ps ctx2 -extLOwnedInfoExt cext@(ExprCtxExt ectx3) (LOwnedInfo {..}) = - LOwnedInfo { lownedInfoECtx = RL.append lownedInfoECtx ectx3, - lownedInfoPCtx = extPermTransCtxExt cext lownedInfoPCtx, - lownedInfoPVars = RL.map (weakenMemberR ectx3) lownedInfoPVars, - .. } - -extLOwnedInfo :: ExprTrans tp -> LOwnedInfo ps ctx -> LOwnedInfo ps (ctx :> tp) -extLOwnedInfo etrans = extLOwnedInfoExt (ExprCtxExt (MNil :>: etrans)) - --- | An 'LOwnedTransM' is a form of parameterized continuation-state monad --- similar to the construct in GenMonad.hs. A computation of this type returns --- an @a@ while also mapping from permission stack @ps_in@, represented as an --- 'LOwnedInfo', to permission stack @ps_out@. The additional complexity here is --- that the expression context @ctx@ can change during computation, and that --- type argument parameterizes the 'LOwnedInfo' structure. Specifically, the --- 'LOwnedInfo' structure for @ps_in@ can be relative to any context @ctx_in@ --- that extends type argument @ctx@, where the extension is chosen by the caller --- / context outside the computation. The computation itself can then choose the --- extended context @ctx_out@ extending @ctx_in@ to be used for the 'LOwnedInfo' --- structure for @ps_out@. -newtype LOwnedTransM ps_in ps_out ctx a = - LOwnedTransM { - runLOwnedTransM :: - forall ctx_in. ExprCtxExt ctx ctx_in -> LOwnedInfo ps_in ctx_in -> - (forall ctx_out. ExprCtxExt ctx_in ctx_out -> LOwnedInfo ps_out ctx_out -> - a -> OpenTerm) -> - OpenTerm } - --- | The bind operation for 'LOwnedTransM' -(>>>=) :: LOwnedTransM ps_in ps' ctx a -> (a -> LOwnedTransM ps' ps_out ctx b) -> - LOwnedTransM ps_in ps_out ctx b -m >>>= f = LOwnedTransM $ \cext s1 k -> - runLOwnedTransM m cext s1 $ \cext' s2 x -> - runLOwnedTransM (f x) (transExprCtxExt cext cext') s2 $ \cext'' -> - k (transExprCtxExt cext' cext'') - --- | The bind operation for 'LOwnedTransM' that throws away the first value -(>>>) :: LOwnedTransM ps_in ps' ctx a -> LOwnedTransM ps' ps_out ctx b -> - LOwnedTransM ps_in ps_out ctx b -m1 >>> m2 = m1 >>>= \_ -> m2 - -instance Functor (LOwnedTransM ps_in ps_out ctx) where - fmap f m = m >>>= \x -> return (f x) - -instance Applicative (LOwnedTransM ps ps ctx) where - pure x = LOwnedTransM $ \_ s k -> k reflExprCtxExt s x - (<*>) = Monad.ap - -instance Monad (LOwnedTransM ps ps ctx) where - (>>=) = (>>>=) - --- | Set the output permission stack to @ps_out@ -gput :: LOwnedInfo ps_out ctx -> LOwnedTransM ps_in ps_out ctx () -gput loInfo = - LOwnedTransM $ \cext _ k -> - k reflExprCtxExt (extLOwnedInfoExt cext loInfo) () - -{- -data ExtLOwnedInfo ps ctx where - ExtLOwnedInfo :: ExprCtxExt ctx ctx' -> LOwnedInfo ps ctx' -> - ExtLOwnedInfo ps ctx - -instance ps_in ~ ps_out => - MonadState (ExtLOwnedInfo ps_in ctx) (LOwnedTransM ps_in ps_out ctx) where - get = LOwnedTransM $ \cext s k -> k reflExprCtxExt s (ExtLOwnedInfo cext s) - put = gput --} - --- | Get the current permission stack, with the additional complexity that it --- could be in an extended expression context @ctx'@ -ggetting :: (forall ctx'. ExprCtxExt ctx ctx' -> - LOwnedInfo ps_in ctx' -> LOwnedTransM ps_in ps_out ctx' a) -> - LOwnedTransM ps_in ps_out ctx a -ggetting f = - LOwnedTransM $ \cext s k -> - runLOwnedTransM (f cext s) reflExprCtxExt s $ \cext' -> - k cext' - --- | Modify the current permission stack relative to its extended expression --- context @ctx'@ -gmodify :: (forall ctx'. ExprCtxExt ctx ctx' -> - LOwnedInfo ps_in ctx' -> LOwnedInfo ps_out ctx') -> - LOwnedTransM ps_in ps_out ctx () -gmodify f = ggetting $ \cext loInfo -> gput (f cext loInfo) - --- | Extend the expression context of an 'LOwnedTransM' computation -extLOwnedTransM :: ExprCtxExt ctx ctx' -> LOwnedTransM ps_in ps_out ctx a -> - LOwnedTransM ps_in ps_out ctx' a -extLOwnedTransM cext m = - LOwnedTransM $ \cext' -> runLOwnedTransM m (transExprCtxExt cext cext') - --- | A representation of the translation of an @lowned@ permission as a --- transformer from a permission stack @ps_in@ to a permission stack @ps_out@ -type LOwnedTransTerm ctx ps_in ps_out = LOwnedTransM ps_in ps_out ctx () - --- | Build an 'LOwnedTransTerm' transformer from @ps_in@ to @ps_out@ relative to --- context @ctx@ that applies a single SAW core monadic function that takes in --- the translations of @ps_in@ and returns a tuple of the translations of --- @ps_out@ -mkLOwnedTransTermFromTerm :: DescPermsTpTrans ctx ps_in -> - DescPermsTpTrans ctx ps_out -> - RAssign (Member ctx) ps_out -> OpenTerm -> - LOwnedTransTerm ctx ps_in ps_out -mkLOwnedTransTermFromTerm _trans_in trans_out vars_out t = - LOwnedTransM $ \(ExprCtxExt ctx') loInfo k -> - let ev = lownedInfoEvType loInfo - t_app = applyOpenTermMulti t $ lownedInfoPCtxTerms loInfo - t_ret_trans = tupleTypeTrans $ descTypeTrans trans_out - t_ret_tp = typeTransTupleType $ descTypeTrans trans_out in - bindSOpenTerm ev t_ret_tp (lownedInfoRetType loInfo) t_app $ - lambdaOpenTerm "lowned_ret" t_ret_tp $ \lowned_ret -> - let pctx_out' = - extPermTransCtxMulti ctx' $ typeTransF t_ret_trans [lowned_ret] - vars_out' = RL.map (weakenMemberR ctx') vars_out in - k reflExprCtxExt (loInfoSetPerms pctx_out' vars_out' loInfo) () - - --- | Build the SAW core term for the function of type @specFun T@ for the --- transformation from @ps_in@ to @ps_out@ represented by an 'LOwnedTransTerm' -lownedTransTermFun :: EventType -> ExprTransCtx ctx -> - RAssign (Member ctx) ps_in -> - DescPermsTpTrans ctx ps_in -> - DescPermsTpTrans ctx ps_out -> - LOwnedTransTerm ctx ps_in ps_out -> OpenTerm -lownedTransTermFun ev ectx vars_in tps_in tps_out t = - lambdaTrans "p" (descTypeTrans tps_in) $ \ps_in -> - let ret_tp = typeTransTupleType $ descTypeTrans tps_out - loInfo = - LOwnedInfo { lownedInfoECtx = ectx, - lownedInfoPCtx = ps_in, lownedInfoPVars = vars_in, - lownedInfoEvType = ev, lownedInfoRetType = ret_tp } in - runLOwnedTransM t reflExprCtxExt loInfo $ \_ loInfo_out _ -> - retSOpenTerm ev ret_tp $ tupleOpenTerm' $ lownedInfoPCtxTerms loInfo_out - --- | Extend the expression context of an 'LOwnedTransTerm' -extLOwnedTransTerm :: ExprTransCtx ctx2 -> - LOwnedTransTerm ctx1 ps_in ps_out -> - LOwnedTransTerm (ctx1 :++: ctx2) ps_in ps_out -extLOwnedTransTerm ectx2 = extLOwnedTransM (ExprCtxExt ectx2) - --- | Build an 'LOwnedTransTerm' that acts as the identity function on the SAW --- core terms in the permissions, using the supplied permission translation for --- the output permissions, which must have the same SAW core terms as the input --- permissions (or the identity translation would be ill-typed) -idLOwnedTransTerm :: DescPermsTpTrans ctx ps_out -> - RAssign (Member ctx) ps_out -> - LOwnedTransTerm ctx ps_in ps_out -idLOwnedTransTerm dtr_out vars_out = - gmodify $ \(ExprCtxExt ctx') loInfo -> - loInfo { lownedInfoPVars = RL.map (weakenMemberR ctx') vars_out, - lownedInfoPCtx = - descTypeTransF (fmap (extPermTransCtxMulti ctx') dtr_out) - (lownedInfoPCtxTerms loInfo) } - - --- | Partially apply an 'LOwnedTransTerm' to some of its input permissions -applyLOwnedTransTerm :: prx ps_in -> PermTransCtx ctx ps_extra -> - RAssign (Member ctx) ps_extra -> - LOwnedTransTerm ctx (ps_extra :++: ps_in) ps_out -> - LOwnedTransTerm ctx ps_in ps_out -applyLOwnedTransTerm _ ps_extra vars_extra t = - gmodify (\(ExprCtxExt ctx') loInfo -> - loInfoSetPerms - (RL.append (extPermTransCtxMulti ctx' ps_extra) - (lownedInfoPCtx loInfo)) - (RL.append (RL.map (weakenMemberR ctx') vars_extra) - (lownedInfoPVars loInfo)) - loInfo) - >>> t - --- | Weaken an 'LOwnedTransTerm' by adding an extra permission to its input and --- output permissions -weakenLOwnedTransTerm :: Desc1PermTpTrans ctx tp -> - LOwnedTransTerm ctx ps_in ps_out -> - LOwnedTransTerm ctx (ps_in :> tp) (ps_out :> tp) -weakenLOwnedTransTerm tptr t = - ggetting $ \cext info_top -> - let (info_ps_in, info_tp) = loInfoSplit Proxy (MNil :>: Proxy) info_top in - gput info_ps_in >>> - extLOwnedTransM cext t >>> - gmodify (\cext' info' -> - loInfoAppend info' $ extLOwnedInfoExt cext' $ - info_tp { lownedInfoPCtx = - (MNil :>:) $ extPermTransExt cext $ - descTypeTransF tptr (lownedInfoPCtxTerms info_tp) }) - --- | Combine 'LOwnedTransTerm's for the 'SImpl_MapLifetime' rule -mapLtLOwnedTransTerm :: - prx ps_extra1 -> RAssign any1 ps_extra2 -> RAssign any2 ps_in -> - LOwnedTransTerm ctx (ps_extra1 :++: ps_in) ps_mid -> - LOwnedTransTerm ctx (ps_extra2 :++: ps_mid) ps_out -> - LOwnedTransTerm ctx ((ps_extra1 :++: ps_extra2) :++: ps_in) ps_out -mapLtLOwnedTransTerm prx_extra1 prx_extra2 prx_in t1 t2 = - ggetting $ \cext info_extra_in -> - let (info_extra, info_in) = loInfoSplit Proxy prx_in info_extra_in - (info_extra1, info_extra2) = - loInfoSplit prx_extra1 prx_extra2 info_extra in - gput (loInfoAppend info_extra1 info_in) >>> - extLOwnedTransM cext t1 >>> - gmodify (\cext' info_out -> - loInfoAppend (extLOwnedInfoExt cext' info_extra2) info_out) >>> - extLOwnedTransM cext t2 - --- | The translation of an @lowned@ permission -data LOwnedTrans ctx ps_extra ps_in ps_out = - LOwnedTrans { - lotrEvType :: EventType, - lotrECtx :: ExprTransCtx ctx, - lotrPsExtra :: PermTransCtx ctx ps_extra, - lotrVarsExtra :: RAssign (Member ctx) ps_extra, - lotrTpTransIn :: DescPermsTpTrans ctx ps_in, - lotrTpTransOut :: DescPermsTpTrans ctx ps_out, - lotrTpTransExtra :: DescPermsTpTrans ctx ps_extra, - lotrTerm :: LOwnedTransTerm ctx (ps_extra :++: ps_in) ps_out } - --- | Build an initial 'LOwnedTrans' with an empty @ps_extra@ -mkLOwnedTrans :: EventType -> ExprTransCtx ctx -> DescPermsTpTrans ctx ps_in -> - DescPermsTpTrans ctx ps_out -> RAssign (Member ctx) ps_out -> - OpenTerm -> LOwnedTrans ctx RNil ps_in ps_out -mkLOwnedTrans ev ectx tps_in tps_out vars_out t = - LOwnedTrans ev ectx MNil MNil tps_in tps_out (pure MNil) - (mkLOwnedTransTermFromTerm (preNilDescPermsTpTrans tps_in) tps_out vars_out t) - --- | Build an initial 'LOwnedTrans' with an empty @ps_extra@ and an identity --- function on SAW core terms -mkLOwnedTransId :: EventType -> ExprTransCtx ctx -> DescPermsTpTrans ctx ps -> - DescPermsTpTrans ctx ps -> RAssign (Member ctx) ps -> - LOwnedTrans ctx RNil ps ps -mkLOwnedTransId ev ectx tps_in tps_out vars_out = - LOwnedTrans ev ectx MNil MNil tps_in tps_out (pure MNil) - (idLOwnedTransTerm tps_out vars_out) - --- | Extend the context of an 'LOwnedTrans' -extLOwnedTransMulti :: ExprTransCtx ctx2 -> - LOwnedTrans ctx1 ps_extra ps_in ps_out -> - LOwnedTrans (ctx1 :++: ctx2) ps_extra ps_in ps_out -extLOwnedTransMulti ctx2 (LOwnedTrans ev ectx ps_extra vars_extra ptrans_in - ptrans_out ptrans_extra t) = - LOwnedTrans - ev (RL.append ectx ctx2) (extPermTransCtxMulti ctx2 ps_extra) - (RL.map (weakenMemberR ctx2) vars_extra) - (fmap (extPermTransCtxMulti ctx2) ptrans_in) - (fmap (extPermTransCtxMulti ctx2) ptrans_out) - (fmap (extPermTransCtxMulti ctx2) ptrans_extra) - (extLOwnedTransTerm ctx2 t) - --- | Weaken an 'LOwnedTrans' by adding one more permission to the input and --- output permission lists. The SAW core terms taken in for the new input --- permission are used as the SAW core terms for the new output permission, so --- the weakening acts as a form of identity function between these new --- permissions. The new input and output permissions can be different, but they --- should translate to the same list of SAW core types, or otherwise the new --- transformation would be ill-typed. -weakenLOwnedTrans :: - Desc1PermTpTrans ctx tp -> - Desc1PermTpTrans ctx tp -> - LOwnedTrans ctx ps_extra ps_in ps_out -> - LOwnedTrans ctx ps_extra (ps_in :> tp) (ps_out :> tp) -weakenLOwnedTrans tp_in tp_out (LOwnedTrans {..}) = - LOwnedTrans { lotrTpTransIn = App.liftA2 (:>:) lotrTpTransIn tp_in, - lotrTpTransOut = App.liftA2 (:>:) lotrTpTransOut tp_out, - lotrTerm = weakenLOwnedTransTerm tp_out lotrTerm, .. } - --- | Convert an 'LOwnedTrans' to a monadic function from @ps_in@ to @ps_out@ by --- partially applying its function to the @ps_extra@ permissions it already --- contains -lownedTransTerm :: Mb ctx (ExprPerms ps_in) -> - LOwnedTrans ctx ps_extra ps_in ps_out -> OpenTerm -lownedTransTerm (mbExprPermsMembers -> Just vars_in) lotr = - let lot = applyLOwnedTransTerm Proxy - (lotrPsExtra lotr) (lotrVarsExtra lotr) (lotrTerm lotr) in - lownedTransTermFun (lotrEvType lotr) (lotrECtx lotr) vars_in - (lotrTpTransIn lotr) (lotrTpTransOut lotr) lot -lownedTransTerm _ _ = - failOpenTerm "FIXME HERE NOW: write this error message" - --- | Apply the 'SImpl_MapLifetime' rule to an 'LOwnedTrans' -mapLtLOwnedTrans :: - PermTransCtx ctx ps1 -> RAssign (Member ctx) ps1 -> - DescPermsTpTrans ctx ps1 -> - PermTransCtx ctx ps2 -> RAssign (Member ctx) ps2 -> - DescPermsTpTrans ctx ps2 -> - RAssign any ps_in' -> DescPermsTpTrans ctx ps_in' -> - DescPermsTpTrans ctx ps_out' -> - LOwnedTransTerm ctx (ps1 :++: ps_in') ps_in -> - LOwnedTransTerm ctx (ps2 :++: ps_out) ps_out' -> - LOwnedTrans ctx ps_extra ps_in ps_out -> - LOwnedTrans ctx ((ps1 :++: ps_extra) :++: ps2) ps_in' ps_out' -mapLtLOwnedTrans pctx1 vars1 dtr1 pctx2 vars2 dtr2 - prx_in' dtr_in' dtr_out' t1 t2 - (LOwnedTrans {..}) = - LOwnedTrans - { lotrEvType = lotrEvType - , lotrECtx = lotrECtx - , lotrPsExtra = RL.append (RL.append pctx1 lotrPsExtra) pctx2 - , lotrVarsExtra = RL.append (RL.append vars1 lotrVarsExtra) vars2 - , lotrTpTransIn = dtr_in' , lotrTpTransOut = dtr_out' - , lotrTpTransExtra = - App.liftA2 RL.append (App.liftA2 RL.append dtr1 lotrTpTransExtra) dtr2 - , lotrTerm = - mapLtLOwnedTransTerm (RL.append pctx1 lotrPsExtra) pctx2 prx_in' - (mapLtLOwnedTransTerm pctx1 lotrPsExtra prx_in' t1 lotrTerm) - t2 - } - - ----------------------------------------------------------------------- --- * Translating Permissions to Types ----------------------------------------------------------------------- - --- | Make a type translation of a 'BVProp' from it and its pure type -mkBVPropTrans :: Mb ctx (BVProp w) -> OpenTerm -> - TypeTrans (BVPropTrans ctx w) -mkBVPropTrans prop tp = mkTypeTrans1 tp $ BVPropTrans prop - -instance (1 <= w, KnownNat w, TransInfo info) => - Translate info ctx (BVProp w) (TypeTrans (BVPropTrans ctx w)) where - translate prop = case mbMatch prop of - [nuMP| BVProp_Eq e1 e2 |] -> - do let w = natVal4 e1 - t1 <- translate1 e1 - t2 <- translate1 e2 - return $ mkBVPropTrans prop $ - dataTypeOpenTerm "Prelude.Eq" - [applyOpenTermMulti (globalOpenTerm "Prelude.Vec") - [natOpenTerm w, globalOpenTerm "Prelude.Bool"], - t1, t2] - - [nuMP| BVProp_Neq _ _ |] -> - -- NOTE: we don't need a proof object for not equal proofs, because we don't - -- actually use them for anything, but it is easier to just have all BVProps - -- be represented as something, so we use the unit type - return $ mkBVPropTrans prop unitTypeOpenTerm - - [nuMP| BVProp_ULt e1 e2 |] -> - do let w = natVal4 e1 - t1 <- translate1 e1 - t2 <- translate1 e2 - return $ mkBVPropTrans prop $ - dataTypeOpenTerm "Prelude.Eq" - [globalOpenTerm "Prelude.Bool", - applyOpenTermMulti (globalOpenTerm "Prelude.bvult") - [natOpenTerm w, t1, t2], trueOpenTerm] - - [nuMP| BVProp_ULeq e1 e2 |] -> - do let w = natVal4 e1 - t1 <- translate1 e1 - t2 <- translate1 e2 - return $ mkBVPropTrans prop $ - dataTypeOpenTerm "Prelude.Eq" - [globalOpenTerm "Prelude.Bool", - applyOpenTermMulti (globalOpenTerm "Prelude.bvule") - [natOpenTerm w, t1, t2], trueOpenTerm] - - [nuMP| BVProp_ULeq_Diff e1 e2 e3 |] -> - do let w = natVal4 e1 - t1 <- translate1 e1 - t2 <- translate1 e2 - t3 <- translate1 e3 - return $ mkBVPropTrans prop $ - dataTypeOpenTerm "Prelude.Eq" - [globalOpenTerm "Prelude.Bool", - applyOpenTermMulti (globalOpenTerm "Prelude.bvule") - [natOpenTerm w, t1, - applyOpenTermMulti (globalOpenTerm "Prelude.bvSub") - [natOpenTerm w, t2, t3]], - trueOpenTerm] - -instance (1 <= w, KnownNat w, TransInfo info) => - Translate info ctx (BVRange w) (BVRangeTrans ctx w) where - translate rng@(mbMatch -> [nuMP| BVRange off len |]) = - do off_tm <- translate off - len_tm <- translate len - return $ BVRangeTrans rng off_tm len_tm - --- Translate a permission to a TypeTrans, that contains a list of 0 or more SAW --- core types along with a mapping from SAW core terms of those types to a --- PermTrans for the type of the permission -instance TransInfo info => - Translate info ctx (ValuePerm a) (TypeTrans (PermTrans ctx a)) where - translate p = case mbMatch p of - [nuMP| ValPerm_Eq e |] -> return $ mkTypeTrans0 $ PTrans_Eq e - [nuMP| ValPerm_Or p1 p2 |] -> - do tp1 <- translate p1 - tp2 <- translate p2 - return $ mkPermTypeTrans1 p (eitherTypeTrans tp1 tp2) - [nuMP| ValPerm_Exists p1 |] -> - do let tp = mbBindingType p1 - tp_trans <- translateClosed tp - mkPermTypeTrans1 p <$> - sigmaTypePermTransM "x_ex" tp_trans (mbCombine RL.typeCtxProxies p1) - [nuMP| ValPerm_Named npn args off |] -> - do env <- infoEnv <$> ask - case lookupNamedPerm env (mbLift npn) of - Just (NamedPerm_Opaque op) -> - mkPermTypeTrans1 p <$> - applyGlobalOpenTerm (opaquePermTrans op) <$> - transTerms <$> translate args - Just (NamedPerm_Rec rp) -> - mkPermTypeTrans1 p <$> - applyGlobalOpenTerm (recPermTransType rp) <$> - transTerms <$> translate args - Just (NamedPerm_Defined dp) -> - fmap (PTrans_Defined (mbLift npn) args off) <$> - translate (mbMap2 (unfoldDefinedPerm dp) args off) - Nothing -> panic "translate" ["Unknown permission name!"] - [nuMP| ValPerm_Conj ps |] -> - fmap PTrans_Conj <$> listTypeTrans <$> translate ps - [nuMP| ValPerm_Var x _ |] -> - do (_, tps) <- unETransPerm <$> translate x - return $ mkPermTypeTrans1 p (tupleTypeOpenTerm' tps) - [nuMP| ValPerm_False |] -> - return $ mkPermTypeTrans1 p $ globalOpenTerm "Prelude.FalseProp" - --- Translate a permission to type descriptions for the types returned by the --- Translate instance above -instance TranslateDescs (ValuePerm a) where - translateDescs mb_p = case mbMatch mb_p of - [nuMP| ValPerm_Eq _ |] -> return [] - [nuMP| ValPerm_Or p1 p2 |] -> - (:[]) <$> (sumTpDesc <$> translateDesc p1 <*> translateDesc p2) - [nuMP| ValPerm_Exists mb_mb_p' |] - | [nuP| ValPerm_Eq _ |] <- mbCombine RL.typeCtxProxies mb_mb_p' -> - do ev <- dtiEvType <$> ask - let tp_repr = mbLift $ fmap bindingType mb_mb_p' - (_, k_ds) = let ?ev = ev in translateType tp_repr - return [tupleTpDesc $ map kindToTpDesc k_ds] - [nuMP| ValPerm_Exists mb_mb_p' |] -> - do let tp_repr = mbLift $ fmap bindingType mb_mb_p' - let mb_p' = mbCombine RL.typeCtxProxies mb_mb_p' - inExtCtxDescTransM (singletonCruCtx tp_repr) $ \kdescs -> - (:[]) <$> sigmaTpDescMulti kdescs <$> translateDesc mb_p' - [nuMP| ValPerm_Named mb_npn args off |] -> - do let npn = mbLift mb_npn - env <- dtiEnv <$> ask - args_ds <- translateDescs args - let (_, k_ds) = - let ?ev = permEnvEventType env in - translateCruCtx (namedPermNameArgs npn) - case lookupNamedPerm env npn of - Just (NamedPerm_Opaque op) -> - return [substIdTpDescMulti (opaquePermTransDesc op) k_ds args_ds] - Just (NamedPerm_Rec rp) -> - return [substIndIdTpDescMulti (recPermTransDesc rp) k_ds args_ds] - Just (NamedPerm_Defined dp) -> - translateDescs (mbMap2 (unfoldDefinedPerm dp) args off) - Nothing -> panic "translate" ["Unknown permission name!"] - [nuMP| ValPerm_Conj ps |] -> translateDescs ps - [nuMP| ValPerm_Var mb_x _ |] -> translateDescs mb_x - [nuMP| ValPerm_False |] -> return [voidTpDesc] - - -instance TransInfo info => - Translate info ctx (AtomicPerm a) (TypeTrans - (AtomicPermTrans ctx a)) where - translate mb_p = case mbMatch mb_p of - [nuMP| Perm_LLVMField fld |] -> - fmap (APTrans_LLVMField fld) <$> translate (fmap llvmFieldContents fld) - - [nuMP| Perm_LLVMArray ap |] -> - fmap APTrans_LLVMArray <$> translate ap - - [nuMP| Perm_LLVMBlock bp |] -> - do shtrans <- unETransShape <$> translate (fmap llvmBlockShape bp) - return $ case shtrans of - Just (_, tp) -> mkTypeTrans1 tp (APTrans_LLVMBlock bp . Just) - Nothing -> mkTypeTrans0 (APTrans_LLVMBlock bp Nothing) - [nuMP| Perm_LLVMFree e |] -> - return $ mkTypeTrans0 $ APTrans_LLVMFree e - [nuMP| Perm_LLVMFunPtr tp p |] -> - translate p >>= \tp_ptrans -> - return $ fmap (APTrans_LLVMFunPtr $ mbLift tp) tp_ptrans - [nuMP| Perm_IsLLVMPtr |] -> - return $ mkTypeTrans0 APTrans_IsLLVMPtr - [nuMP| Perm_LLVMBlockShape sh |] -> - do shtrans <- unETransShape <$> translate sh - return $ case shtrans of - Just (_, tp) -> mkTypeTrans1 tp (APTrans_LLVMBlockShape sh . Just) - Nothing -> mkTypeTrans0 (APTrans_LLVMBlockShape sh Nothing) - [nuMP| Perm_NamedConj npn args off |] - | [nuMP| DefinedSortRepr _ |] <- mbMatch $ fmap namedPermNameSort npn -> - -- To translate P@off as an atomic permission, we translate it as a - -- normal permission and map the resulting PermTrans to an AtomicPermTrans - do tptrans <- translate $ mbMap2 (ValPerm_Named $ mbLift npn) args off - return $ fmap (APTrans_DefinedNamedConj (mbLift npn) args off) tptrans - [nuMP| Perm_NamedConj npn args off |] -> - -- To translate P@off as an atomic permission, we translate it as a - -- normal permission and map the resulting PermTrans to an AtomicPermTrans - do ptrans <- translate $ mbMap2 (ValPerm_Named $ mbLift npn) args off - return $ fmap (\case - (PTrans_Term _ t) -> - APTrans_NamedConj (mbLift npn) args off t - _ -> error "translateSimplImpl: Perm_NamedConj") ptrans - [nuMP| Perm_LLVMFrame fp |] -> - return $ mkTypeTrans0 $ APTrans_LLVMFrame fp - [nuMP| Perm_LOwned ls tps_in tps_out ps_in ps_out |] -> - case mbExprPermsMembers ps_out of - Just vars_out -> - do ev <- infoEvType <$> ask - ectx <- infoCtx <$> ask - dtr_in <- translateDescType ps_in - dtr_out <- translateDescType ps_out - tp <- piTransM "p" (descTypeTrans dtr_in) - (const $ return $ specMTypeOpenTerm ev $ - typeTransTupleType $ descTypeTrans dtr_out) - return $ mkTypeTrans1 tp $ \t -> - (APTrans_LOwned ls (mbLift tps_in) (mbLift tps_out) ps_in ps_out $ - mkLOwnedTrans ev ectx dtr_in dtr_out vars_out t) - Nothing -> - panic "translate" ["lowned output permission is ill-formed"] - [nuMP| Perm_LOwnedSimple tps lops |] -> - return $ mkTypeTrans0 $ APTrans_LOwnedSimple (mbLift tps) lops - [nuMP| Perm_LCurrent l |] -> - return $ mkTypeTrans0 $ APTrans_LCurrent l - [nuMP| Perm_LFinished |] -> - return $ mkTypeTrans0 APTrans_LFinished - [nuMP| Perm_Struct ps |] -> - fmap APTrans_Struct <$> translate ps - [nuMP| Perm_Fun fun_perm |] -> - do tp <- translate fun_perm - d <- descTransM $ translateDesc1 fun_perm - ev <- infoEvType <$> ask - return $ mkTypeTrans1 tp (APTrans_Fun fun_perm . FunTrans ev d) - [nuMP| Perm_BVProp prop |] -> - fmap APTrans_BVProp <$> translate prop - [nuMP| Perm_Any |] -> return $ mkTypeTrans0 APTrans_Any - - -instance TranslateDescs (AtomicPerm a) where - translateDescs mb_p = case mbMatch mb_p of - [nuMP| Perm_LLVMField fld |] -> translateDescs (fmap llvmFieldContents fld) - [nuMP| Perm_LLVMArray ap |] -> translateDescs ap - [nuMP| Perm_LLVMBlock bp |] -> translateDescs (fmap llvmBlockShape bp) - [nuMP| Perm_LLVMFree _ |] -> return [] - [nuMP| Perm_LLVMFunPtr _ p |] -> translateDescs p - [nuMP| Perm_IsLLVMPtr |] -> return [] - [nuMP| Perm_LLVMBlockShape sh |] -> translateDescs sh - [nuMP| Perm_NamedConj npn args off |] -> - translateDescs $ mbMap2 (ValPerm_Named $ mbLift npn) args off - [nuMP| Perm_LLVMFrame _ |] -> return [] - [nuMP| Perm_LOwned _ _ _ ps_in ps_out |] -> - do ds_in <- translateDescs ps_in - d_out <- translateDesc ps_out - return [funTpDesc ds_in d_out] - [nuMP| Perm_LOwnedSimple _ _ |] -> return [] - [nuMP| Perm_LCurrent _ |] -> return [] - [nuMP| Perm_LFinished |] -> return [] - [nuMP| Perm_Struct ps |] -> translateDescs ps - [nuMP| Perm_Fun fun_perm |] -> translateDescs fun_perm - [nuMP| Perm_BVProp _ |] -> - -- NOTE: Translating BVProps to type descriptions would require a lot more - -- type-level expressions, including a type-level kind for equality types, - -- that would greatly complicate the definition of type descriptions. - -- Instead, we choose not to translate them, meaning they cannot be used - -- in places where type descriptions are required, such as the types of - -- functions or lowned permissions. - panic "translateDescs" - ["Cannot translate BV propositions to type descriptions"] - [nuMP| Perm_Any |] -> return [] - - --- | Translate an array permission to a 'TypeTrans' for an array permission --- translation, also returning the translations of the bitvector width as a --- natural, the length of the array as a bitvector, and the type of the elements --- of the translation of the array -translateLLVMArrayPerm :: (1 <= w, KnownNat w, TransInfo info) => - Mb ctx (LLVMArrayPerm w) -> - TransM info ctx (OpenTerm,OpenTerm,OpenTerm, - TypeTrans (LLVMArrayPermTrans ctx w)) -translateLLVMArrayPerm mb_ap = - do let w = natVal2 mb_ap - let w_term = natOpenTerm w - -- To translate mb_ap to an element type, we form the block permission for - -- the first cell of the array and translate that to a TypeTrans - elem_tp_trans <- translate $ mbMapCl $(mkClosed [| Perm_LLVMBlock . - llvmArrayPermHead |]) mb_ap - let elem_tp = typeTransTupleType elem_tp_trans - len_term <- translate1 $ mbLLVMArrayLen mb_ap - {- - bs_trans <- - listTypeTrans <$> mapM (translateLLVMArrayBorrow ap) (mbList bs) -} - let arr_tp = bvVecTypeOpenTerm w_term len_term elem_tp - return (w_term, len_term, elem_tp, - mkTypeTrans1 arr_tp - ({- flip $ -} LLVMArrayPermTrans mb_ap len_term elem_tp_trans - {- <*> bs_trans -})) - -instance (1 <= w, KnownNat w, TransInfo info) => - Translate info ctx (LLVMArrayPerm w) (TypeTrans - (LLVMArrayPermTrans ctx w)) where - translate mb_ap = - (\(_,_,_,tp_trans) -> tp_trans) <$> translateLLVMArrayPerm mb_ap - -instance (1 <= w, KnownNat w) => TranslateDescs (LLVMArrayPerm w) where - translateDescs mb_ap = - do let w = natVal2 mb_ap - let w_term = natOpenTerm w - len_term <- translateDesc1 $ mbLLVMArrayLen mb_ap - -- To translate mb_ap to a type description, we form the block permission - -- for the first cell of the array and translate that to a type desc - elem_d <- - translateDesc $ mbMapCl $(mkClosed [| Perm_LLVMBlock . - llvmArrayPermHead |]) mb_ap - return [bvVecTpDesc w_term len_term elem_d] - -{- --- | Translate an 'LLVMArrayBorrow' into an 'LLVMArrayBorrowTrans'. This --- requires a special-purpose function, instead of the 'Translate' class, --- because it requires the array permission. -translateLLVMArrayBorrow :: (1 <= w, KnownNat w, TransInfo info) => - Mb ctx (LLVMArrayPerm w) -> - Mb ctx (LLVMArrayBorrow w) -> - TransM info ctx (TypeTrans - (LLVMArrayBorrowTrans ctx w)) -translateLLVMArrayBorrow mb_ap mb_b = - do let mb_props = mbMap2 llvmArrayBorrowInArrayBase mb_ap mb_b - prop_trans <- mapM translate $ mbList mb_props - return (LLVMArrayBorrowTrans mb_b <$> listTypeTrans prop_trans) --} - -instance TransInfo info => - Translate info ctx (ValuePerms ps) (TypeTrans - (PermTransCtx ctx ps)) where - translate mb_ps = case mbMatch mb_ps of - [nuMP| ValPerms_Nil |] -> return $ mkTypeTrans0 MNil - [nuMP| ValPerms_Cons ps p |] -> - App.liftA2 (:>:) <$> translate ps <*> translate p - -instance TranslateDescs (ValuePerms ps) where - translateDescs mb_ps = case mbMatch mb_ps of - [nuMP| ValPerms_Nil |] -> return [] - [nuMP| ValPerms_Cons ps p |] -> - (++) <$> translateDescs ps <*> translateDescs p - - --- Translate a DistPerms by translating its corresponding ValuePerms -instance TransInfo info => - Translate info ctx (DistPerms ps) (TypeTrans - (PermTransCtx ctx ps)) where - translate = translate . mbDistPermsToValuePerms - -instance TranslateDescs (DistPerms ps) where - translateDescs = translateDescs . mbDistPermsToValuePerms - - -instance TransInfo info => - Translate info ctx (TypedDistPerms ps) (TypeTrans - (PermTransCtx ctx ps)) where - translate = translate . mbDistPermsToValuePerms . fmap unTypeDistPerms - -instance TransInfo info => - Translate info ctx (ExprPerms ps) (TypeTrans - (PermTransCtx ctx ps)) where - translate mb_eps - | Just mb_ps <- mbExprPermsToValuePerms mb_eps = translate mb_ps - translate mb_ps = - error ("Translating expression permissions that could not be converted " ++ - "to variable permissions:" ++ permPrettyString emptyPPInfo mb_ps) - -instance TranslateDescs (ExprPerms ps) where - translateDescs mb_eps - | Just mb_ps <- mbExprPermsToValuePerms mb_eps = translateDescs mb_ps - translateDescs mb_ps = - error ("Translating expression permissions that could not be converted " ++ - "to variable permissions:" ++ permPrettyString emptyPPInfo mb_ps) - - --- Translate a FunPerm to a type that pi-abstracts over all the real and ghost --- arguments, takes in all the input permissions individually, and returns a --- sigma that quantifiers over the return values and tuples all the output --- permissions together -instance TransInfo info => - Translate info ctx (FunPerm ghosts args gouts ret) OpenTerm where - translate (mbMatch -> - [nuMP| FunPerm ghosts args gouts ret perms_in perms_out |]) = - let tops = appendCruCtx (mbLift ghosts) (mbLift args) - tops_prxs = cruCtxProxies tops - rets = CruCtxCons (mbLift gouts) (mbLift ret) - rets_prxs = cruCtxProxies rets in - (RL.map (const Proxy) <$> infoCtx <$> ask) >>= \ctx -> - (infoEvType <$> ask) >>= \ev -> - case RL.appendAssoc ctx tops_prxs rets_prxs of - Refl -> - piExprCtxApp tops $ - do tptrans_in <- translate (mbCombine tops_prxs perms_in) - piTransM "p" tptrans_in $ \_ -> - specMTypeOpenTerm ev <$> - translateRetType rets (mbCombine - (RL.append tops_prxs rets_prxs) perms_out) - --- Translate a FunPerm to a type description of the type that it translates to; --- see the comments on the Translate instance above for a description of this --- type -instance TranslateDescs (FunPerm ghosts args gouts ret) where - translateDescs (mbMatch -> - [nuMP| FunPerm ghosts args gouts ret perms_in perms_out |]) = - let tops = appendCruCtx (mbLift ghosts) (mbLift args) - tops_prxs = cruCtxProxies tops - rets = CruCtxCons (mbLift gouts) (mbLift ret) - rets_prxs = cruCtxProxies rets in - (dtiProxies <$> ask) >>= \ctx -> - case RL.appendAssoc ctx tops_prxs rets_prxs of - Refl -> - inExtCtxDescTransM tops $ \kdescs -> - (\d -> [d]) <$> piTpDescMulti kdescs <$> - do ds_in <- translateDescs (mbCombine tops_prxs perms_in) - funTpDesc ds_in <$> - translateRetTpDesc rets (mbCombine - (RL.append tops_prxs rets_prxs) perms_out) - --- | Lambda-abstraction over a permission -lambdaPermTrans :: TransInfo info => String -> Mb ctx (ValuePerm a) -> - (PermTrans ctx a -> TransM info ctx OpenTerm) -> - TransM info ctx OpenTerm -lambdaPermTrans str p f = - translate p >>= \tptrans -> lambdaTransM str tptrans f - --- | Lambda-abstraction over a sequence of permissions -lambdaPermCtx :: TransInfo info => Mb ctx (ValuePerms ps) -> - (PermTransCtx ctx ps -> TransM info ctx OpenTerm) -> - TransM info ctx OpenTerm -lambdaPermCtx ps f = - translate ps >>= \tptrans -> lambdaTransM "p" tptrans f - --- | Build the return type for a function, as a right-nested sigma type over the --- translations of the types in @rets@, with the tuple of the translations of --- the returned permissions to types -translateRetType :: TransInfo info => CruCtx rets -> - Mb (ctx :++: rets) (ValuePerms ps) -> - TransM info ctx OpenTerm -translateRetType rets ret_perms = - do tptrans <- translateClosed rets - sigmaTypeTransM "ret" tptrans $ \ectx -> - inExtMultiTransM ectx (translate ret_perms) - --- | Build the type description of the type returned by 'translateRetType' -translateRetTpDesc :: CruCtx rets -> - Mb (ctx :++: rets) (ValuePerms ps) -> - DescTransM ctx OpenTerm -translateRetTpDesc rets ret_perms = - inExtCtxDescTransM rets $ \kdescs -> - sigmaTpDescMulti kdescs <$> translateDesc ret_perms - --- | Build the pure return type (not including the application of @SpecM@) for --- the function resulting from an entrypoint -translateEntryRetType :: TransInfo info => - TypedEntry phase ext blocks tops rets args ghosts -> - TransM info ((tops :++: args) :++: ghosts) OpenTerm -translateEntryRetType (TypedEntry {..} - :: TypedEntry phase ext blocks tops rets args ghosts) = - let mb_perms_out = - mbCombine (cruCtxProxies typedEntryRets) $ - extMbMulti (cruCtxProxies typedEntryGhosts) $ - extMbMulti (cruCtxProxies typedEntryArgs) $ - mbSeparate @_ @tops (cruCtxProxies typedEntryRets) typedEntryPermsOut in - translateRetType typedEntryRets mb_perms_out - - ----------------------------------------------------------------------- --- * The Implication Translation Monad ----------------------------------------------------------------------- - --- | A mapping from a block entrypoint to a corresponding SAW monadic function --- that is bound to its translation if it has one: only those entrypoints marked --- as the heads of strongly-connect components have translations as recursive --- functions -data TypedEntryTrans ext blocks tops rets args ghosts = - TypedEntryTrans { typedEntryTransEntry :: - TypedEntry TransPhase ext blocks tops rets args ghosts, - typedEntryTransFun :: Maybe OpenTerm } - --- | A mapping from a block to the SAW functions for each entrypoint -data TypedBlockTrans ext blocks tops rets args = - TypedBlockTrans { typedBlockTransEntries :: - [Some (TypedEntryTrans ext blocks tops rets args)] } - --- | A mapping from all block entrypoints to their SAW translations -type TypedBlockMapTrans ext blocks tops rets = - RAssign (TypedBlockTrans ext blocks tops rets) blocks - --- | A dummy 'TypedBlockMapTrans' with no blocks -emptyTypedBlockMapTrans :: TypedBlockMapTrans () RNil RNil RNil -emptyTypedBlockMapTrans = MNil - --- | Look up the translation of an entry by entry ID -lookupEntryTrans :: TypedEntryID blocks args -> - TypedBlockMapTrans ext blocks tops rets -> - Some (TypedEntryTrans ext blocks tops rets args) -lookupEntryTrans entryID blkMap = - maybe (error "lookupEntryTrans") id $ - find (\(Some entryTrans) -> - entryID == typedEntryID (typedEntryTransEntry entryTrans)) $ - typedBlockTransEntries (RL.get (entryBlockMember entryID) blkMap) - --- | Look up the translation of an entry by entry ID and make sure that it has --- the supplied ghost arguments -lookupEntryTransCast :: TypedEntryID blocks args -> CruCtx ghosts -> - TypedBlockMapTrans ext blocks tops rets -> - TypedEntryTrans ext blocks tops rets args ghosts -lookupEntryTransCast entryID ghosts blkMap - | Some entry_trans <- lookupEntryTrans entryID blkMap - , Just Refl <- testEquality ghosts (typedEntryGhosts $ - typedEntryTransEntry entry_trans) - = entry_trans -lookupEntryTransCast _ _ _ = - error "lookupEntryTransCast: incorrect ghosts argument" - --- | A 'TypedCallSite' with existentially quantified ghost variables -data SomeTypedCallSite blocks tops args vars = - forall ghosts. - SomeTypedCallSite (TypedCallSite TransPhase blocks tops args ghosts vars) - --- | Look up a call site by id in a 'TypedBlockMapTrans' -lookupCallSite :: TypedCallSiteID blocks args vars -> - TypedBlockMapTrans ext blocks tops rets -> - SomeTypedCallSite blocks tops args vars -lookupCallSite siteID blkMap - | Some entry_trans <- lookupEntryTrans (callSiteDest siteID) blkMap - , Just site <- typedEntryCallerSite siteID (typedEntryTransEntry entry_trans) - = SomeTypedCallSite site -lookupCallSite siteID blkMap - | Some entry_trans <- lookupEntryTrans (callSiteDest siteID) blkMap = - error ("lookupCallSite: no call site for site ID: " ++ show siteID ++ - "\n" ++ "call sites for entrypoint: " ++ - show (map (\(Some site) -> show $ typedCallSiteID site) - (typedEntryCallers $ typedEntryTransEntry entry_trans))) - - --- | Contextual info for an implication translation -data ImpTransInfo ext blocks tops rets ps ctx = - ImpTransInfo - { - itiExprCtx :: ExprTransCtx ctx, - itiPermCtx :: PermTransCtx ctx ctx, - itiPermStack :: PermTransCtx ctx ps, - itiPermStackVars :: RAssign (Member ctx) ps, - itiPermEnv :: PermEnv, - itiBlockMapTrans :: TypedBlockMapTrans ext blocks tops rets, - itiReturnType :: OpenTerm, - itiChecksFlag :: ChecksFlag - } - -instance TransInfo (ImpTransInfo ext blocks tops rets ps) where - infoCtx = itiExprCtx - infoEnv = itiPermEnv - infoChecksFlag = itiChecksFlag - extTransInfo etrans (ImpTransInfo {..}) = - ImpTransInfo - { itiExprCtx = itiExprCtx :>: etrans - , itiPermCtx = consPermTransCtx (extPermTransCtx etrans itiPermCtx) PTrans_True - , itiPermStack = extPermTransCtx etrans itiPermStack - , itiPermStackVars = RL.map Member_Step itiPermStackVars - , .. } - -instance TransInfoM (ImpTransInfo ext blocks tops rets ps) where - infoRetType = itiReturnType - --- | The monad for impure translations -type ImpTransM ext blocks tops rets ps = - TransM (ImpTransInfo ext blocks tops rets ps) - --- | Run an 'ImpTransM' computation in a 'TypeTransM' context (FIXME: better --- documentation; e.g., the pctx starts on top of the stack) -impTransM :: forall ctx ps ext blocks tops rets a. - RAssign (Member ctx) ps -> PermTransCtx ctx ps -> - TypedBlockMapTrans ext blocks tops rets -> OpenTerm -> - ImpTransM ext blocks tops rets ps ctx a -> - TypeTransM ctx a -impTransM pvars pctx mapTrans retType = - withInfoM $ \(TypeTransInfo ectx penv pflag) -> - ImpTransInfo { itiExprCtx = ectx, - itiPermCtx = RL.map (const $ PTrans_True) ectx, - itiPermStack = pctx, - itiPermStackVars = pvars, - itiPermEnv = penv, - itiBlockMapTrans = mapTrans, - itiReturnType = retType, - itiChecksFlag = pflag - } - --- | Run an inner 'ImpTransM' computation that does not use the block map -emptyBlocksImpTransM :: ImpTransM () RNil RNil RNil ps ctx a -> - ImpTransM ext blocks tops rets ps ctx a -emptyBlocksImpTransM = - withInfoM (\(ImpTransInfo {..}) -> - ImpTransInfo { itiBlockMapTrans = emptyTypedBlockMapTrans, .. }) - --- | Run an implication translation computation in an \"empty\" environment, --- where there are no variables in scope and no permissions held anywhere -inEmptyEnvImpTransM :: ImpTransM ext blocks tops rets RNil RNil a -> - ImpTransM ext blocks tops rets ps ctx a -inEmptyEnvImpTransM = - withInfoM (\(ImpTransInfo {..}) -> - ImpTransInfo { itiExprCtx = MNil, itiPermCtx = MNil, - itiPermStack = MNil, itiPermStackVars = MNil, .. }) - --- | Run an implication translation computation with no primary permissions on --- any of the variables -withEmptyPermsImpTransM :: ImpTransM ext blocks tops rets ps ctx a -> - ImpTransM ext blocks tops rets ps ctx a -withEmptyPermsImpTransM = - withInfoM (\(ImpTransInfo {..}) -> - ImpTransInfo { - itiPermCtx = RL.map (const PTrans_True) itiExprCtx, - .. }) - --- | Get most recently bound variable -getTopVarM :: ImpTransM ext blocks tops rets ps (ctx :> tp) (ExprTrans tp) -getTopVarM = (\(_ :>: p) -> p) <$> itiExprCtx <$> ask - --- | Get the top permission on the stack -getTopPermM :: ImpTransM ext blocks tops rets (ps :> tp) ctx (PermTrans ctx tp) -getTopPermM = (\(_ :>: p) -> p) <$> itiPermStack <$> ask - --- | Helper to disambiguate the @ext@ type variable -getExtReprM :: PermCheckExtC ext exprExt => - ImpTransM ext blocks tops rets ps ctx (ExtRepr ext) -getExtReprM = return knownRepr - --- | Apply a transformation to the (translation of the) current perm stack -withPermStackM :: (RAssign (Member ctx) ps_in -> RAssign (Member ctx) ps_out) -> - (PermTransCtx ctx ps_in -> PermTransCtx ctx ps_out) -> - ImpTransM ext blocks tops rets ps_out ctx a -> - ImpTransM ext blocks tops rets ps_in ctx a -withPermStackM f_vars f_p = - withInfoM $ \info -> - info { itiPermStack = f_p (itiPermStack info), - itiPermStackVars = f_vars (itiPermStackVars info) } - --- | Apply a transformation to the (translation of the) current perm stack, also --- converting some portion of it (selected by the supplied selector function) to --- the SAW core terms it represents using 'transTerms' -withPermStackTermsM :: - IsTermTrans tr => - (PermTransCtx ctx ps_in -> tr) -> - (RAssign (Member ctx) ps_in -> RAssign (Member ctx) ps_out) -> - ([OpenTerm] -> PermTransCtx ctx ps_in -> - PermTransCtx ctx ps_out) -> - ImpTransM ext blocks tops rets ps_out ctx OpenTerm -> - ImpTransM ext blocks tops rets ps_in ctx OpenTerm -withPermStackTermsM f_sel f_vars f_p m = - do pctx <- itiPermStack <$> ask - withPermStackM f_vars (f_p $ transTerms $ f_sel pctx) m - --- | Apply a transformation to the (translation of the) current perm stack, also --- converting the top permission to the SAW core terms it represents using --- 'transTerms'; i.e., perform 'withPermStackTermsM' with the top of the stack -withPermStackTopTermsM :: - (RAssign (Member ctx) (ps_in :> tp) -> RAssign (Member ctx) ps_out) -> - ([OpenTerm] -> PermTransCtx ctx (ps_in :> tp) -> - PermTransCtx ctx ps_out) -> - ImpTransM ext blocks tops rets ps_out ctx OpenTerm -> - ImpTransM ext blocks tops rets (ps_in :> tp) ctx OpenTerm -withPermStackTopTermsM = withPermStackTermsM (\ (_ :>: ptrans) -> ptrans) - - --- | Get the current permission stack as a 'DistPerms' in context -getPermStackDistPerms :: ImpTransM ext blocks tops rets ps ctx - (Mb ctx (DistPerms ps)) -getPermStackDistPerms = - do stack <- itiPermStack <$> ask - stack_vars <- itiPermStackVars <$> ask - prxs <- RL.map (const Proxy) <$> itiPermCtx <$> ask - return $ - (nuMulti prxs $ \ns -> - valuePermsToDistPerms (RL.map (flip RL.get ns) stack_vars)) - `mbApply` - permTransCtxPerms prxs stack - --- | Run a computation if the current 'ChecksFlag' is set -ifChecksFlagM :: ImpTransM ext blocks tops rets ps ctx () -> - ImpTransM ext blocks tops rets ps ctx () -ifChecksFlagM m = - (itiChecksFlag <$> ask) >>= \checks -> - if checksFlagSet checks then m else return () - --- | Assert a property of the current permission stack, raising an 'error' if it --- fails to hold. The 'String' names the construct being translated. -assertPermStackM :: HasCallStack => String -> - (RAssign (Member ctx) ps -> PermTransCtx ctx ps -> Bool) -> - ImpTransM ext blocks tops rets ps ctx () -assertPermStackM nm f = - ifChecksFlagM - (ask >>= \info -> - if f (itiPermStackVars info) (itiPermStack info) then return () else - error ("translate: " ++ nm ++ nlPrettyCallStack callStack)) - --- | Assert that the top portion of the current permission stack equals the --- given 'DistPerms' -assertPermStackTopEqM :: HasCallStack => ps ~ (ps1 :++: ps2) => - String -> f ps1 -> Mb ctx (DistPerms ps2) -> - ImpTransM ext blocks tops rets ps ctx () -assertPermStackTopEqM nm prx expected = - ifChecksFlagM - (getPermStackDistPerms >>= \perms -> - let actuals = - fmap (snd . splitDistPerms prx (mbDistPermsToProxies expected)) perms in - if expected == actuals then return () else - error ("assertPermStackEqM (" ++ nm ++ "): expected permission stack:\n" ++ - permPrettyString emptyPPInfo expected ++ - "\nFound permission stack:\n" ++ - permPrettyString emptyPPInfo actuals ++ - nlPrettyCallStack callStack)) - --- | Assert that the current permission stack equals the given 'DistPerms' -assertPermStackEqM :: HasCallStack => String -> Mb ctx (DistPerms ps) -> - ImpTransM ext blocks tops rets ps ctx () -assertPermStackEqM nm perms = - -- FIXME: unify this function with assertPermStackTopEqM - ifChecksFlagM - (getPermStackDistPerms >>= \stack_perms -> - if perms == stack_perms then return () else - error ("assertPermStackEqM (" ++ nm ++ "): expected permission stack:\n" ++ - permPrettyString emptyPPInfo perms ++ - "\nFound permission stack:\n" ++ - permPrettyString emptyPPInfo stack_perms ++ - nlPrettyCallStack callStack)) - --- | Assert that the top permission is as given by the arguments -assertTopPermM :: HasCallStack => String -> Mb ctx (ExprVar a) -> - Mb ctx (ValuePerm a) -> - ImpTransM ext blocks tops rets (ps :> a) ctx () -assertTopPermM nm x p = - ifChecksFlagM - (getPermStackDistPerms >>= \stack_perms -> - case mbMatch stack_perms of - [nuMP| DistPermsCons _ x' p' |] | x == x' && p == p' -> return () - [nuMP| DistPermsCons _ x' p' |] -> - error ("assertTopPermM (" ++ nm ++ "): expected top permissions:\n" ++ - permPrettyString emptyPPInfo (mbMap2 distPerms1 x p) ++ - "\nFound top permissions:\n" ++ - permPrettyString emptyPPInfo (mbMap2 distPerms1 x' p') ++ - nlPrettyCallStack callStack ++ - "\nCurrent perm stack:\n" ++ - permPrettyString emptyPPInfo stack_perms)) - --- | Get the (translation of the) perms for a variable -getVarPermM :: Mb ctx (ExprVar tp) -> - ImpTransM ext blocks tops rets ps ctx (PermTrans ctx tp) -getVarPermM x = RL.get (translateVar x) <$> itiPermCtx <$> ask - --- | Assert that a variable has a given permission -assertVarPermM :: HasCallStack => String -> Mb ctx (ExprVar tp) -> - Mb ctx (ValuePerm tp) -> - ImpTransM ext blocks tops rets ps ctx () -assertVarPermM nm x p = - do x_p <- permTransPerm (mbToProxy p) <$> getVarPermM x - if x_p == p then return () else - error ("assertVarPermM (" ++ nm ++ "):\n" ++ - "expected: " ++ permPrettyString emptyPPInfo p ++ "\n" ++ - "found:" ++ permPrettyString emptyPPInfo x_p ++ - nlPrettyCallStack callStack) - --- | Set the (translation of the) perms for a variable in a computation -setVarPermM :: Mb ctx (ExprVar tp) -> PermTrans ctx tp -> - ImpTransM ext blocks tops rets ps ctx a -> - ImpTransM ext blocks tops rets ps ctx a -setVarPermM x p = - local $ \info -> info { itiPermCtx = - RL.set (translateVar x) p $ itiPermCtx info } - --- | Clear all permissions in the permission variable map in a sub-computation, --- leaving only those permissions on the top of the stack -clearVarPermsM :: ImpTransM ext blocks tops rets ps ctx a -> - ImpTransM ext blocks tops rets ps ctx a -clearVarPermsM = - local $ \info -> info { itiPermCtx = - RL.map (const PTrans_True) $ itiPermCtx info } - --- | Build an @errorS@ computation with the given error message -mkErrorComp :: String -> ImpTransM ext blocks tops rets ps_out ctx OpenTerm -mkErrorComp msg = - do ev <- infoEvType <$> ask - ret_tp <- returnTypeM - return $ errorSOpenTerm ev ret_tp msg - --- | The typeclass for the implication translation of a functor at any --- permission set inside any binding to an 'OpenTerm' -class NuMatchingAny1 f => ImplTranslateF f ext blocks tops rets where - translateF :: Mb ctx (f ps) -> ImpTransM ext blocks tops rets ps ctx OpenTerm - - ----------------------------------------------------------------------- --- * Translating Permission Implication Constructs ----------------------------------------------------------------------- - --- | A failure continuation represents any catch that is around the current --- 'PermImpl', and can either be a term to jump to / call (meaning that there is --- a catch) or an error message (meaning there is not) -data ImplFailCont - -- | A continuation that calls a term on failure - = ImplFailContTerm OpenTerm - -- | An error message to print on failure, along with the event type needed - -- to build an @errorS@ spec term - | ImplFailContMsg EventType String - --- | The prefix used in error strings for implication failures -implicationFailurePrefix :: String -implicationFailurePrefix = "Heapster implication failure:\n" - --- | Convert an 'ImplFailCont' to an error, which should have the given type -implFailContTerm :: OpenTerm -> ImplFailCont -> OpenTerm -implFailContTerm _ (ImplFailContTerm t) = t -implFailContTerm tp (ImplFailContMsg ev msg) = - errorSOpenTerm ev tp $ implicationFailurePrefix ++ msg - --- | Convert an 'ImplFailCont' to an error as in 'implFailContTerm', but use an --- alternate error message in the case of 'ImplFailContMsg' -implFailAltContTerm :: OpenTerm -> String -> ImplFailCont -> OpenTerm -implFailAltContTerm _ _ (ImplFailContTerm t) = t -implFailAltContTerm tp msg (ImplFailContMsg ev _) = - errorSOpenTerm ev tp $ "Failed to prove: " ++ msg - --- | The type of terms use to translation permission implications, which can --- contain calls to the current failure continuation -newtype PImplTerm ext blocks tops rets ps ctx = - PImplTerm { popPImplTerm :: - ImplFailCont -> ImpTransM ext blocks tops rets ps ctx OpenTerm } - deriving OpenTermLike - --- | Build a 'PImplTerm' from the first 'PImplTerm' that uses the second as the --- failure continuation -catchPImplTerm :: PImplTerm ext blocks tops rets ps ctx -> - PImplTerm ext blocks tops rets ps ctx -> - PImplTerm ext blocks tops rets ps ctx -catchPImplTerm t t_catch = - PImplTerm $ \k -> - compReturnTypeM >>= \tp -> - letTransM "catchpoint" tp (popPImplTerm t_catch k) $ \k_tm -> - popPImplTerm t $ ImplFailContTerm k_tm - --- | The failure 'PImplTerm', which immediately calls its failure continuation -failPImplTerm :: PImplTerm ext blocks tops rets ps ctx -failPImplTerm = - PImplTerm $ \k -> returnTypeM >>= \tp -> return (implFailContTerm tp k) - --- | Return the failure 'PImplTerm' like 'failPImplTerm' but use an alternate --- error message in the case that the failure continuation is an error message -failPImplTermAlt :: String -> PImplTerm ext blocks tops rets ps ctx -failPImplTermAlt msg = PImplTerm $ \k -> - returnTypeM >>= \tp -> - return (implFailContTerm tp (case k of - ImplFailContMsg ev _ -> ImplFailContMsg ev msg - _ -> k)) - --- | \"Force\" an optional 'PImplTerm' to a 'PImplTerm' by converting a --- 'Nothing' to the 'failPImplTerm' -forcePImplTerm :: Maybe (PImplTerm ext blocks tops rets ps ctx) -> - PImplTerm ext blocks tops rets ps ctx -forcePImplTerm (Just t) = t -forcePImplTerm Nothing = failPImplTerm - - --- | A flag to indicate whether a 'PImplTerm' calls its failure continuation -data HasFailures = HasFailures | NoFailures deriving Eq - -instance Semigroup HasFailures where - HasFailures <> _ = HasFailures - _ <> HasFailures = HasFailures - NoFailures <> NoFailures = NoFailures - -instance Monoid HasFailures where - mempty = NoFailures - --- | A function for translating an @r@ -newtype ImpRTransFun r ext blocks tops rets ctx = - ImpRTransFun { appImpTransFun :: - forall ps ctx'. CtxExt ctx ctx' -> Mb ctx' (r ps) -> - ImpTransM ext blocks tops rets ps ctx' OpenTerm } - -extImpRTransFun :: RAssign Proxy ctx' -> - ImpRTransFun r ext blocks tops rets ctx -> - ImpRTransFun r ext blocks tops rets (ctx :++: ctx') -extImpRTransFun ctx' f = - ImpRTransFun $ \cext mb_r -> - appImpTransFun f (extCtxExt Proxy ctx' cext) mb_r - - --- | A monad transformer that adds an 'ImpRTransFun' translation function -newtype ImpRTransFunT r ext blocks tops rets ctx m a = - ImpRTransFunT { unImpRTransFunT :: - ReaderT (ImpRTransFun r ext blocks tops rets ctx) m a } - deriving (Functor, Applicative, Monad, MonadTrans) - --- | Run an 'ImpRTransFunT' computation to get an underlying computation in @m@ -runImpRTransFunT :: ImpRTransFunT r ext blocks tops rets ctx m a -> - ImpRTransFun r ext blocks tops rets ctx -> m a -runImpRTransFunT m = runReaderT (unImpRTransFunT m) - --- | Map the underlying computation type of an 'ImpRTransFunT' -mapImpRTransFunT :: (m a -> n b) -> - ImpRTransFunT r ext blocks tops rets ctx m a -> - ImpRTransFunT r ext blocks tops rets ctx n b -mapImpRTransFunT f = ImpRTransFunT . mapReaderT f . unImpRTransFunT - --- | The computation type for translation permission implications, which --- includes the following effects: a 'MaybeT' for representing terms that --- translate to errors using 'Nothing'; a 'WriterT' that tracks all the error --- messages used in translating a term along with a 'HasFailures' flag that --- indicates whether the returned 'PImplTerm' uses its failure continuation; and --- an 'ImpRTransFunT' to pass along a function for translating the final @r@ --- result inside the current 'PermImpl' -type PImplTransM r ext blocks tops rets ctx = - MaybeT (WriterT ([String], HasFailures) - (ImpRTransFunT r ext blocks tops rets ctx Identity)) - --- | Run a 'PermImplTransM' computation -runPermImplTransM :: - PImplTransM r ext blocks tops rets ctx a -> - ImpRTransFun r ext blocks tops rets ctx -> - (Maybe a, ([String], HasFailures)) -runPermImplTransM m rTransFun = - runIdentity $ runImpRTransFunT (runWriterT $ runMaybeT m) rTransFun - -extPermImplTransM :: RAssign Proxy ctx' -> - PImplTransM r ext blocks tops rets (ctx :++: ctx') a -> - PImplTransM r ext blocks tops rets ctx a -extPermImplTransM ctx' m = - pimplRTransFunM >>= \rtransFun -> - MaybeT $ WriterT $ return $ runPermImplTransM m $ extImpRTransFun ctx' rtransFun - -{- -extPermImplTransM :: ExprTransCtx ctx' -> - PImplTransM r ext blocks tops rets ps (ctx :++: ctx') a -> - PImplTransM r ext blocks tops rets ps ctx a -extPermImplTransM ctx' m = - pimplRTransFunM >>= \rtransFun -> - MaybeT $ WriterT $ return $ runPermImplTransM m $ extImpRTransFun ctx' rtransFun - -extPermImplTransMTerm :: CruCtx ctx' -> - PImplTransMTerm r ext blocks tops rets ps (ctx :++: ctx') -> - PImplTransMTerm r ext blocks tops rets ps ctx -extPermImplTransMTerm ctx' m = - MaybeT $ WriterT $ ImpRTransFun $ reader $ \rtransFun -> PImplTerm $ \k -> - TransM $ reader $ \info -> - let ectx' = runTransM (translateClosed ctx') info in - return $ runPermImplTransM m $ extImpRTransFun ectx' rtransFun --} - --- | Look up the @r@ translation function -pimplRTransFunM :: PImplTransM r ext blocks tops rets ctx - (ImpRTransFun r ext blocks tops rets ctx) -pimplRTransFunM = lift $ lift $ ImpRTransFunT ask - --- | Build an error term by recording the error message and returning 'Nothing' -pimplFailM :: String -> PImplTransM r ext blocks tops rets ctx a -pimplFailM msg = tell ([msg],HasFailures) >> mzero - --- | Catch a potential 'Nothing' return value in a 'PImplTransM' computation -pimplCatchM :: PImplTransM r ext blocks tops rets ctx a -> - PImplTransM r ext blocks tops rets ctx (Maybe a) -pimplCatchM m = lift $ runMaybeT m - --- | Prepend a 'String' to all error messages generated in a computation -pimplPrependMsgM :: String -> PImplTransM r ext blocks tops rets ctx a -> - PImplTransM r ext blocks tops rets ctx a -pimplPrependMsgM str m = - pass ((, (\(msgs, hasfs) -> (map (str++) msgs, hasfs))) <$> m) - -type PImplTransMTerm r ext blocks tops rets ps ctx = - PImplTransM r ext blocks tops rets ctx - (PImplTerm ext blocks tops rets ps ctx) - --- | Run the first 'PImplTransM' computation to produce a 'PImplTerm' and use --- the second computation to generate the failure continuation of that first --- 'PImplTerm', using optimizations to omit the first or second term when it is --- not needed. -pimplHandleFailM :: PImplTransMTerm r ext blocks tops rets ps ctx -> - PImplTransMTerm r ext blocks tops rets ps ctx -> - PImplTransMTerm r ext blocks tops rets ps ctx -pimplHandleFailM m m_catch = - do - -- Run the default computation m, exposing whether it returned a term or not - -- and whether it calls the failure continuation or not - (maybe_t, (fails,hasf)) <- lift $ lift $ runWriterT $ runMaybeT m - -- We want to retain all failure messages from m, but we are handling any - -- calls to the failure continuation, so we are NoFailures for now - tell (fails, NoFailures) - case (maybe_t, hasf) of - (Just t, NoFailures) -> - -- If t does not call the failure continuation, then we have no need to - -- use m_catch, and we just return t - return t - (Just t, HasFailures) -> - -- If t does potentially call the failure continuation, then let-bind - -- the result of m_catch as its failure continuation; note that we - -- preserve any MaybeT and WriterT effects of m_catch, meaning that its - -- failure messages and HasFailures flag are preserved, and if it - -- returns Nothing then so will this entire computation - do maybe_t_catch <- lift $ runMaybeT m_catch - case maybe_t_catch of - Just t_catch -> return $ catchPImplTerm t t_catch - Nothing -> return t - (Nothing, _) -> - -- If t definitely fails, then just use m_catch - m_catch - - --- | Translate the output permissions of a 'SimplImpl' -translateSimplImplOut :: Mb ctx (SimplImpl ps_in ps_out) -> - ImpTransM ext blocks tops rets ps ctx - (TypeTrans (PermTransCtx ctx ps_out)) -translateSimplImplOut = translate . mbSimplImplOut - --- | Translate the head output permission of a 'SimplImpl' -translateSimplImplOutHead :: Mb ctx (SimplImpl ps_in (ps_out :> a)) -> - ImpTransM ext blocks tops rets ps ctx - (TypeTrans (PermTrans ctx a)) -translateSimplImplOutHead = - translate . mbMapCl $(mkClosed [| varAndPermPerm . RL.head |]) . mbSimplImplOut - --- | Translate the head of the tail of the output permission of a 'SimplImpl' -translateSimplImplOutTailHead :: Mb ctx (SimplImpl ps_in (ps_out :> a :> b)) -> - ImpTransM ext blocks tops rets ps ctx - (TypeTrans (PermTrans ctx a)) -translateSimplImplOutTailHead = - translate . mbMapCl $(mkClosed [| varAndPermPerm . RL.head . RL.tail |]) - . mbSimplImplOut - --- | Translate a 'SimplImpl' to a function on translation computations -translateSimplImpl :: - Proxy ps -> Mb ctx (SimplImpl ps_in ps_out) -> - ImpTransM ext blocks tops rets (ps :++: ps_out) ctx OpenTerm -> - ImpTransM ext blocks tops rets (ps :++: ps_in) ctx OpenTerm -translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of - [nuMP| SImpl_Drop _ _ |] -> - withPermStackM (\(xs :>: _) -> xs) (\(ps :>: _) -> ps) m - - [nuMP| SImpl_Copy x _ |] -> - withPermStackM (:>: translateVar x) (\(ps :>: p) -> ps :>: p :>: p) m - - [nuMP| SImpl_Swap _ _ _ _ |] -> - withPermStackM (\(xs :>: x :>: y) -> xs :>: y :>: x) - (\(pctx :>: px :>: py) -> pctx :>: py :>: px) - m - - [nuMP| SImpl_MoveUp (mb_ps1 :: DistPerms ps1) (_mb_x :: ExprVar a) _ - (mb_ps2 :: DistPerms ps2) |] -> - let ps1 = mbRAssignProxies mb_ps1 - ps2 = mbRAssignProxies mb_ps2 - prxa = Proxy :: Proxy a - prx0a = Proxy :: Proxy (ps0 :> a) in - case (RL.appendRNilConsEq ps0 prxa (RL.append ps1 ps2)) of - Refl -> - withPermStackM - (\xs -> - let ((xs0 :>: x), xs12) = RL.split prx0a (RL.append ps1 ps2) xs - (xs1, xs2) = RL.split ps1 ps2 xs12 in - RL.append xs0 $ RL.append (xs1 :>: x) xs2) - (\pctx -> - let ((pctx0 :>: ptrans), pctx12) = - RL.split prx0a (RL.append ps1 ps2) pctx - (pctx1, pctx2) = RL.split ps1 ps2 pctx12 in - RL.append pctx0 $ RL.append (pctx1 :>: ptrans) pctx2) - m - - [nuMP| SImpl_MoveDown mb_ps1 (mb_x :: ExprVar a) _ mb_ps2 |] - | prx_a <- mbLift $ fmap (const (Proxy :: Proxy a)) mb_x - , ps1 <- mbRAssignProxies mb_ps1 - , ps1a <- ps1 :>: prx_a - , ps2 <- mbRAssignProxies mb_ps2 - , Refl <- RL.appendRNilConsEq ps0 prx_a (RL.append ps1 ps2) -> - withPermStackM - (\xs -> - let (xs0, xs1a2) = RL.split ps0 (RL.append ps1a ps2) xs - ((xs1 :>: x), xs2) = RL.split ps1a ps2 xs1a2 in - RL.append xs0 (RL.append (MNil :>: x) $ RL.append xs1 xs2)) - (\pctx -> - let (pctx0, pctx1a2) = RL.split ps0 (RL.append ps1a ps2) pctx - ((pctx1 :>: ptrans), pctx2) = RL.split ps1a ps2 pctx1a2 in - RL.append pctx0 (RL.append (MNil :>: ptrans) $ RL.append pctx1 pctx2)) - m - - [nuMP| SImpl_IntroOrL _ p1 p2 |] -> - do tp1 <- translate p1 - tp2 <- translate p2 - tptrans <- translateSimplImplOutHead mb_simpl - withPermStackTopTermsM id - (\ts (ps :>: _p_top) -> - ps :>: typeTransF tptrans [leftTrans tp1 tp2 (tupleOpenTerm' ts)]) - m - - [nuMP| SImpl_IntroOrR _ p1 p2 |] -> - do tp1 <- translate p1 - tp2 <- translate p2 - tptrans <- translateSimplImplOutHead mb_simpl - withPermStackTopTermsM id - (\ts (ps :>: _p_top) -> - ps :>: typeTransF tptrans [rightTrans tp1 tp2 (tupleOpenTerm' ts)]) - m - - [nuMP| SImpl_IntroExists _ e p |] -> - do let tp = mbExprType e - tp_trans <- translateClosed tp - out_trans <- translateSimplImplOutHead mb_simpl - etrans <- translate e - trm <- - sigmaPermTransM "x_ex" tp_trans (mbCombine RL.typeCtxProxies p) - etrans getTopPermM - withPermStackM id - (\(pctx :>: _) -> pctx :>: typeTransF out_trans [trm]) - m - - [nuMP| SImpl_Cast _ _ _ |] -> - withPermStackM RL.tail - (\(pctx :>: _ :>: ptrans) -> pctx :>: ptrans) - m - - [nuMP| SImpl_CastPerm (_::ExprVar a) eqp |] -> - do ttrans <- translateSimplImplOut mb_simpl - let prxs_a = MNil :>: (Proxy :: Proxy a) - let prxs1 = mbLift $ mbMapCl $(mkClosed [| distPermsToProxies - . eqProofPerms |]) eqp - let prxs = RL.append prxs_a prxs1 - withPermStackTermsM - (\pctx -> snd $ RL.split ps0 prxs pctx) - id - (\ts pctx -> - let pctx1 = fst $ RL.split ps0 prxs pctx in - RL.append pctx1 (typeTransF ttrans ts)) - m - - [nuMP| SImpl_IntroEqRefl x |] -> - do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackM (:>: translateVar x) - (\pctx -> pctx :>: typeTransF ttrans []) m - - [nuMP| SImpl_InvertEq _ y |] -> - do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackM ((:>: translateVar y) . RL.tail) - (\(pctx :>: _) -> pctx :>: typeTransF ttrans []) m - - [nuMP| SImpl_InvTransEq _ _ _ |] -> - do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackM RL.tail - (\(pctx :>: _ :>: _) -> pctx :>: typeTransF ttrans []) m - - [nuMP| SImpl_UnitEq x _ |] -> - do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackM (:>: translateVar x) - (\pctx -> pctx :>: typeTransF ttrans []) m - - - [nuMP| SImpl_CopyEq _ _ |] -> - withPermStackM - (\(vars :>: var) -> (vars :>: var :>: var)) - (\(pctx :>: ptrans) -> (pctx :>: ptrans :>: ptrans)) - m - - [nuMP| SImpl_LLVMWordEq _ _ _ |] -> - do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackM RL.tail (\(pctx :>: _ :>: _) -> - pctx :>: typeTransF ttrans []) m - - [nuMP| SImpl_LLVMOffsetZeroEq x |] -> - do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackM (:>: translateVar x) - (\pctx -> pctx :>: typeTransF ttrans []) m - - [nuMP| SImpl_IntroConj x |] -> - withPermStackM (:>: translateVar x) (:>: PTrans_True) m - - [nuMP| SImpl_ExtractConj x _ mb_i |] -> - withPermStackM (:>: translateVar x) - (\(pctx :>: ptrans) -> - let ps = unPTransConj "translateSimplImpl: SImpl_ExtractConj" ptrans - i = mbLift mb_i in - if i < length ps then - pctx :>: PTrans_Conj [ps !! i] - :>: PTrans_Conj (deleteNth i ps) - else - error "translateSimplImpl: SImpl_ExtractConj: index out of bounds") - m - - [nuMP| SImpl_CopyConj x _ mb_i |] -> - withPermStackM (:>: translateVar x) - (\(pctx :>: ptrans) -> - let ps = unPTransConj "translateSimplImpl: SImpl_CopyConj" ptrans - i = mbLift mb_i in - if i < length ps then pctx :>: PTrans_Conj [ps !! i] :>: ptrans else - error "translateSimplImpl: SImpl_CopyConj: index out of bounds") - m - - [nuMP| SImpl_InsertConj _ _ _ i |] -> - withPermStackM RL.tail - (\(pctx :>: ptransi :>: ptrans) -> - let ps = unPTransConj "translateSimplImpl: SImpl_InsertConj" ptrans - pi = unPTransConj1 "translateSimplImpl: SImpl_InsertConj" ptransi in - pctx :>: PTrans_Conj (take (mbLift i) ps ++ pi : drop (mbLift i) ps)) - m - - [nuMP| SImpl_AppendConjs _ _ _ |] -> - withPermStackM RL.tail - (\(pctx :>: ptrans1 :>: ptrans2) -> - let ps1 = unPTransConj "translateSimplImpl: SImpl_AppendConjs" ptrans1 - ps2 = unPTransConj "translateSimplImpl: SImpl_AppendConjs" ptrans2 in - pctx :>: PTrans_Conj (ps1 ++ ps2)) - m - - [nuMP| SImpl_SplitConjs x _ mb_i |] -> - let i = mbLift mb_i in - withPermStackM (:>: translateVar x) - (\(pctx :>: ptrans) -> - let ps = unPTransConj "translateSimplImpl: SImpl_SplitConjs" ptrans in - pctx :>: PTrans_Conj (take i ps) :>: PTrans_Conj (drop i ps)) - m - - [nuMP| SImpl_IntroStructTrue x _ |] -> - do tptrans <- translateSimplImplOutHead mb_simpl - withPermStackM (:>: translateVar x) - (\pctx -> pctx :>: typeTransF tptrans []) - m - - [nuMP| SImpl_StructEqToPerm _ _ |] -> - do tptrans <- translateSimplImplOutHead mb_simpl - withPermStackM id - (\(pctx :>: _) -> pctx :>: typeTransF tptrans []) - m - - [nuMP| SImpl_StructPermToEq _ _ |] -> - do tptrans <- translateSimplImplOutHead mb_simpl - withPermStackM id - (\(pctx :>: _) -> pctx :>: typeTransF tptrans []) - m - - [nuMP| SImpl_IntroStructField _ _ memb _ |] -> - withPermStackM RL.tail - (\case - pctx :>: PTrans_Conj [APTrans_Struct pctx_str] :>: ptrans -> - pctx :>: PTrans_Conj [APTrans_Struct $ - RL.set (mbLift memb) ptrans pctx_str] - _ -> panic "translateSimplImpl" - ["SImpl_IntroStructField: Unexpected permission stack"]) - m - - [nuMP| SImpl_ConstFunPerm _ _ _ ident |] -> - do tptrans <- translateSimplImplOutHead mb_simpl - withPermStackM id - (\(pctx :>: _) -> - pctx :>: typeTransF tptrans [globalOpenTerm $ mbLift ident]) - m - - [nuMP| SImpl_CastLLVMWord _ _ _ |] -> - do tptrans <- translateSimplImplOutHead mb_simpl - withPermStackM RL.tail - (\(pctx :>: _ :>: _) -> - pctx :>: typeTransF tptrans []) - m - - [nuMP| SImpl_InvertLLVMOffsetEq _ _ mb_y |] -> - do tptrans <- translateSimplImplOutHead mb_simpl - withPermStackM - (\(vars :>: _) -> (vars :>: translateVar mb_y)) - (\(pctx :>: _) -> pctx :>: typeTransF tptrans []) - m - - [nuMP| SImpl_OffsetLLVMWord _ _ _ _ |] -> - do tptrans <- translateSimplImplOutHead mb_simpl - withPermStackM - (\(vars :>: _ :>: x_var) -> vars :>: x_var) - (\(pctx :>: _ :>: _) -> pctx :>: typeTransF tptrans []) - m - - [nuMP| SImpl_CastLLVMPtr _ _ _ _ |] -> - -- FIXME: offsetLLVMPerm can throw away conjuncts, like free and llvmfunptr - -- permissions, that change the type of the translation - do tptrans <- translateSimplImplOutHead mb_simpl - withPermStackTopTermsM RL.tail - (\ts (pctx :>: _ :>: _) -> pctx :>: typeTransF tptrans ts) - m - - [nuMP| SImpl_CastLLVMFree _ _ e2 |] -> - withPermStackM RL.tail - ((:>: PTrans_Conj [APTrans_LLVMFree e2]) . RL.tail . RL.tail) - m - - [nuMP| SImpl_CastLLVMFieldOffset _ _ _ |] -> - do tptrans <- translateSimplImplOutHead mb_simpl - withPermStackTermsM - (\(_ :>: ptrans :>: _) -> ptrans) - RL.tail - (\ts (pctx :>: _ :>: _) -> pctx :>: typeTransF tptrans ts) - m - - [nuMP| SImpl_IntroLLVMFieldContents x _ mb_fld |] -> - withPermStackM ((:>: translateVar x) . RL.tail . RL.tail) - (\(pctx :>: _ :>: ptrans) -> - pctx :>: PTrans_Conj [APTrans_LLVMField mb_fld ptrans]) - m - - [nuMP| SImpl_DemoteLLVMFieldRW _ mb_fld |] -> - withPermStackM id - (\(pctx :>: ptrans) -> - let (_,ptrans') = - unPTransLLVMField - "translateSimplImpl: SImpl_DemoteLLVMFieldRW" - knownNat ptrans in - pctx :>: PTrans_Conj [ - APTrans_LLVMField - (mbMapCl $(mkClosed [| \fld -> fld { llvmFieldRW = PExpr_Read } |]) mb_fld) - ptrans']) - m - - [nuMP| SImpl_SplitLLVMTrueField x _ _ _ |] -> - do ttrans <- translateSimplImplOut mb_simpl - withPermStackM (:>: translateVar x) - (\(pctx :>: _) -> RL.append pctx $ typeTransF ttrans []) - m - - [nuMP| SImpl_TruncateLLVMTrueField _ _ _ |] -> - do ttrans <- translateSimplImplOut mb_simpl - withPermStackM id - (\(pctx :>: _) -> RL.append pctx $ typeTransF ttrans []) - m - - [nuMP| SImpl_ConcatLLVMTrueFields _ _ _ |] -> - do ttrans <- translateSimplImplOut mb_simpl - withPermStackM RL.tail - (\(pctx :>: _ :>: _) -> RL.append pctx $ typeTransF ttrans []) - m - - [nuMP| SImpl_DemoteLLVMArrayRW _ _ |] -> - do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackTopTermsM id - (\ts (pctx :>: _) -> pctx :>: typeTransF ttrans ts) - 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 - withPermStackM id - (\(pctx :>: ptrans_array :>: ptrans_props) -> - let array_trans = - unPTransLLVMArray - "translateSimplImpl: SImpl_LLVMArrayCopy" ptrans_array - prop_transs = - unPTransBVProps - "translateSimplImpl: SImpl_LLVMArrayCopy" ptrans_props in - pctx :>: - PTrans_Conj [APTrans_LLVMArray $ - getLLVMArrayTransSlice array_trans sub_ap_tp_trans - rng_trans {- mb_sub_borrows -} prop_transs] - :>: ptrans_array) - m - - [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 - withPermStackM id - (\(pctx :>: ptrans_array :>: ptrans_props) -> - let array_trans = - unPTransLLVMArray - "translateSimplImpl: SImpl_LLVMArrayBorrow" ptrans_array - prop_transs = - unPTransBVProps - "translateSimplImpl: SImpl_LLVMArrayBorrow" ptrans_props - {- borrow_trans = - LLVMArrayBorrowTrans (fmap RangeBorrow mb_rng) prop_transs -} - sub_array_trans = - APTrans_LLVMArray $ - getLLVMArrayTransSlice array_trans sub_ap_tp_trans rng_trans - {- mb_sub_borrows -} prop_transs - array_trans' = - array_trans { - llvmArrayTransPerm = - mbMap2 (\ap sub_ap -> - llvmArrayAddBorrow (llvmSubArrayBorrow ap sub_ap) $ - llvmArrayRemArrayBorrows ap sub_ap) - mb_ap mb_sub_ap } in - pctx :>: - PTrans_Conj [sub_array_trans] - :>: PTrans_Conj [APTrans_LLVMArray array_trans']) - m - - [nuMP| SImpl_LLVMArrayReturn _ mb_ap mb_ret_ap |] -> - do (_ :>: ptrans_sub_array :>: ptrans_array) <- itiPermStack <$> ask - let mb_cell = - fmap fromJust $ mbMap2 llvmArrayIsOffsetArray mb_ap mb_ret_ap - cell_tm <- translate1 mb_cell - let array_trans = - unPTransLLVMArray - "translateSimplImpl: SImpl_LLVMArrayReturn" ptrans_array - let sub_array_trans = - unPTransLLVMArray - "translateSimplImpl: SImpl_LLVMArrayReturn" ptrans_sub_array - {- borrow_i = - mbLift $ mbMap2 llvmArrayFindBorrow (fmap - RangeBorrow mb_rng) mb_ap - borrow_trans = llvmArrayTransBorrows array_trans !! borrow_i -} - let array_trans' = - (setLLVMArrayTransSlice array_trans sub_array_trans cell_tm) - { llvmArrayTransPerm = - mbMap2 (\ap ret_ap -> - llvmArrayRemBorrow (llvmSubArrayBorrow ap ret_ap) $ - llvmArrayAddArrayBorrows ap ret_ap) mb_ap mb_ret_ap } - withPermStackM RL.tail - (\(pctx :>: _ :>: _) -> - pctx :>: PTrans_Conj [APTrans_LLVMArray array_trans']) - m - - [nuMP| SImpl_LLVMArrayAppend _ mb_ap1 mb_ap2 |] -> - do ev <- infoEvType <$> ask - (w_term, len1_tm, elem_tp, _) <- translateLLVMArrayPerm mb_ap1 - (_, len2_tm, _, _) <- translateLLVMArrayPerm mb_ap2 - tp_trans <- translateSimplImplOutHead mb_simpl - len3_tm <- - translate1 $ - fmap (\case - (ValPerm_LLVMArray ap) -> llvmArrayLen ap - _ -> error "translateSimplImpl: SImpl_LLVMArrayAppend") $ - fmap distPermsHeadPerm $ mbSimplImplOut mb_simpl - (_ :>: ptrans1 :>: ptrans2) <- itiPermStack <$> ask - let arr_out_comp_tm = - applyGlobalOpenTerm "SpecM.appendCastBVVecS" - [evTypeTerm ev, w_term, len1_tm, len2_tm, len3_tm, - elem_tp, transTerm1 ptrans1, transTerm1 ptrans2] - bindTransM arr_out_comp_tm tp_trans "appended_array" $ \ptrans_arr' -> - withPermStackM RL.tail (\(pctx :>: _ :>: _) -> - pctx :>: ptrans_arr') m - - - [nuMP| SImpl_LLVMArrayRearrange _ _ _ |] -> - do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackTopTermsM id - (\ts (pctx :>: _) -> pctx :>: typeTransF ttrans ts) - m - - [nuMP| SImpl_LLVMArrayToField _ _ _ |] -> - do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackM id - (\(pctx :>: _) -> pctx :>: typeTransF ttrans []) - m - - [nuMP| SImpl_LLVMArrayEmpty x mb_ap |] -> - do (w_tm, _, elem_tp, ap_tp_trans) <- translateLLVMArrayPerm mb_ap - -- First we build a term of type Vec 0 elem_tp using EmptyVec - let vec_tm = applyGlobalOpenTerm "Prelude.EmptyVec" [elem_tp] - -- Next, we build a computation that casts it to BVVec w 0x0 elem_tp - let w = fromIntegral $ natVal2 mb_ap - let bvZero_nat_tm = - applyGlobalOpenTerm "Prelude.bvToNat" - [w_tm, bvLitOpenTerm (replicate w False)] - ev <- infoEvType <$> ask - let vec_cast_m = - applyGlobalOpenTerm "SpecM.castVecS" - [evTypeTerm ev, elem_tp, natOpenTerm 0, bvZero_nat_tm, vec_tm] - bindTransM vec_cast_m ap_tp_trans "empty_vec" $ \ptrans_arr -> - withPermStackM (:>: translateVar x) - (\pctx -> pctx :>: PTrans_Conj [APTrans_LLVMArray ptrans_arr]) - m - --- translate1/translateClosed ( zeroOfType <- get the default element ) - [nuMP| SImpl_LLVMArrayBorrowed x _ mb_ap |] -> - do (w_tm, len_tm, elem_tp, ap_tp_trans) <- translateLLVMArrayPerm mb_ap - withPermStackTopTermsM (:>: translateVar x) - (\ts (pctx :>: ptrans_block) -> - let arr_term = - applyGlobalOpenTerm "Prelude.repeatBVVec" - [w_tm, len_tm, elem_tp, termsExpect1 ts] in - pctx :>: - PTrans_Conj [APTrans_LLVMArray $ typeTransF ap_tp_trans [arr_term]] :>: - ptrans_block) - m - - [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_tm, len_tm, elem_tp, ap_tp_trans) <- translateLLVMArrayPerm mb_ap - withPermStackTopTermsM id - (\ts (pctx :>: _ptrans_cell) -> - let arr_term = - -- FIXME: this generates a BVVec of length (bvNat n 1), whereas - -- what we need is a BVVec of length [0,0,...,1]; the two are - -- provably equal but not convertible in SAW core - {- - applyOpenTermMulti (globalOpenTerm "Prelude.singletonBVVec") - [w_tm, elem_tp, ts] - -} - applyGlobalOpenTerm "Prelude.repeatBVVec" - [w_tm, len_tm, elem_tp, tupleOpenTerm' ts] in - pctx :>: - PTrans_Conj [APTrans_LLVMArray $ typeTransF ap_tp_trans [arr_term]]) - m - - - [nuMP| SImpl_LLVMArrayCellCopy _ _ mb_cell |] -> - do (_ :>: ptrans_array :>: ptrans_props) <- itiPermStack <$> ask - let arr_trans = - unPTransLLVMArray - "translateSimplImpl: SImpl_LLVMArrayCellCopy" ptrans_array - let prop_transs = - unPTransBVProps - "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 [cell_ptrans] :>: ptrans_array) - m - - [nuMP| SImpl_LLVMArrayCellBorrow _ mb_ap mb_cell |] -> - do (_ :>: ptrans_array :>: ptrans_props) <- itiPermStack <$> ask - let arr_trans = - unPTransLLVMArray - "translateSimplImpl: SImpl_LLVMArrayCellBorrow" ptrans_array - let prop_transs = - unPTransBVProps - "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 cell -> - llvmArrayAddBorrow (FieldBorrow cell) ap) - mb_ap mb_cell } - withPermStackM id - (\(pctx :>: _ :>: _) -> - pctx :>: PTrans_Conj [cell_ptrans] :>: - PTrans_Conj [APTrans_LLVMArray arr_trans']) - m - - [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_LLVMArrayCellReturn" ptrans_array - {- let b_trans = llvmArrayTransFindBorrow (fmap FieldBorrow cell) arr_trans -} - let arr_trans' = arr_trans - { llvmArrayTransPerm = - mbMap2 (\ap cell -> - llvmArrayRemBorrow (FieldBorrow cell) ap) mb_ap mb_cell } - cell_tm <- translate1 mb_cell - let arr_trans'' = setLLVMArrayTransCell arr_trans' cell_tm aptrans_cell - withPermStackM RL.tail - (\(pctx :>: _ :>: _) -> - pctx :>: PTrans_Conj [APTrans_LLVMArray arr_trans'']) - m - - [nuMP| SImpl_LLVMArrayContents _ mb_ap mb_sh impl |] -> - do p_out_trans <- translateSimplImplOutHead mb_simpl - (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 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 cell permissions:" - (mbCombine RL.typeCtxProxies impl) MNil MNil - (fmap ((MNil :>:) . extPermTrans ETrans_LLVM) cell_in_trans) - (MNil :>: Member_Base) - (fmap ((MNil :>:) . extPermTrans ETrans_LLVM) cell_out_trans) - -- Build the computation that maps impl_tm over the input array using the - -- mapBVVecM monadic combinator - ptrans_arr <- getTopPermM - ev <- infoEvType <$> ask - let arr_out_comp_tm = - applyGlobalOpenTerm "SpecM.mapBVVecS" - [evTypeTerm ev, elem_tp, typeTransType1 cell_out_trans, impl_tm, - w_term, len_term, transTerm1 ptrans_arr] - -- Now use bindS to bind the result of arr_out_comp_tm in the remaining - -- computation - bindTransM arr_out_comp_tm p_out_trans "mapped_array" $ \ptrans_arr' -> - withPermStackM id (\(pctx :>: _) -> pctx :>: ptrans_arr') m - - [nuMP| SImpl_LLVMFieldIsPtr x _ |] -> - withPermStackM (:>: translateVar x) - (\(pctx :>: ptrans_fld) -> - pctx :>: PTrans_Conj [APTrans_IsLLVMPtr] :>: ptrans_fld) - m - - [nuMP| SImpl_LLVMArrayIsPtr x _ |] -> - withPermStackM (:>: translateVar x) - (\(pctx :>: ptrans_array) -> - pctx :>: PTrans_Conj [APTrans_IsLLVMPtr] :>: ptrans_array) - m - - [nuMP| SImpl_LLVMBlockIsPtr x _ |] -> - withPermStackM (:>: translateVar x) - (\(pctx :>: ptrans) -> - pctx :>: PTrans_Conj [APTrans_IsLLVMPtr] :>: ptrans) - m - - [nuMP| SImpl_SplitLifetime mb_x f args l mb_l2 _ _ _ _ _ |] -> - -- FIXME HERE: get rid of the mbMaps! - do let l2_e = fmap PExpr_Var mb_l2 - let f_l_args = mbMap3 ltFuncApply f args l - let f_l2_min = mbMap2 ltFuncMinApply f l2_e - let x_tp = mbVarType mb_x - f_l2_args_trans <- translateSimplImplOutTailHead mb_simpl - f_l_args_trans <- tpTransM $ translateDescType f_l_args - f_l2_min_trans <- tpTransM $ translateDescType f_l2_min - withPermStackTermsM - (\ (_ :>: ptrans_x :>: _ :>: _) -> ptrans_x) - (\(ns :>: x :>: _ :>: l2) -> ns :>: x :>: l2) - (\ts pctx_all -> case pctx_all of - (pctx :>: _ptrans_x :>: _ :>: - PTrans_LOwned mb_ls tps_in tps_out mb_ps_in mb_ps_out t) - -> - pctx :>: typeTransF f_l2_args_trans ts :>: - PTrans_LOwned mb_ls (CruCtxCons tps_in x_tp) - (CruCtxCons tps_out x_tp) - (mbMap3 (\ps x p -> ps :>: ExprAndPerm (PExpr_Var x) p) - mb_ps_in mb_x f_l2_min) - (mbMap3 (\ps x p -> ps :>: ExprAndPerm (PExpr_Var x) p) - mb_ps_out mb_x f_l_args) - (weakenLOwnedTrans f_l2_min_trans f_l_args_trans t) - _ -> - panic "translateSimplImpl" - ["In SImpl_SplitLifetime rule: expected an lowned permission"]) - m - - [nuMP| SImpl_SubsumeLifetime _ _ _ _ _ _ mb_l2 |] -> - flip (withPermStackM id) m $ \case - (pctx :>: PTrans_LOwned mb_ls tps_in tps_out mb_ps_in mb_ps_out t) -> - pctx :>: - PTrans_LOwned (mbMap2 (:) mb_l2 mb_ls) tps_in tps_out mb_ps_in mb_ps_out t - _ -> - panic "translateSimplImpl" - ["In SImpl_SubsumeLifetime rule: expected an lowned permission"] - - [nuMP| SImpl_ContainedLifetimeCurrent _ _ _ _ _ _ _ |] -> - do ttr_lcur <- translateSimplImplOutTailHead mb_simpl - withPermStackM - (\(ns :>: l1) -> ns :>: l1 :>: l1) - (\(pctx :>: ptrans_l) -> - pctx :>: typeTransF ttr_lcur [] :>: ptrans_l) - m - - [nuMP| SImpl_RemoveContainedLifetime _ _ _ _ _ _ mb_l2 |] -> - withPermStackM - (\(ns :>: l :>: _) -> ns :>: l) - (\case - (pctx :>: - PTrans_LOwned mb_ls tps_in tps_out mb_ps_in mb_ps_out t :>: _) -> - let mb_ls' = mbMap2 (\l2 ls -> - delete (PExpr_Var l2) ls) mb_l2 mb_ls in - pctx :>: PTrans_LOwned mb_ls' tps_in tps_out mb_ps_in mb_ps_out t - _ -> - panic "translateSimplImpl" - ["In SImpl_RemoveContainedLifetime rule: expected an lowned permission"]) - m - - [nuMP| SImpl_WeakenLifetime _ _ _ _ _ |] -> - do pctx_out_trans <- translateSimplImplOut mb_simpl - withPermStackTermsM (\(_ :>: ptrans_x :>: _) -> ptrans_x) - RL.tail - (\ts (pctx :>: _ :>: _) -> - -- NOTE: lcurrent permissions have no term translations, so we can - -- construct the output PermTransCtx by just passing the terms in - -- ptrans_x to pctx_out_trans - RL.append pctx (typeTransF pctx_out_trans ts)) - m - - [nuMP| SImpl_MapLifetime _ mb_ls tps_in tps_out _ _ tps_in' tps_out' - ps_in' ps_out' ps1 ps2 impl_in impl_out |] -> - -- First, translate the various permissions and implications - do ttr_inF' <- tpTransM $ translateDescType ps_in' - ttr_outF' <- tpTransM $ translateDescType ps_out' - ttr1F <- tpTransM $ translateDescType ps1 - ttr2F <- tpTransM $ translateDescType ps2 - t1 <- - translateLOwnedPermImpl "Error mapping lowned input perms:" impl_in - t2 <- - translateLOwnedPermImpl "Error mapping lowned output perms:" impl_out - - -- Next, split out the various input permissions from the rest of the pctx - let prxs1 = mbRAssignProxies ps1 - let prxs2 = mbRAssignProxies ps2 - let prxs_in = RL.append prxs1 prxs2 :>: Proxy - let prxs_in' = cruCtxProxies $ mbLift tps_in' - pctx <- itiPermStack <$> ask - let (pctx0, pctx12 :>: ptrans_l) = RL.split ps0 prxs_in pctx - let (pctx1, pctx2) = RL.split prxs1 prxs2 pctx12 - let some_lotr = - unPTransLOwned "translateSimplImpl" tps_in tps_out ptrans_l - - -- Also split out the input variables and replace them with the ps_out vars - pctx_vars <- itiPermStackVars <$> ask - let (vars_ps, vars12 :>: _) = RL.split ps0 prxs_in pctx_vars - let (vars1, vars2) = RL.split prxs1 prxs2 vars12 - - -- Finally, modify the PTrans_LOwned on top of the stack using - -- mapLtLOwnedTrans - withPermStackM - (\(_ :>: l) -> vars_ps :>: l) - (\_ -> - case some_lotr of - SomeLOwnedTrans lotr -> - pctx0 :>: - PTrans_LOwned mb_ls (mbLift tps_in') (mbLift tps_out') ps_in' ps_out' - (mapLtLOwnedTrans pctx1 vars1 ttr1F pctx2 vars2 ttr2F - prxs_in' ttr_inF' ttr_outF' t1 t2 lotr)) - m - - [nuMP| SImpl_EndLifetime _ tps_in tps_out ps_in ps_out |] -> - -- First, translate the in and out permissions of the lowned permission - do tr_out <- translate ps_out - let prxs_in = mbRAssignProxies ps_in :>: Proxy - - -- Next, split out the ps_in permissions from the rest of the pctx - pctx <- itiPermStack <$> ask - let (pctx_ps, pctx_in :>: ptrans_l) = RL.split ps0 prxs_in pctx - let some_lotr = - unPTransLOwned "translateSimplImpl" tps_in tps_out ptrans_l - - -- Also split out the ps_in variables and replace them with the ps_out vars - pctx_vars <- itiPermStackVars <$> ask - let (ps_vars, _ :>: _) = RL.split ps0 prxs_in pctx_vars - let vars_out = case mbExprPermsMembers ps_out of - Just x -> x - Nothing -> panic "translateSimplImpl" - ["In SImpl_EndLifetime rule: malformed ps_out"] - - -- Now we apply the lifetime ownerhip function to ps_in and bind its output - -- in the rest of the computation - case some_lotr of - SomeLOwnedTrans lotr -> - let lotr_f = lownedTransTerm ps_in lotr in - bindTransM (applyOpenTermMulti lotr_f $ - transTerms pctx_in) tr_out "endl_ps" $ \pctx_out -> - withPermStackM - (\(_ :>: l) -> RL.append ps_vars vars_out :>: l) - (\_ -> RL.append pctx_ps pctx_out :>: - PTrans_Conj [APTrans_LFinished]) - m - - [nuMP| SImpl_IntroLOwnedSimple _ _ _ |] -> - do let prx_ps_l = mbRAssignProxies $ mbSimplImplIn mb_simpl - ttrans <- translateSimplImplOut mb_simpl - withPermStackTermsM - (\pctx -> - let (_, pctx_ps :>: _) = RL.split ps0 prx_ps_l pctx in pctx_ps) - id - (\ts pctx -> - let (pctx0, _) = RL.split ps0 prx_ps_l pctx in - RL.append pctx0 $ typeTransF ttrans ts) - m - - [nuMP| SImpl_ElimLOwnedSimple mb_l mb_tps mb_ps |] -> - case (mbExprPermsMembers mb_ps, mbMaybe (mbMap2 lownedPermsSimpleIn mb_l mb_ps)) of - (Just vars, Just mb_ps') -> - do ev <- infoEvType <$> ask - ectx <- infoCtx <$> ask - dtr_in <- tpTransM $ translateDescType mb_ps' - dtr_out <- tpTransM $ translateDescType mb_ps - withPermStackM id - (\(pctx :>: _) -> - pctx :>: - PTrans_LOwned (fmap (const []) mb_l) - (mbLift mb_tps) (mbLift mb_tps) mb_ps' mb_ps - (mkLOwnedTransId ev ectx dtr_in dtr_out vars)) - m - _ -> - panic "translateSimplImpl" - ["In SImpl_ElimLOwnedSimple rule: malformed permissions argument"] - - [nuMP| SImpl_LCurrentRefl l |] -> - do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackM (:>: translateVar l) (:>: typeTransF ttrans []) m - - [nuMP| SImpl_LCurrentTrans _ _ _ |] -> - do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackM RL.tail (\(pctx :>: _ :>: _) -> - (pctx :>: typeTransF ttrans [])) m - - [nuMP| SImpl_DemoteLLVMBlockRW _ _ |] -> - do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackTopTermsM id - (\ts (pctx :>: _) -> pctx :>: typeTransF ttrans ts) - m - - [nuMP| SImpl_IntroLLVMBlockEmpty x _ |] -> - do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackM (:>: translateVar x) - (\pctx -> pctx :>: typeTransF ttrans []) - m - - [nuMP| SImpl_CoerceLLVMBlockEmpty _ _ |] -> - do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackM id - (\(pctx :>: _) -> pctx :>: typeTransF ttrans []) - m - - [nuMP| SImpl_ElimLLVMBlockToBytes _ mb_bp |] -> - do let w = natVal2 mb_bp - let w_term = natOpenTerm w - len_term <- translate1 $ fmap llvmBlockLen mb_bp - ttrans <- translateSimplImplOutHead mb_simpl - withPermStackM id - (\(pctx :>: _) -> - let arr_term = - applyGlobalOpenTerm "Prelude.repeatBVVec" - [w_term, len_term, unitTypeOpenTerm, unitOpenTerm] in - pctx :>: typeTransF ttrans [arr_term]) - m - - [nuMP| SImpl_IntroLLVMBlockTuple _ _ |] -> - do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackTopTermsM id - (\ts (pctx :>: _) -> - pctx :>: typeTransF ttrans [tupleOpenTerm' ts]) - m - - [nuMP| SImpl_ElimLLVMBlockTuple _ mb_bp |] -> - do ttrans <- translateSimplImplOutHead mb_simpl - shtrans <- unETransShape <$> translate (mbLLVMBlockShape mb_bp) - withPermStackTopTermsM id - (\ts (pctx :>: _) -> - let ts' = case shtrans of { Just _ -> ts ; Nothing -> [] } in - pctx :>: typeTransF ttrans ts') - m - - [nuMP| SImpl_IntroLLVMBlockSeqEmpty _ _ |] -> - do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackTopTermsM id - (\ts (pctx :>: _) -> - pctx :>: typeTransF ttrans ts) - m - - [nuMP| SImpl_ElimLLVMBlockSeqEmpty _ _ |] -> - do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackTopTermsM id - (\ts (pctx :>: _) -> pctx :>: typeTransF ttrans ts) - m - - [nuMP| SImpl_SplitLLVMBlockEmpty _ _ _ |] -> - do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackM id - (\(pctx :>: _) -> pctx :>: typeTransF ttrans []) - m - - -- Intro for a recursive named shape applies the fold function for the shape - [nuMP| SImpl_IntroLLVMBlockNamed _ bp nmsh |] - | [nuMP| RecShapeBody _ _ mb_sh_id |] <- mbMatch $ fmap namedShapeBody nmsh - , [nuMP| PExpr_NamedShape _ _ nmsh' mb_args |] <- mbMatch $ fmap llvmBlockShape bp -> - -- NOTE: although nmsh' should equal nmsh, it's easier to just use nmsh' - -- rather than convince GHC that they have the same argument types - do ttrans <- translateSimplImplOutHead mb_simpl - let args_ctx = mbLift $ fmap namedShapeArgs nmsh' - d <- substNamedIndTpDesc (mbLift mb_sh_id) args_ctx mb_args - ev <- infoEvType <$> ask - unfolded_ptrans <- getTopPermM - let folded_m = applyGlobalOpenTerm "SpecM.foldTpElem" - [evTypeTerm ev, d, transTupleTerm unfolded_ptrans] - bindTransM folded_m ttrans "ind_val" $ \ptrans -> - withPermStackM id (\(pctx :>: _) -> pctx :>: ptrans) m - - -- Intro for a defined named shape (the other case) is a no-op - | [nuMP| DefinedShapeBody _ |] <- mbMatch $ fmap namedShapeBody nmsh -> - do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackTopTermsM id - (\ts (pctx :>: _) -> pctx :>: typeTransF ttrans ts) - m - - | otherwise -> - panic "translateSimplImpl" - ["SImpl_IntroLLVMBlockNamed, unknown named shape"] - - -- Elim for a recursive named shape applies the unfold function for the shape - [nuMP| SImpl_ElimLLVMBlockNamed _ bp nmsh |] - | [nuMP| RecShapeBody _ _ mb_sh_id |] <- mbMatch $ fmap namedShapeBody nmsh - , [nuMP| PExpr_NamedShape _ _ nmsh' mb_args |] <- mbMatch $ fmap llvmBlockShape bp -> - -- NOTE: although nmsh' should equal nmsh, it's easier to just use nmsh' - -- rather than convince GHC that they have the same argument types - do ttrans <- translateSimplImplOutHead mb_simpl - let args_ctx = mbLift $ fmap namedShapeArgs nmsh' - d <- substNamedIndTpDesc (mbLift mb_sh_id) args_ctx mb_args - ev <- infoEvType <$> ask - withPermStackTopTermsM id - (\ts (pctx :>: _) -> - pctx :>: - typeTransF ttrans [applyGlobalOpenTerm "SpecM.unfoldTpElem" - [evTypeTerm ev, d, tupleOpenTerm' ts]]) - m - - -- Elim for a defined named shape (the other case) is a no-op - | [nuMP| DefinedShapeBody _ |] <- mbMatch $ fmap namedShapeBody nmsh -> - do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackTopTermsM id - (\ts (pctx :>: _) -> - pctx :>: typeTransF ttrans ts) - m - - | otherwise -> - panic "translateSimplImpl" ["ElimLLVMBlockNamed, unknown named shape"] - - [nuMP| SImpl_IntroLLVMBlockNamedMods _ _ |] -> - do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackTopTermsM id - (\ts (pctx :>: _) -> - pctx :>: typeTransF ttrans ts) - m - - [nuMP| SImpl_ElimLLVMBlockNamedMods _ _ |] -> - do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackTopTermsM id - (\ts (pctx :>: _) -> - pctx :>: typeTransF ttrans ts) - m - - [nuMP| SImpl_IntroLLVMBlockFromEq _ _ _ |] -> - do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackTopTermsM RL.tail - (\ts (pctx :>: _ :>: _) -> - pctx :>: typeTransF ttrans ts) - m - - [nuMP| SImpl_IntroLLVMBlockPtr _ _ |] -> - do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackTopTermsM id - (\ts (pctx :>: _) -> - pctx :>: typeTransF ttrans ts) - m - - [nuMP| SImpl_ElimLLVMBlockPtr _ _ |] -> - do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackTopTermsM id - (\ts (pctx :>: _) -> - pctx :>: typeTransF ttrans ts) - m - - [nuMP| SImpl_IntroLLVMBlockField _ _ |] -> - do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackTopTermsM id - (\ts (pctx :>: _) -> - pctx :>: typeTransF ttrans (tupleOpenTermList ts)) - m - - [nuMP| SImpl_ElimLLVMBlockField _ _ |] -> - do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackTopTermsM id - (\ts (pctx :>: _) -> - -- We tuple both ttrans and ts because ts is either an empty list or - -- a tuple of the terms we want to pass to ttrans; tupling ts makes - -- it into a list of length 1 - pctx :>: typeTransF (tupleTypeTrans ttrans) [tupleOpenTerm' ts]) - m - - [nuMP| SImpl_IntroLLVMBlockArray _ _ |] -> - do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackTopTermsM id - (\ts (pctx :>: _) -> - pctx :>: typeTransF ttrans [termsExpect1 ts]) - m - - [nuMP| SImpl_ElimLLVMBlockArray _ _ |] -> - do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackTopTermsM id - (\ts (pctx :>: _) -> - pctx :>: typeTransF ttrans ts) - m - - [nuMP| SImpl_IntroLLVMBlockSeq _ _ _ _ |] -> - do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackTermsM - (\(_ :>: ptrans1 :>: ptrans2) -> (ptrans1,ptrans2)) - RL.tail - (\ts (pctx :>: _ :>: _) -> - pctx :>: typeTransF ttrans (tupleOpenTermList ts)) - m - - [nuMP| SImpl_ElimLLVMBlockSeq _ mb_bp mb_sh2 |] -> - do ttrans <- translateSimplImplOutHead mb_simpl - shtrans1 <- unETransShape <$> translate (mbLLVMBlockShape mb_bp) - shtrans2 <- unETransShape <$> translate mb_sh2 - withPermStackTopTermsM id - (\ts (pctx :>: _) -> - -- NOTE: if both output shapes have translations, then this rule - -- takes in a pair and projects its two components; otherwise its - -- output uses the same list of 0 or 1 terms as the input - let ts' = if isJust shtrans1 && isJust shtrans2 then - let t = termsExpect1 ts in [pairLeftOpenTerm t, - pairRightOpenTerm t] - else tupleOpenTermList ts in - pctx :>: typeTransF ttrans ts') - m - - [nuMP| SImpl_IntroLLVMBlockOr _ _ _ |] -> - do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackTopTermsM id - (\ts (pctx :>: _) -> pctx :>: typeTransF ttrans [termsExpect1 ts]) - m - - [nuMP| SImpl_ElimLLVMBlockOr _ _ _ |] -> - do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackTopTermsM id - (\ts (pctx :>: _) -> pctx :>: typeTransF ttrans [termsExpect1 ts]) - m - - [nuMP| SImpl_IntroLLVMBlockEx _ _ |] -> - do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackTopTermsM id - (\ts (pctx :>: _) -> pctx :>: typeTransF ttrans [termsExpect1 ts]) - m - - [nuMP| SImpl_ElimLLVMBlockEx _ _ |] -> - do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackTopTermsM id - (\ts (pctx :>: _) -> pctx :>: typeTransF ttrans [termsExpect1 ts]) - m - - [nuMP| SImpl_ElimLLVMBlockFalse _ _ |] -> - do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackTopTermsM id - (\ts (pctx :>: _) -> pctx :>: typeTransF ttrans [termsExpect1 ts]) - m - - [nuMP| SImpl_FoldNamed _ (NamedPerm_Rec mb_rp) mb_args _ |] -> - do ttrans <- translateSimplImplOutHead mb_simpl - let args_ctx = mbLift $ fmap (namedPermNameArgs . recPermName) mb_rp - let d_id = mbLift $ fmap recPermTransDesc mb_rp - d <- substNamedIndTpDesc d_id args_ctx mb_args - ev <- infoEvType <$> ask - unfolded_ptrans <- getTopPermM - let folded_m = applyGlobalOpenTerm "SpecM.foldTpElem" - [evTypeTerm ev, d, transTupleTerm unfolded_ptrans] - bindTransM folded_m ttrans "ind_val" $ \ptrans -> - withPermStackM id (\(pctx :>: _) -> pctx :>: ptrans) m - - [nuMP| SImpl_UnfoldNamed _ (NamedPerm_Rec mb_rp) mb_args _ |] -> - do ttrans <- translateSimplImplOutHead mb_simpl - let args_ctx = mbLift $ fmap (namedPermNameArgs . recPermName) mb_rp - let d_id = mbLift $ fmap recPermTransDesc mb_rp - d <- substNamedIndTpDesc d_id args_ctx mb_args - ev <- infoEvType <$> ask - withPermStackTopTermsM id - (\ts (pctx :>: _) -> - pctx :>: - typeTransF ttrans [applyGlobalOpenTerm "SpecM.unfoldTpElem" - [evTypeTerm ev, d, tupleOpenTerm' ts]]) - m - - [nuMP| SImpl_FoldNamed _ (NamedPerm_Defined _) _ _ |] -> - do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackTopTermsM id - (\ts (pctx :>: _) -> pctx :>: typeTransF ttrans ts) - m - - [nuMP| SImpl_UnfoldNamed _ (NamedPerm_Defined _) _ _ |] -> - do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackTopTermsM id - (\ts (pctx :>: _) -> pctx :>: typeTransF ttrans ts) - m - - {- - [nuMP| SImpl_Mu _ _ _ _ |] -> - error "FIXME HERE: SImpl_Mu: translation not yet implemented" - -} - - [nuMP| SImpl_NamedToConj _ _ _ _ |] -> - do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackTopTermsM id - (\ts (pctx :>: _) -> pctx :>: typeTransF ttrans ts) - m - - [nuMP| SImpl_NamedFromConj _ _ _ _ |] -> - do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackTopTermsM id - (\ts (pctx :>: _) -> pctx :>: typeTransF ttrans ts) - m - - [nuMP| SImpl_NamedArgAlways _ _ _ _ _ _ |] -> - do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackTopTermsM id - (\ts (pctx :>: _) -> pctx :>: typeTransF ttrans ts) - m - - [nuMP| SImpl_NamedArgCurrent _ _ _ _ _ _ |] -> - do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackTermsM (\ (_ :>: ptrans :>: _) -> ptrans) - RL.tail - (\ts (pctx :>: _ :>: _) -> pctx :>: typeTransF ttrans ts) - m - - [nuMP| SImpl_NamedArgWrite _ _ _ _ _ _ |] -> - do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackTopTermsM id - (\ts (pctx :>: _) -> pctx :>: typeTransF ttrans ts) - m - - [nuMP| SImpl_NamedArgRead _ _ _ _ _ |] -> - do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackTopTermsM id - (\ts (pctx :>: _) -> pctx :>: typeTransF ttrans ts) - m - - [nuMP| SImpl_ReachabilityTrans _ rp args _ y e |] -> - do args_trans <- translate args - e_trans <- translate e - y_trans <- translate y - ttrans <- translateSimplImplOutHead mb_simpl - let trans_ident = mbLift $ fmap recPermTransMethod rp - withPermStackTermsM - (\(_ :>: ptrans_x :>: ptrans_y) -> (ptrans_x, ptrans_y)) - RL.tail - (\ts (pctx :>: _ :>: _) -> - if length ts == 2 then - pctx :>: - typeTransF (tupleTypeTrans ttrans) [applyGlobalOpenTerm trans_ident - (transTerms args_trans - ++ transTerms e_trans - ++ transTerms y_trans - ++ transTerms e_trans - ++ ts)] - else - panic "translateSimplImpl" - ["SImpl_ReachabilityTrans: incorrect number of terms in translation"]) - m - - [nuMP| SImpl_IntroAnyEqEq _ _ _ |] -> - do tp_trans <- translateSimplImplOutHead mb_simpl - withPermStackM RL.tail - (\(pctx :>: _ :>: _) -> - pctx :>: typeTransF tp_trans []) m - - [nuMP| SImpl_IntroAnyWordPtr _ _ _ |] -> - do tp_trans <- translateSimplImplOutHead mb_simpl - withPermStackM RL.tail - (\(pctx :>: _ :>: _) -> - pctx :>: typeTransF tp_trans []) m - - [nuMP| SImpl_ElimAnyToEq _ _ |] -> - do tp_trans <- translateSimplImplOutHead mb_simpl - withPermStackM id - (\(pctx :>: _) -> - pctx :>: typeTransF tp_trans []) m - - [nuMP| SImpl_ElimAnyToPtr _ _ |] -> - do tp_trans <- translateSimplImplOutHead mb_simpl - withPermStackM id - (\(pctx :>: _) -> - pctx :>: typeTransF tp_trans []) m - - --- | Translate a normal unary 'PermImpl1' rule that succeeds and applies the --- translation function if the argument succeeds and fails if the translation of --- the argument fails -translatePermImplUnary :: - NuMatchingAny1 r => RL.TypeCtx bs => - Mb ctx (MbPermImpls r (RNil :> '(bs,ps_out))) -> - (ImpTransM ext blocks tops rets ps_out (ctx :++: bs) OpenTerm -> - ImpTransM ext blocks tops rets ps ctx OpenTerm) -> - PImplTransMTerm r ext blocks tops rets ps ctx -translatePermImplUnary (mbMatch -> [nuMP| MbPermImpls_Cons _ _ mb_impl |]) f = - let bs = RL.typeCtxProxies in - PImplTerm <$> fmap f <$> popPImplTerm <$> - extPermImplTransM bs (translatePermImpl (mbCombine bs mb_impl)) - --- | Translate a 'PermImpl1' to a function on translation computations -translatePermImpl1 :: NuMatchingAny1 r => - Mb ctx (PermImpl1 ps ps_outs) -> - Mb ctx (MbPermImpls r ps_outs) -> - PImplTransMTerm r ext blocks tops rets ps ctx -translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) of - -- A failure translates to a call to the catch handler, which is the most recent - -- Impl1_Catch, if one exists, or the SAW errorM function otherwise - ([nuMP| Impl1_Fail err |], _) -> - pimplFailM (mbLift (fmap ppError err)) - - ([nuMP| Impl1_Catch dbg_str |], - [nuMP| (MbPermImpls_Cons _ (MbPermImpls_Cons _ _ mb_impl1) mb_impl2) |]) -> - pimplHandleFailM - (pimplPrependMsgM ("Case 1 of " ++ mbLift dbg_str) $ - translatePermImpl $ mbCombine RL.typeCtxProxies mb_impl1) - (pimplPrependMsgM ("Case 2 of " ++ mbLift dbg_str) $ - translatePermImpl $ mbCombine RL.typeCtxProxies mb_impl2) - - -- A push moves the given permission from x to the top of the perm stack - ([nuMP| Impl1_Push x p |], _) -> - translatePermImplUnary mb_impls $ \m -> - do () <- assertVarPermM "Impl1_Push" x p - ptrans <- getVarPermM x - setVarPermM x (PTrans_True) - (withPermStackM (:>: translateVar x) (:>: ptrans) m) - - -- A pop moves the given permission from the top of the perm stack to x - ([nuMP| Impl1_Pop x p |], _) -> - translatePermImplUnary mb_impls $ \m -> - do () <- assertTopPermM "Impl1_Pop 1" x p - () <- assertVarPermM "Impl1_Pop 2" x (nuMulti (mbToProxy p) $ - const ValPerm_True) - ptrans <- getTopPermM - setVarPermM x ptrans (withPermStackM RL.tail RL.tail m) - - -- If all branches of an or elimination fail, the whole thing fails; otherwise, - -- an or elimination performs a multi way Eithers elimination - ([nuMP| Impl1_ElimOrs dbg_str x mb_or_list |], _) -> - -- First, translate all the PermImpls in mb_impls, using pitmCatching to - -- isolate failures to each particular branch, but still reporting failures - -- in any branch - zipWithM (\mb_impl' (i::Int) -> - pimplPrependMsgM ("Case " ++ show i ++ - " of " ++ mbLift dbg_str) $ - pimplCatchM $ translatePermImpl mb_impl') - (mbOrListPermImpls mb_or_list mb_impls) [1..] >>= \maybe_transs -> - -- As a special case, if all branches fail (representing as translating to - -- Nothing), then the entire or elimination fails - if all isNothing maybe_transs then mzero else - return $ PImplTerm $ \k -> - do let mb_or_p = mbOrListPerm mb_or_list - () <- assertTopPermM "Impl1_ElimOrs" x mb_or_p - tps <- mapM translate $ mbOrListDisjs mb_or_list - tp_ret <- compReturnTypeTransM - top_ptrans <- getTopPermM - eithersElimTransM tps tp_ret - (flip map maybe_transs $ \maybe_trans ptrans -> - withPermStackM id ((:>: ptrans) . RL.tail) $ - popPImplTerm (forcePImplTerm maybe_trans) k) - (transTerm1 top_ptrans) - - -- An existential elimination performs a pattern-match on a Sigma - ([nuMP| Impl1_ElimExists x p |], _) -> - translatePermImplUnary mb_impls $ \m -> - do let tp = mbBindingType p - () <- assertTopPermM "Impl1_ElimExists" x (fmap ValPerm_Exists p) - top_ptrans <- getTopPermM - tp_trans <- translateClosed tp - sigmaElimPermTransM "x_elimEx" tp_trans - (mbCombine RL.typeCtxProxies p) - compReturnTypeTransM - (\etrans ptrans -> - inExtTransM etrans $ - withPermStackM id ((:>: ptrans) . RL.tail) m) - (transTerm1 top_ptrans) - - -- A false elimination becomes a call to efq - ([nuMP| Impl1_ElimFalse mb_x |], _) -> - return $ PImplTerm $ const $ - do mb_false <- nuMultiTransM $ const ValPerm_False - () <- assertTopPermM "Impl1_ElimFalse" mb_x mb_false - top_ptrans <- getTopPermM - applyGlobalTransM "Prelude.efq" [compReturnTypeM, - return (transTerm1 top_ptrans)] - - -- A SimplImpl is translated using translateSimplImpl - ([nuMP| Impl1_Simpl simpl mb_prx |], _) -> - let prx' = mbLift mb_prx in - translatePermImplUnary mb_impls $ \m -> - assertPermStackTopEqM "SimplImpl in" prx' (fmap simplImplIn simpl) >>= \() -> - translateSimplImpl prx' simpl $ - do () <- assertPermStackTopEqM "SimplImpl out" prx' (fmap simplImplOut simpl) - m - - -- A let binding becomes a let binding - ([nuMP| Impl1_LetBind _ e |], _) -> - translatePermImplUnary mb_impls $ \m -> - do etrans <- translate e - inExtTransM etrans $ - withPermStackM (:>: Member_Base) (:>: PTrans_Eq (extMb e)) m - - ([nuMP| Impl1_ElimStructField x _ _ memb |], _) -> - translatePermImplUnary mb_impls $ \m -> - do etrans_x <- translate x - let etrans_y = case etrans_x of - ETrans_Struct flds -> RL.get (mbLift memb) flds - _ -> error "translatePermImpl1: Impl1_ElimStructField" - let mb_y = mbCombine RL.typeCtxProxies $ fmap (const $ nu $ \y -> - PExpr_Var y) x - inExtTransM etrans_y $ - withPermStackM (:>: Member_Base) - (\case - (pctx :>: PTrans_Conj [APTrans_Struct pctx_str]) -> - pctx :>: PTrans_Conj [APTrans_Struct $ - RL.set (mbLift memb) (PTrans_Eq mb_y) pctx_str] - :>: RL.get (mbLift memb) pctx_str - _ -> - error "translatePermImpl1: Impl1_ElimStructField") - m - - ([nuMP| Impl1_ElimLLVMFieldContents _ mb_fld |], _) -> - translatePermImplUnary mb_impls $ \m -> - inExtTransM ETrans_LLVM $ - withPermStackM (:>: Member_Base) - (\(pctx :>: ptrans_x) -> - let (_,ptrans') = - unPTransLLVMField "translatePermImpl1: Impl1_ElimLLVMFieldContents" - knownNat ptrans_x in - pctx :>: PTrans_Conj [ - APTrans_LLVMField - (mbCombine RL.typeCtxProxies $ - mbMapCl $(mkClosed [| \fld -> nu $ \y -> - llvmFieldSetEqVar fld y |]) mb_fld) $ - PTrans_Eq (mbCombine RL.typeCtxProxies $ - fmap (const $ nu PExpr_Var) mb_fld)] - :>: ptrans') - m - - ([nuMP| Impl1_ElimLLVMBlockToEq _ mb_bp |], _) -> - translatePermImplUnary mb_impls $ \m -> - inExtTransM ETrans_LLVMBlock $ - do let mb_p_out1 = - mbCombine RL.typeCtxProxies $ - mbMapCl $(mkClosed - [| \bp -> nu $ \y -> - let len = llvmBlockLen bp in - ValPerm_Conj1 $ Perm_LLVMBlock $ - bp { llvmBlockShape = - PExpr_EqShape len $ PExpr_Var y } |]) - mb_bp - tp_trans1 <- translate mb_p_out1 - let mb_p_out2 = - mbMapCl $(mkClosed - [| ValPerm_Conj1 - . Perm_LLVMBlockShape . modalizeBlockShape |]) $ - extMb mb_bp - tp_trans2 <- translate mb_p_out2 - withPermStackTopTermsM (:>: Member_Base) - (\ts (pctx :>: _) -> - pctx :>: typeTransF tp_trans1 [] :>: typeTransF tp_trans2 ts) - m - - ([nuMP| Impl1_SplitLLVMWordField _ mb_fp mb_sz1 mb_endianness |], _) -> - translatePermImplUnary mb_impls $ \m -> - do let mb_e = case mbLLVMFieldContents mb_fp of - [nuP| ValPerm_Eq (PExpr_LLVMWord e) |] -> e - _ -> error "translatePermImpl1: Impl1_SplitLLVMWordField" - e_tm <- translate1 mb_e - sz1_tm <- translate mb_sz1 - sz2_tm <- translateClosed $ mbLLVMFieldSize mb_fp - let sz2m1_tm = applyGlobalOpenTerm "Prelude.subNat" [sz2_tm, sz1_tm] - let (e1_tm,e2_tm) = - bvSplitOpenTerm (mbLift mb_endianness) sz1_tm sz2m1_tm e_tm - inExtTransM (ETrans_Term knownRepr e1_tm) $ - inExtTransM (ETrans_Term knownRepr e2_tm) $ - translate - (mbCombine RL.typeCtxProxies $ flip mbMapCl mb_fp - ($(mkClosed - [| \sz1 endianness fp -> - impl1SplitLLVMWordFieldOutPerms fp sz1 endianness |]) - `clApply` toClosed (mbLift mb_sz1) - `clApply` toClosed (mbLift mb_endianness))) >>= \pctx_out -> - withPermStackM - (\(vars :>: x) -> vars :>: x :>: x :>: - Member_Step Member_Base :>: Member_Base) - (\(pctx :>: _) -> - -- NOTE: all output perms are eq or ptr to eq perms, so contain no - -- SAW core terms - pctx `RL.append` typeTransF pctx_out []) - m - - ([nuMP| Impl1_TruncateLLVMWordField _ mb_fp mb_sz1 mb_endianness |], _) -> - translatePermImplUnary mb_impls $ \m -> - do let mb_e = case mbLLVMFieldContents mb_fp of - [nuP| ValPerm_Eq (PExpr_LLVMWord e) |] -> e - _ -> error "translatePermImpl1: Impl1_TruncateLLVMWordField" - e_tm <- translate1 mb_e - sz1_tm <- translate mb_sz1 - sz2_tm <- translateClosed $ mbLLVMFieldSize mb_fp - let sz2m1_tm = applyGlobalOpenTerm "Prelude.subNat" [sz2_tm, sz1_tm] - let (e1_tm,_) = - bvSplitOpenTerm (mbLift mb_endianness) sz1_tm sz2m1_tm e_tm - inExtTransM (ETrans_Term knownRepr e1_tm) $ - translate - (mbCombine RL.typeCtxProxies $ flip mbMapCl mb_fp - ($(mkClosed - [| \sz1 endianness fp -> - impl1TruncateLLVMWordFieldOutPerms fp sz1 endianness |]) - `clApply` toClosed (mbLift mb_sz1) - `clApply` toClosed (mbLift mb_endianness))) >>= \pctx_out -> - withPermStackM (:>: Member_Base) - (\(pctx :>: _) -> - -- NOTE: all output perms are eq or ptr to eq perms, so contain no - -- SAW core terms - pctx `RL.append` typeTransF pctx_out []) - m - - ([nuMP| Impl1_ConcatLLVMWordFields _ mb_fp1 mb_e2 mb_endianness |], _) -> - translatePermImplUnary mb_impls $ \m -> - do let mb_e1 = case mbLLVMFieldContents mb_fp1 of - [nuP| ValPerm_Eq (PExpr_LLVMWord e1) |] -> e1 - _ -> error "translatePermImpl1: Impl1_ConcatLLVMWordFields" - e1_tm <- translate1 mb_e1 - e2_tm <- translate1 mb_e2 - sz1_tm <- translateClosed $ mbLLVMFieldSize mb_fp1 - sz2_tm <- translateClosed $ mbExprBVTypeWidth mb_e2 - let endianness = mbLift mb_endianness - let e_tm = bvConcatOpenTerm endianness sz1_tm sz2_tm e1_tm e2_tm - inExtTransM (ETrans_Term knownRepr e_tm) $ - translate (mbCombine RL.typeCtxProxies $ - mbMap2 (\fp1 e2 -> - impl1ConcatLLVMWordFieldsOutPerms fp1 e2 endianness) - mb_fp1 mb_e2) >>= \pctx_out -> - withPermStackM - (\(vars :>: x :>: _) -> (vars :>: x :>: Member_Base)) - (\(pctx :>: _ :>: _) -> - -- NOTE: all output perms are eq or ptr to eq perms, so contain no - -- SAW core terms - pctx `RL.append` typeTransF pctx_out []) - m - - ([nuMP| Impl1_BeginLifetime |], _) -> - translatePermImplUnary mb_impls $ \m -> - inExtTransM ETrans_Lifetime $ - do ev <- infoEvType <$> ask - ectx <- infoCtx <$> ask - let prxs = RL.map (const Proxy) ectx - let mb_ps = (nuMulti prxs (const MNil)) - let ttr = pure MNil - withPermStackM (:>: Member_Base) - (:>: - PTrans_LOwned - (nuMulti prxs (const [])) CruCtxNil CruCtxNil mb_ps mb_ps - (mkLOwnedTransId ev ectx ttr ttr MNil)) - m - - -- If e1 and e2 are already equal, short-circuit the proof construction and then - -- elimination - ([nuMP| Impl1_TryProveBVProp x prop@(BVProp_Eq e1 e2) _ |], _) - | mbLift (mbMap2 bvEq e1 e2) -> - translatePermImplUnary mb_impls $ \m -> - do bv_tp <- typeTransType1 <$> translateClosed (mbExprType e1) - e1_trans <- translate1 e1 - let pf = ctorOpenTerm "Prelude.Refl" [bv_tp, e1_trans] - withPermStackM (:>: translateVar x) - (:>: PTrans_Conj [APTrans_BVProp (BVPropTrans prop pf)]) - m - - -- If e1 and e2 are definitely not equal, treat this as a fail - ([nuMP| Impl1_TryProveBVProp _ (BVProp_Eq e1 e2) prop_str |], _) - | not $ mbLift (mbMap2 bvCouldEqual e1 e2) -> - pimplFailM (mbLift prop_str) - - -- Otherwise, insert an equality test with proof construction. Note that, as - -- with all TryProveBVProps, if the test fails and there is no failure - -- continuation, we insert just the proposition failure string using - -- implTransAltErr, not the entire type-checking error message, because this is - -- considered just an assertion and not a failure - ([nuMP| Impl1_TryProveBVProp x prop@(BVProp_Eq e1 e2) prop_str |], - [nuMP| MbPermImpls_Cons _ _ mb_impl' |]) -> - translatePermImpl (mbCombine RL.typeCtxProxies mb_impl') >>= \trans -> - return $ PImplTerm $ \k -> - do prop_tp_trans <- translate prop - ret_tp_m <- compReturnTypeM - ret_tp <- returnTypeM - applyGlobalTransM "Prelude.ifBvEqWithProof" - [ return ret_tp_m - , return (natOpenTerm $ natVal2 prop), translate1 e1, translate1 e2 - , return (implFailAltContTerm ret_tp (mbLift prop_str) k) - , lambdaTransM "eq_pf" prop_tp_trans - (\prop_trans -> - withPermStackM (:>: translateVar x) (:>: bvPropPerm prop_trans) $ - popPImplTerm trans k) - ] - - -- If e1 and e2 are already unequal, short-circuit and do nothing - ([nuMP| Impl1_TryProveBVProp x prop@(BVProp_Neq e1 e2) _ |], _) - | not $ mbLift (mbMap2 bvCouldEqual e1 e2) -> - translatePermImplUnary mb_impls $ - withPermStackM (:>: translateVar x) - (:>: PTrans_Conj [APTrans_BVProp (BVPropTrans prop unitOpenTerm)]) - - -- For an inequality test, we don't need a proof, so just insert an if - ([nuMP| Impl1_TryProveBVProp x prop@(BVProp_Neq e1 e2) prop_str |], - [nuMP| MbPermImpls_Cons _ _ mb_impl' |]) -> - translatePermImpl (mbCombine RL.typeCtxProxies mb_impl') >>= \trans -> - return $ PImplTerm $ \k -> - let w = natVal2 prop in - applyGlobalTransM "Prelude.ite" - [ compReturnTypeM - , applyGlobalTransM "Prelude.bvEq" - [ return (natOpenTerm w), translate1 e1, translate1 e2 ] - , (\ret_tp -> - implFailAltContTerm ret_tp (mbLift prop_str) k) <$> returnTypeM - , withPermStackM (:>: translateVar x) - (:>: PTrans_Conj [APTrans_BVProp (BVPropTrans prop unitOpenTerm)]) $ - popPImplTerm trans k] - - -- If we know e1 < e2 statically, translate to unsafeAssert - ([nuMP| Impl1_TryProveBVProp x prop@(BVProp_ULt e1 e2) _ |], - [nuMP| MbPermImpls_Cons _ _ mb_impl' |]) - | mbLift (fmap bvPropHolds prop) -> - translatePermImpl (mbCombine RL.typeCtxProxies mb_impl') >>= \trans -> - return $ PImplTerm $ \k -> - do let w = natVal4 e1 - t1 <- translate1 e1 - t2 <- translate1 e2 - let pf_tm = - applyGlobalOpenTerm "Prelude.unsafeAssertBVULt" - [natOpenTerm w, t1, t2] - withPermStackM (:>: translateVar x) - (:>: bvPropPerm (BVPropTrans prop pf_tm)) - (popPImplTerm trans k) - - -- If we don't know e1 < e2 statically, translate to ifWithProof of bvult - ([nuMP| Impl1_TryProveBVProp x prop@(BVProp_ULt e1 e2) prop_str |], - [nuMP| MbPermImpls_Cons _ _ mb_impl' |]) -> - translatePermImpl (mbCombine RL.typeCtxProxies mb_impl') >>= \trans -> - return $ PImplTerm $ \k -> - do prop_tp_trans <- translate prop - ret_tp_m <- compReturnTypeM - ret_tp <- returnTypeM - applyGlobalTransM "Prelude.ifWithProof" - [ return ret_tp_m - , applyGlobalTransM "Prelude.bvult" - [ return (natOpenTerm $ natVal2 prop), translate1 e1, translate1 e2 ] - , return (implFailAltContTerm ret_tp (mbLift prop_str) k) - , lambdaTransM "ult_pf" prop_tp_trans - (\prop_trans -> - withPermStackM (:>: translateVar x) (:>: bvPropPerm prop_trans) $ - popPImplTerm trans k) - ] - - -- If we know e1 <= e2 statically, translate to unsafeAssert - ([nuMP| Impl1_TryProveBVProp x prop@(BVProp_ULeq e1 e2) _ |], - [nuMP| MbPermImpls_Cons _ _ mb_impl' |]) - | mbLift (fmap bvPropHolds prop) -> - translatePermImpl (mbCombine RL.typeCtxProxies mb_impl') >>= \trans -> - return $ PImplTerm $ \k -> - do let w = natVal4 e1 - t1 <- translate1 e1 - t2 <- translate1 e2 - let pf_tm = - applyGlobalOpenTerm "Prelude.unsafeAssertBVULe" - [natOpenTerm w, t1, t2] - withPermStackM (:>: translateVar x) - (:>: bvPropPerm (BVPropTrans prop pf_tm)) - (popPImplTerm trans k) - - -- If we don't know e1 <= e2 statically, translate to ifWithProof of bvule - ([nuMP| Impl1_TryProveBVProp x prop@(BVProp_ULeq e1 e2) prop_str |], - [nuMP| MbPermImpls_Cons _ _ mb_impl' |]) -> - translatePermImpl (mbCombine RL.typeCtxProxies mb_impl') >>= \trans -> - return $ PImplTerm $ \k -> - do prop_tp_trans <- translate prop - ret_tp_m <- compReturnTypeM - ret_tp <- returnTypeM - applyGlobalTransM "Prelude.ifWithProof" - [ return ret_tp_m - , applyGlobalTransM "Prelude.bvule" - [ return (natOpenTerm $ natVal2 prop), translate1 e1, translate1 e2 ] - , return (implFailAltContTerm ret_tp (mbLift prop_str) k) - , lambdaTransM "ule_pf" prop_tp_trans - (\prop_trans -> - withPermStackM (:>: translateVar x) (:>: bvPropPerm prop_trans) $ - popPImplTerm trans k) - ] - - -- If we know e1 <= e2-e3 statically, translate to unsafeAssert - ([nuMP| Impl1_TryProveBVProp x prop@(BVProp_ULeq_Diff e1 e2 e3) _ |], - [nuMP| MbPermImpls_Cons _ _ mb_impl' |]) - | mbLift (fmap bvPropHolds prop) -> - translatePermImpl (mbCombine RL.typeCtxProxies mb_impl') >>= \trans -> - return $ PImplTerm $ \k -> - do let w = natVal4 e1 - t1 <- translate1 e1 - t2 <- translate1 e2 - t3 <- translate1 e3 - let pf_tm = - applyGlobalOpenTerm "Prelude.unsafeAssertBVULe" - [natOpenTerm w, t1, - applyGlobalOpenTerm "Prelude.bvSub" [natOpenTerm w, t2, t3]] - withPermStackM (:>: translateVar x) - (:>: bvPropPerm (BVPropTrans prop pf_tm)) - (popPImplTerm trans k) - - -- If we don't know e1 <= e2-e3 statically, translate to ifWithProof of bvule - ([nuMP| Impl1_TryProveBVProp x prop@(BVProp_ULeq_Diff e1 e2 e3) prop_str |], - [nuMP| MbPermImpls_Cons _ _ mb_impl' |]) -> - translatePermImpl (mbCombine RL.typeCtxProxies mb_impl') >>= \trans -> - return $ PImplTerm $ \k -> - do prop_tp_trans <- translate prop - ret_tp_m <- compReturnTypeM - ret_tp <- returnTypeM - applyGlobalTransM "Prelude.ifWithProof" - [ return ret_tp_m - , applyGlobalTransM "Prelude.bvule" - [ return (natOpenTerm $ natVal2 prop), translate1 e1 - , applyGlobalTransM "Prelude.bvSub" - [return (natOpenTerm $ natVal2 prop), translate1 e2, translate1 e3] - ] - , return (implFailAltContTerm ret_tp (mbLift prop_str) k) - , lambdaTransM "ule_diff_pf" prop_tp_trans - (\prop_trans -> - withPermStackM (:>: translateVar x) (:>: bvPropPerm prop_trans) $ - popPImplTerm trans k) - ] - - ([nuMP| Impl1_TryProveBVProp _ _ _ |], _) -> - pimplFailM ("translatePermImpl1: Unhandled BVProp case") - --- | Translate a 'PermImpl' in the 'PermImplTransM' monad to a function that --- takes a failure continuation and returns a monadic computation to generate --- the translation as a term -translatePermImpl :: NuMatchingAny1 r => Mb ctx (PermImpl r ps) -> - PImplTransMTerm r ext blocks tops rets ps ctx -translatePermImpl mb_impl = case mbMatch mb_impl of - [nuMP| PermImpl_Done r |] -> - do f <- pimplRTransFunM - return $ PImplTerm $ const $ appImpTransFun f reflCtxExt r - [nuMP| PermImpl_Step impl1 mb_impls |] -> - translatePermImpl1 impl1 mb_impls - -translatePermImplToTerm :: NuMatchingAny1 r => String -> - Mb ctx (PermImpl r ps) -> - ImpRTransFun r ext blocks tops rets ctx -> - ImpTransM ext blocks tops rets ps ctx OpenTerm -translatePermImplToTerm err mb_impl k = - let (maybe_ptm, (errs,_)) = - runPermImplTransM (translatePermImpl mb_impl) k in - (infoEvType <$> ask) >>= \ev -> - popPImplTerm (forcePImplTerm maybe_ptm) $ - ImplFailContMsg ev (err ++ "\n\n" - ++ concat (intersperse - "\n\n--------------------\n\n" errs)) - -instance ImplTranslateF r ext blocks tops rets => - Translate (ImpTransInfo ext blocks tops rets ps) - ctx (AnnotPermImpl r ps) OpenTerm where - translate (mbMatch -> [nuMP| AnnotPermImpl err mb_impl |]) = - translatePermImplToTerm (mbLift err) mb_impl (ImpRTransFun $ - const translateF) - --- We translate a LocalImplRet to a term that returns all current permissions -instance ImplTranslateF (LocalImplRet ps) ext blocks ps_in rets where - translateF _ = - do pctx <- itiPermStack <$> ask - ev <- infoEvType <$> ask - ret_tp <- returnTypeM - return $ retSOpenTerm ev ret_tp $ transTupleTerm pctx - --- | Translate a local implication to its output, adding an error message -translateLocalPermImpl :: String -> Mb ctx (LocalPermImpl ps_in ps_out) -> - ImpTransM ext blocks tops rets ps_in ctx OpenTerm -translateLocalPermImpl err (mbMatch -> [nuMP| LocalPermImpl impl |]) = - clearVarPermsM $ translate $ fmap (AnnotPermImpl err) impl - --- | Translate a local implication over two sequences of permissions (already --- translated to types) to a monadic function with the first sequence of --- permissions as free variables and that takes in the second permissions as --- arguments. This monadic function is relative to the empty function stack. --- Note that the translations of the second input permissions and the output --- permissions must have exactly one type, i.e., already be tupled. -translateCurryLocalPermImpl :: - String -> Mb ctx (LocalPermImpl (ps1 :++: ps2) ps_out) -> - PermTransCtx ctx ps1 -> RAssign (Member ctx) ps1 -> - TypeTrans (PermTransCtx ctx ps2) -> RAssign (Member ctx) ps2 -> - TypeTrans (PermTransCtx ctx ps_out) -> - ImpTransM ext blocks tops rets ps ctx OpenTerm -translateCurryLocalPermImpl err impl pctx1 vars1 tp_trans2 vars2 tp_trans_out = - lambdaTransM "x_local" tp_trans2 $ \pctx2 -> - local (\info -> info { itiReturnType = typeTransTupleType tp_trans_out }) $ - withPermStackM - (const (RL.append vars1 vars2)) - (const (RL.append pctx1 pctx2)) - (translateLocalPermImpl err impl) - --- | Translate a 'LocalPermImpl' to an 'LOwnedTransTerm' -translateLOwnedPermImpl :: String -> Mb ctx (LocalPermImpl ps_in ps_out) -> - ImpTransM ext blocks tops rets ps ctx - (LOwnedTransTerm ctx ps_in ps_out) -translateLOwnedPermImpl err (mbMatch -> [nuMP| LocalPermImpl mb_impl |]) = - ask >>= \info_top -> - return $ LOwnedTransM $ \e_ext loinfo_in k -> - flip runTransM (lownedInfoToImp loinfo_in info_top) $ - translatePermImplToTerm err (extMbExt e_ext mb_impl) $ - ImpRTransFun $ \cext' r -> - case mbMatch r of - [nuMP| LocalImplRet Refl |] -> - do info_out <- ask - let e_ext' = ctxExtToExprExt cext' $ itiExprCtx info_out - return $ k e_ext' (impInfoToLOwned info_out) () - - ----------------------------------------------------------------------- --- * Translating Typed Crucible Expressions ----------------------------------------------------------------------- - --- translate for a TypedReg yields an ExprTrans -instance TransInfo info => - Translate info ctx (TypedReg tp) (ExprTrans tp) where - translate (mbMatch -> [nuMP| TypedReg x |]) = translate x - -instance TransInfo info => - Translate info ctx (TypedRegs tps) (ExprTransCtx tps) where - translate mb_x = case mbMatch mb_x of - [nuMP| TypedRegsNil |] -> return MNil - [nuMP| TypedRegsCons rs r |] -> - (:>:) <$> translate rs <*> translate r - -instance TransInfo info => - Translate info ctx (RegWithVal tp) (ExprTrans tp) where - translate mb_x = case mbMatch mb_x of - [nuMP| RegWithVal _ e |] -> translate e - [nuMP| RegNoVal x |] -> translate x - --- | Translate a 'RegWithVal' to exactly one SAW term via 'transTerm1' -translateRWV :: TransInfo info => Mb ctx (RegWithVal a) -> - TransM info ctx OpenTerm -translateRWV mb_rwv = translate1 mb_rwv - --- translate for a TypedExpr yields an ExprTrans -instance (PermCheckExtC ext exprExt, TransInfo info) => - Translate info ctx (App ext RegWithVal tp) (ExprTrans tp) where - translate mb_e = case mbMatch mb_e of - [nuMP| BaseIsEq BaseBoolRepr e1 e2 |] -> - ETrans_Term knownRepr <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.boolEq") - [translateRWV e1, translateRWV e2] - -- [nuMP| BaseIsEq BaseNatRepr e1 e2 |] -> - -- ETrans_Term <$> - -- applyMultiTransM (return $ globalOpenTerm "Prelude.equalNat") - -- [translateRWV e1, translateRWV e2] - [nuMP| BaseIsEq (BaseBVRepr w) e1 e2 |] -> - ETrans_Term knownRepr <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvEq") - [translate w, translateRWV e1, translateRWV e2] - - [nuMP| EmptyApp |] -> return ETrans_Unit - - -- Booleans - [nuMP| BoolLit True |] -> - return $ ETrans_Term knownRepr $ globalOpenTerm "Prelude.True" - [nuMP| BoolLit False |] -> - return $ ETrans_Term knownRepr $ globalOpenTerm "Prelude.False" - [nuMP| Not e |] -> - ETrans_Term knownRepr <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.not") - [translateRWV e] - [nuMP| And e1 e2 |] -> - ETrans_Term knownRepr <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.and") - [translateRWV e1, translateRWV e2] - [nuMP| Or e1 e2 |] -> - ETrans_Term knownRepr <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.or") - [translateRWV e1, translateRWV e2] - [nuMP| BoolXor e1 e2 |] -> - ETrans_Term knownRepr <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.xor") - [translateRWV e1, translateRWV e2] - - -- Natural numbers - [nuMP| Expr.NatLit n |] -> - return $ ETrans_Term knownRepr $ natOpenTerm $ mbLift n - [nuMP| NatLt e1 e2 |] -> - ETrans_Term knownRepr <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.ltNat") - [translateRWV e1, translateRWV e2] - -- [nuMP| NatLe _ _ |] -> - [nuMP| NatEq e1 e2 |] -> - ETrans_Term knownRepr <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.equalNat") - [translateRWV e1, translateRWV e2] - [nuMP| NatAdd e1 e2 |] -> - ETrans_Term knownRepr <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.addNat") - [translateRWV e1, translateRWV e2] - [nuMP| NatSub e1 e2 |] -> - ETrans_Term knownRepr <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.subNat") - [translateRWV e1, translateRWV e2] - [nuMP| NatMul e1 e2 |] -> - ETrans_Term knownRepr <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.mulNat") - [translateRWV e1, translateRWV e2] - [nuMP| NatDiv e1 e2 |] -> - ETrans_Term knownRepr <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.divNat") - [translateRWV e1, translateRWV e2] - [nuMP| NatMod e1 e2 |] -> - ETrans_Term knownRepr <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.modNat") - [translateRWV e1, translateRWV e2] - - -- Function handles: the expression part of a function handle has no - -- computational content - [nuMP| HandleLit _ |] -> return ETrans_Fun - - -- Bitvectors - [nuMP| BVUndef w |] -> - -- FIXME: we should really handle poison values; this translation just - -- treats them as if there were the bitvector 0 value - return $ ETrans_Term (BVRepr $ mbLift w) $ - bvBVOpenTerm (mbLift w) $ BV.zero (mbLift w) - [nuMP| BVLit w mb_bv |] -> - return $ ETrans_Term (BVRepr $ mbLift w) $ - bvBVOpenTerm (mbLift w) $ mbLift mb_bv - [nuMP| BVConcat w1 w2 e1 e2 |] -> - ETrans_Term (BVRepr $ addNat (mbLift w1) (mbLift w2)) <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.join") - [translate w1, translate w2, translateRWV e1, translateRWV e2] - [nuMP| BVTrunc w1 w2 e |] -> - ETrans_Term (BVRepr $ mbLift w1) <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvTrunc") - [return (natOpenTerm (natValue (mbLift w2) - natValue (mbLift w1))), - translate w1, - translateRWV e] - [nuMP| BVZext w1 w2 e |] -> - ETrans_Term (BVRepr $ mbLift w1) <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvUExt") - [return (natOpenTerm (natValue (mbLift w1) - natValue (mbLift w2))), - translate w2, translateRWV e] - [nuMP| BVSext w1 w2 e |] -> - ETrans_Term (BVRepr $ mbLift w1) <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvSExt") - [return (natOpenTerm (natValue (mbLift w1) - natValue (mbLift w2))), - -- NOTE: bvSExt adds 1 to the 2nd arg - return (natOpenTerm (natValue (mbLift w2) - 1)), - translateRWV e] - [nuMP| BVNot w e |] -> - ETrans_Term (BVRepr $ mbLift w) <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvNot") - [translate w, translateRWV e] - [nuMP| BVAnd w e1 e2 |] -> - ETrans_Term (BVRepr $ mbLift w) <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvAnd") - [translate w, translateRWV e1, translateRWV e2] - [nuMP| BVOr w e1 e2 |] -> - ETrans_Term (BVRepr $ mbLift w) <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvOr") - [translate w, translateRWV e1, translateRWV e2] - [nuMP| BVXor w e1 e2 |] -> - ETrans_Term (BVRepr $ mbLift w) <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvXor") - [translate w, translateRWV e1, translateRWV e2] - [nuMP| BVNeg w e |] -> - ETrans_Term (BVRepr $ mbLift w) <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvNeg") - [translate w, translateRWV e] - [nuMP| BVAdd w e1 e2 |] -> - ETrans_Term (BVRepr $ mbLift w) <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvAdd") - [translate w, translateRWV e1, translateRWV e2] - [nuMP| BVSub w e1 e2 |] -> - ETrans_Term (BVRepr $ mbLift w) <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvSub") - [translate w, translateRWV e1, translateRWV e2] - [nuMP| BVMul w e1 e2 |] -> - ETrans_Term (BVRepr $ mbLift w) <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvMul") - [translate w, translateRWV e1, translateRWV e2] - [nuMP| BVUdiv w e1 e2 |] -> - ETrans_Term (BVRepr $ mbLift w) <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvUDiv") - [translate w, translateRWV e1, translateRWV e2] - [nuMP| BVSdiv w e1 e2 |] -> - ETrans_Term (BVRepr $ mbLift w) <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvSDiv") - [translate w, translateRWV e1, translateRWV e2] - [nuMP| BVUrem w e1 e2 |] -> - ETrans_Term (BVRepr $ mbLift w) <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvURem") - [translate w, translateRWV e1, translateRWV e2] - [nuMP| BVSrem w e1 e2 |] -> - ETrans_Term (BVRepr $ mbLift w) <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvSRem") - [translate w, translateRWV e1, translateRWV e2] - [nuMP| BVUle w e1 e2 |] -> - ETrans_Term knownRepr <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvule") - [translate w, translateRWV e1, translateRWV e2] - [nuMP| BVUlt w e1 e2 |] -> - ETrans_Term knownRepr <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvult") - [translate w, translateRWV e1, translateRWV e2] - [nuMP| BVSle w e1 e2 |] -> - ETrans_Term knownRepr <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvsle") - [translate w, translateRWV e1, translateRWV e2] - [nuMP| BVSlt w e1 e2 |] -> - ETrans_Term knownRepr <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvslt") - [translate w, translateRWV e1, translateRWV e2] - [nuMP| BVCarry w e1 e2 |] -> - ETrans_Term knownRepr <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvCarry") - [translate w, translateRWV e1, translateRWV e2] - [nuMP| BVSCarry w e1 e2 |] -> - -- NOTE: bvSCarry adds 1 to the bitvector length - let w_minus_1 = natOpenTerm (natValue (mbLift w) - 1) in - ETrans_Term knownRepr <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvSCarry") - [return w_minus_1, translateRWV e1, translateRWV e2] - [nuMP| BVSBorrow w e1 e2 |] -> - -- NOTE: bvSBorrow adds 1 to the bitvector length - let w_minus_1 = natOpenTerm (natValue (mbLift w) - 1) in - ETrans_Term knownRepr <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvSBorrow") - [return w_minus_1, translateRWV e1, translateRWV e2] - [nuMP| BVShl w e1 e2 |] -> - ETrans_Term (BVRepr $ mbLift w) <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvShiftL") - [translate w, return (globalOpenTerm "Prelude.Bool"), translate w, - return (globalOpenTerm "Prelude.False"), translateRWV e1, translateRWV e2] - [nuMP| BVLshr w e1 e2 |] -> - ETrans_Term (BVRepr $ mbLift w) <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvShiftR") - [translate w, return (globalOpenTerm "Prelude.Bool"), translate w, - return (globalOpenTerm "Prelude.False"), translateRWV e1, translateRWV e2] - [nuMP| BVAshr w e1 e2 |] -> - let w_minus_1 = natOpenTerm (natValue (mbLift w) - 1) in - ETrans_Term (BVRepr $ mbLift w) <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvSShiftR") - [return w_minus_1, return (globalOpenTerm "Prelude.Bool"), translate w, - translateRWV e1, translateRWV e2] - [nuMP| BoolToBV mb_w e |] -> - let w = mbLift mb_w in - ETrans_Term (BVRepr w) <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.ite") - [bitvectorTransM (translate mb_w), - translateRWV e, - return (bvBVOpenTerm w (BV.one w)), - return (bvBVOpenTerm w (BV.zero w))] - [nuMP| BVNonzero mb_w e |] -> - let w = mbLift mb_w in - ETrans_Term knownRepr <$> - applyTransM (return $ globalOpenTerm "Prelude.not") - (applyMultiTransM (return $ globalOpenTerm "Prelude.bvEq") - [translate mb_w, translateRWV e, - return (bvBVOpenTerm w (BV.zero w))]) - - -- Strings - [nuMP| Expr.StringLit (UnicodeLiteral text) |] -> - return $ ETrans_Term knownRepr $ stringLitOpenTerm $ - mbLift text - - -- Everything else is an error - _ -> - error ("Unhandled expression form: " ++ - (renderString (layoutSmart opts (mbLift $ fmap (ppApp (const $ pretty ("_" :: String))) mb_e)))) - where opts = PP.LayoutOptions (PP.AvailablePerLine 80 0.8) - - --- translate for a TypedExpr yields an ExprTrans -instance (PermCheckExtC ext exprExt, TransInfo info) => - Translate info ctx (TypedExpr ext tp) (ExprTrans tp) where - translate mb_x = case mbMatch mb_x of - [nuMP| TypedExpr _ (Just e) |] -> translate e - [nuMP| TypedExpr app Nothing |] -> translate app - --- | Get the output permission on the return value of a 'TypedExpr' -exprOutPerm :: PermCheckExtC ext exprExt => Mb ctx (TypedExpr ext tp) -> - PermTrans ctx tp -exprOutPerm mb_x = case mbMatch mb_x of - [nuMP| TypedExpr _ (Just e) |] -> PTrans_Eq e - [nuMP| TypedExpr _ Nothing |] -> PTrans_True - - ----------------------------------------------------------------------- --- * Translating Typed Crucible Jump Targets ----------------------------------------------------------------------- - -{- -debugPrettyPermCtx :: RAssign Proxy ctx -> PermTransCtx ctx ps -> [Doc] -debugPrettyPermCtx _ MNil = [] -debugPrettyPermCtx prxs (ptranss :>: ptrans) = - debugPrettyPermCtx prxs ptranss ++ - [permPretty emptyPPInfo (permTransPerm prxs ptrans) <+> - string ("(" ++ show (length $ transTerms ptrans) ++ " terms)")] --} - -{- --- | Apply the translation of a function-like construct (i.e., a --- 'TypedJumpTarget' or 'TypedFnHandle') to the pure plus impure translations of --- its arguments, given as 'DistPerms', which should match the current --- stack. The 'String' argument is the name of the construct being applied, for --- use in error reporting. -translateApply :: String -> OpenTerm -> Mb ctx (DistPerms ps) -> - ImpTransM ext blocks tops rets ps ctx OpenTerm -translateApply nm f perms = - do assertPermStackEqM nm perms - expr_ctx <- itiExprCtx <$> ask - arg_membs <- itiPermStackVars <$> ask - let e_args = RL.map (flip RL.get expr_ctx) arg_membs - i_args <- itiPermStack <$> ask - return $ - {- - trace ("translateApply for " ++ nm ++ " with perm arguments:\n" ++ - -- renderDoc (list $ debugPrettyPermCtx (mbToProxy perms) i_args) - -- permPrettyString emptyPPInfo (permTransCtxPerms (mbToProxy perms) i_args) - permPrettyString emptyPPInfo perms - ) $ -} - applyOpenTermMulti f (exprCtxToTerms e_args ++ permCtxToTerms i_args) --} - --- | Translate a call to (the translation of) an entrypoint, by either calling --- the letrec-bound variable for the entrypoint, if it has one, or by just --- translating the body of the entrypoint if it does not. -translateCallEntry :: forall ext exprExt tops args ghosts blocks ctx rets. - PermCheckExtC ext exprExt => String -> - TypedEntryTrans ext blocks tops rets args ghosts -> - Mb ctx (RAssign ExprVar tops) -> - Mb ctx (RAssign ExprVar args) -> - Mb ctx (RAssign ExprVar ghosts) -> - ImpTransM ext blocks tops rets - ((tops :++: args) :++: ghosts) ctx OpenTerm -translateCallEntry nm entry_trans mb_tops mb_args mb_ghosts = - -- First test that the stack == the required perms for entryID - do let entry = typedEntryTransEntry entry_trans - ectx_ag <- translate $ mbMap2 RL.append mb_args mb_ghosts - pctx <- itiPermStack <$> ask - let mb_tops_args = mbMap2 RL.append mb_tops mb_args - let mb_s = - mbMap2 (\args ghosts -> - permVarSubstOfNames $ RL.append args ghosts) - mb_tops_args mb_ghosts - let mb_perms = fmap (\s -> varSubst s $ mbValuePermsToDistPerms $ - typedEntryPermsIn entry) mb_s - () <- assertPermStackEqM nm mb_perms - - -- Now check if entryID has an associated recursive function - case typedEntryTransFun entry_trans of - Just f -> - -- If so, apply the function to all the terms in the args and ghosts - -- (but not the tops, which are free) plus all the permissions on the - -- stack - return (applyOpenTermMulti f - (exprCtxToTerms ectx_ag ++ transTerms pctx)) - Nothing -> - -- Otherwise, continue translating with the target entrypoint, with all - -- the current expressions free but with only those permissions on top - -- of the stack - withEmptyPermsImpTransM $ translate $ - fmap (\s -> varSubst s $ _mbBinding $ typedEntryBody entry) mb_s - -instance PermCheckExtC ext exprExt => - Translate (ImpTransInfo ext blocks tops rets ps) ctx - (CallSiteImplRet blocks tops args ghosts ps) OpenTerm where - translate (mbMatch -> - [nuMP| CallSiteImplRet entryID ghosts Refl mb_tvars mb_avars mb_gvars |]) = - do entry_trans <- - lookupEntryTransCast (mbLift entryID) (mbLift ghosts) <$> - itiBlockMapTrans <$> ask - translateCallEntry "CallSiteImplRet" entry_trans mb_tvars mb_avars mb_gvars - -instance PermCheckExtC ext exprExt => - ImplTranslateF (CallSiteImplRet blocks tops args ghosts) - ext blocks tops rets where - translateF mb_tgt = translate mb_tgt - - -instance PermCheckExtC ext exprExt => - Translate (ImpTransInfo ext blocks tops rets ps) ctx - (TypedJumpTarget blocks tops ps) OpenTerm where - translate (mbMatch -> [nuMP| TypedJumpTarget siteID _ _ mb_perms_in |]) = - do SomeTypedCallSite site <- - lookupCallSite (mbLift siteID) <$> itiBlockMapTrans <$> ask - let CallSiteImpl mb_impl = typedCallSiteImpl site - translate $ flip fmap mb_perms_in $ \perms_in -> - varSubst (permVarSubstOfNames $ distPermsVars perms_in) mb_impl - -instance PermCheckExtC ext exprExt => - ImplTranslateF (TypedJumpTarget blocks tops) ext blocks tops rets where - translateF mb_tgt = translate mb_tgt - - ----------------------------------------------------------------------- --- * Translating Typed Crucible Statements ----------------------------------------------------------------------- - --- | Translate a 'TypedStmt' to a function on translation computations -translateStmt :: - PermCheckExtC ext exprExt => ProgramLoc -> - Mb ctx (TypedStmt ext stmt_rets ps_in ps_out) -> - ImpTransM ext blocks tops rets ps_out (ctx :++: stmt_rets) OpenTerm -> - ImpTransM ext blocks tops rets ps_in ctx OpenTerm -translateStmt loc mb_stmt m = case mbMatch mb_stmt of - [nuMP| TypedSetReg tp e |] -> - do tp_trans <- translate tp - tp_ret <- compReturnTypeM - etrans <- tpTransM $ translate e - let ptrans = exprOutPerm e - inExtTransSAWLetBindM tp_trans tp_ret etrans $ - withPermStackM (:>: Member_Base) (:>: extPermTrans etrans ptrans) m - - [nuMP| TypedSetRegPermExpr _ e |] -> - do etrans <- tpTransM $ translate e - inExtTransM etrans $ - withPermStackM (:>: Member_Base) (:>: PTrans_Eq (extMb e)) m - - -- FIXME HERE: document this! - [nuMP| TypedCall _freg fun_perm _ gexprs args |] -> - do f_trans <- getTopPermM - ectx_outer <- itiExprCtx <$> ask - let rets = mbLift $ mbMapCl $(mkClosed [| funPermRets |]) fun_perm - let rets_prxs = cruCtxProxies rets - rets_trans <- translateClosed rets - let perms_out = - mbCombine rets_prxs $ flip mbMapCl mb_stmt - ($(mkClosed [| \prxs stmt -> nuMulti prxs (typedStmtOut stmt) |]) - `clApply` toClosed rets_prxs) - ectx_gexprs <- translate gexprs - ectx_args <- translate args - pctx_in <- RL.tail <$> itiPermStack <$> ask - let (pctx_ghosts_args, _) = - RL.split (RL.append ectx_gexprs ectx_args) ectx_gexprs pctx_in - fret_tp <- - openTermTypeTrans <$> - sigmaTypeTransM "ret" rets_trans - (\ectx -> inExtMultiTransM ectx (translate perms_out)) - let all_args = - exprCtxToTerms ectx_gexprs ++ exprCtxToTerms ectx_args ++ - transTerms pctx_ghosts_args - fapp_trm = case f_trans of - PTrans_Fun _ f_trm -> applyFunTrans f_trm all_args - _ -> - panic "translateStmt" - ["TypedCall: unexpected function permission"] - bindTransM fapp_trm fret_tp "call_ret_val" $ \ret_val -> - sigmaElimTransM "elim_call_ret_val" rets_trans - (flip inExtMultiTransM (translate perms_out)) compReturnTypeTransM - (\rets_ectx pctx -> - inExtMultiTransM rets_ectx $ - withPermStackM - (\(vars :>: _) -> - RL.append - (fst (RL.split - (RL.append ectx_gexprs ectx_args) ectx_gexprs vars)) $ - suffixMembers ectx_outer rets_prxs) - (const pctx) - m) - ret_val - - -- FIXME HERE: figure out why these asserts always translate to ite True - [nuMP| TypedAssert e _ |] -> - applyGlobalTransM "Prelude.ite" - [compReturnTypeM, translate1 e, m, - mkErrorComp ("Failed Assert at " ++ - renderDoc (ppShortFileName (plSourceLoc loc)))] - - [nuMP| TypedLLVMStmt stmt |] -> translateLLVMStmt stmt m - - --- | Translate a 'TypedStmt' to a function on translation computations -translateLLVMStmt :: - Mb ctx (TypedLLVMStmt r ps_in ps_out) -> - ImpTransM ext blocks tops rets ps_out (ctx :> r) OpenTerm -> - ImpTransM ext blocks tops rets ps_in ctx OpenTerm -translateLLVMStmt mb_stmt m = case mbMatch mb_stmt of - [nuMP| ConstructLLVMWord (TypedReg x) |] -> - inExtTransM ETrans_LLVM $ - withPermStackM (:>: Member_Base) (:>: (PTrans_Eq $ extMb $ - fmap (PExpr_LLVMWord . PExpr_Var) x)) m - - [nuMP| AssertLLVMWord reg _ |] -> - inExtTransM (ETrans_Term knownRepr $ natOpenTerm 0) $ - withPermStackM ((:>: Member_Base) . RL.tail) - ((:>: (PTrans_Eq $ fmap (const $ PExpr_Nat 0) $ extMb reg)) . RL.tail) - m - - [nuMP| AssertLLVMPtr _ |] -> - inExtTransM ETrans_Unit $ - withPermStackM RL.tail RL.tail m - - [nuMP| DestructLLVMWord _ e |] -> - translate e >>= \etrans -> - inExtTransM etrans $ - withPermStackM ((:>: Member_Base) . RL.tail) - ((:>: (PTrans_Eq $ extMb e)) . RL.tail) - m - - [nuMP| OffsetLLVMValue _ _ |] -> - let mb_x_off = - mbMapCl $(mkClosed [| \(OffsetLLVMValue x off) -> - PExpr_LLVMOffset (typedRegVar x) off |]) - mb_stmt in - inExtTransM ETrans_LLVM $ - withPermStackM (:>: Member_Base) (:>: (PTrans_Eq $ extMb $ mb_x_off)) - m - - [nuMP| TypedLLVMLoad _ (mb_fp :: LLVMFieldPerm w sz) - (_ :: DistPerms ps) cur_perms |] -> - let prx_l = mbLifetimeCurrentPermsProxies cur_perms - prx_ps :: Proxy (ps :> LLVMPointerType w) = Proxy in - inExtTransM ETrans_LLVM $ - withPermStackM - (\(RL.split prx_ps prx_l -> (vars, vars_l)) -> - RL.append (vars :>: Member_Base) vars_l) - (\(RL.split prx_ps prx_l -> (pctx :>: p_ptr, pctx_l)) -> - let (_, p_ret) = - unPTransLLVMField "translateLLVMStmt: TypedLLVMLoad: expected field perm" - (knownNat @sz) p_ptr in - withKnownNat ?ptrWidth $ - RL.append - (pctx :>: PTrans_Conj [APTrans_LLVMField - (mbCombine RL.typeCtxProxies $ - mbMapCl $(mkClosed - [| \fp -> nu $ \ret -> - llvmFieldSetEqVar fp ret |]) mb_fp) - (PTrans_Eq $ mbCombine RL.typeCtxProxies $ - fmap (const $ nu $ \ret -> PExpr_Var ret) mb_fp)] - :>: p_ret) pctx_l) - m - - [nuMP| TypedLLVMStore _ (mb_fp :: LLVMFieldPerm w sz) mb_e - (_ :: DistPerms ps) cur_perms |] -> - let prx_l = mbLifetimeCurrentPermsProxies cur_perms - prx_ps :: Proxy (ps :> LLVMPointerType w) = Proxy in - withKnownNat ?ptrWidth $ - inExtTransM ETrans_Unit $ - withPermStackM id - (\(RL.split prx_ps prx_l -> (pctx :>: _p_ptr, pctx_l)) -> - RL.append - (pctx :>: PTrans_Conj [APTrans_LLVMField - (extMb $ mbMap2 (\fp e -> - fp { llvmFieldContents = - ValPerm_Eq e }) - mb_fp mb_e) - (PTrans_Eq $ extMb mb_e)]) - pctx_l) - m - - [nuMP| TypedLLVMAlloca _ (mb_fperm :: LLVMFramePerm w) mb_sz |] -> - let sz = mbLift mb_sz - w :: Proxy w = Proxy in - withKnownNat ?ptrWidth $ - inExtTransM ETrans_LLVM $ - translateClosed (llvmEmptyBlockPermOfSize w sz) >>= \ptrans_tp -> - withPermStackM (:>: Member_Base) - (\(pctx :>: _) -> - pctx - :>: PTrans_Conj [APTrans_LLVMFrame $ - flip nuMultiWithElim1 (extMb mb_fperm) $ - \(_ :>: ret) fperm -> (PExpr_Var ret, sz):fperm] - -- the unitTermLike argument is because ptrans_tp is a memblock permission - -- with an empty shape; the empty shape expects a unit argument - :>: typeTransF ptrans_tp []) - m - - [nuMP| TypedLLVMCreateFrame |] -> - withKnownNat ?ptrWidth $ - inExtTransM ETrans_LLVMFrame $ - withPermStackM (:>: Member_Base) - (:>: PTrans_Conj [APTrans_LLVMFrame $ fmap (const []) (extMb mb_stmt)]) - m - - [nuMP| TypedLLVMDeleteFrame _ _ _ |] -> - inExtTransM ETrans_Unit $ - withPermStackM (const MNil) (const MNil) m - - [nuMP| TypedLLVMLoadHandle _ tp _ |] -> - inExtTransM ETrans_Fun $ - withPermStackM ((:>: Member_Base) . RL.tail) - (\case - (pctx :>: PTrans_Conj [APTrans_LLVMFunPtr tp' ptrans]) - | Just Refl <- testEquality (mbLift tp) tp' -> - pctx :>: ptrans - _ -> error ("translateLLVMStmt: TypedLLVMLoadHandle: " - ++ "unexpected permission stack")) - m - - [nuMP| TypedLLVMResolveGlobal gsym (p :: ValuePerm (LLVMPointerType w))|] -> - withKnownNat ?ptrWidth $ - inExtTransM ETrans_LLVM $ - do env <- infoEnv <$> ask - let w :: NatRepr w = knownRepr - case lookupGlobalSymbol env (mbLift gsym) w of - Nothing -> - panic "translateLLVMStmt" - ["TypedLLVMResolveGlobal: no translation of symbol " - ++ globalSymbolName (mbLift gsym)] - Just (_, GlobalTrans ts) -> - do ptrans <- translate (extMb p) - withPermStackM (:>: Member_Base) (:>: typeTransF ptrans ts) m - - [nuMP| TypedLLVMIte _ mb_r1 _ _ |] -> - inExtTransM ETrans_LLVM $ - do b <- translate1 $ extMb mb_r1 - tptrans <- - translate $ mbCombine RL.typeCtxProxies $ - mbMapCl $(mkClosed - [| \stmt -> nu $ \ret -> - distPermsHeadPerm $ typedLLVMStmtOut stmt ret |]) - mb_stmt - let t = applyGlobalTermLike "Prelude.boolToEither" [b] - withPermStackM (:>: Member_Base) (:>: typeTransF tptrans [t]) m - - ----------------------------------------------------------------------- --- * Translating Sequences of Typed Crucible Statements ----------------------------------------------------------------------- - -instance PermCheckExtC ext exprExt => - Translate (ImpTransInfo ext blocks tops rets ps) ctx - (TypedRet tops rets ps) OpenTerm where - translate (mbMatch -> [nuMP| TypedRet Refl mb_rets mb_rets_ns mb_perms |]) = - do ev <- infoEvType <$> ask - let perms = - mbMap2 - (\rets_ns ps -> varSubst (permVarSubstOfNames rets_ns) ps) - mb_rets_ns mb_perms - () <- assertPermStackEqM "TypedRet" perms - rets_trans <- translate mb_rets - let rets_prxs = cruCtxProxies $ mbLift mb_rets - rets_ns_trans <- translate mb_rets_ns - ret_tp <- returnTypeM - retSOpenTerm ev ret_tp <$> - sigmaTransM "r" rets_trans - (flip inExtMultiTransM $ - translate $ mbCombine rets_prxs mb_perms) - rets_ns_trans (itiPermStack <$> ask) - -instance PermCheckExtC ext exprExt => - ImplTranslateF (TypedRet tops rets) ext blocks tops rets where - translateF mb_ret = translate mb_ret - -instance PermCheckExtC ext exprExt => - Translate (ImpTransInfo ext blocks tops rets ps) ctx - (TypedTermStmt blocks tops rets ps) OpenTerm where - translate mb_x = case mbMatch mb_x of - [nuMP| TypedJump impl_tgt |] -> translate impl_tgt - [nuMP| TypedBr reg impl_tgt1 impl_tgt2 |] -> - applyGlobalTransM "Prelude.ite" - [compReturnTypeM, translate1 reg, - translate impl_tgt1, translate impl_tgt2] - [nuMP| TypedReturn impl_ret |] -> translate impl_ret - [nuMP| TypedErrorStmt (Just str) _ |] -> - mkErrorComp ("Error: " ++ mbLift str) - [nuMP| TypedErrorStmt Nothing _ |] -> - mkErrorComp "Error (unknown message)" - - -instance PermCheckExtC ext exprExt => - Translate (ImpTransInfo ext blocks tops rets ps) ctx - (TypedStmtSeq ext blocks tops rets ps) OpenTerm where - translate mb_x = case mbMatch mb_x of - [nuMP| TypedImplStmt impl_seq |] -> translate impl_seq - [nuMP| TypedConsStmt loc stmt pxys mb_seq |] -> - translateStmt (mbLift loc) stmt (translate $ mbCombine (mbLift pxys) (_mbBinding <$> mb_seq)) - [nuMP| TypedTermStmt _ term_stmt |] -> translate term_stmt - -instance PermCheckExtC ext exprExt => - ImplTranslateF (TypedStmtSeq - ext blocks tops rets) ext blocks tops rets where - translateF mb_seq = translate mb_seq - - ----------------------------------------------------------------------- --- * Translating CFGs ----------------------------------------------------------------------- - --- | An entrypoint over some regular and ghost arguments -data SomeTypedEntry ext blocks tops rets = - forall ghosts args. - SomeTypedEntry (TypedEntry TransPhase ext blocks tops rets args ghosts) - --- | Get all entrypoints in a block map that will be translated to recursive --- functions, which is all entrypoints with in-degree > 1 -typedBlockRecEntries :: TypedBlockMap TransPhase ext blocks tops rets -> - [SomeTypedEntry ext blocks tops rets] -typedBlockRecEntries = - concat . RL.mapToList (map (\(Some entry) -> - SomeTypedEntry entry) - . filter (anyF typedEntryHasMultiInDegree) - . (^. typedBlockEntries)) - --- | Fold a function over each 'TypedEntry' in a 'TypedBlockMap' that --- corresponds to a letrec-bound variable -foldBlockMapRec :: - (forall args ghosts. - TypedEntry TransPhase ext blocks tops rets args ghosts -> b -> b) -> - b -> TypedBlockMap TransPhase ext blocks tops rets -> b -foldBlockMapRec f r = - foldr (\(SomeTypedEntry entry) -> f entry) r . typedBlockRecEntries - --- | Map a function over each 'TypedEntry' in a 'TypedBlockMap' that --- corresponds to a letrec-bound variable -mapBlockMapRecs :: - (forall args ghosts. - TypedEntry TransPhase ext blocks tops rets args ghosts -> b) -> - TypedBlockMap TransPhase ext blocks tops rets -> [b] -mapBlockMapRecs f = - map (\(SomeTypedEntry entry) -> f entry) . typedBlockRecEntries - --- | Build the type of the translation of a 'TypedEntry' to a function. This --- type will pi-abstract over the real and ghost arguments, but have the --- top-level arguments of the function free, and then form a function from the --- translations of the input to the output permissions -translateEntryType :: TypedEntry TransPhase ext blocks tops rets args ghosts -> - TypeTransM tops OpenTerm -translateEntryType (TypedEntry {..}) = - -- NOTE: we translate the return type here because it has only the tops and - -- rets free, not the args and ghosts - (translateRetType typedEntryRets typedEntryPermsOut) >>= \ret_tp -> - piExprCtxApp typedEntryArgs $ piExprCtxApp typedEntryGhosts $ - do ev <- infoEvType <$> ask - ps_in_trans <- translate typedEntryPermsIn - piTransM "p" ps_in_trans $ \_ -> return $ specMTypeOpenTerm ev ret_tp - --- | Build the type description of the type returned by 'translateEntryType' --- that is the type of the translation of a 'TypedEntry' to a function -translateEntryDesc :: TypedEntry TransPhase ext blocks tops rets args ghosts -> - TypeTransM tops OpenTerm -translateEntryDesc (TypedEntry {..}) = - descTransM $ - -- NOTE: we translate the return type here because it has only the tops and - -- rets free, not the args and ghosts - (translateRetTpDesc typedEntryRets typedEntryPermsOut) >>= \d_out -> - inExtCtxDescTransM typedEntryArgs $ \args_kdescs -> - inExtCtxDescTransM typedEntryGhosts $ \ghosts_kdescs -> - do ds_in <- translateDescs typedEntryPermsIn - return $ - piTpDescMulti (args_kdescs ++ ghosts_kdescs) $ funTpDesc ds_in d_out - --- | Build a list of the types of all of the entrypoints in a 'TypedBlockMap' --- that will be translated to recursive functions -translateBlockMapTypes :: TypedBlockMap TransPhase ext blocks tops rets -> - TypeTransM tops [OpenTerm] -translateBlockMapTypes blkMap = - sequence $ mapBlockMapRecs translateEntryType blkMap - --- | Build a list of the type descriptions of all of the entrypoints in a --- 'TypedBlockMap' that will be translated to recursive functions -translateBlockMapDescs :: TypedBlockMap TransPhase ext blocks tops rets -> - TypeTransM tops [OpenTerm] -translateBlockMapDescs blkMap = - sequence $ mapBlockMapRecs translateEntryDesc blkMap - --- | Translate the function permission of a CFG to a type description that --- pi-abstracts over the real and ghost arguments and then takes in the input --- permissions, returning a tuple of the output permissions. This is the same as --- the translation of its function permission to a type description. -translateCFGDesc :: TypedCFG ext blocks ghosts inits gouts ret -> - TypeTransM ctx OpenTerm -translateCFGDesc cfg = - nuMultiTransM (const $ tpcfgFunPerm cfg) >>= - descTransM . translateDesc - --- | Translate a 'TypedEntry' to a 'TypedEntryTrans' by associating a monadic --- function with it if it has one, i.e., if its in-degree is greater than 1. The --- state tracks all the @LetRecS@-bound functions for entrypoints that have not --- already been used, so if this 'TypedEntry' does need a function, it should --- take it from the head of that list. -translateTypedEntry :: - Some (TypedEntry TransPhase ext blocks tops rets args) -> - StateT [OpenTerm] (TypeTransM tops) (Some - (TypedEntryTrans ext blocks tops rets args)) -translateTypedEntry (Some entry) = - if typedEntryHasMultiInDegree entry then - do fs <- get - let (f, fs') = - case fs of - [] -> panic "translateTypedEntry" ["Ran out of functions"] - f_:fs'_ -> (f_, fs'_) - put fs' - return (Some (TypedEntryTrans entry $ Just f)) - else return $ Some (TypedEntryTrans entry Nothing) - --- | Translate a 'TypedBlock' to a 'TypedBlockTrans' by translating each --- entrypoint in the block using 'translateTypedEntry' -translateTypedBlock :: - TypedBlock TransPhase ext blocks tops rets args -> - StateT [OpenTerm] (TypeTransM tops) (TypedBlockTrans ext blocks tops rets args) -translateTypedBlock blk = - TypedBlockTrans <$> mapM translateTypedEntry (blk ^. typedBlockEntries) - --- | Helper function to translate a 'TypedBlockMap' to a 'TypedBlockMapTrans' by --- translating every entrypoint using 'translateTypedEntry' -translateTypedBlockMapH :: - RAssign (TypedBlock TransPhase ext blocks tops rets) blks -> - StateT [OpenTerm] (TypeTransM tops) (RAssign - (TypedBlockTrans ext blocks tops rets) blks) -translateTypedBlockMapH MNil = return MNil -translateTypedBlockMapH (blkMap :>: blk) = - do blkMapTrans <- translateTypedBlockMapH blkMap - blkTrans <- translateTypedBlock blk - return (blkMapTrans :>: blkTrans) - --- | Translate a 'TypedBlockMap' to a 'TypedBlockMapTrans' by translating every --- entrypoint using 'translateTypedEntry', using the supplied SAW core terms as --- the recursive functions for those entrypoints that have them -translateTypedBlockMap :: - [OpenTerm] -> TypedBlockMap TransPhase ext blocks tops rets -> - TypeTransM tops (TypedBlockMapTrans ext blocks tops rets) -translateTypedBlockMap fs blkMap = - runStateT (translateTypedBlockMapH blkMap) fs >>= \case - (ret, []) -> return ret - (_, _) -> panic "translateTypedBlockMap" ["Unused function indices"] - --- | Lambda-abstract over monadic functions for all the entrypoints that have --- one in a 'TypedBlockMap', whose types are given as the first argument, and --- then use those functions to translate the block map to a 'TypedBlockMapTrans' --- and pass it to the supplied function -lambdaBlockMap :: [OpenTerm] -> TypedBlockMap TransPhase ext blocks tops rets -> - (TypedBlockMapTrans ext blocks tops rets -> - TypeTransM tops OpenTerm) -> - TypeTransM tops OpenTerm -lambdaBlockMap blk_tps blkMap f = - lambdaTransM "f_loop" (openTermsTypeTrans blk_tps) $ \fs -> - translateTypedBlockMap fs blkMap >>= f - - --- | Translate the typed statements of an entrypoint to a function --- --- > \arg1 ... argm ghost1 ... ghostk p1 ... pj -> stmts_trans --- --- over the local and ghost arguments and (the translations of) the input --- permissions of the entrypoint, leaving the top-level variables free -translateEntryBody :: PermCheckExtC ext exprExt => - TypedBlockMapTrans ext blocks tops rets -> - TypedEntry TransPhase ext blocks tops rets args ghosts -> - TypeTransM tops OpenTerm -translateEntryBody mapTrans entry = - lambdaExprCtxApp (typedEntryArgs entry) $ - lambdaExprCtxApp (typedEntryGhosts entry) $ - lambdaPermCtx (typedEntryPermsIn entry) $ \pctx -> - do retType <- translateEntryRetType entry - impTransM (RL.members pctx) pctx mapTrans retType $ - translate $ _mbBinding $ typedEntryBody entry - --- | Translate all the entrypoints in a 'TypedBlockMap' that translate to --- recursive functions into the bodies of those functions -translateBlockMapBodies :: PermCheckExtC ext exprExt => - TypedBlockMapTrans ext blocks tops rets -> - TypedBlockMap TransPhase ext blocks tops rets -> - TypeTransM tops [OpenTerm] -translateBlockMapBodies mapTrans blkMap = - sequence $ mapBlockMapRecs (translateEntryBody mapTrans) blkMap - --- | Translate a CFG to a monadic function that takes all the top-level --- arguments to that CFG and calls into its initial entrypoint -translateCFGInitBody :: - PermCheckExtC ext exprExt => - TypedBlockMapTrans ext blocks (ghosts :++: inits) (gouts :> ret) -> - TypedCFG ext blocks ghosts inits gouts ret -> - PermTransCtx (ghosts :++: inits) (ghosts :++: inits) -> - TypeTransM (ghosts :++: inits) OpenTerm -translateCFGInitBody mapTrans cfg pctx = - let fun_perm = tpcfgFunPerm cfg - h = tpcfgHandle cfg - inits = typedFnHandleArgs h - ghosts = typedFnHandleGhosts h - retTypes = typedFnHandleRetTypes h in - translateRetType retTypes (tpcfgOutputPerms cfg) >>= \retTypeTrans -> - impTransM (RL.members pctx) pctx mapTrans retTypeTrans $ - - -- Extend the expr context to contain another copy of the initial arguments - -- inits, since the initial entrypoint for the entire function takes two - -- copies of inits, one to represent the top-level arguments and one to - -- represent the local arguments to the entrypoint, which just happen to be - -- the same as those top-level arguments and so get eq perms to relate them - inExtMultiTransCopyLastM ghosts (cruCtxProxies inits) $ - - -- Pass in all the terms in pctx to build pctx', which is the same permissions - -- as pctx except with all the eq permissions added to the end of the input - -- permissions by funPermToBlockInputs; these introduce no extra terms, so the - -- terms for the two are the same - translate (funPermToBlockInputs fun_perm) >>= \ps'_trans -> - let pctx' = typeTransF ps'_trans $ transTerms pctx - all_px = RL.map (\_ -> Proxy) pctx' - init_entry = lookupEntryTransCast (tpcfgEntryID cfg) CruCtxNil mapTrans in - withPermStackM (const $ RL.members pctx') (const pctx') $ - translateCallEntry "CFG" init_entry - (nuMulti all_px $ \ns -> fst $ RL.split pctx (cruCtxProxies inits) ns) - (nuMulti all_px $ \ns -> snd $ RL.split pctx (cruCtxProxies inits) ns) - (nuMulti all_px $ const MNil) - - --- | Translate a CFG to a function that takes in values for its top-level --- arguments (@ghosts@ and @inits@) along with all its input permissions and --- returns a sigma of its output values and permissions. This assumes that SAW --- core functions have been bound for the function itself and any other --- functions it is mutually recursive with, and that these SAW core functions --- are in the current permissions environment. That is, this translation is --- happening for the body of a @LetRecS@ definition that has bound SAW core --- functions for the function itself and all functions it is mutually recursive --- with. -translateCFGBody :: PermCheckExtC ext exprExt => - TypedCFG ext blocks ghosts inits gouts ret -> - TypeTransM RNil OpenTerm -translateCFGBody cfg = - let fun_perm = tpcfgFunPerm cfg - blkMap = tpcfgBlockMap cfg in - lambdaExprCtx (funPermTops fun_perm) $ - lambdaPermCtx (funPermIns fun_perm) $ \pctx -> - do ev <- infoEvType <$> ask - blk_ds <- translateBlockMapDescs $ tpcfgBlockMap cfg - blk_tps <- translateBlockMapTypes $ tpcfgBlockMap cfg - ret_tp <- translateRetType (funPermRets fun_perm) (funPermOuts fun_perm) - bodies <- - lambdaBlockMap blk_tps blkMap $ \mapTrans -> - tupleOpenTerm <$> translateBlockMapBodies mapTrans blkMap - body <- - lambdaBlockMap blk_tps blkMap $ \mapTrans -> - translateCFGInitBody mapTrans cfg pctx - return $ letRecSOpenTerm ev blk_ds ret_tp bodies body - - ----------------------------------------------------------------------- --- * Translating Sets of CFGs ----------------------------------------------------------------------- - --- | An existentially quantified tuple of a 'TypedCFG', its 'GlobalSymbol', and --- a 'String' name we want to translate it to -data SomeTypedCFG ext where - SomeTypedCFG :: PermCheckExtC ext exprExt => GlobalSymbol -> String -> - TypedCFG ext blocks ghosts inits gouts ret -> - SomeTypedCFG ext - --- | Helper function to build an LLVM function permission from a 'FunPerm' -mkPtrFunPerm :: HasPtrWidth w => FunPerm ghosts args gouts ret -> - ValuePerm (LLVMPointerType w) -mkPtrFunPerm fun_perm = - withKnownNat ?ptrWidth $ ValPerm_Conj1 $ mkPermLLVMFunPtr ?ptrWidth fun_perm - --- | Extract the 'FunPerm' of a 'SomeTypedCFG' as a permission on LLVM function --- pointer values -someTypedCFGPtrPerm :: HasPtrWidth w => SomeTypedCFG LLVM -> - ValuePerm (LLVMPointerType w) -someTypedCFGPtrPerm (SomeTypedCFG _ _ cfg) = mkPtrFunPerm $ tpcfgFunPerm cfg - --- | Apply 'translateCFGDesc' to the CFG in a 'SomeTypedCFG' -translateSomeCFGDesc :: SomeTypedCFG LLVM -> TypeTransM ctx OpenTerm -translateSomeCFGDesc (SomeTypedCFG _ _ cfg) = translateCFGDesc cfg - --- | Translate a CFG to its type as a specification function -translateSomeCFGType :: SomeTypedCFG LLVM -> TypeTransM ctx OpenTerm -translateSomeCFGType (SomeTypedCFG _ _ cfg) = - translateClosed (tpcfgFunPerm cfg) - --- | Apply 'translateCFGBody' to the CFG in a 'SomeTypedCFG' -translateSomeCFGBody :: SomeTypedCFG LLVM -> TypeTransM RNil OpenTerm -translateSomeCFGBody (SomeTypedCFG _ _ cfg) = translateCFGBody cfg - --- | Build an entry in a permissions environment that associates the symbol of a --- 'SomeTypedCFG' with a function term -someTypedCFGFunEntry :: HasPtrWidth w => SomeTypedCFG LLVM -> OpenTerm -> - PermEnvGlobalEntry -someTypedCFGFunEntry some_cfg@(SomeTypedCFG sym _ _) f = - withKnownNat ?ptrWidth $ - PermEnvGlobalEntry sym (someTypedCFGPtrPerm some_cfg) - (GlobalTrans [f]) - --- | Build a lambda-abstraction that takes in function indexes for all the CFGs --- in a list and then run the supplied computation with a 'PermEnv' that --- includes translations of the symbols for these CFGs to their corresponding --- lambda-bound function indexes in this lambda-abstraction -lambdaCFGPermEnv :: HasPtrWidth w => [SomeTypedCFG LLVM] -> - TypeTransM ctx OpenTerm -> TypeTransM ctx OpenTerm -lambdaCFGPermEnv some_cfgs m = - mapM translateSomeCFGType some_cfgs >>= \tps -> - lambdaTransM "f" (openTermsTypeTrans tps) $ \fs -> - let entries = zipWith someTypedCFGFunEntry some_cfgs fs in - local (\info -> - info { ttiPermEnv = - permEnvAddGlobalSyms (ttiPermEnv info) entries }) m - --- | Translate a list of CFGs to a SAW core term of type @MultiFixBodies@ that --- lambda-abstracts over function indexes for all the CFGs and returns a tuple --- of their bodies as created by 'translateCFGBody' -translateCFGBodiesTerm :: HasPtrWidth w => [SomeTypedCFG LLVM] -> - TypeTransM RNil OpenTerm -translateCFGBodiesTerm some_cfgs = - lambdaCFGPermEnv some_cfgs (tupleOpenTerm <$> - mapM translateSomeCFGBody some_cfgs) - --- | Build a @LetRecS@ term for the nth CFG in a list of CFGs that it is --- potentially mutually recursive with those CFGs from a SAW core term of type --- @MultiFixBodies@ that specifies how these corecursive functions are defined --- in terms of themselves and each other -translateCFGFromBodies :: HasPtrWidth w => [SomeTypedCFG LLVM] -> OpenTerm -> - Int -> TypeTransM RNil OpenTerm -translateCFGFromBodies cfgs _ i - | i >= length cfgs - = panic "translateCFGFromBodies" ["Index out of bounds!"] -translateCFGFromBodies cfgs bodies i - | SomeTypedCFG _ _ cfg <- cfgs!!i = - let fun_perm = tpcfgFunPerm cfg in - lambdaExprCtx (funPermTops fun_perm) $ - lambdaPermCtx (funPermIns fun_perm) $ \pctx -> - do ev <- infoEvType <$> ask - ectx <- infoCtx <$> ask - ds <- mapM translateSomeCFGDesc cfgs - tps <- mapM translateSomeCFGType cfgs - ret_tp <- translateRetType (funPermRets fun_perm) (funPermOuts fun_perm) - specMTransM ret_tp $ - do body <- - lambdaTransM "f" (openTermsTypeTrans tps) $ \fs -> - return $ applyOpenTermMulti (fs!!i) (transTerms ectx - ++ transTerms pctx) - return $ letRecSOpenTerm ev ds ret_tp bodies body - --- | Translate a list of CFGs for mutually recursive functions to: a list of --- type descriptions for the CFGS; a SAW core term of type @MultiFixBodies@ that --- defines these functions mutually in terms of themselves; and a function that --- takes in such a @MultiFixBodies@ term and returns a list of SAW core types --- and functions for these CFGs that are defined using the @MultiFixBodies@ --- term. This separation allows the caller to insert the @MultiFixBodies@ term --- as a SAW core named definition and use the definition name in the --- translations to functions. -translateCFGs :: HasPtrWidth w => PermEnv -> ChecksFlag -> - [SomeTypedCFG LLVM] -> - ([OpenTerm], OpenTerm, OpenTerm -> [(OpenTerm,OpenTerm)]) -translateCFGs env checks some_cfgs = - (runNilTypeTransM env checks (mapM translateSomeCFGDesc some_cfgs), - runNilTypeTransM env checks (translateCFGBodiesTerm some_cfgs), - \bodies -> - runNilTypeTransM env checks - (zip <$> mapM translateSomeCFGType some_cfgs <*> - mapM (translateCFGFromBodies some_cfgs bodies) [0..(length some_cfgs-1)])) - - --- | An existentially quantified tuple of a 'CFG', its function permission, and --- a 'String' name we want to translate it to -data SomeCFGAndPerm ext where - SomeCFGAndPerm :: GlobalSymbol -> String -> CFG ext blocks inits ret -> - FunPerm ghosts (CtxToRList inits) gouts ret -> - SomeCFGAndPerm ext - --- | Extract the 'GlobalSymbol' from a 'SomeCFGAndPerm' -someCFGAndPermSym :: SomeCFGAndPerm ext -> GlobalSymbol -someCFGAndPermSym (SomeCFGAndPerm sym _ _ _) = sym - --- | Extract the 'String' name from a 'SomeCFGAndPerm' -someCFGAndPermToName :: SomeCFGAndPerm ext -> String -someCFGAndPermToName (SomeCFGAndPerm _ nm _ _) = nm - --- | Map a 'SomeCFGAndPerm' to a 'PermEnvGlobalEntry' with no translation, i.e., --- with an 'error' term for the translation. This is used to type-check --- functions that may call themselves before they have been translated. -someCFGAndPermGlobalEntry :: HasPtrWidth w => SomeCFGAndPerm ext -> - PermEnvGlobalEntry -someCFGAndPermGlobalEntry (SomeCFGAndPerm sym _ _ fun_perm) = - withKnownNat ?ptrWidth $ - PermEnvGlobalEntry sym (mkPtrFunPerm fun_perm) $ - panic "someCFGAndPermGlobalEntry" - ["Attempt to translate CFG during its own type-checking"] - --- | Type-check a list of functions in the Heapster type system, translate each --- to a spec definition bound to the SAW core 'String' name associated with it, --- add these translations as function permissions in the current environment, --- and return the list of type-checked CFGs -tcTranslateAddCFGs :: - HasPtrWidth w => SharedContext -> ModuleName -> PermEnv -> ChecksFlag -> - EndianForm -> DebugLevel -> [SomeCFGAndPerm LLVM] -> - IO (PermEnv, [SomeTypedCFG LLVM]) - --- NOTE: we add an explicit case for the empty list so we can take head of the --- cfgs_and_perms list below and know it will succeeed -tcTranslateAddCFGs _ _ env _ _ _ [] = return (env, []) - -tcTranslateAddCFGs sc mod_name env checks endianness dlevel cfgs_and_perms@(cfg_and_perm:_) = - do - -- First, we type-check all the CFGs, mapping them to SomeTypedCFGs; this - -- uses a temporary PermEnv where all the function symbols being - -- type-checked are assigned their permissions, but no translation yet - let tmp_env1 = - permEnvAddGlobalSyms env $ - map someCFGAndPermGlobalEntry cfgs_and_perms - let tc_cfgs = - flip map cfgs_and_perms $ \(SomeCFGAndPerm gsym nm cfg fun_perm) -> - SomeTypedCFG gsym nm $ - debugTraceTraceLvl dlevel ("Type-checking " ++ show gsym) $ - debugTrace verboseDebugLevel dlevel - ("With type:\n" ++ permPrettyString emptyPPInfo fun_perm) $ - tcCFG ?ptrWidth tmp_env1 endianness dlevel fun_perm cfg - - -- Next, translate those CFGs to a @MultiFixBodies@ term and a function from - -- that term to all the types and definitions for those CFGs - let (ds, bodies, trans_f) = translateCFGs env checks tc_cfgs - - -- Insert a SAW core definition in the current SAW module for bodies - let ev = permEnvEventType env - let bodies_id = - mkSafeIdent mod_name (someCFGAndPermToName cfg_and_perm - ++ "__bodies") - bodies_tp <- completeOpenTerm sc $ multiFixBodiesOpenTerm ev ds - bodies_tm <- completeOpenTerm sc bodies - scInsertDef sc bodies_id bodies_tp bodies_tm - - -- Now insert SAW core definitions for the translations of all the CFGs, - -- putting them all into new entries for the permissions environment - new_entries <- - zipWithM - (\(SomeTypedCFG sym nm cfg) (tp, f) -> - withKnownNat ?ptrWidth $ - do tp_trm <- completeOpenTerm sc tp - f_trm <- completeOpenTerm sc f - let ident = mkSafeIdent mod_name nm - scInsertDef sc ident tp_trm f_trm - let perm = mkPtrFunPerm $ tpcfgFunPerm cfg - return $ PermEnvGlobalEntry sym perm (GlobalTrans - [globalOpenTerm ident])) - tc_cfgs (trans_f $ globalOpenTerm bodies_id) - - -- Finally, add the new entries to the environment and return the new - -- environment and the type-checked CFGs - return (permEnvAddGlobalSyms env new_entries, tc_cfgs) - - ----------------------------------------------------------------------- --- * Top-level Entrypoints for Translating Other Things ----------------------------------------------------------------------- - --- | Translate a function permission to the type of the translation of a --- function with that function permission -translateCompleteFunPerm :: SharedContext -> PermEnv -> - FunPerm ghosts args gouts ret -> IO Term -translateCompleteFunPerm sc env fun_perm = - completeNormOpenTerm sc $ - runNilTypeTransM env noChecks (translateClosed fun_perm) - --- | Translate a 'TypeRepr' to the SAW core type it represents, raising an error --- if it translates to more than one type -translateCompleteType :: SharedContext -> PermEnv -> TypeRepr tp -> IO Term -translateCompleteType sc env tp = - let ?ev = permEnvEventType env in - completeNormOpenTerm sc $ typeTransType1 $ fst $ translateType tp - --- | Translate a 'TypeRepr' within the given context of type arguments to the --- SAW core type it represents -translateCompleteTypeInCtx :: SharedContext -> PermEnv -> - CruCtx args -> Mb args (TypeRepr a) -> IO Term -translateCompleteTypeInCtx sc env args ret = - let ?ev = permEnvEventType env in - completeNormOpenTerm sc $ runNilTypeTransM env noChecks $ - piExprCtx args (return $ typeTransType1 $ fst $ translateType $ mbLift ret) - --- | Translate a type-like construct to a type description of the type it --- represents in a context of free deBruijn indices -translateCompleteDescInCtx :: TranslateDescs a => SharedContext -> PermEnv -> - CruCtx args -> Mb args a -> IO Term -translateCompleteDescInCtx sc env args mb_a = - completeOpenTerm sc $ runNilTypeTransM env noChecks $ descTransM $ - inCtxDescTransM args $ const $ translateDesc mb_a - --- | Translate an input list of 'ValuePerms' and an output 'ValuePerm' to a pure --- SAW core function type, not in the @SpecM@ monad -translateCompletePureFunType :: SharedContext -> PermEnv - -> CruCtx ctx -- ^ Type arguments - -> Mb ctx (ValuePerms args) -- ^ Input perms - -> Mb ctx (ValuePerm ret) -- ^ Return type perm - -> IO Term -translateCompletePureFunType sc env ctx ps_in p_out = - completeNormOpenTerm sc $ runNilTypeTransM env noChecks $ piExprCtx ctx $ - do tps_in <- typeTransTypes <$> translate ps_in - tp_out <- typeTransTupleType <$> translate p_out - return $ piOpenTermMulti (map ("_",) tps_in) (const tp_out) - --- | Translate a context of arguments to the type --- > (arg1:tp1) -> ... (argn:tpn) -> sort 0 --- of a type-level function over those arguments -translateExprTypeFunType :: SharedContext -> PermEnv -> CruCtx ctx -> IO Term -translateExprTypeFunType sc env ctx = - completeOpenTerm sc $ runNilTypeTransM env noChecks $ - piExprCtx ctx $ return $ sortOpenTerm $ mkSort 0 - --- | Translate a context of Crucible types @(tp1,...,tpn)@ that translates to a --- sequence @(k1,...,km)@ of kind descriptions plus a type description @d@ with --- those arguments free (as type description @Tp_Var@ deBruijn variables, not as --- SAW core free variables) into the type function that @d@ describes, which is: --- --- > \ (x1:kindElem k1) ... (xn:kindElem k2) -> tpElemEnv ev [x1,...,xn] d --- --- This is computed by the @pureTpElemTypeFun@ combinator in the @SpecM@ SAW --- core module, so we just build this term by applying that combinator. -translateDescTypeFun :: SharedContext -> PermEnv -> CruCtx ctx -> - OpenTerm -> IO Term -translateDescTypeFun sc env ctx d = - let ?ev = permEnvEventType env in - let klist = listOpenTerm (dataTypeOpenTerm - "SpecM.KindDesc" []) (snd $ translateCruCtx ctx) in - completeNormOpenTerm sc $ - applyGlobalOpenTerm "SpecM.pureTpElemTypeFun" [evTypeTerm ?ev, klist, d] - --- | Translate a context of arguments plus a type description @T@ that describes --- the body of an inductive type over those arguments -- meaning that it uses --- deBruijn index 0 for recursive occurrences of itself and the remaining --- deBruijn indices for the arguments -- to the type-level function --- --- > \ arg1 -> ... \argn -> tpElemEnv (arg1, ..., argn) (Tp_Ind T) --- --- that takes in the arguments and builds the inductive type -translateIndTypeFun :: SharedContext -> PermEnv -> CruCtx ctx -> OpenTerm -> - IO Term -translateIndTypeFun sc env ctx d = - let ?ev = permEnvEventType env in - completeOpenTerm sc $ runNilTypeTransM env noChecks $ - lambdaExprCtx ctx $ - do args_tms <- transTerms <$> infoCtx <$> ask - let ks = snd $ translateCruCtx ctx - return $ applyGlobalOpenTerm "SpecM.tpElemEnv" - [evTypeTerm (permEnvEventType env), tpEnvOpenTerm (zip ks args_tms), - ctorOpenTerm "SpecM.IsData" [], indTpDesc d] diff --git a/heapster/src/Heapster/Token.hs b/heapster/src/Heapster/Token.hs deleted file mode 100644 index ca6155721f..0000000000 --- a/heapster/src/Heapster/Token.hs +++ /dev/null @@ -1,163 +0,0 @@ -module Heapster.Token - ( Token(..), - tokenNat, - tokenIdent, - describeToken, - ) where - -import GHC.Natural (Natural) - --- | Lexical token generated by 'Heapster.Lexer.lexer' -data Token - = TOpenParen -- ^ symbol @(@ - | TCloseParen -- ^ symbol @)@ - | TOpenBrack -- ^ symbol @[@ - | TCloseBrack -- ^ symbol @]@ - | TOpenBrace -- ^ symbol @{@ - | TCloseBrace -- ^ symbol @}@ - | TOpenAngle -- ^ symbol @<@ - | TCloseAngle -- ^ symbol @>@ - | TColon -- ^ symbol @:@ - | TDot -- ^ symbol @.@ - | TSemicolon -- ^ symbol @;@ - | TComma -- ^ symbol @,@ - | TPlus -- ^ symbol @+@ - | TMinus -- ^ symbol @-@ - | TStar -- ^ symbol @*@ - | TAt -- ^ symbol @\@@ - | TLoli -- ^ symbol @-o@ - | TMapsTo -- ^ symbol @|->@ - | TEqual -- ^ symbol @==@ - | TNotEqual -- ^ symbol @/=@ - | TUnsignedLt -- ^ symbol @ Maybe Natural -tokenNat (TNatLit n) = Just n -tokenNat _ = Nothing - --- | Recognizer for 'TIdent' constructor. --- Returns constructor argument if matched. -tokenIdent :: Token -> Maybe String -tokenIdent (TIdent n) = Just n -tokenIdent _ = Nothing - --- | Human readable description of a token for error reporting. -describeToken :: Token -> String -describeToken t = - case t of - TOpenParen -> "'('" - TCloseParen -> "')'" - TOpenBrack -> "'['" - TCloseBrack -> "']'" - TOpenBrace -> "'{'" - TCloseBrace -> "'}'" - TOpenAngle -> "'<'" - TCloseAngle -> "'>'" - TColon -> "':'" - TDot -> "'.'" - TComma -> "','" - TSemicolon -> "';'" - TPlus -> "'+'" - TMinus -> "'-'" - TStar -> "'*'" - TAt -> "'@'" - TLoli -> "'-o'" - TMapsTo -> "'|->'" - TEqual -> "'=='" - TNotEqual -> "'/='" - TUnsignedLt -> "' "'<=u'" - TOr -> "keyword 'or'" - TTrue -> "keyword 'true'" - TFalse -> "keyword 'false'" - TAny -> "keyword 'any'" - TEmpty -> "keyword 'empty'" - TExists -> "keyword 'exists'" - TEq -> "keyword 'eq'" - TUnit -> "keyword 'unit'" - TBool -> "keyword 'bool'" - TNat -> "keyword 'nat'" - TBV -> "keyword 'bv'" - TArray -> "keyword 'array'" - TPtr -> "keyword 'ptr'" - TPerm -> "keyword 'perm'" - TLlvmPtr -> "keyword 'llvmptr'" - TLlvmFunPtr -> "keyword 'llvmfunptr'" - TLlvmFrame -> "keyword 'llvmframe'" - TLlvmShape -> "keyword 'llvmshape'" - TLlvmBlock -> "keyword 'llvmblock'" - TLlvmWord -> "keyword 'llvmword'" - TLifetime -> "keyword 'lifetime'" - TLOwned -> "keyword 'lowned'" - TLCurrent -> "keyword 'lcurrent'" - TLFinished -> "keyword 'lfinished'" - TRWModality -> "keyword 'rwmodality'" - TPermList -> "keyword 'permlist'" - TStruct -> "keyword 'struct'" - TShape -> "keyword 'shape'" - TEmptySh -> "keyword 'emptysh'" - TFalseSh -> "keyword 'falsesh'" - TEqSh -> "keyword 'eqsh'" - TPtrSh -> "keyword 'ptrsh'" - TFieldSh -> "keyword 'fieldsh'" - TArraySh -> "keyword 'arraysh'" - TTupleSh -> "keyword 'tuplesh'" - TExSh -> "keyword 'exsh'" - TOrSh -> "keyword 'orsh'" - TMemBlock -> "keyword 'memblock'" - TFree -> "keyword 'free'" - TAlways -> "keyword 'always'" - TR -> "keyword 'R'" - TW -> "keyword 'W'" - TIdent ident -> "identifier " ++ ident - TNatLit n -> "literal " ++ show n - TError _ -> "lexical error" diff --git a/heapster/src/Heapster/TypeChecker.hs b/heapster/src/Heapster/TypeChecker.hs deleted file mode 100644 index 10343de277..0000000000 --- a/heapster/src/Heapster/TypeChecker.hs +++ /dev/null @@ -1,782 +0,0 @@ -{-# Language GADTs #-} -{-# Language RecordWildCards #-} -{-# Language FlexibleContexts #-} -{-# Language LambdaCase #-} -{-# Language BlockArguments #-} -{-# Language RankNTypes #-} -{-# Language TemplateHaskell #-} -{-# Language QuasiQuotes #-} -{-# Language TypeOperators #-} -{-# Language DataKinds #-} -{-# Language ViewPatterns #-} -{-# Language ScopedTypeVariables #-} -{-# Language KindSignatures #-} -{-# Options_GHC -Wno-unused-foralls #-} -module Heapster.TypeChecker ( - -- * Checker type - Tc, startTc, - - -- * Checker errors - TypeError(..), - - -- * Checker entry-points - tcFunPerm, - tcCtx, - tcType, - tcExpr, - tcValPerm, - inParsedCtxM, - tcAtomicPerms, - tcValPermInCtx, - tcSortedMbValuePerms, - ) where - -import Control.Monad -import qualified Data.BitVector.Sized as BV -import Data.BitVector.Sized (BV) -import Data.Functor.Product -import Data.Functor.Constant -import GHC.TypeLits (Nat, KnownNat) -import GHC.Natural - -import Data.Binding.Hobbits -import Data.Binding.Hobbits.MonadBind - -import Prettyprinter hiding (comma, space) - -import qualified Data.Type.RList as RL -import Data.Parameterized.Some (Some(Some), mapSome) -import qualified Data.Parameterized.Context as Ctx -import Data.Parameterized.BoolRepr (BoolRepr(TrueRepr)) - -import Lang.Crucible.Types -import Lang.Crucible.LLVM.MemModel -import Lang.Crucible.LLVM.Bytes - -import Heapster.Permissions -import Heapster.CruUtil -import Heapster.Located -import Heapster.UntypedAST -import Heapster.ParsedCtx - ----------------------------------------------------------------------- --- * Type-checking environment ----------------------------------------------------------------------- - -data TcEnv = TcEnv { - tcEnvExprVars :: [(String, TypedName)], - tcEnvPermEnv :: PermEnv -} - ----------------------------------------------------------------------- --- * Type errors ----------------------------------------------------------------------- - -data TypeError = TypeError Pos String - deriving Show - -mkNuMatching [t| TypeError |] - -instance Closable TypeError where - toClosed = unsafeClose - -instance Liftable TypeError where - mbLift = unClosed . mbLift . fmap toClosed - ----------------------------------------------------------------------- --- * Type-checking type ----------------------------------------------------------------------- - --- | Type-checking computations carrying a 'TcEnv' and which --- can fail. Access the environment with 'tcLocal' and 'tcAsk' --- and fail with 'tcError'. -newtype Tc a = Tc { runTc :: TcEnv -> Either TypeError a } - --- | Run a type-checking computation given an initial permission --- environment. -startTc :: - Tc a {- ^ typechecking action -} -> - PermEnv {- ^ permission environment -} -> - Either TypeError a -startTc tc env = runTc tc (TcEnv [] env) - --- | 'fmap' derived from 'Monad' -instance Functor Tc where - fmap = liftM - --- | ('<*>') derived from 'Monad' -instance Applicative Tc where - pure x = Tc \_ -> Right x - (<*>) = ap - -instance Monad Tc where - Tc f >>= g = Tc \env -> - do x <- f env - runTc (g x) env - -instance MonadBind Tc where - mbM m = Tc \env -> - case mbMatch $ fmap (`runTc` env) m of - [nuMP| Left e |] -> Left (mbLift e) - [nuMP| Right x |] -> Right x - --- | Run type-checking computation with local changes to the --- type-checking environment. -tcLocal :: - (TcEnv -> TcEnv) {- ^ environment update -} -> - Tc a -> Tc a -tcLocal f (Tc k) = Tc (k . f) - --- | Get current type-checking environment -tcAsk :: Tc TcEnv -tcAsk = Tc Right - --- | Abort checking with an error message -tcError :: - Pos {- ^ error location -} -> - String {- ^ error message -} -> - Tc a -tcError p err = Tc (\_ -> Left (TypeError p err)) - ----------------------------------------------------------------------- --- * Casting ----------------------------------------------------------------------- - --- | Cast a typed value to the requested type or --- raise an error in 'Tc' -tcCastTyped :: - Pos {- ^ position of expression -} -> - TypeRepr a {- ^ target type -} -> - Typed f b {- ^ expression -} -> - Tc (f a) {- ^ casted expression -} -tcCastTyped p tp (Typed tp' f) = - case testEquality tp tp' of - Just Refl -> pure f - Nothing -> tcError p ("Expected type " ++ show tp ++ ", got type " ++ show tp') - ----------------------------------------------------------------------- --- * Extending variable environment ----------------------------------------------------------------------- - --- | Run a parsing computation in a context extended with an expression variable -withExprVar :: - String {- ^ identifier -} -> - TypeRepr tp {- ^ type of identifer -} -> - ExprVar tp {- ^ implementation -} -> - Tc a -> Tc a -withExprVar str tp x = tcLocal \env -> - env { tcEnvExprVars = (str, Some (Typed tp x)) : tcEnvExprVars env } - --- | Run a parsing computation in a context extended with 0 or more expression --- variables -withExprVars :: - RAssign (Constant String) ctx -> - CruCtx ctx -> - RAssign Name ctx -> - Tc a -> - Tc a -withExprVars MNil CruCtxNil MNil m = m -withExprVars (xs :>: Constant x) (CruCtxCons ctx tp) (ns :>: n) m = withExprVars xs ctx ns (withExprVar x tp n m) - ----------------------------------------------------------------------- --- * Checking Types ----------------------------------------------------------------------- - --- | Check an 'AstType' as a 'TypeRepr' -tcType :: AstType -> Tc (Some TypeRepr) -tcType t = mapSome unKnownReprObj <$> tcTypeKnown t - --- | Check an 'AstType' and build a @'KnownRepr' 'TypeRepr'@ instance for it -tcTypeKnown :: AstType -> Tc (Some (KnownReprObj TypeRepr)) -tcTypeKnown t = - case t of - TyUnit {} -> pure (Some (mkKnownReprObj UnitRepr)) - TyBool {} -> pure (Some (mkKnownReprObj BoolRepr)) - TyNat {} -> pure (Some (mkKnownReprObj NatRepr)) - TyLifetime {} -> pure (Some (mkKnownReprObj LifetimeRepr)) - TyRwModality {} -> pure (Some (mkKnownReprObj RWModalityRepr)) - TyPermList {} -> pure (Some (mkKnownReprObj PermListRepr)) - - TyBV p n -> - withPositive p "Zero bitvector width not allowed" n \w -> - pure (Some (mkKnownReprObj (BVRepr w))) - TyLlvmPtr p n -> - withPositive p "Zero LLVM Ptr width not allowed" n \w -> - pure (Some (mkKnownReprObj (LLVMPointerRepr w))) - TyLlvmFrame p n -> - withPositive p "Zero LLVM Frame width not allowed" n \w -> - pure (Some (mkKnownReprObj (LLVMFrameRepr w))) - TyLlvmShape p n -> - withPositive p "Zero LLVM Shape width not allowed" n \w -> - pure (Some (mkKnownReprObj (LLVMShapeRepr w))) - TyLlvmBlock p n -> - withPositive p "Zero LLVM Block width not allowed" n \w -> - pure (Some (mkKnownReprObj (LLVMBlockRepr w))) - - TyStruct _ fs -> - do fs1 <- traverse tcTypeKnown fs - let fs2 = foldl structAdd (Some (mkKnownReprObj Ctx.empty)) fs1 - case fs2 of - Some xs@KnownReprObj -> pure (Some (mkKnownReprObj (StructRepr (unKnownReprObj xs)))) - - TyPerm _ x -> - do Some tp@KnownReprObj <- tcTypeKnown x - pure (Some (mkKnownReprObj (ValuePermRepr (unKnownReprObj tp)))) - --- | Helper function for building struct type lists -structAdd :: - Some (KnownReprObj (Ctx.Assignment TypeRepr)) -> - Some (KnownReprObj TypeRepr) -> - Some (KnownReprObj (Ctx.Assignment TypeRepr)) -structAdd (Some acc@KnownReprObj) (Some x@KnownReprObj) = - Some (mkKnownReprObj (Ctx.extend (unKnownReprObj acc) (unKnownReprObj x))) - ----------------------------------------------------------------------- --- * Checking Expressions ----------------------------------------------------------------------- - --- | Parse an identifier as an expression variable of a specific type -tcVar :: - TypeRepr a {- ^ expected type -} -> - Pos {- ^ identifier position -} -> - String {- ^ identifier -} -> - Tc (ExprVar a) -tcVar ty p name = - do Some tn <- tcTypedName p name - tcCastTyped p ty tn - --- | Check a valid identifier string as an expression variable -tcTypedName :: - Pos {- ^ identifier position -} -> - String {- ^ identifier -} -> - Tc TypedName -tcTypedName p name = - do env <- tcAsk - case lookup name (tcEnvExprVars env) of - Nothing -> tcError p ("Unknown variable:" ++ name) - Just stn -> pure stn - --- | Check an 'AstExpr' as a 'PermExpr' with a known type. -tcKExpr :: KnownRepr TypeRepr a => AstExpr -> Tc (PermExpr a) -tcKExpr = tcExpr knownRepr - --- | Check an 'AstExpr' as a 'PermExpr' with a given type. --- This is a top-level entry-point to the checker that will --- resolve variables. -tcExpr :: TypeRepr a -> AstExpr -> Tc (PermExpr a) -tcExpr ty (ExVar p name Nothing Nothing) = PExpr_Var <$> tcVar ty p name - -tcExpr tp@(LLVMShapeRepr w) (ExVar p name (Just args) Nothing) = - do env <- tcAsk - case lookupNamedShape (tcEnvPermEnv env) name of - Just (SomeNamedShape nmsh) - | Just Refl <- testEquality w (natRepr nmsh) -> - do sub <- tcExprs p (namedShapeArgs nmsh) args - pure (PExpr_NamedShape Nothing Nothing nmsh sub) - Just (SomeNamedShape nmsh) -> - tcError p $ renderDoc $ sep - [ pretty "Named shape" <+> pretty name <+> - pretty "is of incorrect type" - , pretty "Expected:" <+> permPretty emptyPPInfo tp - , pretty "Found:" <+> - permPretty emptyPPInfo (LLVMShapeRepr (natRepr nmsh)) ] - Nothing -> tcError p ("Unknown shape name: " ++ name) - -tcExpr tp@(ValuePermRepr sub_tp) (ExVar p name (Just args) Nothing) = - do env <- tcAsk - case lookupNamedPermName (tcEnvPermEnv env) name of - Just (SomeNamedPermName npn) - | Just Refl <- testEquality (namedPermNameType npn) sub_tp -> - do arg_exprs <- tcExprs p (namedPermNameArgs npn) args - pure (PExpr_ValPerm $ ValPerm_Named npn arg_exprs NoPermOffset) - Just (SomeNamedPermName npn) -> - tcError p $ renderDoc $ sep - [ pretty "Named permission" <+> pretty (namedPermNameName npn) <+> - pretty "is of incorrect type" - , pretty "Expected:" <+> permPretty emptyPPInfo tp - , pretty "Found:" <+> permPretty emptyPPInfo (namedPermNameType npn) ] - Nothing -> tcError p ("Unknown shape name: " ++ name) - -tcExpr _ (ExVar p _ Just{} _) = tcError p "Unexpected variable instantiation" -tcExpr _ (ExVar p _ _ Just{}) = tcError p "Unexpected variable offset" - -tcExpr UnitRepr e = tcUnit e -tcExpr NatRepr e = tcNat e -tcExpr (BVRepr w) e = withKnownNat w (normalizeBVExpr <$> tcBV e) -tcExpr (StructRepr fs) e = tcStruct fs e -tcExpr LifetimeRepr e = tcLifetimeLit e -tcExpr (LLVMPointerRepr w) e = withKnownNat w (tcLLVMPointer w e) -tcExpr FunctionHandleRepr{} e = tcError (pos e) "Expected functionhandle" -- no literals -tcExpr PermListRepr e = tcError (pos e) "Expected permlist" -- no literals -tcExpr RWModalityRepr e = tcRWModality e -tcExpr (ValuePermRepr t) e = permToExpr <$> tcValPerm t e -tcExpr (LLVMShapeRepr w) e = withKnownNat w (tcLLVMShape e) - -tcExpr (IntrinsicRepr s _) e = tcError (pos e) ("Expected intrinsic type: " ++ show s) - --- reprs that we explicitly do not support -tcExpr BoolRepr e = tcError (pos e) "Expected boolean" -tcExpr IntegerRepr e = tcError (pos e) "Expected integerl" -tcExpr AnyRepr e = tcError (pos e) "Expected any type" -tcExpr RealValRepr e = tcError (pos e) "Expected realval" -tcExpr ComplexRealRepr e = tcError (pos e) "Expected realval" -tcExpr CharRepr e = tcError (pos e) "Expected char" -tcExpr RecursiveRepr {} e = tcError (pos e) "Expected recursive-value" -tcExpr FloatRepr {} e = tcError (pos e) "Expected float" -tcExpr IEEEFloatRepr {} e = tcError (pos e) "Expected ieeefloat" -tcExpr StringRepr {} e = tcError (pos e) "Expected string" -tcExpr MaybeRepr {} e = tcError (pos e) "Expected maybe" -tcExpr VectorRepr {} e = tcError (pos e) "Expected vector" -tcExpr VariantRepr {} e = tcError (pos e) "Expected variant" -tcExpr ReferenceRepr {} e = tcError (pos e) "Expected reference" -tcExpr WordMapRepr {} e = tcError (pos e) "Expected wordmap" -tcExpr StringMapRepr {} e = tcError (pos e) "Expected stringmap" -tcExpr SymbolicArrayRepr {} e = tcError (pos e) "Expected symbolicarray" -tcExpr SymbolicStructRepr{} e = tcError (pos e) "Expected symbolicstruct" -tcExpr SequenceRepr {} e = tcError (pos e) "Expected sequencerepr" - --- | Check for a unit literal -tcUnit :: AstExpr -> Tc (PermExpr UnitType) -tcUnit ExUnit{} = pure PExpr_Unit -tcUnit e = tcError (pos e) "Expected unit" - --- | Check for a nat literal -tcNat :: AstExpr -> Tc (PermExpr NatType) -tcNat (ExNat _ i) = pure (PExpr_Nat i) -tcNat e = tcError (pos e) "Expected integer" - --- | Check for a bitvector expression -tcBV :: (KnownNat w, 1 <= w) => AstExpr -> Tc (PermExpr (BVType w)) -tcBV (ExAdd _ x y) = bvAdd <$> tcBV x <*> tcBV y -tcBV (ExNeg _ x) = bvNegate <$> tcBV x -tcBV e = tcBVFactor e - --- | Check for a bitvector factor. This is limited to --- variables, constants, and multiplication by a constant. -tcBVFactor :: (KnownNat w, 1 <= w) => AstExpr -> Tc (PermExpr (BVType w)) --- Constants -tcBVFactor (ExNat _ i) = pure (bvInt (fromIntegral i)) --- Multiplication by a constant -tcBVFactor (ExMul _ c (ExVar p name Nothing Nothing)) = - do c' <- asBVConst c - Some tn <- tcTypedName p name - bvMultBV c' . PExpr_Var <$> tcCastTyped p knownRepr tn -tcBVFactor (ExMul _ (ExVar p name Nothing Nothing) c) = - do c' <- asBVConst c - Some tn <- tcTypedName p name - bvMultBV c' . PExpr_Var <$> tcCastTyped p knownRepr tn --- Variables -tcBVFactor (ExVar p name Nothing Nothing) = - do Some tn <- tcTypedName p name - PExpr_Var <$> tcCastTyped p knownRepr tn -tcBVFactor e = tcError (pos e) "Expected BV factor" - --- | Check for an integer literal, which can be negative. If one is found, --- convert it to a 'BV'. Fail otherwise. -asBVConst :: (KnownNat w, 1 <= w) => AstExpr -> Tc (BV w) -asBVConst (ExNat _ i) = - pure $ BV.mkBV knownNat $ toInteger i -asBVConst (ExNeg _ (ExNat _ i)) = - pure $ BV.negate knownNat $ BV.mkBV knownNat $ toInteger i -asBVConst e = - tcError (pos e) "Expected integer or negated integer" - --- | Check for a struct literal -tcStruct :: CtxRepr fs -> AstExpr -> Tc (PermExpr (StructType fs)) -tcStruct ts (ExStruct p es) = PExpr_Struct <$> tcExprs p (mkCruCtx ts) es -tcStruct _ e = tcError (pos e) "Expected struct" - --- | Check a list of expressions. In case of arity issues --- an arity error is reported at the given position. -tcExprs :: - Pos {- ^ position for arity error -} -> - CruCtx fs {- ^ expected types -} -> - [AstExpr] {- ^ expressions -} -> - Tc (PermExprs fs) -tcExprs p tys es = tcExprs' p tys (reverse es) - --- | Helper for 'tcExprs' -tcExprs' :: Pos -> CruCtx fs -> [AstExpr] -> Tc (PermExprs fs) -tcExprs' _ CruCtxNil [] = pure PExprs_Nil -tcExprs' p (CruCtxCons xs x) (y:ys) = - do zs <- tcExprs' p xs ys - z <- tcExpr x y - pure (zs :>: z) -tcExprs' p _ _ = tcError p "Bad arity" - --- | Parse a sequence of permissions of some given types -tcValuePerms :: Pos -> RAssign TypeRepr tys -> [AstExpr] -> Tc (RAssign ValuePerm tys) -tcValuePerms p tys es = tcValuePerms' p tys (reverse es) - --- | Helper for 'tcValuePerms' -tcValuePerms' :: Pos -> RAssign TypeRepr tps -> [AstExpr] -> Tc (RAssign ValuePerm tps) -tcValuePerms' _ MNil [] = pure MNil -tcValuePerms' p (xs :>: x) (y:ys) = - do zs <- tcValuePerms' p xs ys - z <- tcValPerm x y - pure (zs :>: z) -tcValuePerms' p _ _ = tcError p "Bad arity" - --- | Check an rwmodality literal -tcRWModality :: AstExpr -> Tc (PermExpr RWModalityType) -tcRWModality ExRead {} = pure PExpr_Read -tcRWModality ExWrite{} = pure PExpr_Write -tcRWModality e = tcError (pos e) "Expected rwmodality" - --- | Check an optional lifetime expression. Default to @always@ if missing. -tcOptLifetime :: Maybe AstExpr -> Tc (PermExpr LifetimeType) -tcOptLifetime Nothing = pure PExpr_Always -tcOptLifetime (Just e) = tcKExpr e - --- | Check a lifetime literal -tcLifetimeLit :: AstExpr -> Tc (PermExpr LifetimeType) -tcLifetimeLit ExAlways{} = pure PExpr_Always -tcLifetimeLit e = tcError (pos e) "Expected lifetime" - --- | Check an LLVM shape expression -tcLLVMShape :: (KnownNat w, 1 <= w) => AstExpr -> Tc (PermExpr (LLVMShapeType w)) -tcLLVMShape (ExOrSh _ x y) = PExpr_OrShape <$> tcKExpr x <*> tcKExpr y -tcLLVMShape (ExExSh _ var vartype sh) = - do Some ktp'@KnownReprObj <- tcTypeKnown vartype - fmap PExpr_ExShape $ mbM $ nu \z -> - withExprVar var (unKnownReprObj ktp') z (tcKExpr sh) -tcLLVMShape (ExSeqSh _ x y) = PExpr_SeqShape <$> tcKExpr x <*> tcKExpr y -tcLLVMShape ExEmptySh{} = pure PExpr_EmptyShape -tcLLVMShape (ExEqSh _ len v) = PExpr_EqShape <$> tcKExpr len <*> tcKExpr v -tcLLVMShape (ExPtrSh _ maybe_l maybe_rw sh) = - PExpr_PtrShape - <$> traverse tcKExpr maybe_l - <*> traverse tcKExpr maybe_rw - <*> tcKExpr sh -tcLLVMShape (ExFieldSh _ w fld) = PExpr_FieldShape <$> tcLLVMFieldShape_ w fld -tcLLVMShape (ExArraySh _ len stride sh) = - PExpr_ArrayShape - <$> tcKExpr len - <*> (Bytes . fromIntegral <$> tcNatural stride) - <*> tcKExpr sh -tcLLVMShape (ExTupleSh _ sh) = PExpr_TupShape <$> tcKExpr sh -tcLLVMShape (ExFalseSh _) = pure PExpr_FalseShape -tcLLVMShape e = tcError (pos e) "Expected shape" - --- | Field and array helper for 'tcLLVMShape' -tcLLVMFieldShape_ :: - forall w. (KnownNat w, 1 <= w) => Maybe AstExpr -> AstExpr -> Tc (LLVMFieldShape w) -tcLLVMFieldShape_ Nothing e = tcLLVMFieldShape (knownNat :: NatRepr w) e -tcLLVMFieldShape_ (Just w) e = - do Some (Pair nr LeqProof) <- tcPositive w - withKnownNat nr (tcLLVMFieldShape nr e) - --- | Check a single field or array element shape -tcLLVMFieldShape :: - forall (w :: Nat) (v :: Nat). - (KnownNat w, 1 <= w) => - NatRepr w -> AstExpr -> Tc (LLVMFieldShape v) -tcLLVMFieldShape nr e = LLVMFieldShape <$> tcValPerm (LLVMPointerRepr nr) e - --- | Check a LLVM pointer expression -tcLLVMPointer :: (KnownNat w, 1 <= w) => NatRepr w -> AstExpr -> Tc (PermExpr (LLVMPointerType w)) -tcLLVMPointer _ (ExLlvmWord _ e) = PExpr_LLVMWord <$> tcKExpr e -tcLLVMPointer w (ExAdd _ (ExVar p name Nothing Nothing) off) = PExpr_LLVMOffset <$> tcVar (LLVMPointerRepr w) p name <*> tcKExpr off -tcLLVMPointer _ e = tcError (pos e) "Expected llvmpointer" - --- | Check a value permission of a known type in a given context -tcValPermInCtx :: ParsedCtx ctx -> TypeRepr a -> AstExpr -> Tc (Mb ctx (ValuePerm a)) -tcValPermInCtx ctx tp = inParsedCtxM ctx . const . tcValPerm tp - --- | Parse a value permission of a known type -tcValPerm :: TypeRepr a -> AstExpr -> Tc (ValuePerm a) -tcValPerm _ ExTrue{} = pure ValPerm_True -tcValPerm _ ExFalse{} = pure ValPerm_False -tcValPerm ty (ExOr _ x y) = ValPerm_Or <$> tcValPerm ty x <*> tcValPerm ty y -tcValPerm ty (ExEq _ e) = ValPerm_Eq <$> tcExpr ty e -tcValPerm ty (ExExists _ var vartype e) = - do Some ktp'@KnownReprObj <- tcTypeKnown vartype - fmap ValPerm_Exists $ mbM $ nu \z -> - withExprVar var (unKnownReprObj ktp') z (tcValPerm ty e) -tcValPerm ty (ExVar p n (Just argEs) maybe_off) = - do env <- tcEnvPermEnv <$> tcAsk - case lookupNamedPermName env n of - Just (SomeNamedPermName rpn) - | Just Refl <- testEquality (namedPermNameType rpn) ty -> - do args <- tcExprs p (namedPermNameArgs rpn) argEs - off <- tcPermOffset ty p maybe_off - pure (ValPerm_Named rpn args off) - Just (SomeNamedPermName rpn) -> - tcError p $ renderDoc $ sep - [ pretty "Named permission" <+> pretty n <+> - pretty "is of incorrect type" - , pretty "Expected:" <+> permPretty emptyPPInfo ty - , pretty "Found:" <+> - permPretty emptyPPInfo (namedPermNameType rpn) ] - Nothing -> - tcError p ("Unknown named permission '" ++ n ++ "'") -tcValPerm ty (ExVar p n Nothing off) = - ValPerm_Var <$> tcVar (ValuePermRepr ty) p n <*> tcPermOffset ty p off -tcValPerm ty e = ValPerm_Conj <$> tcAtomicPerms ty e - --- | Parse a @*@-separated list of atomic permissions -tcAtomicPerms :: TypeRepr a -> AstExpr -> Tc [AtomicPerm a] -tcAtomicPerms ty (ExMul _ x y) = (++) <$> tcAtomicPerms ty x <*> tcAtomicPerms ty y -tcAtomicPerms ty e = pure <$> tcAtomicPerm ty e - --- | Parse an atomic permission of a specific type -tcAtomicPerm :: TypeRepr a -> AstExpr -> Tc (AtomicPerm a) -tcAtomicPerm ty (ExVar p n (Just argEs) maybe_off) = - do env <- tcEnvPermEnv <$> tcAsk - case lookupNamedPermName env n of - Just (SomeNamedPermName npn) - | Just Refl <- testEquality (namedPermNameType npn) ty - , TrueRepr <- nameIsConjRepr npn -> - do args <- tcExprs p (namedPermNameArgs npn) argEs - off <- tcPermOffset ty p maybe_off - return (Perm_NamedConj npn args off) - Just (SomeNamedPermName npn) - | Just Refl <- testEquality (namedPermNameType npn) ty -> - tcError p ("Non-conjoinable permission name '" ++ n - ++ "' used in conjunctive context") - Just (SomeNamedPermName _) -> - tcError p ("Permission name '" ++ n ++ "' has incorrect type") - Nothing -> - tcError p ("Unknown permission name '" ++ n ++ "'") -tcAtomicPerm (LLVMPointerRepr w) e = withKnownNat w (tcPointerAtomic e) -tcAtomicPerm (LLVMFrameRepr w) e = withKnownNat w (tcFrameAtomic e) -tcAtomicPerm (LLVMBlockRepr w) e = withKnownNat w (tcBlockAtomic e) -tcAtomicPerm (StructRepr tys) e = tcStructAtomic tys e -tcAtomicPerm LifetimeRepr e = tcLifetimeAtomic e -tcAtomicPerm _ (ExAny _) = return Perm_Any -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 _ 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 -tcPointerAtomic (ExEqual _ x y) = Perm_BVProp <$> (BVProp_Eq <$> tcKExpr x <*> tcKExpr y) -tcPointerAtomic (ExNotEqual _ x y) = Perm_BVProp <$> (BVProp_Neq <$> tcKExpr x <*> tcKExpr y) -tcPointerAtomic (ExLessThan _ x y) = Perm_BVProp <$> (BVProp_ULt <$> tcKExpr x <*> tcKExpr y) -tcPointerAtomic (ExLessEqual _ x y) = Perm_BVProp <$> (BVProp_ULeq <$> tcKExpr x <*> tcKExpr y) -tcPointerAtomic e = tcError (pos e) "Expected pointer perm" - --- | Check a function pointer permission literal -tcFunPtrAtomic :: - (KnownNat w, 1 <= w) => - AstExpr -> AstExpr -> AstFunPerm -> Tc (AtomicPerm (LLVMPointerType w)) -tcFunPtrAtomic x y fun = - do Some args_no <- mkNatRepr <$> tcNatural x - Some (Pair w' LeqProof) <- tcPositive y - Some args <- pure (cruCtxReplicate args_no (LLVMPointerRepr w')) - SomeFunPerm fun_perm <- tcFunPerm args (LLVMPointerRepr w') fun - pure (mkPermLLVMFunPtr knownNat fun_perm) - --- | Check a memblock permission literal -tcMemblock :: - (KnownNat w, 1 <= w) => - Maybe AstExpr -> - AstExpr -> AstExpr -> AstExpr -> AstExpr -> Tc (LLVMBlockPerm w) -tcMemblock l rw off len sh = - do llvmBlockLifetime <- tcOptLifetime l - llvmBlockRW <- tcKExpr rw - llvmBlockOffset <- tcKExpr off - llvmBlockLen <- tcKExpr len - llvmBlockShape <- tcKExpr sh - pure LLVMBlockPerm{..} - --- | Check an atomic array permission literal -tcArrayAtomic :: - (KnownNat w, 1 <= w) => Maybe AstExpr -> AstExpr -> AstExpr -> AstExpr -> - AstExpr -> AstExpr -> Tc (LLVMArrayPerm w) -tcArrayAtomic l rw off len stride sh = - LLVMArrayPerm - <$> tcKExpr rw - <*> tcOptLifetime l - <*> tcKExpr off - <*> tcKExpr len - <*> (Bytes . fromIntegral <$> tcNatural stride) - <*> tcKExpr sh - <*> pure [] - --- | Check a frame permission literal -tcFrameAtomic :: (KnownNat w, 1 <= w) => AstExpr -> Tc (AtomicPerm (LLVMFrameType w)) -tcFrameAtomic (ExLlvmFrame _ xs) = - Perm_LLVMFrame <$> traverse (\(e,i) -> (,) <$> tcKExpr e <*> pure (fromIntegral i)) xs -tcFrameAtomic e = tcError (pos e) "Expected llvmframe perm" - --- | Check a struct permission literal -tcStructAtomic :: CtxRepr tys -> AstExpr -> Tc (AtomicPerm (StructType tys)) -tcStructAtomic tys (ExStruct p es) = Perm_Struct <$> tcValuePerms p (assignToRList tys) es -tcStructAtomic _ e = tcError (pos e) "Expected struct perm" - --- | Check a block shape permission literal -tcBlockAtomic :: (KnownNat w, 1 <= w) => AstExpr -> Tc (AtomicPerm (LLVMBlockType w)) -tcBlockAtomic (ExShape _ e) = Perm_LLVMBlockShape <$> tcKExpr e -tcBlockAtomic e = tcError (pos e) "Expected llvmblock perm" - --- | Check a lifetime permission literal -tcLifetimeAtomic :: AstExpr -> Tc (AtomicPerm LifetimeType) -tcLifetimeAtomic (ExLOwned _ ls ps_in ps_out) = - do Some ps_in' <- tcDistPerms ps_in - Some ps_out' <- tcDistPerms ps_out - ls' <- mapM tcKExpr ls - let eps_in = distPermsToExprPerms $ unTypeDistPerms ps_in' - let eps_out = distPermsToExprPerms $ unTypeDistPerms ps_out' - pure (Perm_LOwned ls' (typedDistPermsCtx ps_in') - (typedDistPermsCtx ps_out') eps_in eps_out) -tcLifetimeAtomic (ExLCurrent _ l) = Perm_LCurrent <$> tcOptLifetime l -tcLifetimeAtomic (ExLFinished _) = return Perm_LFinished -tcLifetimeAtomic e = tcError (pos e) "Expected lifetime perm" - --- | Check a sequence @x1:p1, ..., xn:pn@ of variables and permissions -tcDistPerms :: [(Located String,AstExpr)] -> Tc (Some TypedDistPerms) -tcDistPerms [] = pure (Some MNil) -tcDistPerms ((Located p n,e):xs) = - do Some (Typed tp x) <- tcTypedName p n - perm <- tcValPerm tp e - Some ps <- tcDistPerms xs - pure (Some (ps :>: Typed tp (VarAndPerm x perm))) - --- | Helper for checking permission offsets -tcPermOffset :: TypeRepr a -> Pos -> Maybe AstExpr -> Tc (PermOffset a) -tcPermOffset _ _ Nothing = pure NoPermOffset -tcPermOffset (LLVMPointerRepr w) _ (Just i) = withKnownNat w (LLVMPermOffset <$> tcKExpr i) -tcPermOffset _ p _ = tcError p "Unexpected offset" - --- | Check for a number literal -tcNatural :: AstExpr -> Tc Natural -tcNatural (ExNat _ i) = pure i -tcNatural e = tcError (pos e) "Expected integer literal" - --- | Ensure a natural nubmer is positive -withPositive :: - Pos {- ^ location of literal -} -> - String {- ^ error message -} -> - Natural {- ^ number -} -> - (forall w. (1 <= w, KnownNat w) => NatRepr w -> Tc a) - {- ^ continuation -} -> - Tc a -withPositive p err n k = - case someNatGeq1 n of - Nothing -> tcError p err - Just (Some (Pair w LeqProof)) -> withKnownNat w (k w) - --- | Check for a positive number literal -tcPositive :: AstExpr -> Tc (Some (Product NatRepr (LeqProof 1))) -tcPositive e = - do i <- tcNatural e - withPositive (pos e) "positive required" i \w -> pure (Some (Pair w LeqProof)) - --- | Check a typing context @x1:tp1, x2:tp2, ...@ -tcCtx :: [(Located String, AstType)] -> Tc (Some ParsedCtx) -tcCtx [] = pure (Some emptyParsedCtx) -tcCtx ((n,t):xs) = preconsSomeParsedCtx (locThing n) <$> tcType t <*> tcCtx xs - --- | Check a sequence @x1:p1, x2:p2, ...@ of variables and their permissions, --- where each variable occurs at most once. The input list says which variables --- can occur and which have already been seen. Return a sequence of the --- permissions in the same order as the input list of variables. -tcSortedValuePerms :: - VarPermSpecs ctx -> [(Located String, AstExpr)] -> Tc (ValuePerms ctx) -tcSortedValuePerms var_specs [] = pure (varSpecsToPerms var_specs) -tcSortedValuePerms var_specs ((Located p var, x):xs) = - do Some (Typed tp n) <- tcTypedName p var - perm <- tcValPerm tp x - var_specs' <- tcSetVarSpecs p var n perm var_specs - tcSortedValuePerms var_specs' xs - --- | Check a sequence @x1:p1, x2:p2, ...@ of variables and their permissions, --- and sort the result into a 'ValuePerms' in a multi-binding that is in the --- same order as the 'ParsedCtx' supplied on input -tcSortedMbValuePerms :: - ParsedCtx ctx -> [(Located String, AstExpr)] -> Tc (MbValuePerms ctx) -tcSortedMbValuePerms ctx perms = - inParsedCtxM ctx \ns -> - tcSortedValuePerms (mkVarPermSpecs ns) perms - --- | Check a function permission of the form --- --- > (x1:tp1, ...). arg1:p1, ... -o --- > (y1:tp1', ..., ym:tpm'). arg1:p1', ..., argn:pn', ret:p_ret --- --- for some arbitrary context @x1:tp1, ...@ of ghost variables -tcFunPerm :: CruCtx args -> TypeRepr ret -> AstFunPerm -> Tc (SomeFunPerm args ret) -tcFunPerm args ret (AstFunPerm _ untyCtx ins untyCtxOut outs) = - do Some ghosts_ctx@(ParsedCtx _ ghosts) <- tcCtx untyCtx - Some gouts_ctx@(ParsedCtx _ gouts) <- tcCtx untyCtxOut - let args_ctx = mkArgsParsedCtx args - perms_in_ctx = appendParsedCtx ghosts_ctx args_ctx - perms_out_ctx = - appendParsedCtx (appendParsedCtx ghosts_ctx args_ctx) - (consParsedCtx "ret" ret gouts_ctx) - perms_in <- tcSortedMbValuePerms perms_in_ctx ins - perms_out <- tcSortedMbValuePerms perms_out_ctx outs - pure (SomeFunPerm (FunPerm ghosts args gouts ret perms_in perms_out)) - ----------------------------------------------------------------------- --- * Parsing Permission Sets and Function Permissions ----------------------------------------------------------------------- - --- | Helper type for 'parseValuePerms' that represents whether a pair @x:p@ has --- been parsed yet for a specific variable @x@ and, if so, contains that @p@ -data VarPermSpec a = VarPermSpec (Name a) (Maybe (ValuePerm a)) - --- | A sequence of variables @x@ and what pairs @x:p@ have been parsed so far -type VarPermSpecs = RAssign VarPermSpec - --- | Build a 'VarPermSpecs' from a list of names -mkVarPermSpecs :: RAssign Name ctx -> VarPermSpecs ctx -mkVarPermSpecs = RL.map (\n -> VarPermSpec n Nothing) - --- | Find a 'VarPermSpec' for a particular variable -findVarPermSpec :: Name (a :: CrucibleType) -> - VarPermSpecs ctx -> Maybe (Member ctx a) -findVarPermSpec _ MNil = Nothing -findVarPermSpec n (_ :>: VarPermSpec n' _) - | Just Refl <- testEquality n n' - = Just Member_Base -findVarPermSpec n (specs :>: _) = Member_Step <$> findVarPermSpec n specs - --- | Try to set the permission for a variable in a 'VarPermSpecs' list, raising --- a parse error if the variable already has a permission or is one of the --- expected variables -tcSetVarSpecs :: - Pos -> String -> Name tp -> ValuePerm tp -> VarPermSpecs ctx -> - Tc (VarPermSpecs ctx) -tcSetVarSpecs p var n perm var_specs = - case findVarPermSpec n var_specs of - Nothing -> tcError p ("Unknown variable: " ++ var) - Just memb -> - case RL.get memb var_specs of - VarPermSpec _ Nothing -> - pure (RL.modify memb (const (VarPermSpec n (Just perm))) var_specs) - _ -> tcError p ("Variable " ++ var ++ " occurs more than once!") - --- | Convert a 'VarPermSpecs' sequence to a sequence of permissions, using the --- @true@ permission for any variables without permissions -varSpecsToPerms :: VarPermSpecs ctx -> ValuePerms ctx -varSpecsToPerms MNil = ValPerms_Nil -varSpecsToPerms (var_specs :>: VarPermSpec _ (Just p)) = - ValPerms_Cons (varSpecsToPerms var_specs) p -varSpecsToPerms (var_specs :>: VarPermSpec _ Nothing) = - ValPerms_Cons (varSpecsToPerms var_specs) ValPerm_True - --- | Run a parsing computation inside a name-binding for expressions variables --- given by a 'ParsedCtx'. Returning the results inside a name-binding. -inParsedCtxM :: - NuMatching a => - ParsedCtx ctx -> (RAssign Name ctx -> Tc a) -> Tc (Mb ctx a) -inParsedCtxM (ParsedCtx ids tps) f = - mbM (nuMulti (cruCtxProxies tps) \ns -> withExprVars ids tps ns (f ns)) diff --git a/heapster/src/Heapster/TypedCrucible.hs b/heapster/src/Heapster/TypedCrucible.hs deleted file mode 100644 index 83e5a39162..0000000000 --- a/heapster/src/Heapster/TypedCrucible.hs +++ /dev/null @@ -1,4525 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# OPTIONS_GHC -Wno-orphans #-} -module Heapster.TypedCrucible where - -import Data.Maybe -import qualified Data.Text as Text -import Data.List (find, findIndex, foldl1', nub) -import Data.Functor.Constant -import Data.Functor.Product -import Data.Type.Equality -import Data.Kind -import Data.Reflection -import qualified Data.BitVector.Sized as BV -import GHC.TypeLits (KnownNat) - -import What4.ProgramLoc -import What4.FunctionName -import What4.Interface (StringLiteral(..)) - -import Control.Lens hiding ((:>), Index, ix) -import Control.Monad ((>=>), foldM, forM, forM_) -import Control.Monad.Reader (MonadReader(..), ReaderT(..)) -import Control.Monad.State.Strict (MonadState(..), State, evalState, execState, - gets, modify, runState) -import Control.Monad.Trans.Class (MonadTrans(..)) - -import Prettyprinter as PP - -import qualified Data.Type.RList as RL -import Data.Binding.Hobbits -import Data.Binding.Hobbits.NameSet (NameSet, SomeName(..), SomeRAssign(..), - namesListToNames, namesToNamesList, - nameSetIsSubsetOf) -import qualified Data.Binding.Hobbits.NameSet as NameSet -import Data.Binding.Hobbits.NameMap (NameMap) -import qualified Data.Binding.Hobbits.NameMap as NameMap - -import Data.Parameterized.Context hiding ((:>), empty, take, view, last, drop) -import qualified Data.Parameterized.Context as Ctx -import Data.Parameterized.TraversableF -import Data.Parameterized.TraversableFC - -import Lang.Crucible.FunctionHandle -import Lang.Crucible.Types -import Lang.Crucible.LLVM.Bytes -import Lang.Crucible.LLVM.Extension -import Lang.Crucible.LLVM.MemModel -import Lang.Crucible.CFG.Expr -import Lang.Crucible.CFG.Core -import Lang.Crucible.Analysis.Fixpoint.Components -import Lang.Crucible.LLVM.DataLayout -import Lang.Crucible.LLVM.Errors.UndefinedBehavior as UB - -import Heapster.CruUtil -import Heapster.GenMonad -import Heapster.Implication -import Heapster.NamePropagation -import Heapster.Permissions -import Heapster.Widening -import Heapster.NamedMb - -import GHC.Stack (HasCallStack) - - ----------------------------------------------------------------------- --- * Handling Crucible Extensions ----------------------------------------------------------------------- - --- | A Crucible extension that satisfies 'NuMatching' -type NuMatchingExtC ext exprExt = - ( -#if __GLASGOW_HASKELL__ >= 902 - NuMatchingAny1 (ExprExtension ext RegWithVal) -#else - -- See Note [QuantifiedConstraints + TypeFamilies trick] in - -- Heapster.CruUtil - exprExt ~ ExprExtension ext RegWithVal - , NuMatchingAny1 exprExt -#endif - -- (NuMatchingAny1 (ExprExtension ext TypedReg) - -- , NuMatchingAny1 (StmtExtension ext TypedReg)) - ) - --- | GADT telling us that @ext@ is a syntax extension we can handle -data ExtRepr ext where - ExtRepr_Unit :: ExtRepr () - ExtRepr_LLVM :: ExtRepr LLVM - -instance KnownRepr ExtRepr () where - knownRepr = ExtRepr_Unit - -instance KnownRepr ExtRepr LLVM where - knownRepr = ExtRepr_LLVM - --- | The constraints for a Crucible syntax extension that supports permission --- checking -type PermCheckExtC ext exprExt = - (NuMatchingExtC ext exprExt, IsSyntaxExtension ext, KnownRepr ExtRepr ext) - --- | Extension-specific state -data PermCheckExtState ext where - -- | No extension-specific state for the empty extension - PermCheckExtState_Unit :: PermCheckExtState () - - -- | The extension-specific state for LLVM is the current frame pointer, if it - -- exists - PermCheckExtState_LLVM :: - Maybe SomeFrameReg -> - PermCheckExtState LLVM - --- | Create a default empty extension-specific state object -emptyPermCheckExtState :: ExtRepr ext -> PermCheckExtState ext -emptyPermCheckExtState ExtRepr_Unit = PermCheckExtState_Unit -emptyPermCheckExtState ExtRepr_LLVM = PermCheckExtState_LLVM Nothing - --- | Get all the names contained in a 'PermCheckExtState' -permCheckExtStateNames :: PermCheckExtState ext -> Some (RAssign ExprVar) -permCheckExtStateNames (PermCheckExtState_LLVM (Just (SomeFrameReg _ treg))) = - Some (MNil :>: typedRegVar treg) -permCheckExtStateNames (PermCheckExtState_LLVM Nothing) = Some MNil -permCheckExtStateNames (PermCheckExtState_Unit) = Some MNil - -data SomeFrameReg where - SomeFrameReg :: - NatRepr w -> - TypedReg (LLVMFrameType w) -> - SomeFrameReg - ----------------------------------------------------------------------- --- * Typed Jump Targets and Function Handles ----------------------------------------------------------------------- - --- | During type-checking, we convert Crucible registers to variables -newtype TypedReg tp = TypedReg { typedRegVar :: ExprVar tp } - -instance PermPretty (TypedReg tp) where - permPrettyM = permPrettyM . typedRegVar - --- | A sequence of typed registers -data TypedRegs ctx where - TypedRegsNil :: TypedRegs RNil - TypedRegsCons :: !(TypedRegs ctx) -> !(TypedReg a) -> TypedRegs (ctx :> a) - --- | Extract out a sequence of variables from a 'TypedRegs' -typedRegsToVars :: TypedRegs ctx -> RAssign Name ctx -typedRegsToVars TypedRegsNil = MNil -typedRegsToVars (TypedRegsCons regs (TypedReg x)) = typedRegsToVars regs :>: x - --- | Convert a sequence of variables to a 'TypedRegs' -varsToTypedRegs :: RAssign Name ctx -> TypedRegs ctx -varsToTypedRegs MNil = TypedRegsNil -varsToTypedRegs (xs :>: x) = TypedRegsCons (varsToTypedRegs xs) (TypedReg x) - --- | Turn a sequence of typed registers into a variable substitution -typedRegsToVarSubst :: TypedRegs ctx -> PermVarSubst ctx -typedRegsToVarSubst = permVarSubstOfNames . typedRegsToVars - --- | A typed register along with its value if that is known statically -data RegWithVal a - = RegWithVal (TypedReg a) (PermExpr a) - | RegNoVal (TypedReg a) - --- | Get the 'TypedReg' from a 'RegWithVal' -regWithValReg :: RegWithVal a -> TypedReg a -regWithValReg (RegWithVal r _) = r -regWithValReg (RegNoVal r) = r - --- | Get the expression for a 'RegWithVal', even if it is only the variable for --- its register value when it has no statically-known value -regWithValExpr :: RegWithVal a -> PermExpr a -regWithValExpr (RegWithVal _ e) = e -regWithValExpr (RegNoVal (TypedReg x)) = PExpr_Var x - --- | A type-checked Crucible expression is a Crucible 'Expr' that uses --- 'TypedReg's for variables. As part of type-checking, these typed registers --- (which are the inputs to the expression) as well as the final output value of --- the expression are annotated with equality permissions @eq(e)@ if their --- values can be statically represented as permission expressions @e@. -data TypedExpr ext tp = - TypedExpr !(App ext RegWithVal tp) !(Maybe (PermExpr tp)) - --- | A \"typed\" function handle is a normal function handle along with contexts --- of ghost input and output variables -data TypedFnHandle ghosts args gouts ret where - TypedFnHandle :: !(CruCtx ghosts) -> !(CruCtx gouts) -> - !(FnHandle cargs ret) -> - TypedFnHandle ghosts (CtxToRList cargs) gouts ret - --- | Extract out the context of ghost arguments from a 'TypedFnHandle' -typedFnHandleGhosts :: TypedFnHandle ghosts args gouts ret -> CruCtx ghosts -typedFnHandleGhosts (TypedFnHandle ghosts _ _) = ghosts - --- | Extract out the context of output ghost arguments from a 'TypedFnHandle' -typedFnHandleGouts :: TypedFnHandle ghosts args gouts ret -> CruCtx gouts -typedFnHandleGouts (TypedFnHandle _ gouts _) = gouts - --- | Extract out the context of regular arguments from a 'TypedFnHandle' -typedFnHandleArgs :: TypedFnHandle ghosts args gouts ret -> CruCtx args -typedFnHandleArgs (TypedFnHandle _ _ h) = mkCruCtx $ handleArgTypes h - --- | Extract out the context of all arguments of a 'TypedFnHandle', including --- the lifetime argument -typedFnHandleAllArgs :: TypedFnHandle ghosts args gouts ret -> - CruCtx (ghosts :++: args) -typedFnHandleAllArgs h = - appendCruCtx (typedFnHandleGhosts h) (typedFnHandleArgs h) - - --- | Extract out the return type of a 'TypedFnHandle' -typedFnHandleRetType :: TypedFnHandle ghosts args gouts ret -> TypeRepr ret -typedFnHandleRetType (TypedFnHandle _ _ h) = handleReturnType h - --- | Extract out all the return types of a 'TypedFnHandle' -typedFnHandleRetTypes :: TypedFnHandle ghosts args gouts ret -> - CruCtx (gouts :> ret) -typedFnHandleRetTypes (TypedFnHandle _ gouts h) = - CruCtxCons gouts $ handleReturnType h - - --- | As in standard Crucible, blocks are identified by membership proofs that --- their input arguments are in the @blocks@ list. We also track an 'Int' that --- gives the 'indexVal' of the original Crucible block ID, so that typed block --- IDs can be printed the same way as standard Crucible block IDs. The issue --- here is that 'Member' proofs count from the right of an 'RList', while --- Crucible uses membership proofs that count from the left, and so the sizes --- are not the same. -data TypedBlockID (ctx :: RList (RList CrucibleType)) args = - TypedBlockID { typedBlockIDMember :: Member ctx args, typedBlockIDIx :: Int } - deriving Eq - -instance TestEquality (TypedBlockID ctx) where - testEquality (TypedBlockID memb1 _) (TypedBlockID memb2 _) = - testEquality memb1 memb2 - -instance Show (TypedBlockID ctx args) where - show tblkID = "%" ++ show (typedBlockIDIx tblkID) - --- | Convert a Crucible 'Index' to a 'TypedBlockID' -indexToTypedBlockID :: Size ctx -> Index ctx args -> - TypedBlockID (CtxCtxToRList ctx) (CtxToRList args) -indexToTypedBlockID sz ix = - TypedBlockID (indexCtxToMember sz ix) (Ctx.indexVal ix) - --- | All of our blocks have multiple entry points, for different inferred types, --- so a \"typed\" 'BlockID' is a normal Crucible 'BlockID' (which is just an index --- into the @blocks@ context of contexts) plus an 'Int' specifying which entry --- point to that block -data TypedEntryID (blocks :: RList (RList CrucibleType)) (args :: RList CrucibleType) = - TypedEntryID { entryBlockID :: TypedBlockID blocks args, entryIndex :: Int } - deriving Eq - --- | Get the 'Member' proof of the 'TypedBlockID' of a 'TypedEntryID' -entryBlockMember :: TypedEntryID blocks args -> Member blocks args -entryBlockMember = typedBlockIDMember . entryBlockID - --- | Compute the indices corresponding to the 'BlockID' and 'entryIndex' of a --- 'TypedEntryID', for printing purposes -entryIDIndices :: TypedEntryID blocks args -> (Int, Int) -entryIDIndices (TypedEntryID tblkID ix) = (typedBlockIDIx tblkID, ix) - -instance Show (TypedEntryID blocks args) where - show (TypedEntryID {..}) = show entryBlockID ++ "(" ++ show entryIndex ++ ")" - -instance TestEquality (TypedEntryID blocks) where - testEquality (TypedEntryID memb1 i1) (TypedEntryID memb2 i2) - | i1 == i2 = testEquality memb1 memb2 - testEquality _ _ = Nothing - --- | Each call site, that jumps or branches to another block, is identified by --- the entrypoint it occurs in and the entrypoint it calls, and is associated --- with the free variables at that call site, each of which could have --- permissions being passed by the call. Call sites also have an integer index --- to handle the case when one entrypoint calls another multiple times, which --- can happen if a disjunctive permission is eliminated in the former. -data TypedCallSiteID blocks args vars = - forall args_src. - TypedCallSiteID { callSiteSrc :: TypedEntryID blocks args_src, - callSiteIx :: Int, - callSiteDest :: TypedEntryID blocks args, - callSiteVars :: CruCtx vars } - --- | Get the 'TypedBlockID' of the callee of a call site -callSiteDestBlock :: TypedCallSiteID blocks args vars -> - TypedBlockID blocks args -callSiteDestBlock = entryBlockID . callSiteDest - -instance TestEquality (TypedCallSiteID blocks args) where - testEquality (TypedCallSiteID - src1 ix1 dest1 vars1) (TypedCallSiteID src2 ix2 dest2 vars2) - | Just Refl <- testEquality src1 src2 - , ix1 == ix2, dest1 == dest2 = testEquality vars1 vars2 - testEquality _ _ = Nothing - -instance Show (TypedCallSiteID blocks args vars) where - show (TypedCallSiteID {..}) = - "" - --- | Test if the caller of a 'TypedCallSiteID' equals a given entrypoint -callSiteIDCallerEq :: TypedEntryID blocks args_src -> - TypedCallSiteID blocks args vars -> Bool -callSiteIDCallerEq entryID (TypedCallSiteID {..}) = - isJust $ testEquality entryID callSiteSrc - --- | A typed target for jump and branch statements, where the argument registers --- (including top-level function arguments and free variables) are given with --- their permissions as a 'DistPerms' -data TypedJumpTarget blocks tops ps where - TypedJumpTarget :: - !(TypedCallSiteID blocks args vars) -> - !(Proxy tops) -> !(CruCtx args) -> - !(DistPerms ((tops :++: args) :++: vars)) -> - TypedJumpTarget blocks tops ((tops :++: args) :++: vars) - - -$(mkNuMatching [t| forall tp. TypedReg tp |]) -$(mkNuMatching [t| forall tp. RegWithVal tp |]) -$(mkNuMatching [t| forall ctx. TypedRegs ctx |]) - -$(mkNuMatching [t| forall ext tp exprExt. NuMatchingExtC ext exprExt => TypedExpr ext tp |]) -$(mkNuMatching [t| forall ghosts args gouts ret. - TypedFnHandle ghosts args gouts ret |]) -$(mkNuMatching [t| forall blocks args. TypedBlockID blocks args |]) -$(mkNuMatching [t| forall blocks args. TypedEntryID blocks args |]) -$(mkNuMatching [t| forall blocks args ghosts. TypedCallSiteID blocks args ghosts |]) -$(mkNuMatching [t| forall blocks tops ps_in. TypedJumpTarget blocks tops ps_in |]) - -instance Closable (TypedBlockID blocks args) where - toClosed (TypedBlockID memb ix) = - $(mkClosed [| TypedBlockID |]) - `clApply` toClosed memb `clApply` toClosed ix - -instance Liftable (TypedBlockID blocks args) where - mbLift = unClosed . mbLift . fmap toClosed - -instance Closable (TypedEntryID blocks args) where - toClosed (TypedEntryID entryBlockID entryIndex) = - $(mkClosed [| TypedEntryID |]) - `clApply` toClosed entryBlockID `clApply` toClosed entryIndex - -instance Liftable (TypedEntryID blocks args) where - mbLift = unClosed . mbLift . fmap toClosed - -instance Closable (TypedCallSiteID blocks args vars) where - toClosed (TypedCallSiteID src ix dest vars) = - $(mkClosed [| TypedCallSiteID |]) - `clApply` toClosed src `clApply` toClosed ix - `clApply` toClosed dest `clApply` toClosed vars - -instance Liftable (TypedCallSiteID blocks args vars) where - mbLift = unClosed . mbLift . fmap toClosed - ----------------------------------------------------------------------- --- * Typed Crucible Statements ----------------------------------------------------------------------- - --- | Typed Crucible statements with the given Crucible syntax extension and the --- given set of return values -data TypedStmt ext (stmt_rets :: RList CrucibleType) ps_in ps_out where - - -- | Assign a pure Crucible expressions to a register, where pure here means - -- that its translation to SAW will be pure (i.e., no LLVM pointer operations) - TypedSetReg :: !(TypeRepr tp) -> !(TypedExpr ext tp) -> - TypedStmt ext (RNil :> tp) RNil (RNil :> tp) - - -- | Assign a pure permissions expression to a register - TypedSetRegPermExpr :: !(TypeRepr tp) -> !(PermExpr tp) -> - TypedStmt ext (RNil :> tp) RNil (RNil :> tp) - - -- | A function call to the function in register @f@, which must have function - -- permission @(ghosts). ps_in -o ps_out@, passing the supplied registers for - -- the @ghosts@ and @args@, where the former must be equal to the supplied - -- expressions @gexprs@. A call has permissions - -- - -- > [gexprs/ghosts]ps_in, ghosts1:eq(gexprs1), ..., ghostsn:eq(gexprsn), - -- > f:((ghosts). ps_in -o ps_out) - -- > -o - -- > [gexprs/ghosts]ps_out - TypedCall :: args ~ CtxToRList cargs => - !(TypedReg (FunctionHandleType cargs ret)) -> - !(FunPerm ghosts args gouts ret) -> - !(TypedRegs ghosts) -> !(PermExprs ghosts) -> !(TypedRegs args) -> - TypedStmt ext (gouts :> ret) - ((ghosts :++: args) :++: ghosts :> FunctionHandleType cargs ret) - ((ghosts :++: args) :++: gouts :> ret) - - -- | Assert a boolean condition, printing the given string on failure - TypedAssert :: !(TypedReg BoolType) -> !(TypedReg (StringType Unicode)) -> - TypedStmt ext RNil RNil RNil - - -- | LLVM-specific statement - TypedLLVMStmt :: !(TypedLLVMStmt ret ps_in ps_out) -> - TypedStmt LLVM (RNil :> ret) ps_in ps_out - - -data TypedLLVMStmt ret ps_in ps_out where - -- | Assign an LLVM word (i.e., a pointer with block 0) to a register - -- - -- Type: @. -o ret:eq(word(x))@ - ConstructLLVMWord :: (1 <= w2, KnownNat w2) => - !(TypedReg (BVType w2)) -> - TypedLLVMStmt (LLVMPointerType w2) - RNil - (RNil :> LLVMPointerType w2) - - -- | Assert that an LLVM pointer is a word, and return 0. This is the typed - -- version of 'LLVM_PointerBlock' when we know the input is a word, i.e., has - -- a pointer block value of 0. - -- - -- Type: @x:eq(word(y)) -o ret:eq(0)@ - AssertLLVMWord :: (1 <= w2, KnownNat w2) => - !(TypedReg (LLVMPointerType w2)) -> - !(PermExpr (BVType w2)) -> - TypedLLVMStmt NatType - (RNil :> LLVMPointerType w2) - (RNil :> NatType) - - - -- | Assert that an LLVM pointer is a pointer - -- - -- Type: @x:is_llvmptr -o .@ - AssertLLVMPtr :: (1 <= w2, KnownNat w2) => - !(TypedReg (LLVMPointerType w2)) -> - TypedLLVMStmt UnitType (RNil :> LLVMPointerType w2) RNil - - -- | Destruct an LLVM word into its bitvector value, which should equal the - -- given expression - -- - -- Type: @x:eq(word(e)) -o ret:eq(e)@ - DestructLLVMWord :: (1 <= w2, KnownNat w2) => - !(TypedReg (LLVMPointerType w2)) -> - !(PermExpr (BVType w2)) -> - TypedLLVMStmt (BVType w2) - (RNil :> LLVMPointerType w2) - (RNil :> BVType w2) - - -- | Add an offset to an LLVM value - -- - -- Type: @. -o ret:eq(x &+ off)@ - OffsetLLVMValue :: (1 <= w2, KnownNat w2) => - !(TypedReg (LLVMPointerType w2)) -> - !(PermExpr (BVType w2)) -> - TypedLLVMStmt (LLVMPointerType w2) - RNil - (RNil :> LLVMPointerType w2) - - -- | Load a machine value from the address pointed to by the given pointer - -- using the supplied field permission. Some set of permissions @ps@ can be on - -- the stack below the field permission, and these are preserved. The lifetime - -- of the field permission must also be proved to be current; the permissions - -- for this are on the top of the stack and are also preserved. - -- - -- Type: - -- > ps, x:ptr((rw,0) |-> p), cur_ps - -- > -o ps, x:ptr((rw,0) |-> eq(ret)), ret:p, cur_ps - TypedLLVMLoad :: - (HasPtrWidth w, 1 <= sz, KnownNat sz) => - !(TypedReg (LLVMPointerType w)) -> - !(LLVMFieldPerm w sz) -> - !(DistPerms ps) -> - !(LifetimeCurrentPerms ps_l) -> - TypedLLVMStmt (LLVMPointerType sz) - (ps :> LLVMPointerType w :++: ps_l) - (ps :> LLVMPointerType w :> LLVMPointerType sz :++: ps_l) - - -- | Store a machine value to the address pointed to by the given pointer - -- using the supplied field permission, which also specifies the offset from - -- the pointer where the store occurs. Some set of permissions @ps@ can be on - -- the stack below the field permission, and these are preserved. The lifetime - -- of the field permission must also be proved to be current; the permissions - -- for this are on the top of the stack and are also preserved. - -- - -- Type: - -- > ps, x:ptr((rw,0) |-> p), cur_ps - -- > -o ps, x:ptr((rw,0) |-> eq(e)), cur_ps - TypedLLVMStore :: - (HasPtrWidth w, 1 <= sz, KnownNat sz) => - !(TypedReg (LLVMPointerType w)) -> - !(LLVMFieldPerm w sz) -> - !(PermExpr (LLVMPointerType sz)) -> - !(DistPerms ps) -> - !(LifetimeCurrentPerms ps_l) -> - TypedLLVMStmt UnitType - (ps :> LLVMPointerType w :++: ps_l) - (ps :> LLVMPointerType w :++: ps_l) - - -- | Allocate an object of the given size on the given LLVM frame, described - -- as a memory block with empty shape: - -- - -- Type: - -- > fp:frame(ps) -o fp:frame(ps,(ret,i)), - -- > ret:memblock(W,0,sz,emptysh) - -- - -- where @sz@ is the number of bytes allocated - TypedLLVMAlloca :: - HasPtrWidth w => - !(TypedReg (LLVMFrameType w)) -> - !(LLVMFramePerm w) -> - !Integer -> - TypedLLVMStmt (LLVMPointerType w) - (RNil :> LLVMFrameType w) - (RNil :> LLVMFrameType w :> LLVMPointerType w) - - -- | Create a new LLVM frame - -- - -- Type: @. -o ret:frame()@ - TypedLLVMCreateFrame :: - HasPtrWidth w => - TypedLLVMStmt (LLVMFrameType w) RNil (RNil :> LLVMFrameType w) - - -- | Delete an LLVM frame and deallocate all memory objects allocated in it, - -- assuming that the current distinguished permissions @ps@ correspond to the - -- write permissions to all those objects allocated on the frame - -- - -- Type: @ps, fp:frame(ps) -o .@ - TypedLLVMDeleteFrame :: - HasPtrWidth w => - !(TypedReg (LLVMFrameType w)) -> - !(LLVMFramePerm w) -> !(DistPerms ps) -> - TypedLLVMStmt UnitType (ps :> LLVMFrameType w) RNil - - -- | Typed version of 'LLVM_LoadHandle', that loads the function handle - -- referred to by a function pointer, assuming we know it has one: - -- - -- Type: @x:llvm_funptr(p) -o ret:p@ - TypedLLVMLoadHandle :: - HasPtrWidth w => - !(TypedReg (LLVMPointerType w)) -> - !(TypeRepr (FunctionHandleType cargs ret)) -> - !(ValuePerm (FunctionHandleType cargs ret)) -> - TypedLLVMStmt (FunctionHandleType cargs ret) - (RNil :> LLVMPointerType w) - (RNil :> FunctionHandleType cargs ret) - - -- | Typed version of 'LLVM_ResolveGlobal', that resolves a 'GlobalSymbol' to - -- an LLVM value, assuming it has the given permission in the environment: - -- - -- Type: @. -o ret:p@ - TypedLLVMResolveGlobal :: - HasPtrWidth w => - !GlobalSymbol -> - !(ValuePerm (LLVMPointerType w)) -> - TypedLLVMStmt (LLVMPointerType w) RNil (RNil :> LLVMPointerType w) - - -- | An if-then-else statement over LLVM values - TypedLLVMIte :: - 1 <= w => - !(NatRepr w) -> - !(TypedReg BoolType) -> - !(TypedReg (LLVMPointerType w)) -> - !(TypedReg (LLVMPointerType w)) -> - TypedLLVMStmt (LLVMPointerType w) RNil (RNil :> LLVMPointerType w) - --- | Return the input permissions for a 'TypedStmt' -typedStmtIn :: TypedStmt ext stmt_rets ps_in ps_out -> DistPerms ps_in -typedStmtIn (TypedSetReg _ _) = DistPermsNil -typedStmtIn (TypedSetRegPermExpr _ _) = DistPermsNil -typedStmtIn (TypedCall (TypedReg f) fun_perm ghosts gexprs args) = - DistPermsCons - (funPermDistIns fun_perm (typedRegsToVars ghosts) gexprs (typedRegsToVars args)) - f (ValPerm_Conj1 $ Perm_Fun fun_perm) -typedStmtIn (TypedAssert _ _) = DistPermsNil -typedStmtIn (TypedLLVMStmt llvmStmt) = typedLLVMStmtIn llvmStmt - --- | Return the input permissions for a 'TypedLLVMStmt' -typedLLVMStmtIn :: TypedLLVMStmt ret ps_in ps_out -> DistPerms ps_in -typedLLVMStmtIn (ConstructLLVMWord _) = DistPermsNil -typedLLVMStmtIn (AssertLLVMWord (TypedReg x) e) = - distPerms1 x (ValPerm_Eq $ PExpr_LLVMWord e) -typedLLVMStmtIn (AssertLLVMPtr (TypedReg x)) = - distPerms1 x (ValPerm_Conj1 Perm_IsLLVMPtr) -typedLLVMStmtIn (DestructLLVMWord (TypedReg x) e) = - distPerms1 x (ValPerm_Eq $ PExpr_LLVMWord e) -typedLLVMStmtIn (OffsetLLVMValue _ _) = - DistPermsNil -typedLLVMStmtIn (TypedLLVMLoad (TypedReg x) fp ps ps_l) = - withKnownNat ?ptrWidth $ - permAssert - (lifetimeCurrentPermsLifetime ps_l == llvmFieldLifetime fp) - "typedLLVMStmtIn: TypedLLVMLoad: mismatch for field lifetime" $ - permAssert (bvEq (llvmFieldOffset fp) (bvInt 0)) - "typedLLVMStmtIn: TypedLLVMLoad: mismatch for field offset" $ - appendDistPerms - (DistPermsCons ps x (ValPerm_Conj1 $ Perm_LLVMField fp)) - (lifetimeCurrentPermsPerms ps_l) -typedLLVMStmtIn (TypedLLVMStore (TypedReg x) fp _ ps cur_ps) = - withKnownNat ?ptrWidth $ - permAssert (llvmFieldRW fp == PExpr_Write && - bvEq (llvmFieldOffset fp) (bvInt 0) && - llvmFieldLifetime fp == lifetimeCurrentPermsLifetime cur_ps) - "typedLLVMStmtIn: TypedLLVMStore: mismatch for field permission" $ - appendDistPerms - (DistPermsCons ps x (ValPerm_Conj1 $ Perm_LLVMField fp)) - (lifetimeCurrentPermsPerms cur_ps) -typedLLVMStmtIn (TypedLLVMAlloca (TypedReg f) fperms _) = - withKnownNat ?ptrWidth $ - distPerms1 f (ValPerm_Conj [Perm_LLVMFrame fperms]) -typedLLVMStmtIn TypedLLVMCreateFrame = DistPermsNil -typedLLVMStmtIn (TypedLLVMDeleteFrame (TypedReg f) fperms perms) = - withKnownNat ?ptrWidth $ - case llvmFrameDeletionPerms fperms of - Some perms' - | Just Refl <- testEquality perms perms' -> - DistPermsCons perms f (ValPerm_Conj1 $ Perm_LLVMFrame fperms) - _ -> error "typedLLVMStmtIn: incorrect perms in rule" -typedLLVMStmtIn (TypedLLVMLoadHandle (TypedReg f) tp p) = - withKnownNat ?ptrWidth $ - distPerms1 f (ValPerm_Conj1 $ Perm_LLVMFunPtr tp p) -typedLLVMStmtIn (TypedLLVMResolveGlobal _ _) = - DistPermsNil -typedLLVMStmtIn (TypedLLVMIte _ _ _ _) = DistPermsNil - --- | Return the output permissions for a 'TypedStmt' -typedStmtOut :: TypedStmt ext stmt_rets ps_in ps_out -> - RAssign Name stmt_rets -> DistPerms ps_out -typedStmtOut (TypedSetReg _ (TypedExpr _ (Just e))) (_ :>: ret) = - distPerms1 ret (ValPerm_Eq e) -typedStmtOut (TypedSetReg _ (TypedExpr _ Nothing)) (_ :>: ret) = - distPerms1 ret ValPerm_True -typedStmtOut (TypedSetRegPermExpr _ e) (_ :>: ret) = - distPerms1 ret (ValPerm_Eq e) -typedStmtOut (TypedCall _ fun_perm ghosts gexprs args) rets = - funPermDistOuts fun_perm (typedRegsToVars ghosts) gexprs - (typedRegsToVars args) rets -typedStmtOut (TypedAssert _ _) _ = DistPermsNil -typedStmtOut (TypedLLVMStmt llvmStmt) (_ :>: ret) = - typedLLVMStmtOut llvmStmt ret - --- | Return the output permissions for a 'TypedStmt' -typedLLVMStmtOut :: TypedLLVMStmt ret ps_in ps_out -> Name ret -> - DistPerms ps_out -typedLLVMStmtOut (ConstructLLVMWord (TypedReg x)) ret = - distPerms1 ret (ValPerm_Eq $ PExpr_LLVMWord $ PExpr_Var x) -typedLLVMStmtOut (AssertLLVMWord (TypedReg _) _) ret = - distPerms1 ret (ValPerm_Eq $ PExpr_Nat 0) -typedLLVMStmtOut (AssertLLVMPtr _) _ = DistPermsNil -typedLLVMStmtOut (DestructLLVMWord (TypedReg _) e) ret = - distPerms1 ret (ValPerm_Eq e) -typedLLVMStmtOut (OffsetLLVMValue (TypedReg x) off) ret = - distPerms1 ret (ValPerm_Eq $ PExpr_LLVMOffset x off) -typedLLVMStmtOut (TypedLLVMLoad (TypedReg x) fp ps ps_l) ret = - withKnownNat ?ptrWidth $ - if lifetimeCurrentPermsLifetime ps_l == llvmFieldLifetime fp then - appendDistPerms - (DistPermsCons - (DistPermsCons ps - x (ValPerm_Conj1 $ Perm_LLVMField $ - fp { llvmFieldContents = ValPerm_Eq (PExpr_Var ret) })) - ret (llvmFieldContents fp)) - (lifetimeCurrentPermsPerms ps_l) - else - error "typedLLVMStmtOut: TypedLLVMLoad: mismatch for field lifetime" -typedLLVMStmtOut (TypedLLVMStore (TypedReg x) fp e ps cur_ps) _ = - withKnownNat ?ptrWidth $ - permAssert (llvmFieldRW fp == PExpr_Write && - bvEq (llvmFieldOffset fp) (bvInt 0) && - llvmFieldLifetime fp == lifetimeCurrentPermsLifetime cur_ps) - "typedLLVMStmtOut: TypedLLVMStore: mismatch for field permission" $ - appendDistPerms - (DistPermsCons ps x (ValPerm_Conj1 $ Perm_LLVMField $ - fp { llvmFieldContents = ValPerm_Eq e })) - (lifetimeCurrentPermsPerms cur_ps) -typedLLVMStmtOut (TypedLLVMAlloca - (TypedReg f) (fperms :: LLVMFramePerm w) len) ret = - withKnownNat ?ptrWidth $ - distPerms2 f (ValPerm_Conj [Perm_LLVMFrame ((PExpr_Var ret, len):fperms)]) - ret (llvmEmptyBlockPermOfSize Proxy len) -typedLLVMStmtOut TypedLLVMCreateFrame ret = - withKnownNat ?ptrWidth $ - distPerms1 ret $ ValPerm_Conj [Perm_LLVMFrame []] -typedLLVMStmtOut (TypedLLVMDeleteFrame _ _ _) _ = DistPermsNil -typedLLVMStmtOut (TypedLLVMLoadHandle _ _ p) ret = distPerms1 ret p -typedLLVMStmtOut (TypedLLVMResolveGlobal _ p) ret = - distPerms1 ret p -typedLLVMStmtOut (TypedLLVMIte _ _ (TypedReg x1) (TypedReg x2)) ret = - distPerms1 ret (ValPerm_Or (ValPerm_Eq $ PExpr_Var x1) - (ValPerm_Eq $ PExpr_Var x2)) - - --- | Check that the permission stack of the given permission set matches the --- input permissions of the given statement, and replace them with the output --- permissions of the statement -applyTypedStmt :: TypedStmt ext stmt_rets ps_in ps_out -> - RAssign Name stmt_rets -> PermSet ps_in -> PermSet ps_out -applyTypedStmt stmt stmt_rets = - modifyDistPerms $ \perms -> - if perms == typedStmtIn stmt then - typedStmtOut stmt stmt_rets - else - error "applyTypedStmt: unexpected input permissions!" - - ----------------------------------------------------------------------- --- * Typed Sequences of Crucible Statements ----------------------------------------------------------------------- - --- | A permission implication annotated a top-level error message to be printed --- on failure -data AnnotPermImpl r ps = AnnotPermImpl !String !(PermImpl r ps) - --- | Typed return argument -data TypedRet tops rets ps = - TypedRet - !(ps :~: tops :++: rets) !(CruCtx rets) !(RAssign ExprVar rets) - !(Mb rets (DistPerms ps)) - - --- | Typed Crucible block termination statements -data TypedTermStmt blocks tops rets ps_in where - -- | Jump to the given jump target - TypedJump :: !(AnnotPermImpl (TypedJumpTarget blocks tops) ps_in) -> - TypedTermStmt blocks tops rets ps_in - - -- | Branch on condition: if true, jump to the first jump target, and - -- otherwise jump to the second jump target - TypedBr :: !(TypedReg BoolType) -> - !(AnnotPermImpl (TypedJumpTarget blocks tops) ps_in) -> - !(AnnotPermImpl (TypedJumpTarget blocks tops) ps_in) -> - TypedTermStmt blocks tops rets ps_in - - -- | Return from function, providing the return value and also proof that the - -- current permissions imply the required return permissions - TypedReturn :: !(AnnotPermImpl (TypedRet tops rets) ps_in) -> - TypedTermStmt blocks tops rets ps_in - - -- | Block ends with an error - TypedErrorStmt :: !(Maybe String) -> !(TypedReg (StringType Unicode)) -> - TypedTermStmt blocks tops rets ps_in - - --- | A typed sequence of Crucible statements -data TypedStmtSeq ext blocks tops rets ps_in where - -- | A permission implication step, which modifies the current permission - -- set. This can include pattern-matches and/or assertion failures. - TypedImplStmt :: !(AnnotPermImpl (TypedStmtSeq ext blocks tops rets) ps_in) -> - TypedStmtSeq ext blocks tops rets ps_in - - -- | Typed version of 'ConsStmt', which binds new variables for the return - -- value(s) of each statement - TypedConsStmt :: !ProgramLoc -> - !(TypedStmt ext stmt_rets ps_in ps_next) -> - !(RAssign Proxy stmt_rets) -> - !(NamedMb stmt_rets (TypedStmtSeq ext blocks tops rets ps_next)) -> - TypedStmtSeq ext blocks tops rets ps_in - - -- | Typed version of 'TermStmt', which terminates the current block - TypedTermStmt :: !ProgramLoc -> - !(TypedTermStmt blocks tops rets ps_in) -> - TypedStmtSeq ext blocks tops rets ps_in - - -$(mkNuMatching [t| forall r ps. NuMatchingAny1 r => AnnotPermImpl r ps |]) -$(mkNuMatching [t| forall tp ps_out ps_in. - TypedLLVMStmt tp ps_out ps_in |]) -$(mkNuMatching [t| forall ext stmt_rets ps_in ps_out exprExt. NuMatchingExtC ext exprExt => - TypedStmt ext stmt_rets ps_in ps_out |]) -$(mkNuMatching [t| forall tops rets ps. TypedRet tops rets ps |]) -$(mkNuMatching [t| forall blocks tops rets ps_in. - TypedTermStmt blocks tops rets ps_in |]) -$(mkNuMatching [t| forall ext blocks tops rets ps_in exprExt. - NuMatchingExtC ext exprExt => TypedStmtSeq ext blocks tops rets ps_in |]) - - -instance SubstVar PermVarSubst m => - Substable PermVarSubst (TypedReg tp) m where - genSubst s (mbMatch -> [nuMP| TypedReg x |]) = TypedReg <$> genSubst s x - -instance SubstVar PermVarSubst m => - Substable PermVarSubst (RegWithVal tp) m where - genSubst s mb_x = case mbMatch mb_x of - [nuMP| RegWithVal r e |] -> - RegWithVal <$> genSubst s r <*> genSubst s e - [nuMP| RegNoVal r |] -> RegNoVal <$> genSubst s r - -instance SubstVar PermVarSubst m => - Substable1 PermVarSubst RegWithVal m where - genSubst1 = genSubst - -instance SubstVar PermVarSubst m => - Substable PermVarSubst (TypedRegs tp) m where - genSubst s mb_x = case mbMatch mb_x of - [nuMP| TypedRegsNil |] -> return TypedRegsNil - [nuMP| TypedRegsCons rs r |] -> - TypedRegsCons <$> genSubst s rs <*> genSubst s r - -instance (NuMatchingAny1 r, m ~ Identity, - Substable1 PermVarSubst r m) => - Substable PermVarSubst (AnnotPermImpl r ps) m where - genSubst s (mbMatch -> [nuMP| AnnotPermImpl err impl |]) = - AnnotPermImpl (mbLift err) <$> genSubst s impl - -instance (PermCheckExtC ext exprExt, NuMatchingAny1 f, - SubstVar PermVarSubst m, Substable1 PermVarSubst f m, - Substable PermVarSubst (f BoolType) m) => - Substable PermVarSubst (App ext f a) m where - genSubst s mb_expr = case mbMatch mb_expr of - [nuMP| ExtensionApp _ |] -> - error "genSubst: unexpected ExtensionApp" - [nuMP| BaseIsEq tp e1 e2 |] -> - BaseIsEq (mbLift tp) <$> genSubst1 s e1 <*> genSubst1 s e2 - [nuMP| EmptyApp |] -> return EmptyApp - [nuMP| BoolLit b |] -> return $ BoolLit $ mbLift b - [nuMP| Not e |] -> - Not <$> genSubst1 s e - [nuMP| And e1 e2 |] -> - And <$> genSubst1 s e1 <*> genSubst1 s e2 - [nuMP| Or e1 e2 |] -> - Or <$> genSubst1 s e1 <*> genSubst1 s e2 - [nuMP| BoolXor e1 e2 |] -> - BoolXor <$> genSubst1 s e1 <*> genSubst1 s e2 - [nuMP| NatLit n |] -> - return $ NatLit $ mbLift n - [nuMP| NatLt e1 e2 |] -> - NatLt <$> genSubst1 s e1 <*> genSubst1 s e2 - [nuMP| NatLe e1 e2 |] -> - NatLe <$> genSubst1 s e1 <*> genSubst1 s e2 - [nuMP| NatEq e1 e2 |] -> - NatEq <$> genSubst1 s e1 <*> genSubst1 s e2 - [nuMP| NatAdd e1 e2 |] -> - NatAdd <$> genSubst1 s e1 <*> genSubst1 s e2 - [nuMP| NatSub e1 e2 |] -> - NatSub <$> genSubst1 s e1 <*> genSubst1 s e2 - [nuMP| NatMul e1 e2 |] -> - NatMul <$> genSubst1 s e1 <*> genSubst1 s e2 - [nuMP| NatDiv e1 e2 |] -> - NatDiv <$> genSubst1 s e1 <*> genSubst1 s e2 - [nuMP| NatMod e1 e2 |] -> - NatMod <$> genSubst1 s e1 <*> genSubst1 s e2 - [nuMP| HandleLit h |] -> - return $ HandleLit $ mbLift h - [nuMP| BVUndef w |] -> - BVUndef <$> genSubst s w - [nuMP| BVLit w i |] -> - BVLit <$> genSubst s w <*> return (mbLift i) - [nuMP| BVConcat w1 w2 e1 e2 |] -> - BVConcat <$> genSubst s w1 <*> genSubst s w2 <*> - genSubst1 s e1 <*> genSubst1 s e2 - [nuMP| BVTrunc w1 w2 e |] -> - BVTrunc <$> genSubst s w1 <*> genSubst s w2 <*> genSubst1 s e - [nuMP| BVZext w1 w2 e |] -> - BVZext <$> genSubst s w1 <*> genSubst s w2 <*> genSubst1 s e - [nuMP| BVSext w1 w2 e |] -> - BVSext <$> genSubst s w1 <*> genSubst s w2 <*> genSubst1 s e - [nuMP| BVNot w e |] -> - BVNot <$> genSubst s w <*> genSubst1 s e - [nuMP| BVAnd w e1 e2 |] -> - BVAnd <$> genSubst s w <*> genSubst1 s e1 <*> genSubst1 s e2 - [nuMP| BVOr w e1 e2 |] -> - BVOr <$> genSubst s w <*> genSubst1 s e1 <*> genSubst1 s e2 - [nuMP| BVXor w e1 e2 |] -> - BVXor <$> genSubst s w <*> genSubst1 s e1 <*> genSubst1 s e2 - [nuMP| BVNeg w e |] -> - BVNeg <$> genSubst s w <*> genSubst1 s e - [nuMP| BVAdd w e1 e2 |] -> - BVAdd <$> genSubst s w <*> genSubst1 s e1 <*> genSubst1 s e2 - [nuMP| BVSub w e1 e2 |] -> - BVSub <$> genSubst s w <*> genSubst1 s e1 <*> genSubst1 s e2 - [nuMP| BVMul w e1 e2 |] -> - BVMul <$> genSubst s w <*> genSubst1 s e1 <*> genSubst1 s e2 - [nuMP| BVUdiv w e1 e2 |] -> - BVUdiv <$> genSubst s w <*> genSubst1 s e1 <*> genSubst1 s e2 - [nuMP| BVSdiv w e1 e2 |] -> - BVSdiv <$> genSubst s w <*> genSubst1 s e1 <*> genSubst1 s e2 - [nuMP| BVUrem w e1 e2 |] -> - BVUrem <$> genSubst s w <*> genSubst1 s e1 <*> genSubst1 s e2 - [nuMP| BVSrem w e1 e2 |] -> - BVSrem <$> genSubst s w <*> genSubst1 s e1 <*> genSubst1 s e2 - [nuMP| BVUle w e1 e2 |] -> - BVUle <$> genSubst s w <*> genSubst1 s e1 <*> genSubst1 s e2 - [nuMP| BVUlt w e1 e2 |] -> - BVUlt <$> genSubst s w <*> genSubst1 s e1 <*> genSubst1 s e2 - [nuMP| BVSle w e1 e2 |] -> - BVSle <$> genSubst s w <*> genSubst1 s e1 <*> genSubst1 s e2 - [nuMP| BVSlt w e1 e2 |] -> - BVSlt <$> genSubst s w <*> genSubst1 s e1 <*> genSubst1 s e2 - [nuMP| BVCarry w e1 e2 |] -> - BVCarry <$> genSubst s w <*> genSubst1 s e1 <*> genSubst1 s e2 - [nuMP| BVSCarry w e1 e2 |] -> - BVSCarry <$> genSubst s w <*> genSubst1 s e1 <*> genSubst1 s e2 - [nuMP| BVSBorrow w e1 e2 |] -> - BVSBorrow <$> genSubst s w <*> genSubst1 s e1 <*> genSubst1 s e2 - [nuMP| BVShl w e1 e2 |] -> - BVShl <$> genSubst s w <*> genSubst1 s e1 <*> genSubst1 s e2 - [nuMP| BVLshr w e1 e2 |] -> - BVLshr <$> genSubst s w <*> genSubst1 s e1 <*> genSubst1 s e2 - [nuMP| BVAshr w e1 e2 |] -> - BVAshr <$> genSubst s w <*> genSubst1 s e1 <*> genSubst1 s e2 - [nuMP| BoolToBV w e |] -> - BoolToBV <$> genSubst s w <*> genSubst1 s e - [nuMP| BVNonzero w e |] -> - BVNonzero <$> genSubst s w <*> genSubst1 s e - [nuMP| StringLit str_lit |] -> - return $ StringLit $ mbLift str_lit - [nuMP| MkStruct tps flds |] -> - MkStruct (mbLift tps) <$> genSubst s flds - [nuMP| GetStruct str ix tp |] -> - GetStruct <$> genSubst1 s str <*> return (mbLift ix) <*> return (mbLift tp) - [nuMP| SetStruct tps str ix x |] -> - SetStruct (mbLift tps) <$> genSubst1 s str <*> return (mbLift ix) - <*> genSubst1 s x - _ -> - error ("genSubst: unhandled Crucible expression construct: " - ++ mbLift (fmap (show . ppApp (const (pretty "_"))) mb_expr)) - - -instance (PermCheckExtC ext exprExt, SubstVar PermVarSubst m) => - Substable PermVarSubst (TypedExpr ext tp) m where - genSubst s (mbMatch -> [nuMP| TypedExpr app maybe_val |]) = - TypedExpr <$> genSubst s app <*> genSubst s maybe_val - -instance SubstVar PermVarSubst m => - Substable PermVarSubst (TypedLLVMStmt tp ps_out ps_in) m where - genSubst s mb_x = case mbMatch mb_x of - [nuMP| ConstructLLVMWord r |] -> ConstructLLVMWord <$> genSubst s r - [nuMP| AssertLLVMWord r e |] -> - AssertLLVMWord <$> genSubst s r <*> genSubst s e - [nuMP| AssertLLVMPtr r |] -> - AssertLLVMPtr <$> genSubst s r - [nuMP| DestructLLVMWord r e |] -> - DestructLLVMWord <$> genSubst s r <*> genSubst s e - [nuMP| OffsetLLVMValue r off |] -> - OffsetLLVMValue <$> genSubst s r <*> genSubst s off - [nuMP| TypedLLVMLoad r fp ps ps_l |] -> - TypedLLVMLoad <$> genSubst s r <*> genSubst s fp <*> genSubst s ps <*> - genSubst s ps_l - [nuMP| TypedLLVMStore r fp e ps cur_ps |] -> - TypedLLVMStore <$> genSubst s r <*> genSubst s fp <*> genSubst s e <*> - genSubst s ps <*> genSubst s cur_ps - [nuMP| TypedLLVMAlloca r fperms i |] -> - TypedLLVMAlloca <$> genSubst s r <*> genSubst s fperms <*> - return (mbLift i) - [nuMP| TypedLLVMCreateFrame |] -> return TypedLLVMCreateFrame - [nuMP| TypedLLVMDeleteFrame r fperms perms |] -> - TypedLLVMDeleteFrame <$> genSubst s r <*> genSubst s fperms <*> - genSubst s perms - [nuMP| TypedLLVMLoadHandle r tp p |] -> - TypedLLVMLoadHandle <$> genSubst s r <*> return (mbLift tp) <*> genSubst s p - [nuMP| TypedLLVMResolveGlobal gsym p |] -> - TypedLLVMResolveGlobal (mbLift gsym) <$> genSubst s p - [nuMP| TypedLLVMIte w r1 r2 r3 |] -> - TypedLLVMIte (mbLift w) <$> genSubst s r1 <*> genSubst s r2 <*> genSubst s r3 - -instance (PermCheckExtC ext exprExt, SubstVar PermVarSubst m) => - Substable PermVarSubst (TypedStmt ext rets ps_in ps_out) m where - genSubst s mb_x = case mbMatch mb_x of - [nuMP| TypedSetReg tp expr |] -> - TypedSetReg (mbLift tp) <$> genSubst s expr - [nuMP| TypedSetRegPermExpr tp expr |] -> - TypedSetRegPermExpr (mbLift tp) <$> genSubst s expr - [nuMP| TypedCall f fun_perm ghosts gexprs args |] -> - TypedCall <$> genSubst s f <*> genSubst s fun_perm <*> - genSubst s ghosts <*> genSubst s gexprs <*> genSubst s args - [nuMP| TypedAssert r1 r2 |] -> - TypedAssert <$> genSubst s r1 <*> genSubst s r2 - [nuMP| TypedLLVMStmt llvmStmt |] -> - TypedLLVMStmt <$> genSubst s llvmStmt - - -instance SubstVar PermVarSubst m => - Substable PermVarSubst (TypedRet tops rets ps) m where - genSubst s (mbMatch -> [nuMP| TypedRet e rets ret_vars mb_perms |]) = - give (cruCtxProxies $ mbLift rets) - (TypedRet (mbLift e) (mbLift rets) <$> genSubst s ret_vars - <*> genSubst s mb_perms) - -instance SubstVar PermVarSubst m => - Substable1 PermVarSubst (TypedRet tops rets) m where - genSubst1 = genSubst - -instance SubstVar PermVarSubst m => - Substable PermVarSubst (TypedJumpTarget blocks tops ps) m where - genSubst s (mbMatch -> [nuMP| TypedJumpTarget siteID prx ctx perms |]) = - TypedJumpTarget (mbLift siteID) (mbLift prx) (mbLift ctx) <$> - genSubst s perms - -instance SubstVar PermVarSubst m => - Substable1 PermVarSubst (TypedJumpTarget blocks tops) m where - genSubst1 = genSubst - -instance m ~ Identity => - Substable PermVarSubst (TypedTermStmt blocks tops rets ps_in) m where - genSubst s mb_x = case mbMatch mb_x of - [nuMP| TypedJump impl_tgt |] -> TypedJump <$> genSubst s impl_tgt - [nuMP| TypedBr reg impl_tgt1 impl_tgt2 |] -> - TypedBr <$> genSubst s reg <*> genSubst s impl_tgt1 <*> - genSubst s impl_tgt2 - [nuMP| TypedReturn impl_ret |] -> - TypedReturn <$> genSubst s impl_ret - [nuMP| TypedErrorStmt str r |] -> - TypedErrorStmt (mbLift str) <$> genSubst s r - -instance (PermCheckExtC ext exprExt, m ~ Identity) => - Substable PermVarSubst (TypedStmtSeq ext blocks tops rets ps_in) m where - genSubst s mb_x = case mbMatch mb_x of - [nuMP| TypedImplStmt impl_seq |] -> - TypedImplStmt <$> genSubst s impl_seq - [nuMP| TypedConsStmt loc stmt pxys mb_seq |] -> - TypedConsStmt (mbLift loc) <$> genSubst s stmt <*> pure (mbLift pxys) - <*> give (mbLift pxys) (genSubst s mb_seq) - [nuMP| TypedTermStmt loc term_stmt |] -> - TypedTermStmt (mbLift loc) <$> genSubst s term_stmt - - -instance (PermCheckExtC ext exprExt, m ~ Identity) => - Substable1 PermVarSubst (TypedStmtSeq ext blocks tops rets) m where - genSubst1 = genSubst - - ----------------------------------------------------------------------- --- * Typed Control-Flow Graphs ----------------------------------------------------------------------- - --- FIXME: remove in-degree stuff - --- | This type characterizes the number and sort of jumps to a 'TypedEntry' -data TypedEntryInDegree - -- | There are no jumps to the entrypoint - = EntryInDegree_None - -- | There is one jump to the entrypoint - | EntryInDegree_One - -- | There is more than one jump to the entrypoint - | EntryInDegree_Many - -- | The entrypoint is the head of a loop, so has more than one jump to it, - -- one of which is a back edge - | EntryInDegree_Loop - --- | \"Add\" two in-degrees -addInDegrees :: TypedEntryInDegree -> TypedEntryInDegree -> TypedEntryInDegree -addInDegrees EntryInDegree_Loop _ = EntryInDegree_Loop -addInDegrees _ EntryInDegree_Loop = EntryInDegree_Loop -addInDegrees EntryInDegree_None in_deg = in_deg -addInDegrees in_deg EntryInDegree_None = in_deg -addInDegrees _ _ = - -- The last case is adding 1 or many + 1 or many = many - EntryInDegree_Many - --- | Add one to an in-degree -incrInDegree :: TypedEntryInDegree -> TypedEntryInDegree -incrInDegree = addInDegrees EntryInDegree_One - --- | Test if an in-degree is at least many -inDegreeIsMulti :: TypedEntryInDegree -> Bool -inDegreeIsMulti EntryInDegree_None = False -inDegreeIsMulti EntryInDegree_One = False -inDegreeIsMulti EntryInDegree_Many = True -inDegreeIsMulti EntryInDegree_Loop = True - --- | Type-level data-kind to indicate a phase of Heapster, which could be --- type-checking or translation -data HeapsterPhase = TCPhase | TransPhase - -type TCPhase = 'TCPhase -type TransPhase = 'TransPhase - --- | A piece of data of type @a@ needed in the translation phase but that could --- still be being computed in the type-checking phase -type family TransData phase a where - TransData TCPhase a = Maybe a - TransData TransPhase a = a - --- | The body of an implication in a call site, which ensures that the --- permissions are as expected and gives expressions for the ghost variables. It --- also includes a 'TypedEntryID' for the callee, to make translation easier. -data CallSiteImplRet blocks tops args ghosts ps_out = - CallSiteImplRet (TypedEntryID blocks args) (CruCtx ghosts) - ((tops :++: args) :++: ghosts :~: ps_out) - (RAssign ExprVar tops) (RAssign ExprVar args) (RAssign ExprVar ghosts) - -$(mkNuMatching [t| forall blocks tops args ghosts ps_out. - CallSiteImplRet blocks tops args ghosts ps_out |]) - -instance SubstVar PermVarSubst m => - Substable PermVarSubst (CallSiteImplRet - blocks tops args ghosts ps) m where - genSubst s (mbMatch -> - [nuMP| CallSiteImplRet entryID ghosts Refl tvars avars gvars |]) = - CallSiteImplRet (mbLift entryID) (mbLift ghosts) Refl <$> - genSubst s tvars <*> genSubst s avars <*> genSubst s gvars - -instance SubstVar PermVarSubst m => - Substable1 PermVarSubst (CallSiteImplRet - blocks tops args ghosts) m where - genSubst1 = genSubst - - --- | An implication used in a call site, which binds the input variables in an --- implication of the output variables -newtype CallSiteImpl blocks ps_in tops args ghosts = - CallSiteImpl (Mb ps_in (AnnotPermImpl - (CallSiteImplRet blocks tops args ghosts) ps_in)) - --- | The identity implication -idCallSiteImpl :: TypedEntryID blocks args -> - CruCtx tops -> CruCtx args -> CruCtx vars -> - CallSiteImpl blocks ((tops :++: args) :++: vars) tops args vars -idCallSiteImpl entryID tops args vars = - let tops_args_prxs = cruCtxProxies (appendCruCtx tops args) - vars_prxs = cruCtxProxies vars in - CallSiteImpl $ mbCombine vars_prxs $ nuMulti tops_args_prxs $ \tops_args_ns -> - let (tops_ns, args_ns) = RL.split tops (cruCtxProxies args) tops_args_ns in - nuMulti vars_prxs $ \vars_ns -> - AnnotPermImpl "" $ PermImpl_Done $ - CallSiteImplRet entryID vars Refl tops_ns args_ns vars_ns - --- | A jump / branch to a particular entrypoint -data TypedCallSite phase blocks tops args ghosts vars = - TypedCallSite - { - -- | The ID of this call site - typedCallSiteID :: TypedCallSiteID blocks args vars, - -- | The permissions held at the call site - typedCallSitePerms :: MbValuePerms ((tops :++: args) :++: vars), - -- | An implication from the call site perms to the input perms of the - -- entrypoint we are jumping to - typedCallSiteImpl :: TransData phase (CallSiteImpl - blocks - ((tops :++: args) :++: vars) - tops args ghosts) - } - --- | Transition a 'TypedEntry' from type-checking to translation phase if its --- implication has been proved -completeTypedCallSite :: - TypedCallSite TCPhase blocks tops args ghosts vars -> - Maybe (TypedCallSite TransPhase blocks tops args ghosts vars) -completeTypedCallSite call_site - | Just impl <- typedCallSiteImpl call_site - = Just $ call_site { typedCallSiteImpl = impl } -completeTypedCallSite _ = Nothing - --- | Build a 'TypedCallSite' with no implication -emptyTypedCallSite :: TypedCallSiteID blocks args vars -> - MbValuePerms ((tops :++: args) :++: vars) -> - TypedCallSite TCPhase blocks tops args ghosts vars -emptyTypedCallSite siteID perms = TypedCallSite siteID perms Nothing - --- | Build a 'TypedCallSite' that uses the identity implication, meaning its --- @vars@ will equal the @ghosts@ of its entrypoint -idTypedCallSite :: TypedCallSiteID blocks args vars -> - CruCtx tops -> CruCtx args -> - MbValuePerms ((tops :++: args) :++: vars) -> - TypedCallSite TCPhase blocks tops args vars vars -idTypedCallSite siteID tops args perms = - TypedCallSite siteID perms $ Just $ - idCallSiteImpl (callSiteDest siteID) tops args (callSiteVars siteID) - --- | Test if the implication of a call site fails or is not present -typedCallSiteImplFails :: TypedCallSite TCPhase blocks tops args ghosts vars -> - Bool -typedCallSiteImplFails (TypedCallSite { typedCallSiteImpl = - Just (CallSiteImpl mb_annot_impl) }) = - mbLift $ fmap (\(AnnotPermImpl _ impl) -> permImplFails impl) mb_annot_impl -typedCallSiteImplFails _ = True - --- | Extract the caller permissions of a call site as an 'ArgVarPerms' -typedCallSiteArgVarPerms :: TypedCallSite phase blocks tops args ghsots vars -> - ArgVarPerms (tops :++: args) vars -typedCallSiteArgVarPerms (TypedCallSite {..}) = - ArgVarPerms (callSiteVars typedCallSiteID) typedCallSitePerms - --- | A single, typed entrypoint to a Crucible block. Note that our blocks --- implicitly take extra \"ghost\" arguments, that are needed to express the --- input and output permissions. The first of these ghost arguments are the --- top-level inputs to the entire function. -data TypedEntry phase ext blocks tops rets args ghosts = - TypedEntry - { - -- | The identifier for this particular entrypoing - typedEntryID :: !(TypedEntryID blocks args), - -- | The top-level arguments to the entire function - typedEntryTops :: !(CruCtx tops), - -- | The real arguments to this block - typedEntryArgs :: !(CruCtx args), - -- | The return values (including ghosts) from the entire function - typedEntryRets :: !(CruCtx rets), - -- | The call sites that jump to this particular entrypoint - typedEntryCallers :: ![Some (TypedCallSite phase blocks tops args ghosts)], - -- | The ghost variables for this entrypoint - typedEntryGhosts :: !(CruCtx ghosts), - -- | The input permissions for this entrypoint - typedEntryPermsIn :: !(MbValuePerms ((tops :++: args) :++: ghosts)), - -- | The output permissions for the function (cached locally) - typedEntryPermsOut :: !(MbValuePerms (tops :++: rets)), - -- | The type-checked body of the entrypoint - typedEntryBody :: !(TransData phase - (NamedMb ((tops :++: args) :++: ghosts) - (TypedStmtSeq ext blocks tops rets - ((tops :++: args) :++: ghosts)))) - } - - --- | Test if an entrypoint has in-degree greater than 1 -typedEntryHasMultiInDegree :: TypedEntry phase ext blocks tops rets args ghosts -> - Bool -typedEntryHasMultiInDegree entry = length (typedEntryCallers entry) > 1 - --- | Get the types of all the inputs of an entrypoint -typedEntryAllArgs :: TypedEntry phase ext blocks tops rets args ghosts -> - CruCtx ((tops :++: args) :++: ghosts) -typedEntryAllArgs (TypedEntry {..}) = - appendCruCtx (appendCruCtx typedEntryTops typedEntryArgs) typedEntryGhosts - --- | Transition a 'TypedEntry' from type-checking to translation phase if its --- body is present and all call site implications have been proved -completeTypedEntry :: - TypedEntry TCPhase ext blocks tops rets args ghosts -> - Maybe (TypedEntry TransPhase ext blocks tops rets args ghosts) -completeTypedEntry (TypedEntry { .. }) - | Just body <- typedEntryBody - , Just callers <- mapM (traverseF completeTypedCallSite) typedEntryCallers - = Just $ TypedEntry { typedEntryBody = body, typedEntryCallers = callers, .. } -completeTypedEntry _ = Nothing - --- | Build an entrypoint from a call site, using that call site's permissions as --- the entyrpoint input permissions -singleCallSiteEntry :: TypedCallSiteID blocks args vars -> - CruCtx tops -> CruCtx args -> CruCtx rets -> - MbValuePerms ((tops :++: args) :++: vars) -> - MbValuePerms (tops :++: rets) -> - TypedEntry TCPhase ext blocks tops rets args vars -singleCallSiteEntry siteID tops args rets perms_in perms_out = - TypedEntry - { - typedEntryID = callSiteDest siteID, typedEntryTops = tops, - typedEntryArgs = args, typedEntryRets = rets, - typedEntryCallers = [Some $ idTypedCallSite siteID tops args perms_in], - typedEntryGhosts = callSiteVars siteID, - typedEntryPermsIn = perms_in, typedEntryPermsOut = perms_out, - typedEntryBody = Nothing - } - --- | Test if an entrypoint contains a call site with the given caller -typedEntryHasCaller :: TypedEntryID blocks args_src -> - TypedEntry phase ext blocks tops rets args ghosts -> - Bool -typedEntryHasCaller callerID (typedEntryCallers -> callers) = - any (\(Some site) -> - callSiteIDCallerEq callerID $ typedCallSiteID site) callers - --- | Return the 'TypedCallSite' structure in an entrypoint for a particular call --- site id, if it exists. Unlike 'typedEntryHasCaller', this requires the site --- id to have the same variables. -typedEntryCallerSite :: - TypedCallSiteID blocks args vars -> - TypedEntry phase ext blocks tops rets args ghosts -> - Maybe (TypedCallSite phase blocks tops args ghosts vars) -typedEntryCallerSite siteID (typedEntryCallers -> callers) = - listToMaybe $ flip mapMaybe callers $ \(Some site) -> - case testEquality (typedCallSiteID site) siteID of - Just Refl -> Just site - Nothing -> Nothing - - --- | A typed Crucible block is either a join block, meaning that all jumps to it --- get joined into the same entrypoint, or is a multi-entry block, meaning that --- each jump to it gets type-checked separately with a different entrypoint -data TypedBlockSort = JoinSort | MultiEntrySort - --- | A typed Crucible block is a list of typed entrypoints to that block -data TypedBlock phase ext (blocks :: RList (RList CrucibleType)) tops rets args = - forall gouts ret cargs. (CtxToRList cargs ~ args, rets ~ (gouts :> ret)) => - TypedBlock - { - -- | An identifier for this block - typedBlockID :: TypedBlockID blocks args, - -- | The original Crucible block - typedBlockBlock :: Block ext (RListToCtxCtx blocks) ret cargs, - -- | What sort of block is this - typedBlockSort :: TypedBlockSort, - -- | Whether widening is allowed for entrypoints in this block; widening - -- disallowed for user-supplied permissions - typedBlockCanWiden :: Bool, - -- | The entrypoints into this block - _typedBlockEntries :: [Some (TypedEntry phase ext blocks tops rets args)], - -- | Debug name information for the current block - _typedBlockNames :: [Maybe String] - } - --- NOTE: this doesn't work because of the rets ~ (gouts :> ret) constraint --- makeLenses ''TypedBlock - --- | The lens for '_typedBlockEntries' -typedBlockEntries :: Lens' (TypedBlock phase ext blocks tops rets args) - [Some (TypedEntry phase ext blocks tops rets args)] -typedBlockEntries = - lens _typedBlockEntries (\tblk entries -> - tblk { _typedBlockEntries = entries }) - --- | The lens for '_typedBlockNames' -typedBlockNames :: Lens' (TypedBlock phase ext blocks tops rets args) - [Maybe String] -typedBlockNames = - lens _typedBlockNames (\tblk ns -> tblk { _typedBlockNames = ns }) - --- | The input argument types of a block -blockArgs :: TypedBlock phase ext blocks tops rets args -> CruCtx args -blockArgs (TypedBlock {..}) = mkCruCtx $ blockInputs typedBlockBlock - --- | Get the 'Int' index of the location of entrypoint in the --- 'typedBlockEntries' of a block, if it exists -blockEntryMaybeIx :: TypedEntryID blocks args -> - TypedBlock phase ext blocks tops rets args -> - Maybe Int -blockEntryMaybeIx entryID blk = - findIndex (\(Some entry) -> entryID == typedEntryID entry) - (blk ^. typedBlockEntries) - --- | Get the 'Int' index of the location of entrypoint in the --- 'typedBlockEntries' of a block, or raise an error if it does not exist -blockEntryIx :: TypedEntryID blocks args -> - TypedBlock phase ext blocks tops rets args -> - Int -blockEntryIx entryID blk = - maybe (error "blockEntryIx: no such entrypoint!") id $ - blockEntryMaybeIx entryID blk - --- | Test if an entrypoint ID has a corresponding entrypoint in a block -entryIDInBlock :: TypedEntryID blocks args -> - TypedBlock phase ext blocks tops rets args -> Bool -entryIDInBlock entryID blk = isJust $ blockEntryMaybeIx entryID blk - --- | The 'Lens' for finding a 'TypedEntry' by id in a 'TypedBlock' -entryByID :: TypedEntryID blocks args -> - Lens' (TypedBlock phase ext blocks tops ret args) - (Some (TypedEntry phase ext blocks tops ret args)) -entryByID entryID = - lens - (\blk -> view typedBlockEntries blk !! blockEntryIx entryID blk) - (\blk e -> - over typedBlockEntries (replaceNth (blockEntryIx entryID blk) e) blk) - - --- | Build an empty 'TypedBlock' -emptyBlockOfSort :: - [Maybe String] -> - Assignment CtxRepr cblocks -> - TypedBlockSort -> - Block ext cblocks ret cargs -> - TypedBlock TCPhase ext (CtxCtxToRList cblocks) tops (gouts :> ret) (CtxToRList - cargs) -emptyBlockOfSort names cblocks sort blk - | Refl <- reprReprToCruCtxCtxEq cblocks - = TypedBlock (indexToTypedBlockID (size cblocks) $ - blockIDIndex $ blockID blk) blk sort True [] names - --- | Build a block with a user-supplied input permission -emptyBlockForPerms :: - [Maybe String] -> - Assignment CtxRepr cblocks -> - Block ext cblocks ret cargs -> CruCtx tops -> - TypeRepr ret -> CruCtx ghosts -> CruCtx gouts -> - MbValuePerms ((tops :++: CtxToRList cargs) :++: ghosts) -> - MbValuePerms (tops :++: gouts :> ret) -> - TypedBlock TCPhase ext (CtxCtxToRList - cblocks) tops (gouts :> ret) (CtxToRList cargs) -emptyBlockForPerms names cblocks blk tops ret ghosts gouts perms_in perms_out - | Refl <- reprReprToCruCtxCtxEq cblocks - , blockID <- indexToTypedBlockID (size cblocks) $ blockIDIndex $ blockID blk - , args <- mkCruCtx (blockInputs blk) = - TypedBlock blockID blk JoinSort False - [Some TypedEntry { - typedEntryID = TypedEntryID blockID 0, typedEntryTops = tops, - typedEntryArgs = args, typedEntryRets = CruCtxCons gouts ret, - typedEntryCallers = [], typedEntryGhosts = ghosts, - typedEntryPermsIn = perms_in, typedEntryPermsOut = perms_out, - typedEntryBody = Nothing }] - names - --- | Transition a 'TypedBlock' from type-checking to translation phase, by --- making sure that all of data needed for the translation phase is present -completeTypedBlock :: TypedBlock TCPhase ext blocks tops rets args -> - Maybe (TypedBlock TransPhase ext blocks tops rets args) -completeTypedBlock (TypedBlock { .. }) - | Just entries <- mapM (traverseF completeTypedEntry) _typedBlockEntries - = Just $ TypedBlock { _typedBlockEntries = entries, .. } -completeTypedBlock _ = Nothing - --- | Add a new entrypoint to a block, making sure that its entry ID does not --- already exist in the block -addEntryToBlock :: TypedEntry phase ext blocks tops rets args ghosts -> - TypedBlock phase ext blocks tops rets args -> - TypedBlock phase ext blocks tops rets args -addEntryToBlock entry blk - | entryIDInBlock (typedEntryID entry) blk = - error "addEntryToBlock: entry with the same ID already in block!" -addEntryToBlock entry blk = over typedBlockEntries (++ [Some entry]) blk - --- | Return a 'Int' not in a list -freshInt :: [Int] -> Int -freshInt [] = 0 -freshInt xs = 1 + maximum xs - --- | Build a new 'TypedCallSiteID' for a new call to a block from a given --- entrypoint. If the block has 'JoinSort', this will call the one and only --- entrypoint for that block, and otherwise, for a 'MultiEntrySort' block, it --- will create a new entrypoint id. -newCallSiteID :: TypedEntryID blocks args_src -> CruCtx vars -> - TypedBlock phase ext blocks tops rets args -> - TypedCallSiteID blocks args vars - --- If blk has JoinSort but has no entrypoints yet, we will create one. It cannot --- have any other callers, either, so we use caller index 0. -newCallSiteID callerID vars blk@(typedBlockSort -> JoinSort) - | [] <- blk ^. typedBlockEntries = - let entryID = TypedEntryID (typedBlockID blk) 0 - call_ix = 0 in - TypedCallSiteID callerID call_ix entryID vars - --- If blk has JoinSort and does have an entrypoint already, choose a caller --- index that is greater than any already being used -newCallSiteID callerID vars blk@(typedBlockSort -> JoinSort) - | Some entry:_ <- blk ^. typedBlockEntries = - let entryID = TypedEntryID (typedBlockID blk) 0 - call_ix = freshInt (map - (\(Some site) -> callSiteIx (typedCallSiteID site)) - (typedEntryCallers entry)) in - TypedCallSiteID callerID call_ix entryID vars - --- If blk has MultiEntrySort, make a new entrypoint -newCallSiteID callerID vars blk@(typedBlockSort -> MultiEntrySort) = - let entry_ix = freshInt (map - (\(Some entry) -> entryIndex (typedEntryID entry)) - (blk ^. typedBlockEntries)) - entryID = TypedEntryID (typedBlockID blk) entry_ix - call_ix = 0 in - TypedCallSiteID callerID call_ix entryID vars - --- Should never happen... -newCallSiteID _ _ _ = error "newCallSiteID: impossible case!" - - --- | Add a call site to an entrypoint. It is an error if the entrypoint already --- has a call site with the given call site id. -entryAddCallSite :: TypedCallSiteID blocks args vars -> - MbValuePerms ((tops :++: args) :++: vars) -> - TypedEntry TCPhase ext blocks tops rets args ghosts -> - TypedEntry TCPhase ext blocks tops rets args ghosts -entryAddCallSite siteID _ entry - | any (\(Some site) -> - isJust $ testEquality (typedCallSiteID site) siteID) - (typedEntryCallers entry) - = error "entryAddCallSite: call site already exists!" -entryAddCallSite siteID perms_in entry = - entry { typedEntryCallers = - typedEntryCallers entry ++ [Some $ - emptyTypedCallSite siteID perms_in] } - --- | Add a call site to a block for a particular caller to have the supplied --- permissions over the supplied variables, adding a new entrypoint if that of --- the given call site ID does not yet exist. It is an error if the block --- already has a call site with the given call site id. -blockAddCallSite :: TypedCallSiteID blocks args vars -> - CruCtx tops -> CruCtx rets -> - MbValuePerms ((tops :++: args) :++: vars) -> - MbValuePerms (tops :++: rets) -> - TypedBlock TCPhase ext blocks tops rets args -> - TypedBlock TCPhase ext blocks tops rets args --- If the entrypoint for the site ID exists, update it with entrySetCallSite -blockAddCallSite siteID _ _ perms_in _ blk - | Just _ <- blockEntryMaybeIx (callSiteDest siteID) blk = - over - (entryByID $ callSiteDest siteID) - (\(Some entry) -> Some $ entryAddCallSite siteID perms_in entry) - blk - --- Otherwise, make a new entrypoint -blockAddCallSite siteID tops rets perms_in perms_out blk = - addEntryToBlock (singleCallSiteEntry - siteID tops (blockArgs blk) rets perms_in perms_out) blk - --- | A map assigning a 'TypedBlock' to each 'BlockID' -type TypedBlockMap phase ext blocks tops rets = - RAssign (TypedBlock phase ext blocks tops rets) blocks - -instance Show (TypedEntry phase ext blocks tops rets args ghosts) where - show (TypedEntry { .. }) = - "" - -instance Show (TypedBlock phase ext blocks tops rets args) where - show = concatMap (\(Some entry) -> show entry) . (^. typedBlockEntries) - -instance Show (TypedBlockMap phase ext blocks tops rets) where - show blkMap = show $ RL.mapToList show blkMap - --- | Transition a 'TypedBlockMap' from type-checking to translation phase, by --- making sure that all of data needed for the translation phase is present -completeTypedBlockMap :: TypedBlockMap TCPhase ext blocks tops rets -> - Maybe (TypedBlockMap TransPhase ext blocks tops rets) -completeTypedBlockMap = traverseRAssign completeTypedBlock - --- | The 'Lens' for finding a 'TypedBlock' by id in a 'TypedBlockMap' -blockByID :: TypedBlockID blocks args -> - Lens' - (TypedBlockMap phase ext blocks tops rets) - (TypedBlock phase ext blocks tops rets args) -blockByID blkID = - let memb = typedBlockIDMember blkID in - lens (RL.get memb) (flip $ RL.set memb) - --- | Look up a 'TypedEntry' by its 'TypedEntryID' -lookupEntry :: TypedEntryID blocks args -> - TypedBlockMap phase ext blocks tops rets -> - Some (TypedEntry phase ext blocks tops rets args) -lookupEntry entryID = - view (blockByID (entryBlockID entryID) . entryByID entryID) - --- | Find all call sites called by an entrypoint -entryCallees :: TypedEntryID blocks args -> - TypedBlockMap phase ext blocks tops rets -> - [Some (TypedEntryID blocks)] -entryCallees entryID = - concat . RL.mapToList - (\blk -> - flip mapMaybe (blk ^. typedBlockEntries) $ \(Some entry) -> - if typedEntryHasCaller entryID entry - then Just (Some $ typedEntryID entry) - else Nothing) - --- | Delete any call sites whose source is a given entrypoint. For any call --- sites to entrypoints in multi-entry blocks, delete those entrypoints as well, --- etc. -deleteEntryCallees :: TypedEntryID blocks args -> - TypedBlockMap phase ext blocks tops rets -> - TypedBlockMap phase ext blocks tops rets -deleteEntryCallees topEntryID = execState (deleteCallees topEntryID) where - -- Delete call sites of a caller from all of its callees - deleteCallees :: TypedEntryID blocks args' -> - State (TypedBlockMap phase ext blocks tops rets) () - deleteCallees callerID = - get >>= \blkMap -> - mapM_ (\(Some calleeID) -> - deleteCall callerID calleeID) (entryCallees callerID blkMap) - - -- Delete call sites of a caller to a particular callee - deleteCall :: TypedEntryID blocks args1 -> TypedEntryID blocks args2 -> - State (TypedBlockMap phase ext blocks tops rets) () - deleteCall callerID calleeID = - (typedBlockSort <$> use (blockByID $ entryBlockID calleeID)) >>= \case - JoinSort -> - -- The target has JoinSort, so we want to keep the callee entrypoint. Thus - -- we just delete all call sites whose caller equals callerID. - modifying (blockByID (entryBlockID calleeID) - . entryByID calleeID) $ \(Some callee) -> - let callers' = - flip filter (typedEntryCallers callee) $ \(Some site) -> - not $ callSiteIDCallerEq callerID $ typedCallSiteID site in - Some $ callee { typedEntryCallers = callers' } - MultiEntrySort -> - -- The target has MultiEntrySort, so callerID is the only caller to this - -- entrypoint, and thus we recursively delete the entrypoint - modifying (blockByID (entryBlockID calleeID) . typedBlockEntries) - (filter (\(Some entry) -> typedEntryID entry /= calleeID)) - >> - deleteCallees calleeID - --- | Build the input permissions for the initial block of a CFG, where the --- top-level variables (which in this case are the ghosts plus the normal --- arguments of the function permission) get the function input permissions and --- the normal arguments get equality permissions to their respective top-level --- variables. -funPermToBlockInputs :: FunPerm ghosts args gouts ret -> - MbValuePerms ((ghosts :++: args) :++: args) -funPermToBlockInputs fun_perm = - let args_prxs = cruCtxProxies $ funPermArgs fun_perm in - extMbMulti args_prxs $ - flip nuMultiWithElim1 (funPermIns fun_perm) $ \ghosts_args_ns perms_in -> - let (_, args_ns) = - RL.split (funPermGhosts fun_perm) args_prxs ghosts_args_ns in - appendValuePerms perms_in (eqValuePerms args_ns) - --- | Build an initial 'TypedBlockMap' from a 'BlockMap'. Determine the sort, and --- possibly entrypoint permissions, for each block by using hints in the --- supplied 'PermEnv' along with a list of 'Bool' flags indicating which blocks --- are at the head of a loop (or other strongly-connected component) -initTypedBlockMap :: - KnownRepr ExtRepr ext => - PermEnv -> - FunPerm ghosts (CtxToRList init) gouts ret -> - CFG ext cblocks init ret -> - Assignment (Constant Bool) cblocks -> - TypedBlockMap TCPhase ext (CtxCtxToRList cblocks) - (ghosts :++: CtxToRList init) (gouts :> ret) -initTypedBlockMap env fun_perm cfg sccs = - let block_map = cfgBlockMap cfg - cblocks = fmapFC blockInputs block_map - namess = computeCfgNames knownRepr (size sccs) cfg - gouts = funPermGouts fun_perm - ret = funPermRet fun_perm - tops = funPermTops fun_perm - top_perms_in = funPermToBlockInputs fun_perm - perms_out = funPermOuts fun_perm in - assignToRListRList - (\(Pair blk (Pair (Constant is_scc) (Constant names))) -> - let blkID = blockID blk - hints = lookupBlockHints env (cfgHandle cfg) cblocks blkID in - case hints of - _ | Just Refl <- testEquality (cfgEntryBlockID cfg) blkID -> - emptyBlockForPerms names cblocks blk tops ret - CruCtxNil gouts top_perms_in perms_out - (find isBlockEntryHint -> - Just (BlockEntryHintSort tops' ghosts perms_in)) - | Just Refl <- testEquality tops tops' -> - emptyBlockForPerms names cblocks blk tops ret - ghosts gouts perms_in perms_out - _ | is_scc || any isJoinPointHint hints -> - emptyBlockOfSort names cblocks JoinSort blk - _ -> emptyBlockOfSort names cblocks MultiEntrySort blk) $ - Ctx.zipWith Pair block_map (Ctx.zipWith Pair sccs namess) - -computeCfgNames :: - ExtRepr ext -> - Size cblocks -> - CFG ext cblocks init ret -> - Ctx.Assignment (Constant [Maybe String]) cblocks -computeCfgNames ExtRepr_LLVM _ cfg = computeNames cfg -computeCfgNames ExtRepr_Unit s _ = Ctx.replicate s (Constant []) - --- | A typed Crucible CFG -data TypedCFG - (ext :: Type) - (blocks :: RList (RList CrucibleType)) - (ghosts :: RList CrucibleType) - (inits :: RList CrucibleType) - (gouts :: RList CrucibleType) - (ret :: CrucibleType) - = TypedCFG { tpcfgHandle :: !(TypedFnHandle ghosts inits gouts ret) - , tpcfgFunPerm :: !(FunPerm ghosts inits gouts ret) - , tpcfgBlockMap :: !(TypedBlockMap TransPhase ext blocks - (ghosts :++: inits) (gouts :> ret)) - , tpcfgEntryID :: !(TypedEntryID blocks inits) - } - --- | Get the input permissions for a 'CFG' -tpcfgInputPerms :: TypedCFG ext blocks ghosts inits gouts ret -> - MbValuePerms (ghosts :++: inits) -tpcfgInputPerms = funPermIns . tpcfgFunPerm - --- | Get the output permissions for a 'CFG' -tpcfgOutputPerms :: TypedCFG ext blocks ghosts inits gouts ret -> - MbValuePerms ((ghosts :++: inits) :++: gouts :> ret) -tpcfgOutputPerms = funPermOuts . tpcfgFunPerm - - ----------------------------------------------------------------------- --- * Monad(s) for Permission Checking ----------------------------------------------------------------------- - --- | A translation of a Crucible context to 'TypedReg's that exist in the local --- Hobbits context -type CtxTrans ctx = Assignment TypedReg ctx - --- | Build a Crucible context translation from a set of variables -mkCtxTrans :: Assignment f ctx -> RAssign Name (CtxToRList ctx) -> CtxTrans ctx -mkCtxTrans (viewAssign -> AssignEmpty) _ = Ctx.empty -mkCtxTrans (viewAssign -> AssignExtend ctx' _) (ns :>: n) = - extend (mkCtxTrans ctx' ns) (TypedReg n) - --- | Add a variable to the current Crucible context translation -addCtxName :: CtxTrans ctx -> ExprVar tp -> CtxTrans (ctx ::> tp) -addCtxName ctx x = extend ctx (TypedReg x) - - --- | The translation of a Crucible block id -newtype BlockIDTrans blocks args = - BlockIDTrans { unBlockIDTrans :: TypedBlockID blocks (CtxToRList args) } - --- | Build a map from Crucible block IDs to 'Member' proofs -buildBlockIDMap :: Size cblocks -> - Assignment (BlockIDTrans (CtxCtxToRList cblocks)) cblocks -buildBlockIDMap sz = - Ctx.generate sz $ \ix -> BlockIDTrans (indexToTypedBlockID sz ix) - -data SomePtrWidth where SomePtrWidth :: HasPtrWidth w => SomePtrWidth - --- | Top-level state, maintained outside of permission-checking single blocks -data TopPermCheckState ext cblocks blocks tops rets = - TopPermCheckState - { - -- | The top-level inputs of the function being type-checked - stTopCtx :: !(CruCtx tops), - -- | The return types including ghosts of the function being type-checked - stRetTypes :: !(CruCtx rets), - -- | The return permission of the function being type-checked - stRetPerms :: !(MbValuePerms (tops :++: rets)), - -- | A mapping from 'BlockID's to 'TypedBlockID's - stBlockTrans :: !(Assignment (BlockIDTrans blocks) cblocks), - -- | The current set of type-checked blocks - _stBlockMap :: !(TypedBlockMap TCPhase ext blocks tops rets), - -- | The permissions environment - stPermEnv :: !PermEnv, - -- | The un-translated input types of all of the Crucible blocks - -- - -- FIXME: this is only needed to look up hints, to prove that the @blocks@ - -- type argument of the hints are equal to that of the function being - -- type-checked; if we translated @blocks@ to @'CtxCtxToRList' blocks@ when - -- creating the hints, this field would go away - stBlockTypes :: !(Assignment CtxRepr cblocks), - -- | Equality constraint between @cblocks@ and @blocks@ - stCBlocksEq :: RListToCtxCtx blocks :~: cblocks, - -- | The endianness of the current architecture - stEndianness :: !EndianForm, - stArchWidth :: SomePtrWidth, - -- | The debugging level - stDebugLevel :: DebugLevel - } - -makeLenses ''TopPermCheckState - --- | Build an empty 'TopPermCheckState' from a Crucible 'BlockMap' -emptyTopPermCheckState :: - HasPtrWidth w => - KnownRepr ExtRepr ext => - PermEnv -> - FunPerm ghosts (CtxToRList init) gouts ret -> - EndianForm -> - DebugLevel -> - CFG ext cblocks init ret -> - Assignment (Constant Bool) cblocks -> - TopPermCheckState ext cblocks - (CtxCtxToRList cblocks) - (ghosts :++: CtxToRList init) (gouts :> ret) -emptyTopPermCheckState env fun_perm endianness dlevel cfg sccs = - let blkMap = cfgBlockMap cfg in - TopPermCheckState - { stTopCtx = funPermTops fun_perm - , stRetTypes = funPermRets fun_perm - , stRetPerms = funPermOuts fun_perm - , stBlockTrans = buildBlockIDMap (Ctx.size blkMap) - , _stBlockMap = initTypedBlockMap env fun_perm cfg sccs - , stPermEnv = env - , stBlockTypes = fmapFC blockInputs blkMap - , stCBlocksEq = reprReprToCruCtxCtxEq (fmapFC blockInputs blkMap) - , stEndianness = endianness - , stArchWidth = SomePtrWidth - , stDebugLevel = dlevel - } - - --- | Look up a Crucible block id in a top-level perm-checking state -stLookupBlockID :: BlockID cblocks args -> - TopPermCheckState ext cblocks blocks tops rets -> - TypedBlockID blocks (CtxToRList args) -stLookupBlockID (BlockID ix) st = - unBlockIDTrans $ stBlockTrans st Ctx.! ix - --- | The top-level monad for permission-checking CFGs -type TopPermCheckM ext cblocks blocks tops rets = - State (TopPermCheckState ext cblocks blocks tops rets) - -{- --- | A datakind for the type-level parameters needed to define blocks, including --- the @ext@, @blocks@, @ret@ and @args@ arguments -data BlkParams = - BlkParams Type (RList (RList CrucibleType)) CrucibleType (RList CrucibleType) - -type family BlkExt (args :: BlkParams) :: Type where - BlkExt ('BlkParams ext _ _ _) = ext - -type family BlkBlocks (args :: BlkParams) :: (RList (RList CrucibleType)) where - BlkBlocks ('BlkParams _ blocks _ _) = blocks - -type family BlkRet (args :: BlkParams) :: CrucibleType where - BlkRet ('BlkParams _ _ ret _) = ret - -type family BlkArgs (args :: BlkParams) :: RList CrucibleType where - BlkArgs ('BlkParams _ _ _ args) = args --} - - - --- | A change to a 'TypedBlockMap' -data TypedBlockMapDelta blocks tops rets where - -- | Add a call site to a block for a particular caller to have the supplied - -- permissions over the supplied variables - TypedBlockMapAddCallSite :: TypedCallSiteID blocks args vars -> - MbValuePerms ((tops :++: args) :++: vars) -> - TypedBlockMapDelta blocks tops rets - --- | Apply a 'TypedBlockMapDelta' to a 'TypedBlockMap' -applyTypedBlockMapDelta :: TypedBlockMapDelta blocks tops rets -> - TopPermCheckState ext cblocks blocks tops rets -> - TopPermCheckState ext cblocks blocks tops rets -applyTypedBlockMapDelta (TypedBlockMapAddCallSite siteID perms_in) top_st = - over (stBlockMap . member (entryBlockMember $ callSiteDest siteID)) - (blockAddCallSite siteID (stTopCtx top_st) (stRetTypes top_st) - perms_in (stRetPerms top_st)) - top_st - --- | Apply a list of 'TypedBlockMapDelta's to a 'TopPermCheckState' -applyDeltasToTopState :: [TypedBlockMapDelta blocks tops rets] -> - TopPermCheckState ext cblocks blocks tops rets -> - TopPermCheckState ext cblocks blocks tops rets -applyDeltasToTopState deltas top_st = - foldl (flip applyTypedBlockMapDelta) top_st deltas - --- | The state that can be modified by \"inner\" computations = a list of --- changes / \"deltas\" to the current 'TypedBlockMap' -data InnerPermCheckState blocks tops rets = - InnerPermCheckState - { - innerStateDeltas :: [TypedBlockMapDelta blocks tops rets] - } - --- | Build an empty, closed 'InnerPermCheckState' -clEmptyInnerPermCheckState :: Closed (InnerPermCheckState blocks tops rets) -clEmptyInnerPermCheckState = $(mkClosed [| InnerPermCheckState [] |]) - - --- | The \"inner\" monad that runs inside 'PermCheckM' continuations. It can see --- but not modify the top-level state, but it can add 'TypedBlockMapDelta's to --- be applied later to the top-level state. -type InnerPermCheckM ext cblocks blocks tops rets = - ReaderT (TopPermCheckState ext cblocks blocks tops rets) - (State (Closed (InnerPermCheckState blocks tops rets))) - - --- | The local state maintained while type-checking is the current permission --- set and the permissions required on return from the entire function. -data PermCheckState ext blocks tops rets ps = - PermCheckState - { - stCurPerms :: !(PermSet ps), - stExtState :: !(PermCheckExtState ext), - stTopVars :: !(RAssign Name tops), - stCurEntry :: !(Some (TypedEntryID blocks)), - stVarTypes :: !(NameMap TypeRepr), - stUnitVar :: !(Maybe (ExprVar UnitType)), - -- ^ An optional global unit variable that all other unit variables will be - -- equal to - stPPInfo :: !PPInfo, - stErrPrefix :: !(Maybe (Doc ())), - stDebug :: ![Maybe String] - } - --- | Build a default, empty 'PermCheckState' -emptyPermCheckState :: - KnownRepr ExtRepr ext => - PermSet ps -> - RAssign ExprVar tops -> - TypedEntryID blocks args -> - [Maybe String] -> - PermCheckState ext blocks tops rets ps -emptyPermCheckState perms tops entryID names = - PermCheckState { stCurPerms = perms, - stExtState = emptyPermCheckExtState knownRepr, - stTopVars = tops, - stCurEntry = Some entryID, - stVarTypes = NameMap.empty, - stUnitVar = Nothing, - stPPInfo = emptyPPInfo, - stErrPrefix = Nothing, - stDebug = names } - --- | Like the 'set' method of a lens, but allows the @ps@ argument to change -setSTCurPerms :: PermSet ps2 -> PermCheckState ext blocks tops rets ps1 -> - PermCheckState ext blocks tops rets ps2 -setSTCurPerms perms (PermCheckState {..}) = - PermCheckState { stCurPerms = perms, .. } - -modifySTCurPerms :: (PermSet ps1 -> PermSet ps2) -> - PermCheckState ext blocks tops rets ps1 -> - PermCheckState ext blocks tops rets ps2 -modifySTCurPerms f_perms st = setSTCurPerms (f_perms $ stCurPerms st) st - -nextDebugName :: PermCheckM ext cblocks blocks tops rets a ps a ps (Maybe String) -nextDebugName = - do st <- get - put st { stDebug = drop 1 (stDebug st)} - pure (foldr (\x _ -> x) Nothing (stDebug st)) - --- | The generalized monad for permission-checking -type PermCheckM ext cblocks blocks tops rets r1 ps1 r2 ps2 = - GenStateContT - (PermCheckState ext blocks tops rets ps1) r1 - (PermCheckState ext blocks tops rets ps2) r2 - (InnerPermCheckM ext cblocks blocks tops rets) - --- | The generalized monad for permission-checking statements -type StmtPermCheckM ext cblocks blocks tops rets ps1 ps2 = - PermCheckM ext cblocks blocks tops rets - (TypedStmtSeq ext blocks tops rets ps1) ps1 - (TypedStmtSeq ext blocks tops rets ps2) ps2 - --- | Lift an 'InnerPermCheckM' computation to a 'PermCheckM' computation -liftPermCheckM :: InnerPermCheckM ext cblocks blocks tops rets a -> - PermCheckM ext cblocks blocks tops rets r ps r ps a -liftPermCheckM = lift - --- | Lift an 'InnerPermCheckM' to a 'TopPermCheckM' -liftInnerToTopM :: InnerPermCheckM ext cblocks blocks tops rets a -> - TopPermCheckM ext cblocks blocks tops rets a -liftInnerToTopM m = - do st <- get - let (a, cl_inner_st) = - runState (runReaderT m st) clEmptyInnerPermCheckState - let deltas = innerStateDeltas $ unClosed cl_inner_st - modify (applyDeltasToTopState deltas) - return a - --- | Get the current top-level state modulo the modifications to the current --- block info map -top_get :: PermCheckM ext cblocks blocks tops rets r ps r ps - (TopPermCheckState ext cblocks blocks tops rets) -top_get = gcaptureCC $ \k -> - do top_st <- ask - deltas <- innerStateDeltas <$> unClosed <$> get - k $ applyDeltasToTopState deltas top_st - --- | Get the current top-level state modulo the modifications to the current --- block info map in an 'InnerPermCheckM' computation -inner_top_get :: InnerPermCheckM ext cblocks blocks tops rets - (TopPermCheckState ext cblocks blocks tops rets) -inner_top_get = - do top_st <- ask - deltas <- innerStateDeltas <$> unClosed <$> get - return $ applyDeltasToTopState deltas top_st - --- | Set the extension-specific state -setInputExtState :: ExtRepr ext -> CruCtx as -> RAssign Name as -> - PermCheckM ext cblocks blocks tops rets r ps r ps () -setInputExtState ExtRepr_Unit _ _ = pure () -setInputExtState ExtRepr_LLVM tps ns - | [SomeExprVarFrame rep n] <- findLLVMFrameVars tps ns - = setFramePtr rep (TypedReg n) -setInputExtState ExtRepr_LLVM _ _ = - -- FIXME: make sure there are not more than one frame var and/or a frame var - -- of the wrong type - pure () - --- | Run a 'PermCheckM' computation for a particular entrypoint with a given set --- of top-level arguments, local arguments, ghost variables, and permissions on --- all three, and return a result inside a binding for these variables --- --- Note that calls to @runPermCheckM@ should be accompanied by calls to --- @handleUnitVars@ or @stmtHandleUnitVars@ to ensure that all unit-typed --- variables are unified during type-checking. These functions are not currently --- combined because @handleUnitVars@ embeds an @ImplM@ computation and someties --- it is more convenient to combine multiple @ImplM@ computations into one. -runPermCheckM :: - KnownRepr ExtRepr ext => - [Maybe String] -> - TypedEntryID blocks some_args -> - CruCtx args -> CruCtx ghosts -> MbValuePerms ((tops :++: args) :++: ghosts) -> - (RAssign ExprVar tops -> RAssign ExprVar args -> RAssign ExprVar ghosts -> - DistPerms ((tops :++: args) :++: ghosts) -> - PermCheckM ext cblocks blocks tops rets - () ps_out - r ((tops :++: args) :++: ghosts) - ()) -> - TopPermCheckM ext cblocks blocks tops rets (NamedMb ((tops :++: args) :++: ghosts) r) -runPermCheckM names entryID args ghosts mb_perms_in m = - get >>= \(TopPermCheckState {..}) -> - let args_prxs = cruCtxProxies args - ghosts_prxs = cruCtxProxies ghosts - (arg_names, local_names) = initialNames args names - (dbgs, ppi) = flip runState emptyPPInfo $ - do x <- state (allocateDebugNames (Just "top") (noNames' stTopCtx) stTopCtx) - y <- state (allocateDebugNames (Just "local") arg_names args) - z <- state (allocateDebugNames (Just "ghost") (noNames' ghosts) ghosts) - pure (x `rappend` y `rappend` z) - in - liftInnerToTopM $ strongMbMNamed $ - flip nuMultiWithElim1Named (NamedMb dbgs - (mbValuePermsToDistPerms mb_perms_in)) $ \ns perms_in -> - let (tops_args, ghosts_ns) = RL.split Proxy ghosts_prxs ns - (tops_ns, args_ns) = RL.split Proxy args_prxs tops_args - st1 = emptyPermCheckState (distPermSet perms_in) tops_ns entryID local_names - st = st1 { stPPInfo = ppi } in - let go x = runGenStateContT x st (\_ () -> pure ()) in - go $ - setVarTypes tops_ns stTopCtx >>> - setVarTypes args_ns args >>> - setVarTypes ghosts_ns ghosts >>> - modify (\s->s{ stPPInfo = ppInfoApplyAllocation ns dbgs (stPPInfo st)}) >>> - setInputExtState knownRepr ghosts ghosts_ns >>> - m tops_ns args_ns ghosts_ns perms_in - -{- -explore :: - forall tops args ghosts ext blocks cblocks ret ps r1 r2. - KnownRepr ExtRepr ext => - [Maybe String] -> - TypedEntryID blocks args -> - CruCtx tops -> - CruCtx args -> - CruCtx ghosts -> - MbValuePerms ((tops :++: args) :++: ghosts) -> - - (RAssign ExprVar tops -> RAssign ExprVar args -> RAssign ExprVar ghosts -> - DistPerms ((tops :++: args) :++: ghosts) -> - PermCheckM ext cblocks blocks tops ret r1 ps r2 ((tops :++: args) - :++: ghosts) ()) -> - - PermCheckM ext cblocks blocks tops ret r1 ps r2 ps () -explore names entryID topCtx argCtx ghostCtx mb_perms_in m = - let args_prxs = cruCtxProxies argCtx - ghosts_prxs = cruCtxProxies ghostCtx - (arg_names, local_names) = initialNames argCtx names in - - allocateDebugNamesM (Just "top") (noNames' topCtx) topCtx >>>= \topDbgs -> - allocateDebugNamesM (Just "local") arg_names argCtx >>>= \argDbgs -> - allocateDebugNamesM (Just "ghost") (noNames' ghostCtx) ghostCtx >>>= \ghostDbgs -> - gopenBinding (fmap _ . strongMbM) (mbValuePermsToDistPerms mb_perms_in) >>>= \(ns, perms_in) -> - let (tops_args, ghosts_ns) = RL.split Proxy ghosts_prxs ns - (tops_ns, args_ns) = RL.split Proxy args_prxs tops_args - st :: PermCheckState ext blocks tops ret ((tops :++: args) :++: ghosts) - st = emptyPermCheckState (distPermSet perms_in) tops_ns entryID local_names in - - setVarTypes tops_ns topCtx >>> - modify (\s->s{ stPPInfo = ppInfoApplyAllocation tops_ns topDbgs (stPPInfo st)}) >>> - modify (\s->s{ stPPInfo = ppInfoApplyAllocation args_ns argDbgs (stPPInfo st)}) >>> - modify (\s->s{ stPPInfo = ppInfoApplyAllocation ghosts_ns ghostDbgs (stPPInfo st)}) >>> - setInputExtState knownRepr ghostCtx ghosts_ns >>> - m tops_ns args_ns ghosts_ns perms_in - - -} - -rassignLen :: RAssign f x -> Int -rassignLen = go 0 - where - go :: Int -> RAssign f x -> Int - go acc MNil = acc - go acc (xs :>: _) = (go $! (acc+1)) xs - -initialNames :: - CruCtx tps -> - [Maybe String] -> - (RAssign (Constant (Maybe String)) tps, [Maybe String]) -initialNames CruCtxNil xs = (MNil, xs) -initialNames (CruCtxCons ts _) xs = - case initialNames ts xs of - (ys, z:zs) -> (ys :>: Constant z, zs) - (ys, [] ) -> (ys :>: Constant Nothing, []) - --- | Compute an empty debug name assignment from a known context -noNames :: - KnownRepr CruCtx tps => - RAssign (Constant (Maybe String)) tps -noNames = noNames' knownRepr - --- | Compute an empty debug name assignment from a given context -noNames' :: - CruCtx tps -> - RAssign (Constant (Maybe String)) tps -noNames' CruCtxNil = MNil -noNames' (CruCtxCons xs _) = noNames' xs :>: Constant Nothing - --- | Call 'debugNames'' with a known type list. -dbgNames :: - KnownRepr CruCtx tps => - PermCheckM ext cblocks blocks tops rets a ps a ps - (RAssign (Constant (Maybe String)) tps) -dbgNames = dbgNames' knownRepr - --- | Pop as many local variable names from the debug information --- as needed to populate the given type list. -dbgNames' :: - CruCtx tps -> - PermCheckM ext cblocks blocks tops rets a ps a ps - (RAssign (Constant (Maybe String)) tps) -dbgNames' CruCtxNil = pure MNil -dbgNames' (CruCtxCons ts _) = - do ns <- dbgNames' ts - n <- nextDebugName - pure (ns :>: Constant n) - --- | Emit a 'TypedBlockMapDelta', which must be 'Closed', in an --- 'InnerPermCheckM' computation -innerEmitDelta :: Closed (TypedBlockMapDelta blocks tops rets) -> - InnerPermCheckM ext cblocks blocks tops rets () -innerEmitDelta cl_delta = - modify (clApply - ($(mkClosed [| \delta st -> - st { innerStateDeltas = - innerStateDeltas st ++ [delta] } |]) - `clApply` cl_delta)) - --- | Create a call from the current entrypoint to the specified block, passing --- the supplied permissions, which must be closed, on local variables -callBlockWithPerms :: TypedEntryID blocks args_src -> - TypedBlockID blocks args -> CruCtx vars -> - Closed (MbValuePerms ((tops :++: args) :++: vars)) -> - InnerPermCheckM ext cblocks blocks tops rets - (TypedCallSiteID blocks args vars) -callBlockWithPerms srcEntryID destID vars cl_perms_in = - do top_st <- inner_top_get - let blk = view (stBlockMap . member (typedBlockIDMember destID)) top_st - let siteID = newCallSiteID srcEntryID vars blk - innerEmitDelta ($(mkClosed [| TypedBlockMapAddCallSite |]) - `clApply` toClosed siteID `clApply` cl_perms_in) - return siteID - --- | Look up the current primary permission associated with a variable -getVarPerm :: ExprVar a -> - PermCheckM ext cblocks blocks tops rets r ps r ps (ValuePerm a) -getVarPerm x = gets (view (varPerm x) . stCurPerms) - --- | Set the current primary permission associated with a variable -setVarPerm :: ExprVar a -> ValuePerm a -> - PermCheckM ext cblocks blocks tops rets r ps r ps () -setVarPerm x p = modify (modifySTCurPerms (set (varPerm x) p)) - --- | Look up the current primary permission associated with a register -getRegPerm :: TypedReg a -> - PermCheckM ext cblocks blocks tops rets r ps r ps (ValuePerm a) -getRegPerm (TypedReg x) = getVarPerm x - --- | Eliminate any disjunctions, existentials, or recursive permissions for a --- register and then return the resulting \"simple\" permission, leaving it on the --- top of the stack -getPushSimpleRegPerm :: PermCheckExtC ext exprExt => TypedReg a -> - StmtPermCheckM ext cblocks blocks tops rets - (ps :> a) ps (ValuePerm a) -getPushSimpleRegPerm r = - getRegPerm r >>>= \p_init -> - pcmEmbedImplM TypedImplStmt emptyCruCtx - (implPushM (typedRegVar r) p_init >>> - elimOrsExistsNamesM (typedRegVar r)) >>>= \(_, p_ret) -> - pure p_ret - --- | Eliminate any disjunctions, existentials, or recursive permissions for a --- register and then return the resulting \"simple\" permission -getSimpleRegPerm :: PermCheckExtC ext exprExt => TypedReg a -> - StmtPermCheckM ext cblocks blocks tops rets ps ps - (ValuePerm a) -getSimpleRegPerm r = - snd <$> pcmEmbedImplM TypedImplStmt emptyCruCtx (getSimpleVarPerm $ - typedRegVar r) - --- | A version of 'getEqualsExpr' for 'TypedReg's -getRegEqualsExpr :: - PermCheckExtC ext exprExt => TypedReg a -> - StmtPermCheckM ext cblocks blocks tops rets ps ps (PermExpr a) -getRegEqualsExpr r = - snd <$> pcmEmbedImplM TypedImplStmt emptyCruCtx (getEqualsExpr $ - PExpr_Var $ typedRegVar r) - --- | Eliminate any disjunctions, existentials, recursive permissions, or --- equality permissions for an LLVM register until we either get a conjunctive --- permission for it or we get that it is equal to a bitvector word. In either --- case, leave the resulting permission on the top of the stack and return its --- contents as the return value. -getAtomicOrWordLLVMPerms :: - (1 <= w, KnownNat w, PermCheckExtC ext exprExt) => TypedReg (LLVMPointerType w) -> - StmtPermCheckM ext cblocks blocks tops rets - (ps :> LLVMPointerType w) - ps - (Either (PermExpr (BVType w)) [AtomicPerm (LLVMPointerType w)]) -getAtomicOrWordLLVMPerms r = - let x = typedRegVar r in - getPushSimpleRegPerm r >>>= \p -> - case p of - ValPerm_Conj ps -> - pure $ Right ps - ValPerm_Eq (PExpr_Var y) -> - pcmEmbedImplM TypedImplStmt emptyCruCtx - (introEqCopyM x (PExpr_Var y) >>> recombinePerm x p) >>> - getAtomicOrWordLLVMPerms (TypedReg y) >>>= \eith -> - case eith of - Left e -> - pcmEmbedImplM TypedImplStmt emptyCruCtx - (introCastM x y $ ValPerm_Eq $ PExpr_LLVMWord e) >>> - pure (Left e) - Right ps -> - pcmEmbedImplM TypedImplStmt emptyCruCtx (introCastM x y $ - ValPerm_Conj ps) >>> - pure (Right ps) - ValPerm_Eq e@(PExpr_LLVMOffset y off) -> - pcmEmbedImplM TypedImplStmt emptyCruCtx - (introEqCopyM x e >>> recombinePerm x p) >>> - getAtomicOrWordLLVMPerms (TypedReg y) >>>= \eith -> - case eith of - Left e' -> - pcmEmbedImplM TypedImplStmt emptyCruCtx (offsetLLVMWordM - y e' off x) >>> - pure (Left $ bvAdd e' off) - Right ps -> - pcmEmbedImplM TypedImplStmt emptyCruCtx (castLLVMPtrM - y (ValPerm_Conj ps) off x) >>> - pure (Right $ mapMaybe (offsetLLVMAtomicPerm $ bvNegate off) ps) - ValPerm_Eq e@(PExpr_LLVMWord e_word) -> - pcmEmbedImplM TypedImplStmt emptyCruCtx (introEqCopyM x e >>> - recombinePerm x p) >>> - pure (Left e_word) - _ -> - permGetPPInfo >>>= \ppinfo -> - stmtFailM $ AtomicPermError (permPretty ppinfo r) (permPretty ppinfo p) - - --- | Like 'getAtomicOrWordLLVMPerms', but fail if an equality permission to a --- bitvector word is found -getAtomicLLVMPerms :: (1 <= w, KnownNat w, PermCheckExtC ext exprExt) => - TypedReg (LLVMPointerType w) -> - StmtPermCheckM ext cblocks blocks tops rets - (ps :> LLVMPointerType w) - ps - [AtomicPerm (LLVMPointerType w)] -getAtomicLLVMPerms r = - getAtomicOrWordLLVMPerms r >>>= \eith -> - case eith of - Right ps -> pure ps - Left e -> - permGetPPInfo >>>= \ppinfo -> - stmtFailM $ AtomicPermError - (permPretty ppinfo r) - (permPretty ppinfo (ValPerm_Eq $ PExpr_LLVMWord e)) - - -data SomeExprVarFrame where - SomeExprVarFrame :: - NatRepr w -> - ExprVar (LLVMFrameType w) -> - SomeExprVarFrame - --- | Find all the variables of LLVM frame pointer type in a sequence --- FIXME: move to Permissions.hs -findLLVMFrameVars :: - CruCtx as -> RAssign Name as -> - [SomeExprVarFrame] -findLLVMFrameVars CruCtxNil _ = [] -findLLVMFrameVars (CruCtxCons tps (LLVMFrameRepr w')) (ns :>: n) = - SomeExprVarFrame w' n : findLLVMFrameVars tps ns -findLLVMFrameVars (CruCtxCons tps _) (ns :>: _) = findLLVMFrameVars tps ns - - --- | Get the current frame pointer on LLVM architectures -getFramePtr :: - NatRepr w -> - PermCheckM LLVM cblocks blocks tops rets r ps r ps - (Maybe (TypedReg (LLVMFrameType w))) -getFramePtr w = - gets stExtState >>= \case - PermCheckExtState_LLVM (Just (SomeFrameReg rep fp)) - | Just Refl <- testEquality rep w -> pure (Just fp) - _ -> pure Nothing - --- | Set the current frame pointer on LLVM architectures -setFramePtr :: - NatRepr w -> - TypedReg (LLVMFrameType w) -> - PermCheckM LLVM cblocks blocks tops rets r ps r ps () -setFramePtr rep fp = - modify (\st -> st { stExtState = PermCheckExtState_LLVM (Just (SomeFrameReg rep fp)) }) - --- | Look up the type of a free variable, or raise an error if it is unknown -getVarType :: ExprVar a -> - PermCheckM ext cblocks blocks tops rets r ps r ps (TypeRepr a) -getVarType x = - gets (NameMap.lookup x . stVarTypes) >>= \case - Just tp -> pure tp - Nothing -> - stmtTraceM (\i -> pretty "getVarType: could not find type for variable:" - <+> permPretty i x) >>> - error "getVarType" - --- | Look up the types of multiple free variables -getVarTypes :: RAssign Name tps -> - PermCheckM ext cblocks blocks tops rets r ps r ps (CruCtx tps) -getVarTypes MNil = pure CruCtxNil -getVarTypes (xs :>: x) = CruCtxCons <$> getVarTypes xs <*> getVarType x - --- | Output a string representing a variable given optional information such as --- a base name and a C name -dbgStringPP :: - Maybe String {- ^ The base name of the variable (e.g., "top", "arg", etc.) -} -> - Maybe String {- ^ The C name of the variable, if applicable -} -> - TypeRepr a {- ^ The type of the variable -} -> - String -dbgStringPP _ (Just d) _ = "C[" ++ d ++ "]" -dbgStringPP (Just str) _ tp = str ++ "_" ++ typeBaseName tp -dbgStringPP Nothing Nothing tp = typeBaseName tp - - --- | After all variables have been added to the context, unify all unit-typed --- variables by lifting through the ImplM monad -stmtHandleUnitVars :: forall (tps :: RList CrucibleType) - ext cblocks blocks tops ret ps exprExt. - PermCheckExtC ext exprExt => - RAssign Name tps -> - StmtPermCheckM ext cblocks blocks tops ret ps ps () -stmtHandleUnitVars ns = - stmtEmbedImplM $ handleUnitVars ns - --- | Remember the type of a free variable, and ensure that it has a permission -setVarType :: - ExprVar a -> -- ^ The Hobbits variable itself - TypeRepr a -> -- ^ The type of the variable - PermCheckM ext cblocks blocks tops ret r ps r ps () -setVarType x tp = - modify $ \st -> - st { stCurPerms = initVarPerm x (stCurPerms st), - stVarTypes = NameMap.insert x tp (stVarTypes st) } - --- | Remember the types of a sequence of free variables -setVarTypes :: - RAssign Name tps -> - CruCtx tps -> - PermCheckM ext cblocks blocks tops ret r ps r ps () -setVarTypes MNil CruCtxNil = pure () -setVarTypes (ns :>: n) (CruCtxCons ts t) = - do setVarTypes ns ts - setVarType n t - -allocateDebugNames :: - Maybe String -> -- ^ The base name of the variable (e.g., \"top\", \"arg\", etc.) - RAssign (Constant (Maybe String)) tps -> - CruCtx tps -> - PPInfo -> - (RAssign StringF tps, PPInfo) -allocateDebugNames _ MNil _ ppi = (MNil, ppi) -allocateDebugNames base (ds :>: Constant dbg) (CruCtxCons ts tp) ppi = - case allocateDebugNames base ds ts ppi of - (outs, ppi1) -> - case ppInfoAllocateName str ppi1 of - (ppi2, out) -> (outs :>: StringF out, ppi2) - where - str = - case (base,dbg) of - (_,Just d) -> "C[" ++ d ++ "]" - (Just b,_) -> b ++ "_" ++ typeBaseName tp - (Nothing,Nothing) -> typeBaseName tp - - -allocateDebugNamesM :: - Maybe String -> -- ^ The base name of the variable (e.g., \"top\", \"arg\", etc.) - RAssign (Constant (Maybe String)) tps -> - CruCtx tps -> - PermCheckM ext cblocks blocks tops ret r ps r ps - (RAssign StringF tps) -allocateDebugNamesM base ds tps = - do ppi <- permGetPPInfo - let (strs, ppi') = allocateDebugNames base ds tps ppi - gmodify $ \st -> st { stPPInfo = ppi' } - return strs - --- | Emit debugging output at the given 'DebugLevel' -stmtDebugM :: DebugLevel -> (PPInfo -> Doc ()) -> - PermCheckM ext cblocks blocks tops ret r ps r ps String -stmtDebugM reqlvl f = - do dlevel <- stDebugLevel <$> top_get - doc <- f <$> permGetPPInfo - let str = renderDoc doc - debugTrace reqlvl dlevel str (return str) - --- | Emit debugging output at 'traceDebugLevel' -stmtTraceM :: (PPInfo -> Doc ()) -> - PermCheckM ext cblocks blocks tops ret r ps r ps String -stmtTraceM = stmtDebugM traceDebugLevel - --- | Emit debugging output at 'verboseDebugLevel' -stmtVerbTraceM :: (PPInfo -> Doc ()) -> - PermCheckM ext cblocks blocks tops ret r ps r ps String -stmtVerbTraceM = stmtDebugM verboseDebugLevel - --- | FIXME HERE: Make 'ImplM' quantify over any underlying monad, so that we do --- not have to use 'traversePermImpl' after we run an 'ImplM' -data WithImplState vars a ps ps' = - WithImplState a (ImplState vars ps) (ps' :~: ps) - --- | Run a 'PermCheckM' computation in a locally-scoped way, where all effects --- are restricted to the local computation. This is essentially a form of the --- @reset@ operation of delimited continuations. --- --- FIXME: this is not used, but is still here in case we need it later... -localPermCheckM :: - PermCheckM ext cblocks blocks tops rets r_out ps_out r_in ps_in r_out -> - PermCheckM ext cblocks blocks tops rets r' ps_in r' ps_in r_in -localPermCheckM m = - get >>= \st -> - liftPermCheckM (runGenStateContT m st (\_ -> pure)) - --- | Call 'runImplM' in the 'PermCheckM' monad -pcmRunImplM :: - HasCallStack => - NuMatchingAny1 r => - CruCtx vars -> Doc () -> (a -> r ps_out) -> - ImplM vars (InnerPermCheckState blocks tops rets) r ps_out ps_in a -> - PermCheckM ext cblocks blocks tops rets r' ps_in r' ps_in - (AnnotPermImpl r ps_in) -pcmRunImplM vars fail_doc retF impl_m = - getErrorPrefix >>>= \err_prefix -> - (stPermEnv <$> top_get) >>>= \env -> - gets stCurPerms >>>= \perms_in -> - gets stPPInfo >>>= \ppInfo -> - gets stVarTypes >>>= \varTypes -> - gets stUnitVar >>>= \unitVar -> - (stEndianness <$> top_get) >>>= \endianness -> - (stDebugLevel <$> top_get) >>>= \dlevel -> - liftPermCheckM $ lift $ - fmap (AnnotPermImpl (renderDoc (err_prefix <> line <> fail_doc))) $ - runImplM vars perms_in env ppInfo "" dlevel varTypes unitVar endianness impl_m - (return . retF . fst) - --- | Call 'runImplImplM' in the 'PermCheckM' monad -pcmRunImplImplM :: - HasCallStack => - NuMatchingAny1 r => - CruCtx vars -> Doc () -> - ImplM vars (InnerPermCheckState blocks tops rets) r ps_out ps_in (PermImpl - r ps_out) -> - PermCheckM ext cblocks blocks tops rets r' ps_in r' ps_in - (AnnotPermImpl r ps_in) -pcmRunImplImplM vars fail_doc impl_m = - getErrorPrefix >>>= \err_prefix -> - (stPermEnv <$> top_get) >>>= \env -> - gets stCurPerms >>>= \perms_in -> - gets stPPInfo >>>= \ppInfo -> - gets stVarTypes >>>= \varTypes -> - gets stUnitVar >>>= \unitVar -> - (stEndianness <$> top_get) >>>= \endianness -> - (stDebugLevel <$> top_get) >>>= \dlevel -> - liftPermCheckM $ lift $ - fmap (AnnotPermImpl (renderDoc (err_prefix <> line <> fail_doc))) $ - runImplImplM vars perms_in env ppInfo "" dlevel varTypes unitVar endianness impl_m - --- | Embed an implication computation inside a permission-checking computation, --- also supplying an overall error message for failures -pcmEmbedImplWithErrM :: - HasCallStack => - NuMatchingAny1 r => - (forall ps. AnnotPermImpl r ps -> r ps) -> CruCtx vars -> Doc () -> - ImplM vars (InnerPermCheckState blocks tops rets) r ps_out ps_in a -> - PermCheckM ext cblocks blocks tops rets (r ps_out) ps_out (r ps_in) ps_in - (PermSubst vars, a) -pcmEmbedImplWithErrM f_impl vars fail_doc m = - getErrorPrefix >>>= \err_prefix -> - gmapRet ((f_impl . AnnotPermImpl (renderDoc - (err_prefix <> line <> fail_doc))) <$>) >>> - (stPermEnv <$> top_get) >>>= \env -> - gets stCurPerms >>>= \perms_in -> - gets stPPInfo >>>= \ppInfo -> - gets stVarTypes >>>= \varTypes -> - gets stUnitVar >>>= \unitVar -> - (stEndianness <$> top_get) >>>= \endianness -> - (stDebugLevel <$> top_get) >>>= \dlevel -> - - addReader - (gcaptureCC - (runImplM vars perms_in env ppInfo "" dlevel varTypes unitVar endianness m)) - >>>= \(a, implSt) -> - - gmodify ((\st -> st { stPPInfo = implSt ^. implStatePPInfo, - stVarTypes = implSt ^. implStateNameTypes, - stUnitVar = implSt ^. implStateUnitVar }) - . setSTCurPerms (implSt ^. implStatePerms)) >>> - pure (completePSubst vars (implSt ^. implStatePSubst), a) - --- | Embed an implication computation inside a permission-checking computation -pcmEmbedImplM :: - HasCallStack => - NuMatchingAny1 r => - (forall ps. AnnotPermImpl r ps -> r ps) -> CruCtx vars -> - ImplM vars (InnerPermCheckState blocks tops rets) r ps_out ps_in a -> - PermCheckM ext cblocks blocks tops rets (r ps_out) ps_out (r ps_in) ps_in - (PermSubst vars, a) -pcmEmbedImplM f_impl vars m = pcmEmbedImplWithErrM f_impl vars mempty m - --- | Special case of 'pcmEmbedImplM' for a statement type-checking context where --- @vars@ is empty -stmtEmbedImplM :: - HasCallStack => - NuMatchingExtC ext exprExt => - ImplM RNil (InnerPermCheckState - blocks tops rets) (TypedStmtSeq ext blocks tops rets) ps_out ps_in a -> - StmtPermCheckM ext cblocks blocks tops rets ps_out ps_in a -stmtEmbedImplM m = snd <$> pcmEmbedImplM TypedImplStmt emptyCruCtx m - --- | Recombine any outstanding distinguished permissions back into the main --- permission set, in the context of type-checking statements -stmtRecombinePerms :: - HasCallStack => - PermCheckExtC ext exprExt => - StmtPermCheckM ext cblocks blocks tops rets RNil ps_in () -stmtRecombinePerms = - get >>>= \(!st) -> - let dist_perms = view distPerms (stCurPerms st) in - pcmEmbedImplM TypedImplStmt emptyCruCtx (recombinePerms dist_perms) >>> - pure () - --- | Helper function to pretty print \"Could not prove ps\" for permissions @ps@ -ppProofError :: PermPretty a => PPInfo -> String -> a -> Doc () -ppProofError ppInfo f mb_ps = - nest 2 $ sep [ pretty f <> colon <+> pretty "Could not prove" - , PP.group (PP.align (permPretty ppInfo mb_ps)) ] - --- | Helper function to pretty print \"Could not prove ps1 -o ps2\" for --- permissions @ps1@ and @ps2@ -ppImplProofError :: (PermPretty a, PermPretty b) => - PPInfo -> String -> a -> b -> Doc () -ppImplProofError ppInfo f mb_ps1 mb_ps2 = - nest 2 $ sep [ pretty f <> colon <+> pretty "Could not prove" - , PP.group (PP.align (permPretty ppInfo mb_ps1)) - , pretty "-o" - , PP.group (PP.align (permPretty ppInfo mb_ps2)) ] - --- | Prove a sequence of permissions over some existential variables and append --- them to the top of the stack -stmtProvePermsAppend :: PermCheckExtC ext exprExt => - CruCtx vars -> ExDistPerms vars ps -> - StmtPermCheckM ext cblocks blocks tops rets - (ps_in :++: ps) ps_in (PermSubst vars) -stmtProvePermsAppend vars ps = - permGetPPInfo >>>= \ppInfo -> - let err = ppProofError ppInfo "stmtProvePermsAppend" ps in - fst <$> pcmEmbedImplWithErrM TypedImplStmt vars err (proveVarsImplAppend ps) - --- | Prove a sequence of permissions over some existential variables in the --- context of the empty permission stack -stmtProvePerms :: PermCheckExtC ext exprExt => - CruCtx vars -> ExDistPerms vars ps -> - StmtPermCheckM ext cblocks blocks tops rets - ps RNil (PermSubst vars) -stmtProvePerms vars ps = - permGetPPInfo >>>= \ppInfo -> - let err = ppProofError ppInfo "stmtProvePerms" ps in - fst <$> pcmEmbedImplWithErrM TypedImplStmt vars err (proveVarsImpl ps) - --- | Prove a sequence of permissions over some existential variables in the --- context of the empty permission stack, but first generate fresh lifetimes for --- any existential lifetime variables -stmtProvePermsFreshLs :: PermCheckExtC ext exprExt => - CruCtx vars -> ExDistPerms vars ps -> - StmtPermCheckM ext cblocks blocks tops rets - ps RNil (PermSubst vars) -stmtProvePermsFreshLs vars ps = - permGetPPInfo >>>= \ppInfo -> - let err = ppProofError ppInfo "stmtProvePermsFreshLs" ps in - fst <$> pcmEmbedImplWithErrM TypedImplStmt vars err - (instantiateLifetimeVars ps >>> proveVarsImpl ps) - --- | Prove a single permission in the context of type-checking statements -stmtProvePerm :: (PermCheckExtC ext exprExt, KnownRepr CruCtx vars) => - TypedReg a -> Mb vars (ValuePerm a) -> - StmtPermCheckM ext cblocks blocks tops rets - (ps :> a) ps (PermSubst vars) -stmtProvePerm (TypedReg x) mb_p = - permGetPPInfo >>>= \ppInfo -> - let err = ppProofError ppInfo "stmtProvePerm" (fmap (distPerms1 x) mb_p) in - fst <$> pcmEmbedImplWithErrM TypedImplStmt knownRepr err - (proveVarImpl x mb_p) - - --- | Try to prove that a register equals a constant integer (of the given input --- type) using equality permissions in the context -resolveConstant :: TypedReg tp -> - StmtPermCheckM ext cblocks blocks tops rets ps ps - (Maybe Integer) -resolveConstant = helper . PExpr_Var . typedRegVar where - helper :: PermExpr a -> - StmtPermCheckM ext cblocks blocks tops rets ps ps - (Maybe Integer) - helper (PExpr_Var x) = - getVarPerm x >>= \case - ValPerm_Eq e -> helper e - _ -> pure Nothing - helper (PExpr_Nat i) = pure (Just $ toInteger i) - helper (PExpr_BV factors (BV.BV off)) = - foldM (\maybe_res (BVFactor (BV.BV i) x) -> - helper (PExpr_Var x) >>= \maybe_x_val -> - case (maybe_res, maybe_x_val) of - (Just res, Just x_val) -> - return (Just (res + x_val * i)) - _ -> return Nothing) - (Just off) factors - helper (PExpr_LLVMWord e) = helper e - helper (PExpr_LLVMOffset x e) = - do maybe_x_val <- helper (PExpr_Var x) - maybe_e_val <- helper e - case (maybe_x_val, maybe_e_val) of - (Just x_val, Just e_val) -> return (Just (x_val + e_val)) - _ -> return Nothing - helper _ = return Nothing - - --- | Convert a register of one type to one of another type, if possible -convertRegType :: PermCheckExtC ext exprExt => ExtRepr ext -> ProgramLoc -> - TypedReg tp1 -> TypeRepr tp1 -> TypeRepr tp2 -> - StmtPermCheckM ext cblocks blocks tops rets RNil RNil - (TypedReg tp2) -convertRegType _ _ reg tp1 tp2 - | Just Refl <- testEquality tp1 tp2 = pure reg -convertRegType _ loc reg (BVRepr w1) tp2@(BVRepr w2) - | Left LeqProof <- decideLeq (knownNat :: NatRepr 1) w2 - , NatCaseGT LeqProof <- testNatCases w1 w2 = - withKnownNat w2 $ - emitStmt knownRepr noNames loc - (TypedSetReg tp2 $ - TypedExpr (BVTrunc w2 w1 $ RegNoVal reg) - Nothing) >>>= \(MNil :>: x) -> - stmtRecombinePerms >>> - pure (TypedReg x) -convertRegType _ loc reg (BVRepr w1) tp2@(BVRepr w2) - | Left LeqProof <- decideLeq (knownNat :: NatRepr 1) w1 - , Left LeqProof <- decideLeq (knownNat :: NatRepr 1) w2 - , NatCaseLT LeqProof <- testNatCases w1 w2 = - -- FIXME: should this use endianness? - -- (stEndianness <$> top_get) >>>= \endianness -> - withKnownNat w2 $ - emitStmt knownRepr noNames loc - (TypedSetReg tp2 $ - TypedExpr (BVSext w2 w1 $ RegNoVal reg) - Nothing) >>>= \(MNil :>: x) -> - stmtRecombinePerms >>> - pure (TypedReg x) -convertRegType ExtRepr_LLVM loc reg (LLVMPointerRepr w1) (BVRepr w2) - | Just Refl <- testEquality w1 w2 = - withKnownNat w1 $ - stmtProvePerm reg (llvmExEqWord w1) >>>= \sbst -> - let e = substLookup sbst Member_Base in - emitLLVMStmt knownRepr Nothing loc (DestructLLVMWord reg e) >>>= \x -> - stmtRecombinePerms >>> - pure (TypedReg x) -convertRegType ext loc reg (LLVMPointerRepr w1) (BVRepr w2) = - convertRegType ext loc reg (LLVMPointerRepr w1) (BVRepr w1) >>>= \reg' -> - convertRegType ext loc reg' (BVRepr w1) (BVRepr w2) -convertRegType ExtRepr_LLVM loc reg (BVRepr w2) (LLVMPointerRepr w1) - | Just Refl <- testEquality w1 w2 = - withKnownNat w1 $ - emitLLVMStmt knownRepr Nothing loc (ConstructLLVMWord reg) >>>= \x -> - stmtRecombinePerms >>> pure (TypedReg x) -convertRegType ext loc reg (BVRepr w1) (LLVMPointerRepr w2) = - convertRegType ext loc reg (BVRepr w1) (BVRepr w2) >>>= \reg' -> - convertRegType ext loc reg' (BVRepr w2) (LLVMPointerRepr w2) -convertRegType ext loc reg (LLVMPointerRepr w1) (LLVMPointerRepr w2) = - convertRegType ext loc reg (LLVMPointerRepr w1) (BVRepr w1) >>>= \reg1 -> - convertRegType ext loc reg1 (BVRepr w1) (BVRepr w2) >>>= \reg2 -> - convertRegType ext loc reg2 (BVRepr w2) (LLVMPointerRepr w2) -convertRegType _ _ x tp1 tp2 = - permGetPPInfo >>>= \ppinfo -> - stmtFailM $ RegisterConversionError (permPretty ppinfo x) tp1 tp2 - - --- | Extract the bitvector of size @sz@ at offset @off@ from a larger bitvector --- @bv@, using the current endianness to determine how this extraction works -extractBVBytes :: (1 <= w, KnownNat w) => - ProgramLoc -> NatRepr sz -> Bytes -> TypedReg (BVType w) -> - StmtPermCheckM LLVM cblocks blocks tops rets RNil RNil - (TypedReg (BVType sz)) -extractBVBytes loc sz off_bytes (reg :: TypedReg (BVType w)) = - let w :: NatRepr w = knownNat in - (stEndianness <$> top_get) >>= \endianness -> - withKnownNat sz $ - case (endianness, decideLeq (knownNat @1) sz) of - - -- For little endian, we can just call BVSelect - (LittleEndian, Left sz_pf) - | Just (Some off) <- someNat (bytesToBits off_bytes) - , Left off_sz_w_pf <- decideLeq (addNat off sz) w -> - withLeqProof sz_pf $ withLeqProof off_sz_w_pf $ - emitStmt knownRepr noNames loc - (TypedSetReg (BVRepr sz) $ - TypedExpr (BVSelect off sz w $ RegNoVal reg) - Nothing) >>>= \(MNil :>: x) -> - stmtRecombinePerms >>> - pure (TypedReg x) - - -- For big endian, we call BVSelect with idx = w - off - sz - (BigEndian, Left sz_pf) - | Just (Some idx) <- someNat (intValue w - - toInteger (bytesToBits off_bytes) - - intValue sz) - , Left idx_sz_w_pf <- decideLeq (addNat idx sz) w -> - withLeqProof sz_pf $ withLeqProof idx_sz_w_pf $ - emitStmt knownRepr noNames loc - (TypedSetReg (BVRepr sz) $ - TypedExpr (BVSelect idx sz w $ RegNoVal reg) - Nothing) >>>= \(MNil :>: x) -> - stmtRecombinePerms >>> - pure (TypedReg x) - _ -> error "extractBVBytes: negative offset!" - - --- | Emit a statement in the current statement sequence, where the supplied --- function says how that statement modifies the current permissions, given the --- freshly-bound names for the return values. Return those freshly-bound names --- for the return values. -emitStmt :: - PermCheckExtC ext exprExt => - CruCtx stmt_rets -> - RAssign (Constant (Maybe String)) stmt_rets -> - ProgramLoc -> - TypedStmt ext stmt_rets ps_in ps_out -> - StmtPermCheckM ext cblocks blocks tops rets ps_out ps_in - (RAssign Name stmt_rets) -emitStmt tps names loc stmt = - let pxys = cruCtxProxies tps in - allocateDebugNamesM Nothing names tps >>>= \debugs -> - startNamedBinding debugs (fmap (TypedConsStmt loc stmt pxys) - . strongMbMNamed) >>>= \ns -> - modify (\st -> st { stPPInfo = ppInfoApplyAllocation ns debugs (stPPInfo st)}) >>> - setVarTypes ns tps >>> - gmodify (modifySTCurPerms (applyTypedStmt stmt ns)) >>> - gets (view distPerms . stCurPerms) >>>= \perms_out -> - stmtVerbTraceM (\i -> - pretty "Created new variables: " - <+> permPretty i ns <> line <> - pretty "Statement output permissions: " <+> - permPretty i perms_out) >>> - -- Note: must come after both setVarTypes and gmodify - stmtHandleUnitVars ns >>> - pure ns - - --- | Call emitStmt with a 'TypedLLVMStmt' -emitLLVMStmt :: - TypeRepr tp -> - Maybe String -> - ProgramLoc -> - TypedLLVMStmt tp ps_in ps_out -> - StmtPermCheckM LLVM cblocks blocks tops rets ps_out ps_in (Name tp) -emitLLVMStmt tp name loc stmt = - RL.head <$> emitStmt (singletonCruCtx tp) (RL.singleton (Constant name)) loc (TypedLLVMStmt stmt) - --- | A program location for code which was generated by the type-checker -checkerProgramLoc :: ProgramLoc -checkerProgramLoc = - mkProgramLoc (functionNameFromText (Text.pack "None")) - (OtherPos (Text.pack "(Generated by permission type-checker)")) - - ----------------------------------------------------------------------- --- * Permission Checking and Pretty-Printing for Registers ----------------------------------------------------------------------- - --- | Type-check a Crucible register by looking it up in the translated context -tcReg :: CtxTrans ctx -> Reg ctx tp -> TypedReg tp -tcReg ctx (Reg ix) = ctx ! ix - --- | Type-check a Crucible register and also look up its value, if known -tcRegWithVal :: PermCheckExtC ext exprExt => CtxTrans ctx -> Reg ctx tp -> - StmtPermCheckM ext cblocks blocks tops rets ps ps - (RegWithVal tp) -tcRegWithVal ctx r_untyped = - let r = tcReg ctx r_untyped in - getRegEqualsExpr r >>= \case - PExpr_Var x | x == typedRegVar r -> pure $ RegNoVal r - e -> pure $ RegWithVal r e - --- | Type-check a sequence of Crucible registers -tcRegs :: CtxTrans ctx -> Assignment (Reg ctx) tps -> TypedRegs (CtxToRList tps) -tcRegs _ctx (viewAssign -> AssignEmpty) = TypedRegsNil -tcRegs ctx (viewAssign -> AssignExtend regs reg) = - TypedRegsCons (tcRegs ctx regs) (tcReg ctx reg) - --- | Pretty-print the permissions that are \"relevant\" to a register, which --- includes its permissions and all those relevant to any register it is equal --- to, possibly plus some offset -ppRelevantPerms :: TypedReg tp -> - PermCheckM ext cblocks blocks tops rets r ps r ps (Doc ()) -ppRelevantPerms r = - getRegPerm r >>>= \p -> - permGetPPInfo >>>= \ppInfo -> - let pp_r = permPretty ppInfo r <> colon <> permPretty ppInfo p in - case p of - ValPerm_Eq (PExpr_Var x) -> - ((pp_r <> comma) <+>) <$> ppRelevantPerms (TypedReg x) - ValPerm_Eq (PExpr_LLVMOffset x _) -> - ((pp_r <> comma) <+>) <$> ppRelevantPerms (TypedReg x) - ValPerm_Eq (PExpr_LLVMWord (PExpr_Var x)) -> - ((pp_r <> comma) <+>) <$> ppRelevantPerms (TypedReg x) - _ -> pure pp_r - --- | Pretty-print a Crucible 'Reg' and what 'TypedReg' it is equal to, along --- with the relevant permissions for that 'TypedReg' -ppCruRegAndPerms :: CtxTrans ctx -> Reg ctx a -> - PermCheckM ext cblocks blocks tops rets r ps r ps (Doc ()) -ppCruRegAndPerms ctx r = - permGetPPInfo >>>= \ppInfo -> - ppRelevantPerms (tcReg ctx r) >>>= \doc -> - pure (PP.group (pretty r <+> pretty '=' <+> permPretty ppInfo (tcReg ctx r) - <> comma <+> doc)) - --- | Get the permissions on the variables in the input set, the variables in --- their permissions, the variables in those permissions etc., as in --- 'varPermsTransFreeVars' -getRelevantPerms :: [SomeName CrucibleType] -> - PermCheckM ext cblocks blocks tops rets r ps r ps - (Some DistPerms) -getRelevantPerms (namesListToNames -> SomeRAssign ns) = - gets stCurPerms >>>= \perms -> - case varPermsTransFreeVars ns perms of - Some all_ns -> pure (Some $ varPermsMulti (RL.append ns all_ns) perms) - --- | Pretty-print a list of Crucible registers and the variables they translate --- to, and then pretty-print the permissions on those variables and all --- variables they contain, as well as the top-level input variables and the --- extension-specific variables -ppCruRegsAndTopsPerms :: - [Maybe String] -> - CtxTrans ctx -> - [Some (Reg ctx)] -> - PermCheckM ext cblocks blocks tops rets r ps r ps (Doc (), Doc ()) -ppCruRegsAndTopsPerms names ctx regs = - permGetPPInfo >>>= \ppInfo -> - gets stTopVars >>>= \tops -> - gets (permCheckExtStateNames . stExtState) >>>= \(Some ext_ns) -> - let vars_pp = - fillSep $ punctuate comma $ - map (\(Some r) -> - let name = listToMaybe (drop (indexVal (regIndex r)) names) in - pretty r <+> pretty '=' <+> - permPretty ppInfo (tcReg ctx r) <> - foldMap (\n -> pretty " @" <+> pretty n) name) - (nub regs) - vars = - namesToNamesList tops ++ namesToNamesList ext_ns ++ - map (\(Some r) -> SomeName $ typedRegVar $ tcReg ctx r) regs in - getRelevantPerms vars >>>= \some_perms -> - case some_perms of - Some perms -> pure (vars_pp, permPretty ppInfo perms) - --- | Set the current prefix string to give context to error messages -setErrorPrefix :: - [Maybe String] -> - ProgramLoc -> - Doc () -> - CtxTrans ctx -> - [Some (Reg ctx)] -> - PermCheckM ext cblocks blocks tops rets r ps r ps () -setErrorPrefix names loc stmt_pp ctx regs = - ppCruRegsAndTopsPerms names ctx regs >>>= \(regs_pp, perms_pp) -> - let prefix = - PP.sep - [PP.group (pretty "At" <+> ppShortFileName (plSourceLoc loc) - <+> parens stmt_pp), - PP.group (pretty "Regs:" <+> regs_pp), - PP.group (pretty "Input perms:" <+> perms_pp)] in - gmodify $ \st -> st { stErrPrefix = Just prefix } - - ----------------------------------------------------------------------- --- * Permission Checking for Expressions and Statements ----------------------------------------------------------------------- - --- | Get a dynamic representation of an architecture's width -archWidth :: KnownNat (ArchWidth arch) => f arch -> NatRepr (ArchWidth arch) -archWidth _ = knownNat - --- | Type-check a Crucibe block id into a 'TypedBlockID' -tcBlockID :: BlockID cblocks args -> - StmtPermCheckM ext cblocks blocks tops rets ps ps - (TypedBlockID blocks (CtxToRList args)) -tcBlockID blkID = stLookupBlockID blkID <$> top_get - --- | Type-check a Crucible expression to test if it has a statically known --- 'PermExpr' value that we can use as an @eq(e)@ permission on the output of --- the expression -tcExpr :: - forall ext tp cblocks blocks tops rets ps exprExt. - (PermCheckExtC ext exprExt, KnownRepr ExtRepr ext) => - App ext RegWithVal tp -> - StmtPermCheckM ext cblocks blocks tops rets ps ps (Maybe (PermExpr tp)) -tcExpr (ExtensionApp _e_ext :: App ext RegWithVal tp) - | ExtRepr_LLVM <- knownRepr :: ExtRepr ext - = error "tcExpr: unexpected LLVM expression" - --- Equality expressions -- - --- For equalities, we can definitely return True if the values of the two --- expressions being compared are equal, but we can only return False if we know --- for sure that the two values are unequal. If, e.g., one is a variable with --- unknown value, it could equal anything, so we know nothing about the result --- of the equality test. -tcExpr (BoolEq (RegWithVal _ (PExpr_Bool b1)) - (RegWithVal _ (PExpr_Bool b2))) = - pure $ Just $ PExpr_Bool (b1 == b2) -tcExpr (BoolEq rwv1 rwv2) - | regWithValExpr rwv1 == regWithValExpr rwv2 = - pure $ Just $ PExpr_Bool True -tcExpr (NatEq (RegWithVal _ (PExpr_Nat i1)) - (RegWithVal _ (PExpr_Nat i2))) = - pure $ Just $ PExpr_Bool (i1 == i2) -tcExpr (NatEq rwv1 rwv2) - | regWithValExpr rwv1 == regWithValExpr rwv2 = - pure $ Just $ PExpr_Bool True -tcExpr (BVEq _ (RegWithVal _ bv1) (RegWithVal _ bv2)) - | bvEq bv1 bv2 = pure $ Just $ PExpr_Bool True -tcExpr (BVEq _ (RegWithVal _ bv1) (RegWithVal _ bv2)) - | not (bvCouldEqual bv1 bv2) = pure $ Just $ PExpr_Bool False -tcExpr (BVEq _ rwv1 rwv2) - | regWithValExpr rwv1 == regWithValExpr rwv2 = - pure $ Just $ PExpr_Bool True -tcExpr (BaseIsEq _ rwv1 rwv2) - | regWithValExpr rwv1 == regWithValExpr rwv2 = - pure $ Just $ PExpr_Bool True - --- Boolean expressions -- - -tcExpr (BoolLit b) = pure $ Just $ PExpr_Bool b - -tcExpr (Not (RegWithVal _ (PExpr_Bool b))) = - pure $ Just $ PExpr_Bool $ not b - -tcExpr (And (RegWithVal _ (PExpr_Bool False)) _) = - pure $ Just $ PExpr_Bool False -tcExpr (And _ (RegWithVal _ (PExpr_Bool False))) = - pure $ Just $ PExpr_Bool False -tcExpr (And (RegWithVal _ (PExpr_Bool True)) rwv) = - pure $ Just $ regWithValExpr rwv -tcExpr (And rwv (RegWithVal _ (PExpr_Bool True))) = - pure $ Just $ regWithValExpr rwv - -tcExpr (Or (RegWithVal _ (PExpr_Bool True)) _) = - pure $ Just $ PExpr_Bool True -tcExpr (Or _ (RegWithVal _ (PExpr_Bool True))) = - pure $ Just $ PExpr_Bool True -tcExpr (Or (RegWithVal _ (PExpr_Bool False)) rwv) = - pure $ Just $ regWithValExpr rwv -tcExpr (Or rwv (RegWithVal _ (PExpr_Bool False))) = - pure $ Just $ regWithValExpr rwv - -tcExpr (BoolXor (RegWithVal _ (PExpr_Bool False)) rwv) = - pure $ Just $ regWithValExpr rwv -tcExpr (BoolXor rwv (RegWithVal _ (PExpr_Bool False))) = - pure $ Just $ regWithValExpr rwv -tcExpr (BoolXor (RegWithVal _ (PExpr_Bool True)) - (RegWithVal _ (PExpr_Bool True))) = - pure $ Just $ PExpr_Bool False - --- Nat expressions -- - -tcExpr (NatLit i) = pure $ Just $ PExpr_Nat i - --- Bitvector expressions -- - -tcExpr (BVUndef _w) = - -- "Undefined" bitvectors are translated to 0 as a stand-in but we don't - -- return any equality permissions about them - pure Nothing - -tcExpr (BVLit w (BV.BV i)) = withKnownNat w $ pure $ Just $ bvInt i - -tcExpr (BVTrunc w2 _ (RegWithVal _ (bvMatchConst -> Just bv))) = - withKnownNat w2 $ pure $ Just $ bvBV $ BV.trunc w2 bv -tcExpr (BVZext w2 _ (RegWithVal _ (bvMatchConst -> Just bv))) = - withKnownNat w2 $ pure $ Just $ bvBV $ BV.zext w2 bv -tcExpr (BVSext w2 w (RegWithVal _ (bvMatchConst -> Just bv))) = - withKnownNat w2 $ pure $ Just $ bvBV $ BV.sext w w2 bv - -tcExpr (BVNot w (RegWithVal _ (bvMatchConst -> Just bv))) = - withKnownNat w $ pure $ Just $ bvBV $ BV.complement w bv -tcExpr (BVAnd w (RegWithVal _ (bvMatchConst -> - Just bv1)) (RegWithVal _ - (bvMatchConst -> Just bv2))) = - withKnownNat w $ pure $ Just $ bvBV $ BV.and bv1 bv2 -tcExpr (BVOr w (RegWithVal _ (bvMatchConst -> - Just bv1)) (RegWithVal _ - (bvMatchConst -> Just bv2))) = - withKnownNat w $ pure $ Just $ bvBV $ BV.or bv1 bv2 -tcExpr (BVXor w (RegWithVal _ (bvMatchConst -> - Just bv1)) (RegWithVal _ - (bvMatchConst -> Just bv2))) = - withKnownNat w $ pure $ Just $ bvBV $ BV.xor bv1 bv2 - -tcExpr (BVAdd w (RegWithVal _ e1) (RegWithVal _ e2)) = - withKnownNat w $ pure $ Just $ bvAdd e1 e2 - -tcExpr (BVMul w (RegWithVal _ (bvMatchConstInt -> Just i)) (RegWithVal _ e)) = - withKnownNat w $ pure $ Just $ bvMult i e -tcExpr (BVMul w (RegWithVal _ e) (RegWithVal _ (bvMatchConstInt -> Just i))) = - withKnownNat w $ pure $ Just $ bvMult i e - -tcExpr (BoolToBV w (RegWithVal _ (PExpr_Bool True))) = - withKnownNat w $ pure $ Just $ bvInt 1 -tcExpr (BoolToBV w (RegWithVal _ (PExpr_Bool False))) = - withKnownNat w $ pure $ Just $ bvInt 0 - -tcExpr (BVUlt _ (RegWithVal _ e1) (RegWithVal _ e2)) - | bvLt e1 e2 = pure $ Just $ PExpr_Bool True -tcExpr (BVUlt _ (RegWithVal _ e1) (RegWithVal _ e2)) - | not (bvCouldBeLt e1 e2) = pure $ Just $ PExpr_Bool False -tcExpr (BVUle _ (RegWithVal _ e1) (RegWithVal _ e2)) - | bvLt e2 e1 = pure $ Just $ PExpr_Bool False -tcExpr (BVUle _ (RegWithVal _ e1) (RegWithVal _ e2)) - | not (bvCouldBeLt e2 e1) = pure $ Just $ PExpr_Bool True - -tcExpr (BVSlt w (RegWithVal _ e1) (RegWithVal _ e2)) - | withKnownNat w $ bvSLt e1 e2 - = pure $ Just $ PExpr_Bool True -tcExpr (BVSlt w (RegWithVal _ e1) (RegWithVal _ e2)) - | withKnownNat w $ not (bvCouldBeSLt e1 e2) - = pure $ Just $ PExpr_Bool False -tcExpr (BVSle w (RegWithVal _ e1) (RegWithVal _ e2)) - | withKnownNat w $ bvSLt e2 e1 - = pure $ Just $ PExpr_Bool False -tcExpr (BVSle w (RegWithVal _ e1) (RegWithVal _ e2)) - | withKnownNat w $ not (bvCouldBeSLt e2 e1) - = pure $ Just $ PExpr_Bool True - -tcExpr (BVNonzero w (RegWithVal _ bv)) - | bvEq bv (withKnownNat w $ bvInt 0) = pure $ Just $ PExpr_Bool False -tcExpr (BVNonzero _ (RegWithVal _ bv)) - | not (bvZeroable bv) = pure $ Just $ PExpr_Bool True - --- String expressions -- - -tcExpr (StringLit (UnicodeLiteral text)) = - pure $ Just $ PExpr_String $ Text.unpack text - --- Struct expressions -- - --- For a struct built from registers r1, ..., rn, return struct(r1,...,rn) -tcExpr (MkStruct _ vars) = - pure $ Just $ PExpr_Struct $ namesToExprs $ - RL.map (typedRegVar . regWithValReg) $ assignToRList vars - --- For GetStruct x ix, if x has a value it will have been eta-expanded to a --- struct expression, so simply get out the required field of that struct -tcExpr (GetStruct (RegWithVal r (PExpr_Struct es)) ix _) = - getVarType (typedRegVar r) >>= \(StructRepr tps) -> - let memb = indexToMember (Ctx.size tps) ix in - pure $ Just $ RL.get memb (exprsToRAssign es) - --- For SetStruct x ix y, if x has a value it will have been eta-expanded to a --- struct expression, so simply replace required field of that struct with y -tcExpr (SetStruct tps (RegWithVal _ (PExpr_Struct es)) ix r') = - let memb = indexToMember (Ctx.size tps) ix in - pure $ Just $ PExpr_Struct $ rassignToExprs $ - RL.set memb (PExpr_Var $ typedRegVar $ regWithValReg r') $ - exprsToRAssign es - --- Misc expressions -- - -tcExpr _ = pure Nothing - - --- | Test if a sequence of arguments could potentially satisfy some function --- input permissions. This is an overapproximation, meaning that we might return --- 'True' even if the arguments do not satisfy the permissions. -couldSatisfyPermsM :: PermCheckExtC ext exprExt => CruCtx args -> TypedRegs args -> - Mb ghosts (ValuePerms args) -> - StmtPermCheckM ext cblocks blocks tops rets ps ps Bool -couldSatisfyPermsM CruCtxNil _ _ = pure True -couldSatisfyPermsM (CruCtxCons tps (BVRepr _)) (TypedRegsCons args arg) - (mbMatch -> [nuMP| ValPerms_Cons ps (ValPerm_Eq mb_e) |]) = - do b <- couldSatisfyPermsM tps args ps - arg_val <- getRegEqualsExpr arg - pure (b && mbLift (fmap (bvCouldEqual arg_val) mb_e)) -couldSatisfyPermsM (CruCtxCons tps _) (TypedRegsCons args arg) - (mbMatch -> [nuMP| ValPerms_Cons ps - (ValPerm_Eq (PExpr_LLVMWord mb_e)) |]) = - do b <- couldSatisfyPermsM tps args ps - getRegEqualsExpr arg >>= \case - PExpr_LLVMWord e -> - pure (b && mbLift (fmap (bvCouldEqual e) mb_e)) - _ -> pure False -couldSatisfyPermsM (CruCtxCons tps _) (TypedRegsCons args _) - (mbMatch -> [nuMP| ValPerms_Cons ps _ |]) = - couldSatisfyPermsM tps args ps - - --- | Typecheck a statement and emit it in the current statement sequence, --- starting and ending with an empty stack of distinguished permissions -tcEmitStmt :: - (PermCheckExtC ext exprExt, KnownRepr ExtRepr ext) => - CtxTrans ctx -> - ProgramLoc -> - Stmt ext ctx ctx' -> - StmtPermCheckM ext cblocks blocks tops rets RNil RNil (CtxTrans ctx') -tcEmitStmt ctx loc stmt = - do _ <- stmtTraceM (const (pretty "Type-checking statement:" <+> - ppStmt (size ctx) stmt)) - !_ <- permGetPPInfo - !pps <- mapM (\(Some r) -> ppCruRegAndPerms ctx r) (stmtInputRegs stmt) - !_ <- stmtTraceM (\_-> pretty "Input perms:" <> softline <> - ppCommaSep pps) - !ctx' <- tcEmitStmt' ctx loc stmt - !pps' <- mapM (\(Some r) -> ppCruRegAndPerms ctx' r) - (stmtOutputRegs (Ctx.size ctx') stmt) - _ <- stmtTraceM (const (pretty "Output perms:" <> softline <> - ppCommaSep pps')) - pure ctx' - - -tcEmitStmt' :: - forall ext ctx ctx' cblocks blocks tops rets exprExt. - (PermCheckExtC ext exprExt, KnownRepr ExtRepr ext) => - CtxTrans ctx -> - ProgramLoc -> - Stmt ext ctx ctx' -> - StmtPermCheckM ext cblocks blocks tops rets RNil RNil - (CtxTrans ctx') - -tcEmitStmt' ctx loc (SetReg _ (App (ExtensionApp e_ext - :: App ext (Reg ctx) tp))) - | ExtRepr_LLVM <- knownRepr :: ExtRepr ext - = tcEmitLLVMSetExpr ctx loc e_ext - -tcEmitStmt' ctx loc (SetReg tp (App e)) = - traverseFC (tcRegWithVal ctx) e >>= \e_with_vals -> - tcExpr e_with_vals >>= \maybe_val -> - let typed_e = TypedExpr e_with_vals maybe_val in - let stmt_rets = (singletonCruCtx tp) in - dbgNames' stmt_rets >>= \names -> - emitStmt stmt_rets names loc (TypedSetReg tp typed_e) >>>= \(_ :>: x) -> - stmtRecombinePerms >>> - pure (addCtxName ctx x) - -tcEmitStmt' ctx loc (ExtendAssign stmt_ext :: Stmt ext ctx ctx') - | ExtRepr_LLVM <- knownRepr :: ExtRepr ext - = tcEmitLLVMStmt Proxy ctx loc stmt_ext - -tcEmitStmt' ctx loc (CallHandle _ret freg_untyped _args_ctx args_untyped) = - let freg = tcReg ctx freg_untyped - args = tcRegs ctx args_untyped - {- args_subst = typedRegsToVarSubst args -} in - {- getVarTypes (typedRegsToVars args) >>>= \argTypes -> -} - getSimpleRegPerm freg >>>= \p_freg -> - (case p_freg of - ValPerm_Conj ps -> - forM ps $ \p -> case p of - Perm_Fun fun_perm -> - -- FIXME: rewrite couldSatisfyPermsM to fit ghosts having permissions - {- couldSatisfyPermsM argTypes args (fmap (varSubst args_subst) $ - funPermIns fun_perm) >>>= \could -> -} - let could = True in - pure (if could then Just (SomeFunPerm fun_perm) else Nothing) - _ -> pure Nothing - _ -> pure []) >>>= \maybe_fun_perms -> - (stmtEmbedImplM $ foldr1WithDefault (implCatchM "tcEmitStmt (fun perm)" $ - typedRegVar freg) - (implFailM FunctionPermissionError) - (mapMaybe (fmap pure) maybe_fun_perms)) >>>= \some_fun_perm -> - case some_fun_perm of - SomeFunPerm fun_perm -> - let ghosts = funPermGhosts fun_perm - args_ns = typedRegsToVars args - rets = funPermRets fun_perm in - (stmtProvePermsFreshLs ghosts (funPermExDistIns - fun_perm args_ns)) >>>= \gsubst -> - let gexprs = exprsOfSubst gsubst in - gets (RL.split ghosts args_ns . distPermsVars . view distPerms . stCurPerms) - >>>= \(ghosts_ns,_) -> - stmtProvePermsAppend CruCtxNil (emptyMb $ - eqDistPerms ghosts_ns gexprs) >>>= \_ -> - stmtProvePerm freg (emptyMb $ ValPerm_Conj1 $ Perm_Fun fun_perm) >>>= \_ -> - dbgNames' rets >>>= \names -> - emitStmt rets names loc (TypedCall freg fun_perm - (varsToTypedRegs ghosts_ns) gexprs args) - >>>= \(_ :>: ret') -> - stmtRecombinePerms >>> - pure (addCtxName ctx ret') - -tcEmitStmt' ctx loc (Assert reg msg) = - let treg = tcReg ctx reg in - getRegEqualsExpr treg >>= \case - PExpr_Bool True -> pure ctx - PExpr_Bool False -> stmtFailM FailedAssertionError - _ -> ctx <$ emitStmt CruCtxNil MNil loc (TypedAssert (tcReg ctx reg) (tcReg ctx msg)) - -tcEmitStmt' _ _ _ = error "tcEmitStmt: unsupported statement" - - --- | Translate a Crucible assignment of an LLVM expression -tcEmitLLVMSetExpr :: - CtxTrans ctx -> - ProgramLoc -> - LLVMExtensionExpr (Reg ctx) tp -> - StmtPermCheckM LLVM cblocks blocks tops rets RNil RNil - (CtxTrans (ctx ::> tp)) - --- Type-check a pointer-building expression, which is only valid when the block --- = 0, i.e., when building a word -tcEmitLLVMSetExpr ctx loc (LLVM_PointerExpr w blk_reg off_reg) = - let toff_reg = tcReg ctx off_reg - tblk_reg = tcReg ctx blk_reg in - resolveConstant tblk_reg >>= \case - Just 0 -> - nextDebugName >>>= \name -> - withKnownNat w $ - emitLLVMStmt knownRepr name loc (ConstructLLVMWord toff_reg) >>>= \x -> - stmtRecombinePerms >>> - pure (addCtxName ctx x) - _ -> - permGetPPInfo >>>= \ppinfo -> - stmtFailM $ NonZeroPointerBlockError (permPretty ppinfo tblk_reg) - --- Type-check the LLVM value destructor that gets the block value, by either --- proving a permission eq(llvmword e) and returning block 0 or proving --- permission is_llvmptr and returning the constant value 1. --- --- NOTE: our SAW translation does not include any computational content for --- pointer blocks and offsets, so we cannot represent the actual runtime value --- of the pointer block of a pointer. We can only know if it is zero or not by --- using permissions, and we map all non-zero values to 1. This implicitly --- assumes that the behavior of the program we are verifying is not altered in a --- meaningful way by mapping the return value of 'LLVM_PointerBlock' to 1 when --- it is applied to pointers, which is the case for all programs currently --- generated by Crucible from LLVM. -tcEmitLLVMSetExpr ctx loc (LLVM_PointerBlock w ptr_reg) = - let tptr_reg = tcReg ctx ptr_reg in - withKnownNat w $ - getAtomicOrWordLLVMPerms tptr_reg >>>= \case - Left e -> - nextDebugName >>>= \name -> - emitLLVMStmt knownRepr name loc (AssertLLVMWord tptr_reg e) >>>= \ret -> - stmtRecombinePerms >>> - pure (addCtxName ctx ret) - Right _ -> - stmtRecombinePerms >>> - stmtProvePerm tptr_reg (emptyMb $ ValPerm_Conj1 Perm_IsLLVMPtr) >>> - emitLLVMStmt knownRepr Nothing loc (AssertLLVMPtr tptr_reg) >>> - dbgNames >>>= \names -> - emitStmt - knownRepr names loc - (TypedSetReg knownRepr $ - TypedExpr (NatLit 1) - (Just $ PExpr_Nat 1)) >>>= \(_ :>: ret) -> - stmtRecombinePerms >>> - pure (addCtxName ctx ret) - --- Type-check the LLVM value destructor that gets the offset value, by either --- proving a permission eq(llvmword e) and returning e or proving --- permission is_llvmptr and returning the constant bitvector value 0. --- --- NOTE: Just as with 'LLVM_PointerBlock', because our SAW translation does not --- include any computational content for pointer blocks and offsets, we cannot --- represent the actual runtime value of the offset of a pointer. We thus return --- 0 as a dummy value. This implicitly assumes that the behavior of the program --- we are verifying is not altered in a meaningful way by mapping the return --- value of 'LLVM_PointerOffset' to 0 when it is applied to pointers, which is --- the case for all programs currently generated by Crucible from LLVM. -tcEmitLLVMSetExpr ctx loc (LLVM_PointerOffset w ptr_reg) = - let tptr_reg = tcReg ctx ptr_reg in - withKnownNat w $ - getAtomicOrWordLLVMPerms tptr_reg >>>= \eith -> - case eith of - Left e -> - nextDebugName >>>= \name -> - emitLLVMStmt knownRepr name loc (DestructLLVMWord - tptr_reg e) >>>= \ret -> - stmtRecombinePerms >>> - pure (addCtxName ctx ret) - Right _ -> - stmtRecombinePerms >>> - stmtProvePerm tptr_reg (emptyMb $ ValPerm_Conj1 Perm_IsLLVMPtr) >>> - emitLLVMStmt knownRepr Nothing loc (AssertLLVMPtr tptr_reg) >>> - dbgNames >>>= \names -> - emitStmt knownRepr names loc - (TypedSetReg knownRepr $ - TypedExpr (BVLit w $ BV.mkBV w 0) - (Just $ bvInt 0)) >>>= \(MNil :>: ret) -> - stmtRecombinePerms >>> - pure (addCtxName ctx ret) - --- An if-then-else at pointer type is just preserved, though we propogate --- equality information when possible -tcEmitLLVMSetExpr ctx loc (LLVM_PointerIte w cond_reg then_reg else_reg) = - withKnownNat w $ - let tcond_reg = tcReg ctx cond_reg - tthen_reg = tcReg ctx then_reg - telse_reg = tcReg ctx else_reg in - getRegEqualsExpr tcond_reg >>= \case - PExpr_Bool True -> - dbgNames >>= \names -> - emitStmt knownRepr names loc - (TypedSetRegPermExpr knownRepr $ - PExpr_Var $ typedRegVar tthen_reg) >>>= \(MNil :>: ret) -> - stmtRecombinePerms >>> - pure (addCtxName ctx ret) - PExpr_Bool False -> - dbgNames >>>= \names -> - emitStmt knownRepr names loc - (TypedSetRegPermExpr knownRepr $ - PExpr_Var $ typedRegVar telse_reg) >>>= \(MNil :>: ret) -> - stmtRecombinePerms >>> - pure (addCtxName ctx ret) - _ -> - nextDebugName >>>= \name -> - emitLLVMStmt knownRepr name loc (TypedLLVMIte w - tcond_reg tthen_reg telse_reg) >>>= \ret -> - stmtRecombinePerms >>> - pure (addCtxName ctx ret) - --- For LLVM side conditions, treat each side condition as an assert -tcEmitLLVMSetExpr ctx loc (LLVM_SideConditions _ tp conds reg) = - let treg = tcReg ctx reg in - foldr - (\(LLVMSideCondition cond_reg ub) rest_m -> - let tcond_reg = tcReg ctx cond_reg - err_msg = pretty "Undefined behavior" <> softline <> UB.explain ub in - -- err_str = renderDoc (pretty "Undefined behavior: " <> softline <> UB.explain ub) in - getRegEqualsExpr tcond_reg >>= \case - PExpr_Bool True -> - rest_m - PExpr_Bool False -> stmtFailM $ UndefinedBehaviorError err_msg - _ -> - emitStmt knownRepr noNames loc - (TypedSetRegPermExpr knownRepr $ - PExpr_String (renderDoc err_msg)) >>>= \(_ :>: str_var) -> - stmtRecombinePerms >>> - emitStmt CruCtxNil MNil loc - (TypedAssert tcond_reg $ - TypedReg str_var) >>>= \MNil -> - stmtRecombinePerms >>> - rest_m) - (let rets = singletonCruCtx tp in - dbgNames' rets >>>= \names -> - emitStmt rets names loc - (TypedSetRegPermExpr tp $ PExpr_Var $ - typedRegVar treg) >>>= \(MNil :>: ret) -> - stmtRecombinePerms >>> - pure (addCtxName ctx ret)) - conds -tcEmitLLVMSetExpr _ctx _loc X86Expr{} = - stmtFailM X86ExprError - - - --- FIXME HERE: move withLifetimeCurrentPerms somewhere better... - --- | Perform a statement type-checking conversation inside a context where the --- supplied lifetime has been proved to be current using the supplied --- 'LifetimeCurrentPerms' -withLifetimeCurrentPerms :: - PermCheckExtC ext exprExt => PermExpr LifetimeType -> - (forall ps_l. LifetimeCurrentPerms ps_l -> - StmtPermCheckM ext cblocks blocks tops rets (ps_out :++: ps_l) - (ps_in :++: ps_l) a) -> - StmtPermCheckM ext cblocks blocks tops rets ps_out ps_in a -withLifetimeCurrentPerms l m = - -- Get the proof steps needed to prove that the lifetime l is current - stmtEmbedImplM (getLifetimeCurrentPerms l) >>>= \(Some cur_perms) -> - -- Prove that the required permissions - stmtEmbedImplM (proveLifetimeCurrent cur_perms) >>> - -- Perform the computation - m cur_perms >>>= \a -> - -- Recombine the proof that the lifetime is current - stmtEmbedImplM (recombineLifetimeCurrentPerms cur_perms) >>> - -- Finally, return the result - pure a - - --- | Emit a 'TypedLLVMLoad' instruction, assuming the given LLVM field --- permission is on the top of the stack. Prove the required lifetime --- permissions as part of this process, and pop the resulting lifetime --- permission off the stack before returning. Return the resulting return --- register. -emitTypedLLVMLoad :: - forall w sz arch cblocks blocks tops rets ps. - (HasPtrWidth w, 1 <= sz, KnownNat sz) => - Proxy arch -> ProgramLoc -> - TypedReg (LLVMPointerType w) -> LLVMFieldPerm w sz -> DistPerms ps -> - StmtPermCheckM LLVM cblocks blocks tops rets - (ps :> LLVMPointerType w :> LLVMPointerType sz) - (ps :> LLVMPointerType w) - (Name (LLVMPointerType sz)) -emitTypedLLVMLoad _ loc treg fp ps = - withLifetimeCurrentPerms (llvmFieldLifetime fp) $ \cur_perms -> - emitLLVMStmt knownRepr Nothing loc (TypedLLVMLoad treg fp ps cur_perms) - - --- | Emit a 'TypedLLVMStore' instruction, assuming the given LLVM field --- permission is on the top of the stack. Prove the required lifetime --- permissions as part of this process, and pop the resulting lifetime --- permission off the stack before returning. Return the resulting return --- register of unit type. -emitTypedLLVMStore :: - (HasPtrWidth w, 1 <= sz, KnownNat sz) => - Proxy arch -> - Maybe String -> - ProgramLoc -> - TypedReg (LLVMPointerType w) -> - LLVMFieldPerm w sz -> - PermExpr (LLVMPointerType sz) -> - DistPerms ps -> - StmtPermCheckM LLVM cblocks blocks tops rets - (ps :> LLVMPointerType w) - (ps :> LLVMPointerType w) - (Name UnitType) -emitTypedLLVMStore _ name loc treg_ptr fp e ps = - withLifetimeCurrentPerms (llvmFieldLifetime fp) $ \cur_perms -> - emitLLVMStmt knownRepr name loc (TypedLLVMStore treg_ptr fp e ps cur_perms) - -open :: HasPtrWidth wptr => f (LLVMPointerType wptr) -> NatRepr wptr -open _ = ?ptrWidth - --- | Typecheck a statement and emit it in the current statement sequence, --- starting and ending with an empty stack of distinguished permissions -tcEmitLLVMStmt :: - forall arch ctx tp cblocks blocks tops rets. - Proxy arch -> - CtxTrans ctx -> - ProgramLoc -> - LLVMStmt (Reg ctx) tp -> - StmtPermCheckM LLVM cblocks blocks tops rets RNil RNil - (CtxTrans (ctx ::> tp)) - --- Type-check a load of an LLVM pointer by requiring a ptr permission and using --- TypedLLVMLoad, rounding up the size of the load to a whole number of bytes -tcEmitLLVMStmt arch ctx loc (LLVM_Load _ ptr tp storage _) - | sz_bits <- bytesToBits $ storageTypeSize storage - , sz_rnd_bits <- 8 * ceil_div sz_bits 8 - , Just (Some (sz_rnd :: NatRepr sz_rnd)) <- someNat sz_rnd_bits - , Left LeqProof <- decideLeq (knownNat @1) sz_rnd - = withKnownNat ?ptrWidth $ withKnownNat sz_rnd $ - let tptr = tcReg ctx ptr in - -- Prove [l]ptr((sz_rnd,0,rw) |-> eq(y)) for some l, rw, and y - stmtProvePerm tptr (llvmPtr0EqExPerm sz_rnd) >>>= \impl_res -> - let fp = subst impl_res (llvmPtr0EqEx sz_rnd) in - -- Emit a TypedLLVMLoad instruction - emitTypedLLVMLoad arch loc tptr fp DistPermsNil >>>= \z -> - -- Recombine the resulting permissions onto the stack - stmtRecombinePerms >>> - -- Convert the return value to the requested type and return it - (convertRegType knownRepr loc (TypedReg z) knownRepr tp >>>= \ret -> - pure (addCtxName ctx $ typedRegVar ret)) - --- FIXME: add a case for stores of smaller-than-byte-sized values - --- Type-check a store of an LLVM pointer -tcEmitLLVMStmt arch ctx loc (LLVM_Store _ ptr tp storage _ val) - | Just (Some sz) <- someNat $ bytesToBits $ storageTypeSize storage - , Left LeqProof <- decideLeq (knownNat @1) sz = - withKnownNat ?ptrWidth $ - withKnownNat sz $ - let tptr = tcReg ctx ptr - tval = tcReg ctx val in - convertRegType knownRepr loc tval tp (LLVMPointerRepr sz) >>>= \tval' -> - stmtProvePerm tptr (llvmWriteTrueExLPerm sz $ bvInt 0) >>>= \sbst -> - let l = substLookup sbst Member_Base in - let fp = llvmFieldWriteTrueL sz (bvInt 0) l in - nextDebugName >>>= \name -> - emitTypedLLVMStore arch name loc tptr fp - (PExpr_Var $ typedRegVar tval') DistPermsNil >>>= \z -> - stmtRecombinePerms >>> - pure (addCtxName ctx z) - --- Type-check a clear instruction by getting the list of field permissions --- returned by 'llvmFieldsOfSize' and storing word 0 to each of them -tcEmitLLVMStmt arch ctx loc (LLVM_MemClear _ (ptr :: Reg ctx (LLVMPointerType wptr)) bytes) = - withKnownNat ?ptrWidth $ - let tptr = tcReg ctx ptr - flds = llvmFieldsOfSize @wptr knownNat (bytesToInteger bytes) in - - -- For each field perm, prove it and write 0 to it - (forM_ @_ @_ @_ @() flds $ \case - Perm_LLVMField fp -> - stmtProvePerm tptr (emptyMb $ ValPerm_Conj1 $ Perm_LLVMField fp) >>> - emitTypedLLVMStore arch Nothing loc tptr fp (PExpr_LLVMWord (bvInt 0)) DistPermsNil >>> - stmtRecombinePerms >>> - pure () - _ -> error "Unexpected return value from llvmFieldsOfSize") >>> - - -- Return a fresh unit variable - dbgNames >>= \names -> - emitStmt knownRepr names loc - (TypedSetReg knownRepr $ - TypedExpr EmptyApp - (Just PExpr_Unit)) >>>= \(MNil :>: z) -> - stmtRecombinePerms >>> - pure (addCtxName ctx z) - - -{- --- Type-check a non-empty mem-clear instruction by writing a 0 to the last word --- and then recursively clearing all but the last word --- FIXME: add support for using non-word-size ptr perms with MemClear -tcEmitLLVMStmt arch ctx loc (LLVM_MemClear mem ptr bytes) = - let tptr = tcReg ctx ptr - bytes' = bytes - bitsToBytes (intValue (archWidth arch)) - off = bytesToInteger bytes' in - stmtProvePerm tptr (llvmWriteTrueExLPerm - (archWidth arch) (bvInt off)) >>>= \sbst -> - let l = substLookup sbst Member_Base in - let fp = llvmFieldWriteTrueL (archWidth arch) (bvInt off) l in - emitTypedLLVMStore arch loc tptr fp (PExpr_LLVMWord $ - bvInt 0) DistPermsNil >>> - stmtRecombinePerms >>> - tcEmitLLVMStmt arch ctx loc (LLVM_MemClear mem ptr bytes') --} - --- Type-check an alloca instruction -tcEmitLLVMStmt _arch ctx loc (LLVM_Alloca w _ sz_reg _ _) = - withKnownNat w $ - let sz_treg = tcReg ctx sz_reg in - getFramePtr w >>>= \maybe_fp -> - maybe (pure ValPerm_True) getRegPerm maybe_fp >>>= \fp_perm -> - resolveConstant sz_treg >>>= \maybe_sz -> - case (maybe_fp, fp_perm, maybe_sz) of - (Just fp, ValPerm_Conj [Perm_LLVMFrame fperms], Just sz) -> - stmtProvePerm fp (emptyMb fp_perm) >>>= \_ -> - nextDebugName >>>= \name -> - emitLLVMStmt knownRepr name loc - (TypedLLVMAlloca fp fperms sz) >>>= \y -> - stmtRecombinePerms >>> - pure (addCtxName ctx y) - (_, _, Nothing) -> - permGetPPInfo >>>= \ppinfo -> - stmtFailM $ AllocaError (AllocaNonConstantError $ permPretty ppinfo sz_treg) - (Just fp, p, _) -> - permGetPPInfo >>>= \ppinfo -> - stmtFailM $ AllocaError $ AllocaFramePermError - (permPretty ppinfo fp) - (permPretty ppinfo p) - (Nothing, _, _) -> - stmtFailM $ AllocaError AllocaFramePtrError - --- Type-check a push frame instruction -tcEmitLLVMStmt _arch ctx loc (LLVM_PushFrame _ _) = - fmap stArchWidth top_get >>>= \SomePtrWidth -> - withKnownNat ?ptrWidth $ - emitLLVMStmt knownRepr Nothing loc TypedLLVMCreateFrame >>>= \fp -> - setFramePtr ?ptrWidth (TypedReg fp) >>> - stmtRecombinePerms >>> - dbgNames >>>= \names -> - emitStmt knownRepr names loc - (TypedSetReg knownRepr - (TypedExpr EmptyApp Nothing)) >>>= \(MNil :>: y) -> - stmtRecombinePerms >>> - pure (addCtxName ctx y) - --- Type-check a pop frame instruction -tcEmitLLVMStmt _arch ctx loc (LLVM_PopFrame _) = - fmap stArchWidth top_get >>>= \SomePtrWidth -> - getFramePtr ?ptrWidth >>>= \maybe_fp -> - maybe (pure ValPerm_True) getRegPerm maybe_fp >>>= \fp_perm -> - case (maybe_fp, fp_perm) of - (Just fp, ValPerm_Conj [Perm_LLVMFrame fperms]) - | Some del_perms <- llvmFrameDeletionPerms fperms -> - stmtProvePerms knownRepr (distPermsToExDistPerms del_perms) >>>= \_ -> - stmtProvePerm fp (emptyMb fp_perm) >>>= \_ -> - nextDebugName >>>= \name -> - emitLLVMStmt knownRepr name loc - (TypedLLVMDeleteFrame fp fperms del_perms) >>>= \y -> - modify (\st -> st { stExtState = PermCheckExtState_LLVM Nothing }) >>> - pure (addCtxName ctx y) - _ -> stmtFailM $ PopFrameError - --- Type-check a pointer offset instruction by emitting OffsetLLVMValue -tcEmitLLVMStmt _arch ctx loc (LLVM_PtrAddOffset _w _ ptr off) = - let tptr = tcReg ctx ptr - toff = tcReg ctx off in - getRegEqualsExpr toff >>>= \off_expr -> - nextDebugName >>>= \name -> - withKnownNat ?ptrWidth $ - emitLLVMStmt knownRepr name loc (OffsetLLVMValue tptr off_expr) >>>= \ret -> - stmtRecombinePerms >>> - pure (addCtxName ctx ret) - --- Type-check a LoadHandle instruction by looking for a function pointer perm -tcEmitLLVMStmt _arch ctx loc (LLVM_LoadHandle _ _ ptr args ret) = - let tptr = tcReg ctx ptr - x = typedRegVar tptr in - withKnownNat ?ptrWidth $ - getAtomicLLVMPerms tptr >>>= \ps -> - case findIndex (\p -> case p of - Perm_LLVMFunPtr _ _ -> True - _ -> False) ps of - Just i - | Perm_LLVMFunPtr tp p <- ps!!i - , Just Refl <- testEquality tp (FunctionHandleRepr args ret) -> - stmtEmbedImplM (implCopyConjM x ps i >>> - recombinePerm x (ValPerm_Conj ps)) >>> - nextDebugName >>>= \name -> - emitLLVMStmt (FunctionHandleRepr args ret) name loc - (TypedLLVMLoadHandle tptr tp p) >>>= \ret' -> - stmtRecombinePerms >>> - pure (addCtxName ctx ret') - _ -> stmtFailM LoadHandleError - --- Type-check a ResolveGlobal instruction by looking up the global symbol -tcEmitLLVMStmt _arch ctx loc (LLVM_ResolveGlobal w _ gsym) = - (stPermEnv <$> top_get) >>>= \env -> - case lookupGlobalSymbol env gsym w of - Just (p, _) -> - nextDebugName >>>= \name -> - withKnownNat ?ptrWidth $ - emitLLVMStmt knownRepr name loc (TypedLLVMResolveGlobal gsym p) >>>= \ret -> - stmtRecombinePerms >>> - pure (addCtxName ctx ret) - Nothing -> - stmtFailM $ ResolveGlobalError gsym - -{- -tcEmitLLVMStmt _arch ctx loc (LLVM_PtrLe _ r1 r2) = - let x1 = tcReg ctx r1 - x2 = tcReg ctx r2 in - getRegEqualsExpr x1 >>>= \e1 -> - getRegEqualsExpr x2 >>>= \e2 -> - case (e1, e2) of - - -- If both variables equal words, then compare the words - -- - -- FIXME: if we have bvEq e1' e2' or not (bvCouldEqual e1' e2') then we - -- should return a known Boolean value in place of the Nothing - (PExpr_LLVMWord e1', PExpr_LLVMWord e2') -> - emitStmt knownRepr loc (TypedSetRegPermExpr - knownRepr e1') >>>= \(_ :>: n1) -> - stmtRecombinePerms >>> - emitStmt knownRepr loc (TypedSetRegPermExpr - knownRepr e2') >>>= \(_ :>: n2) -> - stmtRecombinePerms >>> - emitStmt knownRepr loc (TypedSetReg knownRepr $ - TypedExpr (BVUle knownRepr - (RegWithVal (TypedReg n1) e1') - (RegWithVal (TypedReg n1) e2')) - Nothing) >>>= \(_ :>: ret) -> - stmtRecombinePerms >>> - pure (addCtxName ctx ret) - - -- If both variables equal x+off for the same x, compare the offsets - -- - -- FIXME: test off1 == off2 like above - (asLLVMOffset -> Just (x1', off1), asLLVMOffset -> Just (x2', off2)) - | x1' == x2' -> - emitStmt knownRepr loc (TypedSetRegPermExpr - knownRepr off1) >>>= \(_ :>: n1) -> - stmtRecombinePerms >>> - emitStmt knownRepr loc (TypedSetRegPermExpr - knownRepr off2) >>>= \(_ :>: n2) -> - stmtRecombinePerms >>> - emitStmt knownRepr loc (TypedSetReg knownRepr $ - TypedExpr (BVUle knownRepr - (RegWithVal (TypedReg n1) off1) - (RegWithVal (TypedReg n1) off2)) - Nothing) >>>= \(_ :>: ret) -> - stmtRecombinePerms >>> - pure (addCtxName ctx ret) - - -- If one variable is a word and the other is not known to be a word, then - -- that other has to be a pointer, in which case the comparison will - -- definitely fail. Otherwise we cannot compare them and we fail. - (PExpr_LLVMWord e, asLLVMOffset -> Just (x', _)) -> - let r' = TypedReg x' in - stmtProvePerm r' (emptyMb $ ValPerm_Conj1 Perm_IsLLVMPtr) >>> - emitLLVMStmt knownRepr loc (AssertLLVMPtr r') >>> - emitStmt knownRepr loc (TypedSetReg knownRepr $ - TypedExpr (BoolLit False) - Nothing) >>>= \(_ :>: ret) -> - stmtRecombinePerms >>> - pure (addCtxName ctx ret) - - -- Symmetrical version of the above case - (asLLVMOffset -> Just (x', _), PExpr_LLVMWord e) -> - let r' = TypedReg x' in - stmtProvePerm r' (emptyMb $ ValPerm_Conj1 Perm_IsLLVMPtr) >>> - emitLLVMStmt knownRepr loc (AssertLLVMPtr r') >>> - emitStmt knownRepr loc (TypedSetReg knownRepr $ - TypedExpr (BoolLit False) - Nothing) >>>= \(_ :>: ret) -> - stmtRecombinePerms >>> - pure (addCtxName ctx ret) - - -- If we don't know any relationship between the two registers, then we - -- fail, because there is no way to compare pointers in the translation - _ -> - stmtFailM (\i -> - sep [pretty "Could not compare LLVM pointer values", - permPretty i x1, pretty "and", permPretty i x2]) --} - -tcEmitLLVMStmt _arch ctx loc (LLVM_PtrEq _ (r1 :: Reg ctx (LLVMPointerType wptr)) r2) = - let x1 = tcReg ctx r1 - x2 = tcReg ctx r2 in - withKnownNat (?ptrWidth :: NatRepr wptr) $ - getRegEqualsExpr x1 >>>= \e1 -> - getRegEqualsExpr x2 >>>= \e2 -> - case (e1, e2) of - - -- If both variables equal words, then compare the words - -- - -- FIXME: if we have bvEq e1' e2' or not (bvCouldEqual e1' e2') then we - -- should return a known Boolean value in place of the Nothing - (PExpr_LLVMWord e1', PExpr_LLVMWord e2') -> - emitStmt knownRepr noNames loc (TypedSetRegPermExpr - knownRepr e1') >>>= \(MNil :>: n1) -> - stmtRecombinePerms >>> - emitStmt knownRepr noNames loc (TypedSetRegPermExpr - knownRepr e2') >>>= \(MNil :>: n2) -> - stmtRecombinePerms >>> - dbgNames >>>= \names -> - emitStmt knownRepr names loc - (TypedSetReg knownRepr $ - TypedExpr (BaseIsEq knownRepr - (RegWithVal (TypedReg n1) e1') - (RegWithVal (TypedReg n2) e2')) - Nothing) >>>= \(MNil :>: ret) -> - stmtRecombinePerms >>> - pure (addCtxName ctx ret) - - -- If both variables equal x+off for the same x, compare the offsets - -- - -- FIXME: test off1 == off2 like above - (asLLVMOffset -> Just (x1', off1), asLLVMOffset -> Just (x2', off2)) - | x1' == x2' -> - emitStmt knownRepr noNames loc (TypedSetRegPermExpr - knownRepr off1) >>>= \(MNil :>: n1) -> - stmtRecombinePerms >>> - emitStmt knownRepr noNames loc (TypedSetRegPermExpr - knownRepr off2) >>>= \(MNil :>: n2) -> - stmtRecombinePerms >>> - dbgNames >>>= \names -> - emitStmt knownRepr names loc - (TypedSetReg knownRepr $ - TypedExpr (BaseIsEq knownRepr - (RegWithVal (TypedReg n1) off1) - (RegWithVal (TypedReg n2) off2)) - Nothing) >>>= \(MNil :>: ret) -> - stmtRecombinePerms >>> - pure (addCtxName ctx ret) - - -- If one variable is a word and the other is not known to be a word, then - -- that other has to be a pointer, in which case the comparison will - -- definitely fail. Otherwise we cannot compare them and we fail. - (PExpr_LLVMWord _e, asLLVMOffset -> Just (x', _)) -> - let r' = TypedReg x' in - stmtProvePerm r' (emptyMb $ ValPerm_Conj1 Perm_IsLLVMPtr) >>> - emitLLVMStmt knownRepr Nothing loc (AssertLLVMPtr r') >>> - dbgNames >>= \names -> - emitStmt knownRepr names loc - (TypedSetReg knownRepr $ - TypedExpr (BoolLit False) - Nothing) >>>= \(MNil :>: ret) -> - stmtRecombinePerms >>> - pure (addCtxName ctx ret) - - -- Symmetrical version of the above case - (asLLVMOffset -> Just (x', _), PExpr_LLVMWord _e) -> - let r' = TypedReg x' in - stmtProvePerm r' (emptyMb $ ValPerm_Conj1 Perm_IsLLVMPtr) >>> - emitLLVMStmt knownRepr Nothing loc (AssertLLVMPtr r') >>> - dbgNames >>= \names -> - emitStmt knownRepr names loc - (TypedSetReg knownRepr $ - TypedExpr (BoolLit False) - Nothing) >>>= \(MNil :>: ret) -> - stmtRecombinePerms >>> - pure (addCtxName ctx ret) - - -- If we don't know any relationship between the two registers, then we - -- fail, because there is no way to compare pointers in the translation - _ -> - permGetPPInfo >>>= \ppinfo -> - stmtFailM $ PointerComparisonError - (permPretty ppinfo x1) - (permPretty ppinfo x2) - -tcEmitLLVMStmt _arch ctx loc LLVM_Debug{} = --- let tptr = tcReg ctx ptr in - dbgNames >>= \names -> - emitStmt knownRepr names loc - (TypedSetReg knownRepr (TypedExpr EmptyApp Nothing)) >>>= \(MNil :>: ret) -> - stmtRecombinePerms >>> - pure (addCtxName ctx ret) - -tcEmitLLVMStmt _arch _ctx _loc stmt = - error ("tcEmitLLVMStmt: unimplemented statement - " ++ show (ppApp (\_ -> mempty) stmt)) - --- FIXME HERE: need to handle PtrEq, PtrLe, and PtrSubtract - - ----------------------------------------------------------------------- --- * Permission Checking for Jump Targets and Termination Statements ----------------------------------------------------------------------- - --- | Cast the primary permission for @x@ using any equality permissions on --- variables *not* in the supplied list of determined variables. The idea here --- is that we are trying to simplify out and remove un-determined variables. -castUnDetVarsForVar :: NuMatchingAny1 r => NameSet CrucibleType -> ExprVar a -> - ImplM vars s r RNil RNil () -castUnDetVarsForVar det_vars x = - (view varPermMap <$> getPerms) >>>= \var_perm_map -> - getPerm x >>>= \p -> - let nondet_perms = - NameMap.fromList $ - filter (\(NameMap.NameAndElem y _) -> not $ NameSet.member y det_vars) $ - NameMap.assocs var_perm_map in - let eqp = someEqProofFromSubst nondet_perms p in - implPushM x p >>> - implCastPermM Proxy x eqp >>> - implPopM x (someEqProofRHS eqp) - - --- | Simplify @lowned@ permissions @p@ on variable @x@ so they only depend on --- the determined variables given in the supplied list. This function only ends --- lifetimes, so that all lifetime ending happens before other unneeded --- permissions are dropped. -simplify1LOwnedPermForDetVars :: NuMatchingAny1 r => - NameSet CrucibleType -> Name a -> ValuePerm a -> - ImplM vars s r RNil RNil () - --- For permission l:lowned[ls](ps_in -o ps_out) where l or some free variable in --- ps_in or ps_out is not determined, end l -simplify1LOwnedPermForDetVars det_vars l (ValPerm_LOwned _ _ _ ps_in ps_out) - | vars <- NameSet.insert l $ freeVars (ps_in,ps_out) - , not $ NameSet.nameSetIsSubsetOf vars det_vars - = implEndLifetimeRecM l - --- For lowned permission l:lowned[ls](ps_in -o ps_out), end any lifetimes in ls --- that are not determined and remove them from the lowned permission for ls -simplify1LOwnedPermForDetVars det_vars l (ValPerm_LOwned ls _ _ _ _) - | l':_ <- flip mapMaybe ls (asVar >=> \l' -> - if NameSet.member l' det_vars then Nothing - else return l') = - implEndLifetimeRecM l' >>> - getPerm l >>>= \p' -> simplify1PermForDetVars det_vars l p' - --- Otherwise do nothing -simplify1LOwnedPermForDetVars _ _ _ = return () - - --- | Simplify and drop permissions @p@ on variable @x@ so they only depend on --- the determined variables given in the supplied list -simplify1PermForDetVars :: NuMatchingAny1 r => - NameSet CrucibleType -> Name a -> ValuePerm a -> - ImplM vars s r RNil RNil () - --- If the permissions contain an array permission with undetermined borrows, --- return those undetermined borrows if possible --- --- FIXME: we should only return borrows if we can; currently, if there are --- borrows we can't return, we fail here, and should instead just drop the array --- permission and keep going. To do this, we have to make a way to try to prove --- a permission, either by changing the ImplM monad or by adding a notion of --- local implication proofs where failure is scoped inside a proof -simplify1PermForDetVars det_vars x (ValPerm_Conj ps) - | Just i <- - findIndex - (\case - Perm_LLVMArray ap -> - any (\b -> not (nameSetIsSubsetOf - (freeVars b) det_vars)) (llvmArrayBorrows ap) - _ -> False) ps - , Perm_LLVMArray ap <- ps!!i - , det_borrows <- filter (\b -> nameSetIsSubsetOf - (freeVars b) det_vars) (llvmArrayBorrows ap) - , ret_p <- ValPerm_Conj1 $ Perm_LLVMArray $ ap { llvmArrayBorrows = - det_borrows } = - mbVarsM ret_p >>>= \mb_ret_p -> - proveVarImpl x mb_ret_p >>> - (getTopDistPerm x >>>= recombinePerm x) >>> - getPerm x >>>= \new_p -> - simplify1PermForDetVars det_vars x new_p - --- If none of the above cases match but p has only determined free variables, --- just leave p as is -simplify1PermForDetVars det_vars _ p - | nameSetIsSubsetOf (freeVars p) det_vars = pure () - --- If p is an equality permission to a word with undetermined variables, --- existentially quantify over the word -simplify1PermForDetVars _ x p@(ValPerm_Eq (PExpr_LLVMWord e)) = - let mb_p = nu $ \z -> ValPerm_Eq $ PExpr_LLVMWord $ PExpr_Var z in - implPushM x p >>> introExistsM x e mb_p >>> - implPopM x (ValPerm_Exists mb_p) - --- Otherwise, drop p, because it is not determined -simplify1PermForDetVars _det_vars x p = - implPushM x p >>> implDropM x p - - --- | Simplify and drop permissions so they only depend on the determined --- variables given in the supplied list -simplifyPermsForDetVars :: NuMatchingAny1 r => [SomeName CrucibleType] -> - ImplM vars s r RNil RNil () -simplifyPermsForDetVars det_vars_list = - let det_vars = NameSet.fromList det_vars_list in - (permSetVars <$> getPerms) >>>= \vars -> - -- Step 1: cast all the primary permissions using non-determined variables, to - -- try to simplify them out - mapM_ (\(SomeName x) -> castUnDetVarsForVar det_vars x) vars >>> - -- Step 2: end any unneeded lifetimes, but do this before any other unneeded - -- permissions have been dropped, in case they are needed to end lifetimes - mapM_ (\(SomeName x) -> - getPerm x >>>= simplify1LOwnedPermForDetVars det_vars x) vars >>> - -- Step 3: simplify any other remaining permissions - mapM_ (\(SomeName x) -> - getPerm x >>>= simplify1PermForDetVars det_vars x) vars - - --- | If @x@ has permission @eq(llvmword e)@ where @e@ is not a needed variable --- (in the supplied set), replace that perm with an existential permission --- @x:exists z.eq(llvmword z)@. Similarly, if @x@ has permission @eq(e)@ where --- @e@ is a literal, replace that permission with just @true@. Also do this --- inside pointer permissions, by recursively destructing any pointer --- permissions @ptr((rw,off) |-> p)@ to the permission @ptr((rw,off) |-> eq(y))@ --- for fresh variable @y@ and generalizing unneeded word equalities for @y@. -generalizeUnneededEqPerms1 :: - NuMatchingAny1 r => NameSet CrucibleType -> Name a -> ValuePerm a -> - ImplM vars s r ps ps () - --- For x:eq(y) for needed variable y, do nothing -generalizeUnneededEqPerms1 needed_vars _ (ValPerm_Eq (PExpr_Var y)) - | NameSet.member y needed_vars = pure () -generalizeUnneededEqPerms1 needed_vars _ (ValPerm_Eq e@(PExpr_BV _ _)) - | PExpr_Var y <- normalizeBVExpr e - , NameSet.member y needed_vars = pure () - --- Similarly, for x:eq(llvmword y) for needed variable y, do nothing -generalizeUnneededEqPerms1 needed_vars _ (ValPerm_Eq (PExpr_LLVMWord e)) - | PExpr_Var y <- normalizeBVExpr e - , NameSet.member y needed_vars = pure () -generalizeUnneededEqPerms1 _needed_vars x p@(ValPerm_Eq (PExpr_LLVMWord e)) = - let mb_eq = nu $ \z -> ValPerm_Eq $ PExpr_LLVMWord $ PExpr_Var z in - implPushM x p >>> - introExistsM x e mb_eq >>> - implPopM x (ValPerm_Exists mb_eq) - --- Similarly, for x:eq(y &+ off) for needed variable y, do nothing -generalizeUnneededEqPerms1 needed_vars _ (ValPerm_Eq (PExpr_LLVMOffset y _)) - | NameSet.member y needed_vars = pure () - --- For x:eq(e) where e is a literal, just drop the eq(e) permission -generalizeUnneededEqPerms1 _needed_vars x p@(ValPerm_Eq PExpr_Unit) = - implPushM x p >>> implDropM x p -generalizeUnneededEqPerms1 _needed_vars x p@(ValPerm_Eq (PExpr_Nat _)) = - implPushM x p >>> implDropM x p -generalizeUnneededEqPerms1 _needed_vars x p@(ValPerm_Eq (PExpr_Bool _)) = - implPushM x p >>> implDropM x p - --- If x:p1 * ... * pn, generalize the contents of field permissions in the pis -generalizeUnneededEqPerms1 needed_vars x p@(ValPerm_Conj ps) - | Just i <- findIndex isLLVMFieldPerm ps - , Perm_LLVMField fp <- ps!!i - , y_p <- llvmFieldContents fp - , ps' <- deleteNth i ps - , (case y_p of - ValPerm_Eq (PExpr_Var _) -> False - _ -> True) = - implPushM x p >>> implExtractConjM x ps i >>> - implPopM x (ValPerm_Conj ps') >>> - implElimLLVMFieldContentsM x fp >>>= \y -> - let fp' = fp { llvmFieldContents = ValPerm_Eq (PExpr_Var y) } in - implPushM x (ValPerm_Conj ps') >>> - implInsertConjM x (Perm_LLVMField fp') ps' i >>> - implPopM x (ValPerm_Conj (take i ps' ++ Perm_LLVMField fp' : drop i ps')) >>> - generalizeUnneededEqPerms1 needed_vars y y_p -generalizeUnneededEqPerms1 _ _ _ = pure () - --- | Find all permissions of the form @x:eq(llvmword e)@ other than those where --- @e@ is a needed variable, and replace them with @x:exists z.eq(llvmword z)@ -generalizeUnneededEqPerms :: NuMatchingAny1 r => ImplM vars s r ps ps () -generalizeUnneededEqPerms = - do Some var_perms <- permSetAllVarPerms <$> getPerms - let needed_vars = neededVars var_perms - foldDistPerms - (\m x p -> m >> generalizeUnneededEqPerms1 needed_vars x p) - (pure ()) - var_perms - - --- | Type-check a Crucible jump target -tcJumpTarget :: PermCheckExtC ext exprExt => CtxTrans ctx -> JumpTarget cblocks ctx -> - StmtPermCheckM ext cblocks blocks tops rets RNil RNil - (AnnotPermImpl (TypedJumpTarget blocks tops) RNil) -tcJumpTarget ctx (JumpTarget blkID args_tps args) = - -- NOTE: we need to get the "raw" top-level state, without deltas being - -- applied to it, to run the InnerPermCheckM inside the ImplM monad below. - -- FIXME: there should be a nicer way to do this... maybe if we got rid of - -- InnerPermCheckM and just had TopPermCheckM be a state monad on a Closed - -- TopPermCheckState? - (gcaptureCC $ \k -> ask >>= k) >>>= \top_st_raw -> - get >>= \st -> - gets (permCheckExtStateNames . stExtState) >>= \(Some ext_ns) -> - tcBlockID blkID >>>= \tpBlkID -> - - -- Step 0: run all of the following steps inside a local ImplM computation, - -- which we run in order to get out an AnnotPermImpl. This ensures that any - -- simplifications or other changes to permissions that are performed by this - -- computation are kept inside this local scope, which in turn is necessary so - -- that when we type-check a condition branch instruction (Br), the - -- simplifications of each branch do not affect each other. - pcmRunImplImplM CruCtxNil mempty $ - - -- NOTE: the args all must be distinct variables (this is required by - -- implPushOrReflMultiM below and also the translation of jump targets) - implFreshenNames (typedRegsToVars $ tcRegs ctx args) >>>= \args_ns -> - let tops_ns = stTopVars st - tops_args_ns = RL.append tops_ns args_ns - tops_args_ext_ns = RL.append tops_args_ns ext_ns in - - -- Step 1: Compute the variables whose values are determined by the - -- permissions on the top and normal arguments as the starting point for - -- figuring out our ghost variables. The determined variables are the only - -- variables that could possibly be inferred by a caller, and they are the - -- only variables that could actually be accessed by the block we are calling, - -- so we should not be really giving up any permissions we need. - let orig_cur_perms = stCurPerms st - det_vars = - namesToNamesList tops_args_ext_ns ++ - determinedVars orig_cur_perms tops_args_ext_ns in - - implTraceM (\i -> - pretty ("tcJumpTarget " ++ show blkID) <> - {- (if gen_perms_hint then pretty "(gen)" else emptyDoc) <> -} - line <> - (case permSetAllVarPerms orig_cur_perms of - Some all_perms -> - pretty "Current perms:" <+> - align (permPretty i all_perms)) - <> line <> - pretty "Determined vars:"<+> - align (list (map (permPretty i) det_vars))) >>> - - -- Step 2: Simplify and drop permissions so they do not depend on undetermined - -- variables - simplifyPermsForDetVars det_vars >>> - - -- Step 3: if gen_perms_hint is set, generalize any permissions of the form - -- eq(llvmword e) to exists z.eq(llvmword z) as long as they do not determine - -- a variable that we need, i.e., as long as they are not of the form - -- eq(llvmword x) for a variable x that we need - -- (if gen_perms_hint then generalizeUnneededEqPerms else pure ()) >>> - - -- Step 4: Compute the ghost variables for the target block as those variables - -- whose values are determined by the permissions on the top and normal - -- arguments after our above simplifications, adding in the extension-specific - -- variables as well - getPerms >>>= \cur_perms -> - case namesListToNames $ determinedVars cur_perms tops_args_ext_ns of - SomeRAssign ghosts_ns' -> - localImplM $ - let ghosts_ns = RL.append ext_ns ghosts_ns' - tops_perms = varPermsMulti tops_ns cur_perms - tops_set = NameSet.fromList $ namesToNamesList tops_ns - ghosts_perms = varPermsMulti ghosts_ns cur_perms - args_perms = - buildDistPerms (\n -> if NameSet.member n tops_set - then ValPerm_Eq (PExpr_Var n) - else cur_perms ^. varPerm n) args_ns - perms_in = appendDistPerms (appendDistPerms - tops_perms args_perms) ghosts_perms in - implTraceM (\i -> - pretty ("tcJumpTarget " ++ show blkID) <> - line <> - pretty "Input perms:" <+> - hang 2 (permPretty i perms_in)) >>> - - -- Step 5: abstract all the variables out of the input permissions. Note - -- that abstractVars uses the left-most occurrence of any variable that - -- occurs multiple times in the variable list and we want our eq perms for - -- our args to map to our tops, not our args, so this order works for what - -- we want - (case abstractVars - (RL.append (RL.append tops_ns args_ns) ghosts_ns) - (distPermsToValuePerms perms_in) of - Just ps -> pure ps - Nothing - | SomeRAssign orig_det_vars <- namesListToNames det_vars - , orig_perms <- varPermsMulti orig_det_vars orig_cur_perms -> - implTraceM - (\i -> - pretty ("tcJumpTarget: unexpected free variable in perms_in:\n" - ++ renderDoc (permPretty i perms_in) - ++ "\norig_perms:\n" - ++ renderDoc (permPretty i orig_perms))) >>>= \str -> - error str) >>>= \cl_mb_perms_in -> - - -- Step 6: insert a new block entrypoint that has all the permissions - -- we constructed above as input permissions - implGetVarTypes ghosts_ns >>>= \ghosts_tps -> - (case stCurEntry st of - Some curEntryID -> - lift $ flip runReaderT top_st_raw $ - callBlockWithPerms curEntryID tpBlkID - ghosts_tps cl_mb_perms_in) >>>= \siteID -> - implTraceM (\_ -> - pretty ("tcJumpTarget " ++ show blkID ++ " siteID =" ++ - show siteID)) >>> - - -- Step 7: return a TypedJumpTarget inside a PermImpl that proves all the - -- required input permissions from the current permission set by copying - -- the existing permissions into the current distinguished perms, except - -- for the eq permissions for real arguments, which are proved by - -- reflexivity. - implWithoutTracingM (implPushOrReflMultiM perms_in) >>> - pure (PermImpl_Done $ - TypedJumpTarget siteID Proxy (mkCruCtx args_tps) perms_in) - - --- | Type-check a termination statement -tcTermStmt :: PermCheckExtC ext exprExt => CtxTrans ctx -> - TermStmt cblocks ret ctx -> - StmtPermCheckM ext cblocks blocks tops (gouts :> ret) RNil RNil - (TypedTermStmt blocks tops (gouts :> ret) RNil) -tcTermStmt ctx (Jump tgt) = - TypedJump <$> tcJumpTarget ctx tgt -tcTermStmt ctx (Br reg tgt1 tgt2) = - -- FIXME: Instead of mapping Br to TypedJump when the jump target is known, - -- make a version of TypedBr that still stores the JumpTargets of never-taken - -- branches in order to allow translating back to untyped Crucible - let treg = tcReg ctx reg in - getRegEqualsExpr treg >>>= \treg_expr -> - case treg_expr of - PExpr_Bool True -> - stmtTraceM (const $ pretty "tcTermStmt: br reg known to be true!") >> - (TypedJump <$> tcJumpTarget ctx tgt1) - PExpr_Bool False -> - stmtTraceM (const $ pretty "tcTermStmt: br reg known to be false!") >> - (TypedJump <$> tcJumpTarget ctx tgt2) - _ -> - stmtTraceM (const $ pretty - "tcTermStmt: br reg unknown, checking both branches...") >> - (TypedBr treg <$> tcJumpTarget ctx tgt1 <*> tcJumpTarget ctx tgt2) -tcTermStmt ctx (Return reg) = - let ret_n = typedRegVar $ tcReg ctx reg in - get >>>= \st -> - top_get >>>= \top_st -> - let tops = stTopVars st - rets = stRetTypes top_st - CruCtxCons gouts _ = rets - mb_ret_perms = - give (cruCtxProxies rets) $ - varSubst (permVarSubstOfNames tops) $ - mbSeparate (cruCtxProxies rets) $ - mbValuePermsToDistPerms (stRetPerms top_st) - mb_req_perms = - fmap (varSubst (singletonVarSubst ret_n)) $ - mbSeparate (MNil :>: Proxy) mb_ret_perms - err = ppProofError (stPPInfo st) "Type-checking return statement" mb_req_perms in - mapM (\(SomeName x) -> ppRelevantPerms $ TypedReg x) (NameSet.toList $ - freeVars mb_req_perms) - >>>= \pps_before -> - stmtTraceM (\i -> - pretty "Type-checking return statement" <> line <> - pretty "Current perms:" <> softline <> - ppCommaSep pps_before <> line <> - pretty "Required perms:" <> softline <> - permPretty i mb_req_perms) >>> - TypedReturn <$> - pcmRunImplM gouts err - (\gouts_ns -> TypedRet Refl rets (gouts_ns :>: ret_n) mb_ret_perms) - (proveVarsImplVarEVars mb_req_perms) -tcTermStmt ctx (ErrorStmt reg) = - let treg = tcReg ctx reg in - getRegPerm treg >>>= \treg_p -> - let maybe_str = case treg_p of - ValPerm_Eq (PExpr_String str) -> Just str - _ -> Nothing in - pure $ TypedErrorStmt maybe_str treg -tcTermStmt _ tstmt = - error ("tcTermStmt: unhandled termination statement: " - ++ show (pretty tstmt)) - - ----------------------------------------------------------------------- --- * Permission Checking for Blocks and Sequences of Statements ----------------------------------------------------------------------- - --- | Translate and emit a Crucible statement sequence, starting and ending with --- an empty stack of distinguished permissions -tcEmitStmtSeq :: - (PermCheckExtC ext exprExt, KnownRepr ExtRepr ext) => - [Maybe String] -> - CtxTrans ctx -> - StmtSeq ext cblocks ret ctx -> - PermCheckM ext cblocks blocks tops (gouts :> ret) - () RNil - (TypedStmtSeq ext blocks tops (gouts :> ret) RNil) RNil - () -tcEmitStmtSeq names ctx (ConsStmt loc stmt stmts) = - setErrorPrefix names loc (ppStmt (Ctx.size ctx) stmt) ctx (stmtInputRegs stmt) >>> - tcEmitStmt ctx loc stmt >>>= \ctx' -> tcEmitStmtSeq names ctx' stmts -tcEmitStmtSeq names ctx (TermStmt loc tstmt) = - setErrorPrefix names loc (pretty tstmt) ctx (termStmtRegs tstmt) >>> - tcTermStmt ctx tstmt >>>= \typed_tstmt -> - gmapRet (>> return (TypedTermStmt loc typed_tstmt)) - --- | Type-check the body of a Crucible block as the body of an entrypoint -tcBlockEntryBody :: - (PermCheckExtC ext exprExt, KnownRepr ExtRepr ext) => - [Maybe String] -> - Block ext cblocks ret args -> - TypedEntry TCPhase ext blocks tops (gouts :> ret) (CtxToRList args) ghosts -> - TopPermCheckM ext cblocks blocks tops (gouts :> ret) - (NamedMb ((tops :++: CtxToRList args) :++: ghosts) - (TypedStmtSeq ext blocks tops (gouts :> ret) - ((tops :++: CtxToRList args) :++: ghosts))) -tcBlockEntryBody names blk entry@(TypedEntry {..}) = - runPermCheckM names typedEntryID typedEntryArgs typedEntryGhosts typedEntryPermsIn $ - \tops_ns args_ns ghosts_ns perms -> - let ctx = mkCtxTrans (blockInputs blk) args_ns - ns = RL.append (RL.append tops_ns args_ns) ghosts_ns in - stmtTraceM (\i -> - pretty "Type-checking block" <+> pretty (blockID blk) <> - comma <+> pretty "entrypoint" <+> pretty (entryIndex typedEntryID) - <> line <> - pretty "Input types:" - <> align (permPretty i $ - RL.map2 VarAndType ns $ cruCtxToTypes $ - typedEntryAllArgs entry) - <> line <> - pretty "Input perms:" - <> align (permPretty i perms)) >>> - -- handle unit variables - stmtHandleUnitVars ns >>> - stmtRecombinePerms >>> - tcEmitStmtSeq names ctx (blk ^. blockStmts) - -rappend :: RAssign f x -> RAssign f y -> RAssign f (x :++: y) -rappend xs (ys :>: y) = rappend xs ys :>: y -rappend xs MNil = xs - --- | Prove that the permissions held at a call site from the given source --- entrypoint imply the supplied input permissions of the current entrypoint -proveCallSiteImpl :: - KnownRepr ExtRepr ext => TypedEntryID blocks some_args -> - TypedEntryID blocks args -> CruCtx args -> CruCtx ghosts -> CruCtx vars -> - MbValuePerms ((tops :++: args) :++: vars) -> - MbValuePerms ((tops :++: args) :++: ghosts) -> - TopPermCheckM ext cblocks blocks tops rets (CallSiteImpl - blocks - ((tops :++: args) :++: vars) - tops args ghosts) -proveCallSiteImpl srcID destID args ghosts vars mb_perms_in mb_perms_out = - fmap (CallSiteImpl . _mbBinding) $ runPermCheckM [] srcID args vars mb_perms_in $ - \tops_ns args_ns _ perms_in -> - let ns = RL.append tops_ns args_ns - perms_out = - give (cruCtxProxies ghosts) $ - varSubst (permVarSubstOfNames $ ns) $ - mbSeparate (cruCtxProxies ghosts) $ - mbValuePermsToDistPerms mb_perms_out in - stmtTraceM (\i -> - pretty ("proveCallSiteImpl, src = " ++ show srcID ++ - ", dest = " ++ show destID) <> line <> - indent 2 (permPretty i perms_in) <> line <> - pretty "-o" <> line <> - indent 2 (permPretty i perms_out)) >>> - permGetPPInfo >>>= \ppInfo -> - let err = ppImplProofError ppInfo "proveCallSiteImpl" perms_in perms_out in - pcmRunImplM ghosts err - (CallSiteImplRet destID ghosts Refl tops_ns args_ns) - (handleUnitVars ns >>> - recombinePerms perms_in >>> - proveVarsImplVarEVars perms_out - ) >>>= \impl -> - gmapRet (>> return impl) - - --- | Set the entrypoint ghost variables of a call site, erasing its implication -callSiteSetGhosts :: CruCtx ghosts' -> - TypedCallSite TCPhase blocks tops args ghosts vars -> - TypedCallSite TCPhase blocks tops args ghosts' vars -callSiteSetGhosts _ (TypedCallSite {..}) = - TypedCallSite typedCallSiteID typedCallSitePerms Nothing - --- | Visit a call site, proving its implication of the entrypoint input --- permissions if that implication does not already exist -visitCallSite :: - (PermCheckExtC ext exprExt, KnownRepr ExtRepr ext) => - TypedEntry TCPhase ext blocks tops rets args ghosts -> - TypedCallSite TCPhase blocks tops args ghosts vars -> - TopPermCheckM ext cblocks blocks tops rets - (TypedCallSite TCPhase blocks tops args ghosts vars) -visitCallSite _ site@(TypedCallSite { typedCallSiteImpl = Just _ }) = - return site -visitCallSite (TypedEntry {..}) site@(TypedCallSite {..}) - | TypedCallSiteID { callSiteSrc = srcID, - callSiteVars = vars } <- typedCallSiteID = - fmap (\impl -> site { typedCallSiteImpl = Just impl }) $ - proveCallSiteImpl srcID typedEntryID - typedEntryArgs typedEntryGhosts vars - typedCallSitePerms typedEntryPermsIn - --- | Widen the permissions held by all callers of an entrypoint to compute new, --- weaker input permissions that can hopefully be satisfied by them -widenEntry :: PermCheckExtC ext exprExt => DebugLevel -> PermEnv -> - TypedEntry TCPhase ext blocks tops rets args ghosts -> - Some (TypedEntry TCPhase ext blocks tops rets args) -widenEntry dlevel env (TypedEntry {..}) = - debugTraceTraceLvl dlevel ("Widening entrypoint: " ++ show typedEntryID) $ - case foldl1' (widen dlevel env typedEntryTops typedEntryArgs) $ - map (fmapF typedCallSiteArgVarPerms) typedEntryCallers of - Some (ArgVarPerms (ghosts :: CruCtx x) perms_in) -> - let callers = - map (fmapF (callSiteSetGhosts ghosts)) typedEntryCallers - in - Some $ - TypedEntry { typedEntryCallers = callers, typedEntryGhosts = ghosts, - typedEntryPermsIn = perms_in, typedEntryBody = Nothing, - .. } - --- | Visit an entrypoint, by first proving the required implications at each --- call site, meaning that the permissions held at the call site imply the input --- permissions of the entrypoint, and then type-checking the body of the block --- with those input permissions, if it has not been type-checked already. --- --- If any of the call site implications fail, and the input \"can widen\" flag --- is 'True', recompute the entrypoint input permissions using widening. -visitEntry :: - (PermCheckExtC ext exprExt, CtxToRList cargs ~ args, KnownRepr ExtRepr ext) => - [Maybe String] -> - Bool -> Block ext cblocks ret cargs -> - TypedEntry TCPhase ext blocks tops (gouts :> ret) args ghosts -> - TopPermCheckM ext cblocks blocks tops (gouts :> ret) - (Some (TypedEntry TCPhase ext blocks tops (gouts :> ret) args)) - --- If the entry is already complete, do nothing -visitEntry _ _ _ entry - | isJust $ completeTypedEntry entry = - (stDebugLevel <$> get) >>= \dlevel -> - debugTraceTraceLvl dlevel ("visitEntry " ++ show (typedEntryID entry) - ++ ": no change") $ - return $ Some entry --- Otherwise, visit the call sites, widen if needed, and type-check the body -visitEntry names can_widen blk entry = - (stDebugLevel <$> get) >>= \dlevel -> - (stPermEnv <$> get) >>= \env -> - debugTracePretty traceDebugLevel dlevel - (vsep [pretty ("visitEntry " ++ show (typedEntryID entry) - ++ " with input perms:"), - permPretty emptyPPInfo (typedEntryPermsIn entry)]) - (return ()) >>= \() -> - - mapM (traverseF $ - visitCallSite entry) (typedEntryCallers entry) >>= \callers -> - debugTraceTraceLvl 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' -> - -- If we widen then we are throwing away the old body, so all of its - -- callees are no longer needed and can be deleted - modifying stBlockMap (deleteEntryCallees $ typedEntryID entry) >> - visitEntry names False blk entry' - else - if isJust (typedEntryBody entry) then - -- If the body was complete when we started and we are not widening, there - -- is no reason to re-type-check the body, so just update the callers - return $ Some $ entry { typedEntryCallers = callers } - else - do body <- maybe (tcBlockEntryBody names blk entry) return (typedEntryBody entry) - return $ Some $ entry { typedEntryCallers = callers, - typedEntryBody = Just body - } - - --- | Visit a block by visiting all its entrypoints -visitBlock :: - (PermCheckExtC ext exprExt, KnownRepr ExtRepr ext) => - Bool {- ^ Whether widening can be applied in type-checking this block -} -> - TypedBlock TCPhase ext blocks tops rets args -> - TopPermCheckM ext cblocks blocks tops rets - (TypedBlock TCPhase ext blocks tops rets args) -visitBlock can_widen blk@(TypedBlock {..}) = - (stCBlocksEq <$> get) >>= \Refl -> - flip (set typedBlockEntries) blk <$> - mapM (\(Some entry) -> - visitEntry _typedBlockNames (can_widen && typedBlockCanWiden) - typedBlockBlock entry) - _typedBlockEntries - --- | Flatten a list of topological ordering components to a list of nodes in --- topological order paired with a flag denoting which nodes were loop heads -wtoCompsToListWithSCCs :: [WTOComponent n] -> [(n, Bool)] -wtoCompsToListWithSCCs = - concatMap (\case - Vertex n -> [(n,False)] - SCC comps -> [(wtoHead comps,True)] ++ wtoCompsToListWithSCCs (wtoComps comps)) - --- | Build a topologically sorted list of 'BlockID's for a 'CFG', along with a --- flag for each 'BlockID' indicating whether it is the head of a loop -cfgOrderWithSCCs :: CFG ext blocks init ret -> - ([Some (BlockID blocks)], Assignment (Constant Bool) blocks) -cfgOrderWithSCCs cfg = - let nodes_sccs = wtoCompsToListWithSCCs $ cfgWeakTopologicalOrdering cfg in - (map fst nodes_sccs, - foldr (\(Some blkID, is_scc) -> - set (ixF $ blockIDIndex blkID) $ Constant is_scc) - (fmapFC (const $ Constant False) $ cfgBlockMap cfg) - nodes_sccs) - --- | The maximum number of iterations through the CFG while we allow widening --- when type-checking before we give up and force everything to be done -maxWideningIters :: Int -maxWideningIters = 5 - --- | Type-check a Crucible CFG -tcCFG :: - forall w ext cblocks ghosts inits gouts ret exprExt. - (PermCheckExtC ext exprExt, KnownRepr ExtRepr ext, 1 <= w, 16 <= w) => - NatRepr w -> - PermEnv -> EndianForm -> DebugLevel -> - FunPerm ghosts (CtxToRList inits) gouts ret -> - CFG ext cblocks inits ret -> - TypedCFG ext (CtxCtxToRList cblocks) ghosts (CtxToRList inits) gouts ret -tcCFG w env endianness dlevel fun_perm cfg = - let h = cfgHandle cfg - ghosts = funPermGhosts fun_perm - gouts = funPermGouts fun_perm - (nodes, sccs) = cfgOrderWithSCCs cfg - init_st = - let ?ptrWidth = w in - emptyTopPermCheckState env fun_perm endianness dlevel cfg sccs - tp_nodes = map (\(Some blkID) -> - Some $ stLookupBlockID blkID init_st) nodes in - let tp_blk_map = - flip evalState init_st $ main_loop maxWideningIters tp_nodes in - TypedCFG { tpcfgHandle = TypedFnHandle ghosts gouts h - , tpcfgFunPerm = fun_perm - , tpcfgBlockMap = tp_blk_map - , tpcfgEntryID = - TypedEntryID (stLookupBlockID (cfgEntryBlockID cfg) init_st) 0 } - where - main_loop :: Int -> - [Some (TypedBlockID blocks :: RList CrucibleType -> Type)] -> - TopPermCheckM ext cblocks blocks tops rets - (TypedBlockMap TransPhase ext blocks tops rets) - main_loop rem_iters _ - -- We may have to iterate through the CFG twice with widening turned off - -- to finally get everything to quiesce, once to ensure all block bodies - -- have type-checked and once again to ensure any back edged produced in - -- that last iteration have completed - | rem_iters < -2 = error "tcCFG: failed to complete on last iteration" - main_loop rem_iters nodes = - get >>= \st -> - case completeTypedBlockMap $ view stBlockMap st of - Just blkMapOut -> return blkMapOut - Nothing -> - forM_ nodes (\(Some tpBlkID) -> - let memb = typedBlockIDMember tpBlkID in - use (stBlockMap . member memb) >>= - (visitBlock (rem_iters > 0) >=> - assign (stBlockMap . member memb))) >> - main_loop (rem_iters - 1) nodes - --------------------------------------------------------------------------------- --- Error handling and logging - -data StmtError where - AtomicPermError :: Doc ann -> Doc ann -> StmtError - RegisterConversionError - :: (Show tp1, Show tp2) - => Doc ann -> tp1 -> tp2 -> StmtError - FailedAssertionError :: StmtError - NonZeroPointerBlockError :: Doc ann -> StmtError - UndefinedBehaviorError :: Doc () -> StmtError - X86ExprError :: StmtError - AllocaError :: AllocaErrorType -> StmtError - PopFrameError :: StmtError - LoadHandleError :: StmtError - ResolveGlobalError :: GlobalSymbol -> StmtError - PointerComparisonError :: Doc ann -> Doc ann -> StmtError - -data AllocaErrorType where - AllocaNonConstantError :: Doc ann -> AllocaErrorType - AllocaFramePermError :: Doc ann -> Doc ann -> AllocaErrorType - AllocaFramePtrError :: AllocaErrorType - -instance ErrorPretty StmtError where - ppError (AtomicPermError r p) = renderDoc $ - sep [pretty "getAtomicOrWordLLVMPerms:", - pretty "Needed atomic permissions for" <+> r, - pretty "but found" <+> p] - ppError (RegisterConversionError docx tp1 tp2) = renderDoc $ - pretty "Could not cast" <+> docx <+> - pretty "from" <+> pretty (show tp1) <+> - pretty "to" <+> pretty (show tp2) - ppError FailedAssertionError = - "Failed assertion" - ppError (NonZeroPointerBlockError tblk_reg) = renderDoc $ - pretty "LLVM_PointerExpr: Non-zero pointer block: " <> tblk_reg - ppError (UndefinedBehaviorError doc) = - renderDoc doc - ppError X86ExprError = - "X86Expr not supported" - ppError (AllocaError (AllocaNonConstantError sz_treg)) = renderDoc $ - pretty "LLVM_Alloca: non-constant size for" <+> - sz_treg - ppError (AllocaError (AllocaFramePermError fp p)) = renderDoc $ - pretty "LLVM_Alloca: expected LLVM frame perm for " <+> - fp <> pretty ", found perm" <+> p - ppError (AllocaError AllocaFramePtrError) = - "LLVM_Alloca: no frame pointer set" - ppError PopFrameError = - "LLVM_PopFrame: no frame perms" - ppError LoadHandleError = - "LLVM_LoadHandle: no function pointer perms" - ppError (ResolveGlobalError gsym) = - "LLVM_ResolveGlobal: no perms for global " ++ - globalSymbolName gsym - ppError (PointerComparisonError x1 x2) = renderDoc $ - sep [ pretty "Could not compare LLVM pointer values" - , x1, pretty "and", x2 ] - - --- | Get the current 'PPInfo' -permGetPPInfo :: PermCheckM ext cblocks blocks tops ret r ps r ps PPInfo -permGetPPInfo = gets stPPInfo - --- | Get the current prefix string to give context to error messages -getErrorPrefix :: PermCheckM ext cblocks blocks tops ret r ps r ps (Doc ()) -getErrorPrefix = gets (fromMaybe emptyDoc . stErrPrefix) - --- | Failure in the statement permission-checking monad -stmtFailM :: StmtError -> PermCheckM ext cblocks blocks tops ret r1 ps1 - (TypedStmtSeq ext blocks tops ret ps2) ps2 a -stmtFailM err = - getErrorPrefix >>>= \err_prefix -> - stmtTraceM (const $ err_prefix <> line <> - pretty "Type-checking failure:" <> softline <> - pretty (ppError err)) >>>= \str -> - gabortM (return $ TypedImplStmt $ AnnotPermImpl str $ - PermImpl_Step (Impl1_Fail $ GeneralError (pretty "")) MbPermImpls_Nil) diff --git a/heapster/src/Heapster/UntypedAST.hs b/heapster/src/Heapster/UntypedAST.hs deleted file mode 100644 index e81402b0af..0000000000 --- a/heapster/src/Heapster/UntypedAST.hs +++ /dev/null @@ -1,147 +0,0 @@ -module Heapster.UntypedAST where - -import GHC.Natural - -import Heapster.Located - --- | Unchecked function permission --- @(context). inputs -o outputs@ -data AstFunPerm = AstFunPerm - Pos - [(Located String, AstType)] -- ^ The context of ghost variables - [(Located String, AstExpr)] -- ^ The input permissions - [(Located String, AstType)] -- ^ The context of ghost output variables - [(Located String, AstExpr)] -- ^ The output permissions - deriving Show - --- | Unchecked array permission --- @[lifetime]array(rw, offset, size, width) |-> permission -data ArrayPerm = - ArrayPerm Pos (Maybe AstExpr) AstExpr AstExpr (Maybe AstExpr) AstExpr - -- ^ @array@ position, lifetime, rw, offset, size, width, permission - deriving Show - --- | Unchecked types -data AstType - = TyUnit Pos -- ^ unit type - | TyBool Pos -- ^ bool type - | TyNat Pos -- ^ nat type - | TyBV Pos Natural -- ^ bitvector type - | TyLlvmPtr Pos Natural -- ^ llvm pointer with width - | TyLlvmFrame Pos Natural -- ^ llvm frame with width - | TyLlvmBlock Pos Natural -- ^ llvm block with width - | TyLlvmShape Pos Natural -- ^ llvm shape with width - | TyLifetime Pos -- ^ lifetime - | TyRwModality Pos -- ^ rwmodality - | TyPermList Pos -- ^ permlist - | TyStruct Pos [AstType] -- ^ struct(types) - | TyPerm Pos AstType -- ^ perm(type) - deriving Show - --- | Unchecked expressions -data AstExpr - = ExUnit Pos -- ^ unit - | ExAlways Pos -- ^ always - | ExNat Pos Natural -- ^ number literal - | ExVar Pos String (Maybe [AstExpr]) (Maybe AstExpr) -- ^ identifier, shape arguments, offset - | ExAdd Pos AstExpr AstExpr -- ^ addition - | ExNeg Pos AstExpr -- ^ negation - | ExMul Pos AstExpr AstExpr -- ^ multiplication or permission conjunction - | ExRead Pos -- ^ read modality - | ExWrite Pos -- ^ read/write modality - | ExStruct Pos [AstExpr] -- ^ struct literal with field expressions - | ExLlvmWord Pos AstExpr -- ^ llvmword with value - | ExLlvmFrame Pos [(AstExpr, Natural)] -- ^ llvmframe literal - | ExOr Pos AstExpr AstExpr -- ^ or permission - | ExFalse Pos -- ^ false permission - | ExAny Pos -- ^ any permission - - | ExEmptySh Pos -- ^ empty shape - | ExEqSh Pos AstExpr AstExpr -- ^ equal shape - | ExTrue Pos -- ^ trivial permission - | ExExists Pos String AstType AstExpr -- ^ existentially quantified value - | ExSeqSh Pos AstExpr AstExpr -- ^ sequenced shapes - | ExOrSh Pos AstExpr AstExpr -- ^ alternative shapes - | 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 AstExpr -- ^ array shape - | ExTupleSh Pos AstExpr -- ^ field shape - | ExFalseSh Pos -- ^ false shape - - | ExEqual Pos AstExpr AstExpr -- ^ equal bitvector proposition - | ExNotEqual Pos AstExpr AstExpr -- ^ not-equal bitvector proposition - | ExLessThan Pos AstExpr AstExpr -- ^ less-than bitvector proposition - | ExLessEqual Pos AstExpr AstExpr -- ^ less-than or equal-to bitvector proposition - - | ExEq Pos AstExpr -- ^ equal permission - | ExLOwned Pos [AstExpr] [(Located String, AstExpr)] [(Located String, AstExpr)] -- ^ owned permission - | ExLCurrent Pos (Maybe AstExpr) -- ^ current permission - | ExLFinished Pos -- ^ finished permission - | ExShape Pos AstExpr -- ^ shape literal - | ExFree Pos AstExpr -- ^ free literal - | 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 (Maybe AstExpr) AstExpr AstExpr AstExpr AstExpr AstExpr -- ^ array permission - deriving Show - --- | Returns outermost position -instance HasPos AstExpr where - pos (ExUnit p ) = p - pos (ExAlways p ) = p - pos (ExNat p _ ) = p - pos (ExVar p _ _ _ ) = p - pos (ExAdd p _ _ ) = p - pos (ExNeg p _ ) = p - pos (ExMul p _ _ ) = p - pos (ExRead p ) = p - pos (ExWrite p ) = p - pos (ExStruct p _ ) = p - pos (ExLlvmWord p _ ) = p - pos (ExEmptySh p ) = p - pos (ExEqSh p _ _ ) = p - pos (ExEq p _ ) = p - pos (ExOr p _ _ ) = p - pos (ExFalse p ) = p - pos (ExTrue p ) = p - pos (ExAny p ) = p - pos (ExExists p _ _ _ ) = p - pos (ExSeqSh p _ _ ) = p - pos (ExOrSh p _ _ ) = p - pos (ExExSh p _ _ _ ) = p - pos (ExFieldSh p _ _ ) = p - pos (ExTupleSh p _ ) = p - pos (ExPtrSh p _ _ _ ) = p - pos (ExEqual p _ _ ) = p - pos (ExNotEqual p _ _ ) = p - pos (ExLessThan p _ _ ) = p - pos (ExLessEqual p _ _ ) = p - pos (ExLOwned p _ _ _ ) = p - pos (ExLCurrent p _ ) = p - pos (ExLFinished p ) = p - pos (ExShape p _ ) = p - pos (ExFree p _ ) = p - pos (ExPtr p _ _ _ _ _) = p - pos (ExMemblock p _ _ _ _ _) = p - pos (ExLlvmFunPtr p _ _ _ ) = p - pos (ExLlvmFrame p _ ) = p - pos (ExArray p _ _ _ _ _ _) = p - pos (ExArraySh p _ _ _ ) = p - pos (ExFalseSh p ) = p - --- | Returns outermost position -instance HasPos AstType where - pos (TyUnit p ) = p - pos (TyBool p ) = p - pos (TyNat p ) = p - pos (TyBV p _) = p - pos (TyLlvmPtr p _) = p - pos (TyLlvmFrame p _) = p - pos (TyLlvmBlock p _) = p - pos (TyLlvmShape p _) = p - pos (TyLifetime p ) = p - pos (TyRwModality p ) = p - pos (TyPermList p ) = p - pos (TyStruct p _) = p - pos (TyPerm p _) = p diff --git a/heapster/src/Heapster/Widening.hs b/heapster/src/Heapster/Widening.hs deleted file mode 100644 index f7fdf87347..0000000000 --- a/heapster/src/Heapster/Widening.hs +++ /dev/null @@ -1,1046 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE BangPatterns #-} - -module Heapster.Widening where - -import Data.Maybe -import Data.List (findIndex) -import Data.Functor (void) -import Data.Functor.Constant -import Data.Functor.Product -import Control.Monad (ap, zipWithM) -import Control.Monad.State (MonadState(..), StateT(..), modify) -import Control.Monad.Trans.Class (MonadTrans(..)) -import GHC.TypeLits (KnownNat) -import Control.Lens hiding ((:>), Index, Empty, ix, op) -import Control.Monad.Extra (concatMapM) - -import Data.Parameterized.Some -import Data.Parameterized.BoolRepr - -import Prettyprinter - -import Lang.Crucible.LLVM.MemModel -import Heapster.CruUtil -import Heapster.Permissions - -import qualified Data.Type.RList as RL -import Data.Binding.Hobbits -import Data.Binding.Hobbits.NameMap (NameMap, NameAndElem(..)) -import qualified Data.Binding.Hobbits.NameMap as NameMap - -import Lang.Crucible.Types - - ----------------------------------------------------------------------- --- * The Widening Monad ----------------------------------------------------------------------- - --- | A sequence of permissions for some list of variables that extends @vars@ -data ExtVarPerms vars - = ExtVarPerms_Base (ValuePerms vars) - | forall var. ExtVarPerms_Mb (TypeRepr var) (Binding var - (ExtVarPerms (vars :> var))) - -$(mkNuMatching [t| forall vars. ExtVarPerms vars |]) - -extVarPerms_MbMulti :: CruCtx ctx -> Mb ctx (ExtVarPerms (vars :++: ctx)) -> - ExtVarPerms vars -extVarPerms_MbMulti CruCtxNil mb_ewid = elimEmptyMb mb_ewid -extVarPerms_MbMulti (CruCtxCons ctx tp) mb_ewid = - extVarPerms_MbMulti ctx $ - fmap (ExtVarPerms_Mb tp) $ mbSeparate (MNil :>: Proxy) mb_ewid - -newtype ExtVarPermsFun vars = - ExtVarPermsFun { applyExtVarPermsFun :: - RAssign Name vars -> ExtVarPerms vars } - --- | A map from free variables to their permissions and whether they have been --- \"visited\" yet -type WidNameMap = NameMap (Product ValuePerm (Constant Bool)) - --- | Modify the entry in a 'WidNameMap' associated with a particular free --- variable, starting from the default entry of @('ValPerm_True','False')@ if --- the variable has not been entered into the map yet -wnMapAlter :: (Product ValuePerm (Constant Bool) a -> - Product ValuePerm (Constant Bool) a) -> ExprVar a -> - WidNameMap -> WidNameMap -wnMapAlter f = - NameMap.alter $ \case - Just entry -> Just $ f entry - Nothing -> Just $ f (Pair ValPerm_True (Constant False)) - --- | Look up the permission for a name in a 'WidNameMap' -wnMapGetPerm :: Name a -> WidNameMap -> ValuePerm a -wnMapGetPerm n nmap | Just (Pair p _) <- NameMap.lookup n nmap = p -wnMapGetPerm _ _ = ValPerm_True - --- | Build an 'ExtVarPermsFun' from a widening name map -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) - --- | Look up a variable of block type in a 'WidNameMap' to see if it has an --- associated @shape(sh)@ permission -wnMapBlockShape :: WidNameMap -> ExprVar (LLVMBlockType w) -> - Maybe (PermExpr (LLVMShapeType w)) -wnMapBlockShape nmap n = - NameMap.lookup n nmap >>= \case - Pair (ValPerm_Conj1 (Perm_LLVMBlockShape sh)) _ -> Just sh - _ -> Nothing - -newtype PolyContT r m a = - PolyContT { runPolyContT :: forall x. (forall y. a -> m (r y)) -> m (r x) } - -instance Functor (PolyContT r m) where - fmap f m = m >>= return . f - -instance Applicative (PolyContT r m) where - pure x = PolyContT $ \k -> k x - (<*>) = ap - -instance Monad (PolyContT r m) where - return = pure - (PolyContT m) >>= f = - PolyContT $ \k -> m $ \a -> runPolyContT (f a) k - -data WidState = WidState { _wsNameMap :: WidNameMap, - _wsPPInfo :: PPInfo, - _wsPermEnv :: PermEnv, - _wsDebugLevel :: DebugLevel, - _wsRecFlag :: RecurseFlag } - -makeLenses ''WidState - -type WideningM = - StateT WidState (PolyContT ExtVarPermsFun Identity) - -runWideningM :: WideningM () -> DebugLevel -> PermEnv -> RAssign Name args -> - ExtVarPerms args -runWideningM m dlevel env = - applyExtVarPermsFun $ runIdentity $ - runPolyContT (runStateT m $ - WidState NameMap.empty emptyPPInfo env dlevel RecNone) - (Identity . wnMapExtWidFun . _wsNameMap . snd) - -openMb :: CruCtx ctx -> Mb ctx a -> WideningM (RAssign Name ctx, a) -openMb ctx mb_a = - lift $ PolyContT $ \k -> Identity $ ExtVarPermsFun $ \ns -> - extVarPerms_MbMulti ctx $ - mbMap2 (\ns' a -> - applyExtVarPermsFun (runIdentity $ k (ns',a)) (RL.append ns ns')) - (nuMulti (cruCtxProxies ctx) id) mb_a - -bindFreshVar :: TypeRepr tp -> WideningM (ExprVar tp) -bindFreshVar tp = - (snd <$> openMb (singletonCruCtx tp) (nu id)) >>= \n -> - setVarNameM "var" n >> - return n - -visitM :: ExprVar a -> WideningM () -visitM n = modify $ over wsNameMap $ wnMapAlter (\(Pair p _) -> - Pair p (Constant True)) n - -isVisitedM :: ExprVar a -> WideningM Bool -isVisitedM n = - maybe False (\(Pair _ (Constant b)) -> b) <$> - NameMap.lookup n <$> view wsNameMap <$> get - -getVarPermM :: ExprVar a -> WideningM (ValuePerm a) -getVarPermM n = wnMapGetPerm n <$> view wsNameMap <$> get - -setVarPermM :: ExprVar a -> ValuePerm a -> WideningM () -setVarPermM n p = - modify $ over wsNameMap $ wnMapAlter (\(Pair _ isv) -> Pair p isv) n - --- | Set the permissions for @x &+ off@ to @p@, by setting the permissions for --- @x@ to @p - off@ -setOffVarPermM :: ExprVar a -> PermOffset a -> ValuePerm a -> WideningM () -setOffVarPermM x off p = - setVarPermM x (offsetPerm (negatePermOffset off) p) - -setVarPermsM :: RAssign Name ctx -> RAssign ValuePerm ctx -> WideningM () -setVarPermsM MNil MNil = return () -setVarPermsM (ns :>: n) (ps :>: p) = setVarPermsM ns ps >> setVarPermM n p - -setVarNameM :: String -> ExprVar tp -> WideningM () -setVarNameM base x = modify $ over wsPPInfo $ ppInfoAddExprName base x - -setVarNamesM :: String -> RAssign ExprVar tps -> WideningM () -setVarNamesM base xs = modify $ over wsPPInfo $ ppInfoAddExprNames base xs - -traceM :: (PPInfo -> Doc ()) -> WideningM () -traceM f = do - dlevel <- view wsDebugLevel <$> get - str <- renderDoc <$> f <$> view wsPPInfo <$> get - debugTraceTraceLvl dlevel str $ return () - --- | Unfold an 'AtomicPerm' if it is a named conjunct, otherwise leave it alone -widUnfoldConjPerm :: AtomicPerm a -> WideningM [AtomicPerm a] -widUnfoldConjPerm (Perm_NamedConj npn args off) - | TrueRepr <- nameCanFoldRepr npn = - do env <- use wsPermEnv - let np = requireNamedPerm env npn - return $ unfoldConjPerm np args off -widUnfoldConjPerm p = return [p] - - ----------------------------------------------------------------------- --- * Widening Itself ----------------------------------------------------------------------- - -{- --- | Test if an expression in a binding is a free variable plus offset -mbAsOffsetVar :: KnownCruCtx vars -> Mb vars (PermExpr a) -> - Maybe (Name a, PermOffset a) -mbAsOffsetVar vars [nuP| PExpr_Var mb_x |] - | Right n <- mbNameBoundP mb_x = Just (n, NoPermOffset) -mbAsOffsetVar vars [nuP| PExpr_LLVMOffset mb_x mb_off |] - | Right n <- mbNameBoundP mb_x - , Just off <- partialSubst (emptyPSubst vars) mb_off - = Just (n, LLVMPermOffset off) -mbAsOffsetVar _ _ = Nothing --} - --- | Take a permission @p1@ at some existing location and split it into some --- @p1'*p1''@ such that @p1'@ will remain at the existing location and @p1''@ --- will be widened against @p1''@. Return @p1'@ and the result of widening --- @p1''@ against @p2@. -splitWidenPerm :: TypeRepr a -> ValuePerm a -> ValuePerm a -> - WideningM (ValuePerm a, ValuePerm a) -splitWidenPerm tp p1 p2 - | permIsCopyable p1 = (p1,) <$> widenPerm tp p1 p2 -splitWidenPerm _ p1 _ = return (p1, ValPerm_True) - --- | Take permissions @p1@ and @p2@ that are both on existing locations and --- split them both into @p1'*p1''@ and @p2'*p2''@ such that @p1'@ and @p2'@ --- remain at the existing locations and @p1''@ and @p2''@ are widened against --- each other. Return @p1'@, @p2'@, and the result of the further widening of --- @p1''@ against @p2''@. -doubleSplitWidenPerm :: TypeRepr a -> ValuePerm a -> ValuePerm a -> - WideningM ((ValuePerm a, ValuePerm a), ValuePerm a) -doubleSplitWidenPerm tp p1 p2 - | permIsCopyable p1 && permIsCopyable p2 - = ((p1,p2),) <$> widenPerm tp p1 p2 -doubleSplitWidenPerm _ p1 p2 = - return ((p1, p2), ValPerm_True) - - --- | Replace all variables @x@ in an expression or permission that have an --- equality permission @eq(e)@ with the expression @e@ -substEqVars :: Substable PermSubst a Identity => PermPretty a => - AbstractVars a => FreeVars a => WidNameMap -> a -> a -substEqVars wnmap a - | AbsObj vars cl_mb_a <- abstractFreeVars a = - subst (substOfExprs $ - RL.map (\x -> case wnMapGetPerm x wnmap of - ValPerm_Eq e -> substEqVars wnmap e - _ -> PExpr_Var x) - vars) $ - unClosed cl_mb_a - - --- | Widen two expressions against each other --- --- FIXME: document this more -widenExpr :: TypeRepr a -> PermExpr a -> PermExpr a -> WideningM (PermExpr a) -widenExpr tp e1 e2 = - traceM (\i -> - fillSep [pretty "widenExpr", permPretty i e1, permPretty i e2]) >> - widenExpr' tp e1 e2 - -widenExpr' :: TypeRepr a -> PermExpr a -> PermExpr a -> WideningM (PermExpr a) - --- If both sides are equal, return one of the sides -widenExpr' _ e1 e2 | e1 == e2 = return e1 - --- If both sides are variables, look up their permissions and whether they have --- been visited and use that information to decide what to do -widenExpr' tp e1@(asVarOffset -> Just (x1, off1)) e2@(asVarOffset -> - Just (x2, off2)) = - do p1 <- getVarPermM x1 - p2 <- getVarPermM x2 - isv1 <- isVisitedM x1 - isv2 <- isVisitedM x2 - case (p1, p2, isv1, isv2) of - - -- If we have the same variable with the same offsets (it can avoid the - -- case above of e1 == e2 if the offsets are offsetsEq but not ==) then - -- we are done, though we do want to visit the variable - _ | x1 == x2 && offsetsEq off1 off2 -> - visitM x1 >> return e1 - - -- If we have the same variable but different offsets, we widen them - -- using 'widenOffsets'. Note that we cannot have the same variable - -- x on both sides unless they have been visited, so we can safely - -- ignore the isv1 and isv2 flags. The complexity of having these two - -- cases is to find the BVType of one of off1 or off2; because the - -- previous case did not match, we know at least one is LLVMPermOffset. - _ | x1 == x2, LLVMPermOffset (exprType -> off_tp) <- off1 -> - PExpr_LLVMOffset x1 <$> widenOffsets off_tp off1 off2 - _ | x1 == x2, LLVMPermOffset (exprType -> off_tp) <- off2 -> - PExpr_LLVMOffset x1 <$> widenOffsets off_tp off1 off2 - - -- If a variable has an eq(e) permission, replace it with e and recurse - (ValPerm_Eq e1', _, _, _) -> - visitM x1 >> widenExpr tp (offsetExpr off1 e1') e2 - (_, ValPerm_Eq e2', _, _) -> - visitM x2 >> widenExpr tp e1 (offsetExpr off2 e2') - - -- If both variables have been visited and are not equal and do not have - -- eq permissions, then they are equal to different locations elsewhere - -- in our widening, and so this location should not be equated to either - -- of them; thus we make a fresh variable - (_, _, True, True) -> - do x <- bindFreshVar tp - visitM x - ((p1',p2'), p') <- - doubleSplitWidenPerm tp (offsetPerm off1 p1) (offsetPerm off2 p2) - setOffVarPermM x1 off1 p1' - setOffVarPermM x2 off2 p2' - setVarPermM x p' - return $ PExpr_Var x - - -- If only one variable has been visited, its perms need to be split - -- between its other location(s) and here - (_, _, True, _) -> - do (p1', p2') <- - splitWidenPerm tp (offsetPerm off1 p1) (offsetPerm off2 p2) - setVarPermM x1 (offsetPerm (negatePermOffset off1) p1') - setVarPermM x2 (offsetPerm (negatePermOffset off2) p2') - return e2 - (_, _, _, True) -> - do (p2', p1') <- - splitWidenPerm tp (offsetPerm off2 p2) (offsetPerm off1 p2) - setVarPermM x1 (offsetPerm (negatePermOffset off1) p1') - setVarPermM x2 (offsetPerm (negatePermOffset off2) p2') - return e1 - - -- If we get here, then neither x1 nor x2 has been visited, so choose x1, - -- set x2 equal to x1 &+ (off1 - off2), and set x1's permissions to be - -- the result of widening p1 against p2 - _ -> - do visitM x1 >> visitM x2 - setVarPermM x2 (ValPerm_Eq $ - offsetExpr (addPermOffsets off1 $ - negatePermOffset off2) $ PExpr_Var x1) - p' <- widenPerm tp (offsetPerm off1 p1) (offsetPerm off2 p2) - setVarPermM x1 (offsetPerm (negatePermOffset off1) p') - return e1 - - --- If one side is a variable x and the other is not, then the non-variable side --- cannot have any permissions, and there are fewer cases than the above -widenExpr' tp (asVarOffset -> Just (x1, off1)) e2 = - do p1 <- getVarPermM x1 - case p1 of - - -- If x1 has an eq(e) permission, replace it with e and recurse - ValPerm_Eq e1' -> - visitM x1 >> widenExpr tp (offsetExpr off1 e1') e2 - - -- Otherwise bind a fresh variable, because even if x1 has not been - -- visited before, it could still occur somewhere we haven't visited yet - _ -> - do x <- bindFreshVar tp - visitM x - return $ PExpr_Var x - --- Similar to the previous case, but with the variable on the right -widenExpr' tp e1 (asVarOffset -> Just (x2, off2)) = - do p2 <- getVarPermM x2 - case p2 of - - -- If x2 has an eq(e) permission, replace it with e and recurse - ValPerm_Eq e2' -> - visitM x2 >> widenExpr tp e1 (offsetExpr off2 e2') - - -- Otherwise bind a fresh variable, because even if x1 has not been - -- visited before, it could still occur somewhere we haven't visited yet - _ -> - do x <- bindFreshVar tp - visitM x - return $ PExpr_Var x - --- Widen two structs by widening their contents -widenExpr' (StructRepr tps) (PExpr_Struct es1) (PExpr_Struct es2) = - PExpr_Struct <$> widenExprs (mkCruCtx tps) es1 es2 - --- Widen llvmwords by widening the words -widenExpr' (LLVMPointerRepr w) (PExpr_LLVMWord e1) (PExpr_LLVMWord e2) = - PExpr_LLVMWord <$> widenExpr (BVRepr w) e1 e2 - --- Widen named shapes with the same names --- --- FIXME: we currently only handle shapes with no modalities, because the --- modalities only come about when proving equality shapes, which themselves are --- only really used by memcpy and similar functions -widenExpr' _ (PExpr_NamedShape Nothing Nothing nmsh1 args1) - (PExpr_NamedShape Nothing Nothing nmsh2 args2) - | Just (Refl,Refl) <- namedShapeEq nmsh1 nmsh2 = - PExpr_NamedShape Nothing Nothing nmsh1 <$> - widenExprs (namedShapeArgs nmsh1) args1 args2 - -widenExpr' (LLVMShapeRepr w) (PExpr_EqShape len1 e1) (PExpr_EqShape len2 e2) - | bvEq len1 len2 - = PExpr_EqShape len1 <$> widenExpr (LLVMBlockRepr w) e1 e2 - -widenExpr' tp (PExpr_PtrShape Nothing Nothing sh1) - (PExpr_PtrShape Nothing Nothing sh2) = - PExpr_PtrShape Nothing Nothing <$> widenExpr tp sh1 sh2 - -widenExpr' _ (PExpr_FieldShape (LLVMFieldShape p1)) (PExpr_FieldShape - (LLVMFieldShape p2)) - | Just Refl <- testEquality (exprLLVMTypeWidth p1) (exprLLVMTypeWidth p2) = - PExpr_FieldShape <$> LLVMFieldShape <$> widenPerm knownRepr p1 p2 - --- Array shapes can 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 - --- An array shape of length 1 can be replaced by its sole cell -widenExpr' tp (PExpr_ArrayShape len1 _ sh1) sh2 - | bvEq len1 (bvInt 1) = widenExpr' tp sh1 sh2 -widenExpr' tp sh1 (PExpr_ArrayShape len2 _ sh2) - | bvEq len2 (bvInt 1) = widenExpr' tp 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...? -widenExpr' tp (PExpr_SeqShape sh1 sh1') (PExpr_SeqShape sh2 sh2') = - PExpr_SeqShape <$> widenExpr tp sh1 sh2 <*> widenExpr tp sh1' sh2' - -widenExpr' tp (PExpr_OrShape sh1 sh1') (PExpr_OrShape sh2 sh2') = - PExpr_OrShape <$> widenExpr tp sh1 sh2 <*> widenExpr tp sh1' sh2' - -widenExpr' tp (PExpr_ExShape mb_sh1) sh2 = - do x <- bindFreshVar knownRepr - widenExpr tp (varSubst (singletonVarSubst x) mb_sh1) sh2 - -widenExpr' tp sh1 (PExpr_ExShape mb_sh2) = - do x <- bindFreshVar knownRepr - widenExpr tp sh1 (varSubst (singletonVarSubst x) mb_sh2) - --- For two shapes that don't match any of the above cases, return the most --- general shape, which is the empty shape -widenExpr' (LLVMShapeRepr _) _ _ = return $ PExpr_EmptyShape - --- NOTE: this assumes that permission expressions only occur in covariant --- positions -widenExpr' (ValuePermRepr tp) (PExpr_ValPerm p1) (PExpr_ValPerm p2) = - PExpr_ValPerm <$> widenPerm tp p1 p2 - --- Default case: widen two unequal expressions by making a fresh output --- existential variable, which could be equal to either -widenExpr' tp _ _ = - do x <- bindFreshVar tp - visitM x - return $ PExpr_Var x - - --- | Widen a sequence of expressions -widenExprs :: CruCtx tps -> PermExprs tps -> PermExprs tps -> - WideningM (PermExprs tps) -widenExprs _ MNil MNil = return MNil -widenExprs (CruCtxCons tps tp) (es1 :>: e1) (es2 :>: e2) = - (:>:) <$> widenExprs tps es1 es2 <*> widenExpr tp e1 e2 - - --- | Widen two bitvector offsets by trying to widen them additively --- ('widenBVsAddy'), or if that is not possible, by widening them --- multiplicatively ('widenBVsMulty') -widenOffsets :: (1 <= w, KnownNat w) => TypeRepr (BVType w) -> - PermOffset (LLVMPointerType w) -> - PermOffset (LLVMPointerType w) -> - WideningM (PermExpr (BVType w)) -widenOffsets tp (llvmPermOffsetExpr -> off1) (llvmPermOffsetExpr -> off2) = - widenBVsAddy tp off1 off2 >>= maybe (widenBVsMulty tp off1 off2) return - --- | Widen two bitvectors @bv1@ and @bv2@ additively, i.e. bind a fresh --- variable @bv@ and return @(bv2 - bv1) * bv + bv1@, assuming @bv2 - bv1@ --- is a constant -widenBVsAddy :: (1 <= w, KnownNat w) => TypeRepr (BVType w) -> - PermExpr (BVType w) -> PermExpr (BVType w) -> - WideningM (Maybe (PermExpr (BVType w))) -widenBVsAddy tp bv1 bv2 = - case bvMatchConst (bvSub bv2 bv1) of - Just d -> do x <- bindFreshVar tp - visitM x - return $ Just (bvAdd (bvFactorExpr d x) bv1) - _ -> return Nothing - --- | Widen two bitvectors @bv1@ and @bv2@ multiplicatively, i.e. bind a fresh --- variable @bv@ and return @(bvGCD bv1 bv2) * bv@ -widenBVsMulty :: (1 <= w, KnownNat w) => TypeRepr (BVType w) -> - PermExpr (BVType w) -> PermExpr (BVType w) -> - WideningM (PermExpr (BVType w)) -widenBVsMulty tp bv1 bv2 = - do x <- bindFreshVar tp - visitM x - return $ bvFactorExpr (bvGCD bv1 bv2) x - - --- | Take two block permissions @bp1@ and @bp2@ with the same offset and use --- 'splitLLVMBlockPerm' to remove any parts of them that do not overlap, --- returning some @bp1'@ and @bp2'@ with the same range, along with additional --- portions of @bp1@ and @bp2@ that were removed -equalizeLLVMBlockRanges' :: (1 <= w, KnownNat w) => - WidNameMap -> LLVMBlockPerm w -> LLVMBlockPerm w -> - Maybe (LLVMBlockPerm w, LLVMBlockPerm w, - [LLVMBlockPerm w], [LLVMBlockPerm w]) -equalizeLLVMBlockRanges' _ bp1 bp2 - | not (bvEq (llvmBlockOffset bp1) (llvmBlockOffset bp2)) = - error "equalizeLLVMBlockRanges'" -equalizeLLVMBlockRanges' _ bp1 bp2 - | bvEq (llvmBlockLen bp1) (llvmBlockLen bp2) = - return (bp1, bp2, [], []) -equalizeLLVMBlockRanges' wnmap bp1 bp2 - | bvLt (llvmBlockLen bp1) (llvmBlockLen bp2) = - do let blsubst = wnMapBlockShape wnmap - (bp2', bp2'') <- splitLLVMBlockPerm blsubst (llvmBlockEndOffset bp1) bp2 - return (bp1, bp2', [], [bp2'']) -equalizeLLVMBlockRanges' wnmap bp1 bp2 - | bvLt (llvmBlockLen bp2) (llvmBlockLen bp1) = - do let blsubst = wnMapBlockShape wnmap - (bp1', bp1'') <- splitLLVMBlockPerm blsubst (llvmBlockEndOffset bp2) bp1 - return (bp1', bp2, [bp1''], []) -equalizeLLVMBlockRanges' _ _ _ = Nothing - --- | Take two block permissions @bp1@ and @bp2@ whose ranges overlap and use --- 'splitLLVMBlockPerm' to remove any parts of them that do not overlap, --- returning some @bp1'@ and @bp2'@ with the same range, along with additional --- portions of @bp1@ and @bp2@ that were removed -equalizeLLVMBlockRanges :: (1 <= w, KnownNat w) => - WidNameMap -> LLVMBlockPerm w -> LLVMBlockPerm w -> - Maybe (LLVMBlockPerm w, LLVMBlockPerm w, - [LLVMBlockPerm w], [LLVMBlockPerm w]) -equalizeLLVMBlockRanges wnmap bp1 bp2 - | bvEq (llvmBlockOffset bp1) (llvmBlockOffset bp2) = - equalizeLLVMBlockRanges' wnmap bp1 bp2 -equalizeLLVMBlockRanges wnmap bp1 bp2 - | bvLt (llvmBlockOffset bp1) (llvmBlockOffset bp2) = - do let blsubst = wnMapBlockShape wnmap - (bp1', bp1'') <- splitLLVMBlockPerm blsubst (llvmBlockOffset bp2) bp1 - (bp1_ret, bp2_ret, bps1, bps2) <- equalizeLLVMBlockRanges' wnmap bp1'' bp2 - return (bp1_ret, bp2_ret, bp1':bps1, bps2) -equalizeLLVMBlockRanges wnmap bp1 bp2 - | bvLt (llvmBlockOffset bp2) (llvmBlockOffset bp1) = - do let blsubst = wnMapBlockShape wnmap - (bp2', bp2'') <- splitLLVMBlockPerm blsubst (llvmBlockOffset bp1) bp2 - (bp1_ret, bp2_ret, bps1, bps2) <- equalizeLLVMBlockRanges' wnmap bp1 bp2'' - return (bp1_ret, bp2_ret, bps1, bp2':bps2) -equalizeLLVMBlockRanges _ _ _ = Nothing - - --- | Widen two block permissions against each other, assuming they already have --- the same range -widenBlockPerm :: (1 <= w, KnownNat w) => LLVMBlockPerm w -> LLVMBlockPerm w -> - WideningM (LLVMBlockPerm w) -widenBlockPerm bp1 bp2 = - LLVMBlockPerm <$> - widenExpr knownRepr (llvmBlockRW bp1) (llvmBlockRW bp2) <*> - widenExpr knownRepr (llvmBlockLifetime bp1) (llvmBlockLifetime bp2) <*> - return (llvmBlockOffset bp1) <*> return (llvmBlockLen bp1) <*> - widenExpr knownRepr (llvmBlockShape bp1) (llvmBlockShape bp2) - - --- | Widen a sequence of atomic permissions against each other -widenAtomicPerms :: TypeRepr a -> [AtomicPerm a] -> [AtomicPerm a] -> - WideningM [AtomicPerm a] -widenAtomicPerms tp ps1 ps2 = - do traceM (\i -> - fillSep [pretty "widenAtomicPerms", - permPretty i ps1, permPretty i ps2]) - wnmap <- view wsNameMap <$> get - widenAtomicPerms' wnmap tp ps1 ps2 - -widenAtomicPerms' :: WidNameMap -> TypeRepr a -> - [AtomicPerm a] -> [AtomicPerm a] -> - WideningM [AtomicPerm a] - --- If one side is empty, we return the empty list, i.e., true -widenAtomicPerms' _ _ [] _ = return [] -widenAtomicPerms' _ _ _ [] = return [] - --- If there is a permission on the right that equals p1, use p1, and recursively --- widen the remaining permissions -widenAtomicPerms' _ tp (p1 : ps1) ps2 - | Just i <- findIndex (== p1) ps2 = - (p1 :) <$> widenAtomicPerms tp ps1 (deleteNth i ps2) - --- If we have array permissions with the same offset, length, and stride on both --- sides, check that their fields are the same and equalize their borrows --- --- FIXME: handle arrays with different lengths, and widen their fields -widenAtomicPerms' wnmap tp (Perm_LLVMArray ap1 : ps1) ps2 = - case findIndex - (\case - Perm_LLVMArray ap2 -> - substEqVars wnmap (llvmArrayOffset ap1) - == substEqVars wnmap (llvmArrayOffset ap2) && - substEqVars wnmap (llvmArrayLen ap1) - == substEqVars wnmap (llvmArrayLen ap2) && - llvmArrayStride ap1 == llvmArrayStride 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 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 - widenAtomicPerms tp ps1 ps2 - --- If the first permission on the left is an LLVM permission overlaps with some --- permission on the right, widen these against each other -widenAtomicPerms' wnmap tp@(LLVMPointerRepr w) (p1 : ps1) ps2 - | Just bp1 <- llvmAtomicPermToBlock p1 - , rng1 <- llvmBlockRange bp1 - , Just i <- - withKnownNat w (findIndex ((== Just True) . fmap (bvRangesOverlap rng1) - . llvmAtomicPermRange) ps2) - , Just bp2 <- llvmAtomicPermToBlock (ps2!!i) - , Just (bp1', bp2', bps1_rem, bps2_rem) <- - withKnownNat w (equalizeLLVMBlockRanges wnmap bp1 bp2) - = withKnownNat w ( - (:) <$> (Perm_LLVMBlock <$> widenBlockPerm bp1' bp2') <*> - widenAtomicPerms tp (map Perm_LLVMBlock bps1_rem ++ ps1) - (map Perm_LLVMBlock bps2_rem ++ deleteNth i ps2)) - --- If the LHS is a frame permission such that there is a frame permission on the --- RHS with the same list of lengths, widen the expressions -widenAtomicPerms' _ tp@(LLVMFrameRepr w) (Perm_LLVMFrame frmps1 : ps1) ps2 - | Just i <- findIndex (\case - Perm_LLVMFrame _ -> True - _ -> False) ps2 - , Perm_LLVMFrame frmps2 <- ps2 !! i - , map snd frmps1 == map snd frmps2 = - do es <- zipWithM (widenExpr - (LLVMPointerRepr w)) (map fst frmps1) (map fst frmps2) - (Perm_LLVMFrame (zip es (map snd frmps1)) :) <$> - widenAtomicPerms tp ps1 (deleteNth i ps2) - --- If either side has unfoldable named permissions, unfold them and recurse -widenAtomicPerms' _ tp ps1 ps2 - | any isFoldableConjPerm (ps1 ++ ps2) - = do ps1' <- concatMapM widUnfoldConjPerm ps1 - ps2' <- concatMapM widUnfoldConjPerm ps2 - widenAtomicPerms tp ps1' ps2' - --- Default: cannot widen p1 against any p2 on the right, so drop it and recurse -widenAtomicPerms' _ tp (_ : ps1) ps2 = widenAtomicPerms tp ps1 ps2 - - --- | Widen permissions against each other -widenPerm :: TypeRepr a -> ValuePerm a -> ValuePerm a -> WideningM (ValuePerm a) -widenPerm tp p1 p2 = - traceM (\i -> - fillSep [pretty "widenPerm", permPretty i p1, permPretty i p2]) >> - widenPerm' tp p1 p2 - -widenPerm' :: TypeRepr a -> ValuePerm a -> ValuePerm a -> - WideningM (ValuePerm a) - -widenPerm' tp (ValPerm_Eq e1) (ValPerm_Eq e2) = - ValPerm_Eq <$> widenExpr tp e1 e2 - -widenPerm' tp (ValPerm_Eq (asVarOffset -> Just (x1, off1))) p2 = - do p1 <- getVarPermM x1 - isv1 <- isVisitedM x1 - case (p1, isv1) of - (ValPerm_Eq e1, _) -> - visitM x1 >> widenPerm tp (ValPerm_Eq $ offsetExpr off1 e1) p2 - (_, False) -> - do visitM x1 - p1' <- widenPerm tp (offsetPerm off1 p1) p2 - setVarPermM x1 (offsetPerm (negatePermOffset off1) p1') - return (ValPerm_Eq $ offsetExpr off1 $ PExpr_Var x1) - (_, True) -> - do x <- bindFreshVar tp - visitM x - (p1', p1'') <- splitWidenPerm tp (offsetPerm off1 p1) p2 - setVarPermM x1 p1' - setVarPermM x p1'' - return (ValPerm_Eq $ PExpr_Var x) - -widenPerm' tp p1 (ValPerm_Eq (asVarOffset -> Just (x2, off2))) = - do p2 <- getVarPermM x2 - isv2 <- isVisitedM x2 - case (p2, isv2) of - (ValPerm_Eq e2, _) -> - visitM x2 >> widenPerm tp p1 (ValPerm_Eq $ offsetExpr off2 e2) - (_, False) -> - do visitM x2 - p2' <- widenPerm tp p1 (offsetPerm off2 p2) - setVarPermM x2 (offsetPerm (negatePermOffset off2) p2') - return (ValPerm_Eq $ offsetExpr off2 $ PExpr_Var x2) - (_, True) -> - do x <- bindFreshVar tp - visitM x - (p2', p2'') <- splitWidenPerm tp (offsetPerm off2 p2) p1 - setVarPermM x2 p2' - setVarPermM x p2'' - return (ValPerm_Eq $ PExpr_Var x) - -widenPerm' tp (ValPerm_Or p1 p1') (ValPerm_Or p2 p2') = - ValPerm_Or <$> widenPerm tp p1 p2 <*> widenPerm tp p1' p2' -widenPerm' tp (ValPerm_Exists mb_p1) p2 = - do x <- bindFreshVar knownRepr - widenPerm tp (varSubst (singletonVarSubst x) mb_p1) p2 -widenPerm' tp p1 (ValPerm_Exists mb_p2) = - do x <- bindFreshVar knownRepr - widenPerm tp p1 (varSubst (singletonVarSubst x) mb_p2) -widenPerm' _ (ValPerm_Named npn1 args1 off1) (ValPerm_Named npn2 args2 off2) - | Just (Refl, Refl, Refl) <- testNamedPermNameEq npn1 npn2 - , offsetsEq off1 off2 = - (\args -> ValPerm_Named npn1 args off1) <$> - widenExprs (namedPermNameArgs npn1) args1 args2 -widenPerm' tp (ValPerm_Named npn1 args1 off1) p2 - | DefinedSortRepr _ <- namedPermNameSort npn1 = - do env <- use wsPermEnv - let np1 = requireNamedPerm env npn1 - widenPerm tp (unfoldPerm np1 args1 off1) p2 -widenPerm' tp p1 (ValPerm_Named npn2 args2 off2) - | DefinedSortRepr _ <- namedPermNameSort npn2 = - do env <- use wsPermEnv - let np2 = requireNamedPerm env npn2 - widenPerm tp p1 (unfoldPerm np2 args2 off2) -widenPerm' tp (ValPerm_Named npn1 args1 off1) p2 - | RecursiveSortRepr _ _ <- namedPermNameSort npn1 = - use wsRecFlag >>= \case - RecRight -> - -- If we have already unfolded on the right, don't unfold on the left - -- (for termination reasons); instead just give up and return true - return ValPerm_True - _ -> - do wsRecFlag .= RecLeft - env <- use wsPermEnv - let np1 = requireNamedPerm env npn1 - widenPerm tp (unfoldPerm np1 args1 off1) p2 -widenPerm' tp p1 (ValPerm_Named npn2 args2 off2) - | RecursiveSortRepr _ _ <- namedPermNameSort npn2 = - use wsRecFlag >>= \case - RecLeft -> - -- If we have already unfolded on the left, don't unfold on the right - -- (for termination reasons); instead just give up and return true - return ValPerm_True - _ -> - do wsRecFlag .= RecRight - env <- use wsPermEnv - let np2 = requireNamedPerm env npn2 - widenPerm tp p1 (unfoldPerm np2 args2 off2) -widenPerm' _ (ValPerm_Var x1 off1) (ValPerm_Var x2 off2) - | x1 == x2 && offsetsEq off1 off2 = return $ ValPerm_Var x1 off1 -widenPerm' tp (ValPerm_Conj ps1) (ValPerm_Conj ps2) = - ValPerm_Conj <$> widenAtomicPerms tp ps1 ps2 -widenPerm' _ _ _ = return ValPerm_True - - --- | Widen a sequence of permissions -widenPerms :: CruCtx tps -> ValuePerms tps -> ValuePerms tps -> - WideningM (ValuePerms tps) -widenPerms _ MNil MNil = return MNil -widenPerms (CruCtxCons tps tp) (ps1 :>: p1) (ps2 :>: p2) = - (:>:) <$> widenPerms tps ps1 ps2 <*> widenPerm tp p1 p2 - - ----------------------------------------------------------------------- --- * Extension-Specific Widening ----------------------------------------------------------------------- - -data SomeLLVMFrameMember ctx = - forall w. SomeLLVMFrameMember (TypeRepr (LLVMFrameType w)) (Member ctx - (LLVMFrameType w)) --- | Find some LLVM frame variable type in a 'CruCtx' -findLLVMFrameType :: CruCtx ctx -> Maybe (SomeLLVMFrameMember ctx) -findLLVMFrameType CruCtxNil = Nothing -findLLVMFrameType (CruCtxCons _ tp@(LLVMFrameRepr _)) = - Just (SomeLLVMFrameMember tp Member_Base) -findLLVMFrameType (CruCtxCons tps _) = - fmap (\(SomeLLVMFrameMember tp memb) -> - SomeLLVMFrameMember tp (Member_Step memb)) $ - findLLVMFrameType tps - --- | Infer which ghost variables on the LHS and RHS correspond to --- extension-specific state, and widen them against each other --- --- FIXME: instead of this guessing which variables correspond to --- extension-specific state, that state should really be part of what is --- widened, and, correspondingly, should thus be part of @CallSiteImplRet@. That --- is, @CallSiteImplRet@ should contain a @PermCheckExtState@, which should be --- passed to 'widen' along with the permissions. This change would additionally --- eliminate @setInputExtState@, which also has to guess which variables --- correspond to extension-specific state. It would also require @ExtRepr@ and --- @PermCheckExtState@ to be factored out into their own module. -widenExtGhostVars :: CruCtx tp1 -> RAssign Name tp1 -> - CruCtx tp2 -> RAssign Name tp2 -> WideningM () -widenExtGhostVars tps1 vars1 tps2 vars2 - | Just (SomeLLVMFrameMember tp1 memb1) <- findLLVMFrameType tps1 - , Just (SomeLLVMFrameMember tp2 memb2) <- findLLVMFrameType tps2 - , Just Refl <- testEquality tp1 tp2 = - void $ widenExpr tp1 (PExpr_Var $ RL.get memb1 vars1) (PExpr_Var $ - RL.get memb2 vars2) -widenExtGhostVars _ _ _ _ = return () - - ----------------------------------------------------------------------- --- * The Result Type for Widening ----------------------------------------------------------------------- - --- | A sequence of permissions on some regular and ghost arguments -data ArgVarPerms args vars = - ArgVarPerms { wideningVars :: CruCtx vars, - wideningPerms :: MbValuePerms (args :++: vars) } - -$(mkNuMatching [t| forall args vars. ArgVarPerms args vars |]) - -completeMbArgVarPerms :: CruCtx vars -> - Mb (args :++: vars) (ExtVarPerms (args :++: vars)) -> - Some (ArgVarPerms args) -completeMbArgVarPerms vars (mbMatch -> [nuMP| ExtVarPerms_Base ps |]) = - Some $ ArgVarPerms vars ps -completeMbArgVarPerms vars (mbMatch -> - [nuMP| ExtVarPerms_Mb var mb_ext_wid |]) = - completeMbArgVarPerms - (CruCtxCons vars (mbLift var)) - (mbCombine RL.typeCtxProxies mb_ext_wid) - -completeArgVarPerms :: Mb args (ExtVarPerms args) -> Some (ArgVarPerms args) -completeArgVarPerms = completeMbArgVarPerms CruCtxNil - -{- -completeWideningM :: CruCtx args -> MbValuePerms args -> Mb args (WideningM ()) -> - Some (Widening args) -completeWideningM args mb_arg_perms mb_m = - widMapWidening args $ - flip nuMultiWithElim (MNil :>: mb_m :>: mb_arg_perms) $ - \ns (_ :>: Identity m :>: Identity arg_perms) -> - unWideningM m $ wnMapFromPerms ns arg_perms --} - -{- -rlMap2ToList :: (forall a. f a -> g a -> c) -> RAssign f ctx -> - RAssign g ctx -> [c] -rlMap2ToList _ MNil MNil = [] -rlMap2ToList f (xs :>: x) (ys :>: y) = rlMap2ToList f xs ys ++ [f x y] - --- | Extend the context of a name-binding on the left with multiple types -extMbMultiL :: RAssign f ctx1 -> Mb ctx2 a -> Mb (ctx1 :++: ctx2) a -extMbMultiL ns mb = mbCombine $ nuMulti ns $ const mb - --} - -data FoundPerm ctx ps where - FoundPerm :: RAssign Proxy ps1 -> RAssign Proxy ps2 -> - Mb ctx (ValuePerm a) -> FoundPerm ctx (ps1 :> a :++: ps2) - -extFoundPerm :: FoundPerm ctx ps -> FoundPerm ctx (ps :> a) -extFoundPerm (FoundPerm prxs1 prxs2 mb_p) = - FoundPerm prxs1 (prxs2 :>: Proxy) mb_p - -findPerms :: (forall a. Mb ctx (ValuePerm a) -> Bool) -> - Mb ctx (ValuePerms ps) -> [FoundPerm ctx ps] -findPerms perm_pred mb_ps_top = case mbMatch mb_ps_top of - [nuMP| MNil |] -> [] - [nuMP| mb_ps :>: mb_p |] -> - (if perm_pred mb_p - then (FoundPerm (mbRAssignProxies mb_ps) MNil mb_p :) else id) $ - map extFoundPerm (findPerms perm_pred mb_ps) - -findGhostPerm :: (forall a. Mb (args :++: vars) (ValuePerm a) -> Bool) -> - ArgVarPerms args vars -> [FoundPerm (args :++: vars) vars] -findGhostPerm perm_pred (avps :: ArgVarPerms args vars) = - findPerms perm_pred $ - fmap (snd . RL.split (Proxy :: Proxy args) (cruCtxProxies $ - wideningVars avps)) $ - wideningPerms avps - -findGhostSimplPerm :: ArgVarPerms args vars -> [FoundPerm (args :++: vars) vars] -findGhostSimplPerm = - findGhostPerm (\case - [nuP| ValPerm_Eq _ |] -> True - [nuP| ValPerm_True |] -> True - _ -> False) - --- | Swap a name in the middle of a binding list to the inner-most position, as --- its own binding --- --- NOTE: this is specifically implemented in a way to avoid using 'fmap' so that --- name-bindings in pair representation maintain that pair representation -mbSwapMidToEnd :: RAssign Proxy ctx1 -> RAssign Proxy ctx2 -> Proxy a -> - Mb (ctx1 :> a :++: ctx2) b -> - Mb (ctx1 :++: ctx2) (Binding a b) -mbSwapMidToEnd ctx1 ctx2 a mb_b = - mbCombine ctx2 $ mbSwap ctx1 $ mbSeparate ctx1 $ - mbSeparate (MNil :>: a) $ - mbCombine (ctx1 :>: a) $ mbSwap ctx2 $ mbSeparate ctx2 mb_b - -cruCtxRemMid :: RAssign Proxy ctx1 -> RAssign Proxy ctx2 -> prx a -> - CruCtx (ctx1 :> a :++: ctx2) -> CruCtx (ctx1 :++: ctx2) -cruCtxRemMid _ MNil _ (CruCtxCons tps _) = tps -cruCtxRemMid ctx1 (ctx2 :>: _) a (CruCtxCons tps tp) = - CruCtxCons (cruCtxRemMid ctx1 ctx2 a tps) tp - -rlRemMid :: RAssign Proxy ctx1 -> RAssign Proxy ctx2 -> prx a -> - RAssign f (ctx1 :> a :++: ctx2) -> RAssign f (ctx1 :++: ctx2) -rlRemMid _ MNil _ (fs :>: _) = fs -rlRemMid ctx1 (ctx2 :>: _) a (fs :>: f) = - rlRemMid ctx1 ctx2 a fs :>: f - -subst1Mid :: Substable PermSubst b Identity => - RAssign Proxy ctx1 -> RAssign Proxy ctx2 -> - Mb (ctx1 :++: ctx2) (PermExpr a) -> - Mb (ctx1 :> a :++: ctx2) b -> Mb (ctx1 :++: ctx2) b -subst1Mid ctx1 ctx2 mb_e mb_b = - mbMap2 subst1 mb_e $ mbSwapMidToEnd ctx1 ctx2 Proxy mb_b - -tryLift1Mid :: NuMatching b => Substable PartialSubst b Maybe => - RAssign Proxy ctx1 -> RAssign Proxy ctx2 -> - Proxy (a :: CrucibleType) -> - Mb (ctx1 :> a :++: ctx2) b -> - Maybe (Mb (ctx1 :++: ctx2) b) -tryLift1Mid ctx1 ctx2 a mb_e = - mbMaybe $ fmap (partialSubst $ emptyPSubst' (MNil :>: a)) $ - mbSwapMidToEnd ctx1 ctx2 a mb_e - -emptyPSubst' :: RAssign any ctx -> PartialSubst ctx -emptyPSubst' = PartialSubst . RL.map (PSubstElem . const Nothing) - -mbExprProxy :: Mb ctx (f a) -> Proxy a -mbExprProxy _ = Proxy - -simplify1GhostPerm :: RAssign Proxy args -> - FoundPerm (args :++: vars) vars -> - ArgVarPerms args vars -> - Maybe (Some (ArgVarPerms args)) -simplify1GhostPerm args (FoundPerm vars1 vars2 - [nuP| ValPerm_Eq mb_e |]) (ArgVarPerms - vars mb_perms) - | a <- mbExprProxy mb_e - , Refl <- RL.appendAssoc args vars1 vars2 - , Refl <- RL.appendAssoc args (vars1 :>: a) vars2 - , args_vars1 <- RL.append args vars1 - , Just mb_e' <- tryLift1Mid args_vars1 vars2 a mb_e = - Just (Some $ ArgVarPerms (cruCtxRemMid vars1 vars2 a vars) - (subst1Mid args_vars1 vars2 mb_e' $ - fmap (rlRemMid args_vars1 vars2 a) mb_perms)) -simplify1GhostPerm args (FoundPerm vars1 vars2 - p@[nuP| ValPerm_True |]) (ArgVarPerms - vars mb_perms) - | a <- mbExprProxy p - , Refl <- RL.appendAssoc args vars1 vars2 - , Refl <- RL.appendAssoc args (vars1 :>: a) vars2 - , args_vars1 <- RL.append args vars1 - , Just mb_perms' <- (tryLift1Mid args_vars1 vars2 a $ - fmap (rlRemMid args_vars1 vars2 a) mb_perms) = - Just $ Some $ ArgVarPerms (cruCtxRemMid vars1 vars2 a vars) mb_perms' -simplify1GhostPerm _ _ _ = Nothing - - -simplifyGhostPerms :: RAssign Proxy args -> Some (ArgVarPerms args) -> - Some (ArgVarPerms args) -simplifyGhostPerms args (Some avps) - | some_avps':_ <- - mapMaybe (flip (simplify1GhostPerm args) avps) (findGhostSimplPerm avps) - = simplifyGhostPerms args some_avps' -simplifyGhostPerms _ some_avps = some_avps - - ----------------------------------------------------------------------- --- * Top-Level Entrypoint ----------------------------------------------------------------------- - --- | Widen two lists of permissions-in-bindings -widen :: DebugLevel -> PermEnv -> CruCtx tops -> CruCtx args -> - Some (ArgVarPerms (tops :++: args)) -> - Some (ArgVarPerms (tops :++: args)) -> - Some (ArgVarPerms (tops :++: args)) -widen dlevel env tops args (Some (ArgVarPerms - vars1 mb_perms1)) (Some (ArgVarPerms - vars2 mb_perms2)) = - let all_args = appendCruCtx tops args - prxs1 = cruCtxProxies vars1 - prxs2 = cruCtxProxies vars2 - mb_mb_perms1 = mbSeparate prxs1 mb_perms1 in - simplifyGhostPerms (cruCtxProxies all_args) $ - completeArgVarPerms $ flip nuMultiWithElim1 mb_mb_perms1 $ - \args_ns1 mb_perms1' -> - (\m -> runWideningM m dlevel env args_ns1) $ - do (vars1_ns, ps1) <- openMb vars1 mb_perms1' - (ns2, ps2) <- openMb (appendCruCtx all_args vars2) mb_perms2 - let (args_ns2, vars2_ns) = RL.split all_args prxs2 ns2 - setVarPermsM (RL.append args_ns1 vars1_ns) ps1 - setVarPermsM ns2 ps2 - let (tops1, locals1) = RL.split tops (cruCtxProxies args) args_ns1 - let (tops2, locals2) = RL.split tops (cruCtxProxies args) args_ns2 - setVarNamesM "topL" tops1 - setVarNamesM "topR" tops2 - setVarNamesM "localL" locals1 - setVarNamesM "localR" locals2 - setVarNamesM "varL" vars1_ns - setVarNamesM "varR" vars2_ns - let dist_ps1 = RL.map2 VarAndPerm (RL.append args_ns1 vars1_ns) ps1 - let dist_ps2 = RL.map2 VarAndPerm ns2 ps2 - traceM (\i -> - pretty "Widening" <> line <> - indent 2 (permPretty i dist_ps1) <> line <> - pretty "Against" <> line <> - indent 2 (permPretty i dist_ps2)) - 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 <> - indent 2 (fillSep $ - map (\(NameAndElem x (Pair p _)) -> - permPretty i x <> colon <> permPretty i p) $ - NameMap.assocs wnmap)) - return () diff --git a/hie.yaml b/hie.yaml index be49f83df8..d3471e080f 100644 --- a/hie.yaml +++ b/hie.yaml @@ -18,8 +18,6 @@ cradle: component: "saw:lib:saw-core-sbv" - path: "./saw-core-what4/src" component: "saw:lib:saw-core-what4" - - path: "./heapster/src" - component: "saw:lib:heapster" - path: "./saw-central/src" component: "saw:lib:saw-central" - path: "./saw-script/src" @@ -44,8 +42,6 @@ cradle: component: "saw:test:cryptol-saw-core-tests" - path: "./otherTests/saw-core-coq" component: "saw:test:saw-core-coq-tests" - - path: "./heapster/proverTests" - component: "saw:test:heapster-prover-tests" - path: "crucible-mir-comp/src" component: "crucible-mir-comp:lib:crucible-mir-comp" - path: "crux-mir-comp/src" diff --git a/intTests/test2009/test.saw b/intTests/test2009/test.saw index f4c5adc448..5c8ac07289 100644 --- a/intTests/test2009/test.saw +++ b/intTests/test2009/test.saw @@ -1,4 +1,4 @@ -let pairEq = parse_core "pairEq (Vec 32 Bool) (Vec 32 Bool) (bvEq 32) (bvEq 32)"; +let pairEq = parse_core "pairEq (Vec 32 Bool) (TypeCons (Vec 32 Bool) TypeNil) (bvEq 32) (pairEq (Vec 32 Bool) TypeNil (bvEq 32) unitEq)"; t <- prove_print w4 {{ \x -> pairEq (x, x + 1) (x, 1 + x) }}; print_term (rewrite (addsimp t empty_ss) {{ (0 : [32], 0 + 1 : [32]) }}); diff --git a/intTests/test2049/test.log.1.good b/intTests/test2049/test.log.1.good index 55279c374a..102feaea21 100644 --- a/intTests/test2049/test.log.1.good +++ b/intTests/test2049/test.log.1.good @@ -13,12 +13,12 @@ Literal equality postcondition Expected term: let { x@1 = Prelude.Vec 8 Prelude.Bool } - in fresh:zero::table#1583 + in fresh:zero::table#1580 Actual term: let { x@1 = Prelude.Vec 8 Prelude.Bool } - in Cryptol.ecArrayUpdate x@1 x@1 fresh:zero::table#1583 - fresh:zero::k#1584 + in Cryptol.ecArrayUpdate x@1 x@1 fresh:zero::table#1580 + fresh:zero::k#1581 (Prelude.bvNat 8 0) SolverStats {solverStatsSolvers = fromList ["W4 ->z3"], solverStatsGoalSize = N} diff --git a/intTests/test2049/test.log.2.good b/intTests/test2049/test.log.2.good index 242eeb5f8d..98ff2e17e8 100644 --- a/intTests/test2049/test.log.2.good +++ b/intTests/test2049/test.log.2.good @@ -13,12 +13,12 @@ Literal equality postcondition Expected term: let { x@1 = Prelude.Vec 8 Prelude.Bool } - in fresh:zero::table#1583 + in fresh:zero::table#1580 Actual term: let { x@1 = Prelude.Vec 8 Prelude.Bool } - in Cryptol.ecArrayUpdate x@1 x@1 fresh:zero::table#1583 - fresh:zero::k#1584 + in Cryptol.ecArrayUpdate x@1 x@1 fresh:zero::table#1580 + fresh:zero::k#1581 (Prelude.bvNat 8 0) SolverStats {solverStatsSolvers = fromList ["W4 ->z3"], solverStatsGoalSize = N} diff --git a/intTests/test_llvm_errors/err001.log.good b/intTests/test_llvm_errors/err001.log.good index 29bdd38dc1..ed7fe3bb12 100644 --- a/intTests/test_llvm_errors/err001.log.good +++ b/intTests/test_llvm_errors/err001.log.good @@ -8,11 +8,11 @@ Expected term: let { x@1 = Prelude.Vec 32 Prelude.Bool x@2 = Cryptol.TCNum 32 } - in Cryptol.ecMul x@1 (Cryptol.PRingSeqBool x@2) fresh:x#1580 + in Cryptol.ecMul x@1 (Cryptol.PRingSeqBool x@2) fresh:x#1577 (Cryptol.ecNumber (Cryptol.TCNum 3) x@1 (Cryptol.PLiteralSeqBool x@2)) Actual term: -Prelude.bvMul 32 (Prelude.bvNat 32 2) fresh:x#1580 +Prelude.bvMul 32 (Prelude.bvNat 32 2) fresh:x#1577 SolverStats {solverStatsSolvers = fromList ["SBV->Z3"], solverStatsGoalSize = N} ----------Counterexample---------- diff --git a/intTests/test_sawcore_prelude/testDrop.sawcore b/intTests/test_sawcore_prelude/testDrop.sawcore index e723257435..f4a9818d61 100644 --- a/intTests/test_sawcore_prelude/testDrop.sawcore +++ b/intTests/test_sawcore_prelude/testDrop.sawcore @@ -2,10 +2,10 @@ module testDrop where import Prelude; my3Types : ListSort; -my3Types = LS_Cons Bool (LS_Cons UnitType (LS_Cons Bool LS_Nil)); +my3Types = LS_Cons Bool (LS_Cons #() (LS_Cons Bool LS_Nil)); my4Types : ListSort; -my4Types = LS_Cons UnitType my3Types; +my4Types = LS_Cons #() my3Types; test1a : ListSort = listSortDrop my4Types 0; test1b : ListSort = listSortDrop my4Types 1; diff --git a/intTests/test_search/search00.log.good b/intTests/test_search/search00.log.good index 031ee4ba9b..f0013799fc 100644 --- a/intTests/test_search/search00.log.good +++ b/intTests/test_search/search00.log.good @@ -49,12 +49,12 @@ llvm_verify : LLVMModule -> String -> [LLVMSpec] -> Bool -> LLVMSetup () -> Proo -- Int String get_opt : Int -> String write_saig' : String -> Term -> Int -> TopLevel () -12 more matches tagged experimental; use enable_experimental to see them +6 more matches tagged experimental; use enable_experimental to see them -------------------------------- -- String Int get_opt : Int -> String write_saig' : String -> Term -> Int -> TopLevel () -12 more matches tagged experimental; use enable_experimental to see them +6 more matches tagged experimental; use enable_experimental to see them -------------------------------- -- (TopLevel Int) No matches. diff --git a/intTests/test_search/search02.log.good b/intTests/test_search/search02.log.good index 73e5d0a884..5eece7e10d 100644 --- a/intTests/test_search/search02.log.good +++ b/intTests/test_search/search02.log.good @@ -23,7 +23,7 @@ term_eval : Term -> Term term_eval_unint : [String] -> Term -> Term time : {a} TopLevel a -> TopLevel a unfold_term : [String] -> Term -> Term -22 more matches tagged experimental; use enable_experimental to see them +19 more matches tagged experimental; use enable_experimental to see them 2 more matches tagged deprecated; use enable_deprecated to see them -------------------------------- -- {a} (a -> String) diff --git a/otherTests/saw-core/Tests/Functor.hs b/otherTests/saw-core/Tests/Functor.hs index 291c9a58ee..1762fd1cd6 100644 --- a/otherTests/saw-core/Tests/Functor.hs +++ b/otherTests/saw-core/Tests/Functor.hs @@ -12,6 +12,7 @@ module Tests.Functor (functorTests) where import Control.Monad (when) import Data.Hashable +import qualified Data.Vector as V import Test.Tasty import Test.Tasty.HUnit @@ -173,12 +174,12 @@ instance TestIt Term where -- build and test more stuff when (depth < 2) $ do let depth' = depth + 1 - unit = Unshared $ FTermF $ UnitValue + unit = Unshared $ FTermF $ TupleValue V.empty zero = Unshared $ FTermF $ NatLit 0 localvar = Unshared $ LocalVar 0 - testOne depth' $ PairValue t t - testOne depth' $ PairValue t zero - testOne depth' $ PairValue unit t + testOne depth' $ TupleValue $ V.fromList [t, t] + testOne depth' $ TupleValue $ V.fromList [t, zero] + testOne depth' $ TupleValue $ V.fromList [unit, t] testOne depth' $ App t t testOne depth' $ App t zero testOne depth' $ App unit t @@ -209,7 +210,7 @@ instance TestIt Term where tests :: Result tests = do let unit, zero, one :: FlatTermF Term - unit = UnitValue + unit = TupleValue V.empty zero = NatLit 0 one = NatLit 1 testOne 0 unit diff --git a/saw-central/src/SAWCentral/Bisimulation.hs b/saw-central/src/SAWCentral/Bisimulation.hs index cf789c7094..af0df98ac7 100644 --- a/saw-central/src/SAWCentral/Bisimulation.hs +++ b/saw-central/src/SAWCentral/Bisimulation.hs @@ -244,7 +244,7 @@ stateFromApp :: TermF Term -> TopLevel Term stateFromApp app = do sc <- getSharedContext case app of - App _ arg -> io $ scFlatTermF sc $ PairLeft arg + App _ arg -> io $ scTupleSelector sc arg 0 _ -> do term <- io $ scTermF sc app fail $ "Error: " ++ showTerm term ++ " is not an App" diff --git a/saw-central/src/SAWCentral/Builtins.hs b/saw-central/src/SAWCentral/Builtins.hs index 1fbf891095..7936b983e1 100644 --- a/saw-central/src/SAWCentral/Builtins.hs +++ b/saw-central/src/SAWCentral/Builtins.hs @@ -27,7 +27,6 @@ import Control.Monad.Except (MonadError(..)) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Reader (asks) import Control.Monad.State (MonadState(..), gets, modify) -import Control.Monad.Trans.Class (MonadTrans(..)) import qualified Control.Exception as Ex import qualified Data.ByteString as StrictBS import qualified Data.ByteString.Lazy as BS @@ -42,6 +41,7 @@ import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Lazy as LText +import qualified Data.Text.Lazy.IO as TLIO import Data.Time.Clock import Data.Typeable @@ -60,26 +60,26 @@ import qualified Cryptol.Utils.PP as CryptolPP import qualified Cryptol.TypeCheck.AST as Cryptol import qualified CryptolSAWCore.Cryptol as Cryptol import qualified CryptolSAWCore.Simpset as Cryptol -import qualified CryptolSAWCore.Monadify as Monadify -- saw-support -import qualified SAWSupport.Pretty as PPS (Doc, MemoStyle(..), Opts(..), defaultOpts, render, pShow) +import qualified SAWSupport.Pretty as PPS (MemoStyle(..), Opts(..), pShow) -- saw-core -import SAWCore.Parser.Grammar (parseSAWTerm) +import qualified SAWCore.Parser.AST as Un +import SAWCore.Parser.Grammar (parseSAW, parseSAWTerm) import SAWCore.ExternalFormat import SAWCore.FiniteValue ( FiniteType(..), readFiniteValue , FirstOrderValue(..) , scFirstOrderValue ) -import SAWCore.Module (ModuleMap) import SAWCore.Name (ecShortName) import SAWCore.SATQuery import SAWCore.SCTypeCheck import SAWCore.Recognizer import SAWCore.Prelude (scEq) import SAWCore.SharedTerm +import SAWCore.Typechecker (tcInsertModule) import SAWCore.Term.Functor import SAWCore.Term.Pretty (ppTerm, scPrettyTerm) import CryptolSAWCore.TypedTerm @@ -149,7 +149,6 @@ import qualified SAWCentral.Prover.RME as Prover import qualified SAWCentral.Prover.ABC as Prover import qualified SAWCentral.Prover.What4 as Prover import qualified SAWCentral.Prover.Exporter as Prover -import qualified SAWCentral.Prover.MRSolver as Prover import SAWCentral.VerificationSummary showPrim :: SV.Value -> TopLevel Text @@ -1363,10 +1362,10 @@ proveByBVInduction script t = io $ sequence $ [ scFreshGlobal sc ("i_" <> ecShortName ec) (ecType ec) | ec <- pis ] t1 <- io $ scApplyAllBeta sc (ttTerm t) vars - tsz <- io $ scTupleSelector sc t1 1 2 -- left element - tbody <- io $ scEqTrue sc =<< scTupleSelector sc t1 2 2 -- rightmost tuple element + tsz <- io $ scTupleSelector sc t1 0 -- left element + tbody <- io $ scEqTrue sc =<< scTupleSelector sc t1 1 -- rightmost tuple element inner_t1 <- io $ scApplyAllBeta sc (ttTerm t) innerVars - innersz <- io $ scTupleSelector sc inner_t1 1 2 -- left element + innersz <- io $ scTupleSelector sc inner_t1 0 -- left element -- The result type of the theorem. -- @@ -2221,226 +2220,6 @@ importSchemaCEnv sc cenv schema = do cry_env <- let ?fileReader = StrictBS.readFile in CEnv.mkCryEnv cenv Cryptol.importSchema sc cry_env schema -monadifyTypedTerm :: SharedContext -> TypedTerm -> TopLevel TypedTerm -monadifyTypedTerm sc t = - do rw <- get - let menv = rwMonadify rw - (ret_t, menv') <- - liftIO $ - case ttType t of - TypedTermSchema schema -> - do tp <- importSchemaCEnv sc (rwCryptol rw) schema - Monadify.monadifyTermInEnv sc menv (ttTerm t) tp - TypedTermKind _ -> - fail "monadify_term applied to a type" - TypedTermOther tp -> - Monadify.monadifyTermInEnv sc menv (ttTerm t) tp - modify (\s -> s { rwMonadify = menv' }) - tp <- liftIO $ scTypeOf sc ret_t - return $ TypedTerm (TypedTermOther tp) ret_t - --- | Ensure that a 'TypedTerm' has been monadified -ensureMonadicTerm :: SharedContext -> TypedTerm -> TopLevel TypedTerm -ensureMonadicTerm sc t - | TypedTermOther tp <- ttType t = - io (Prover.isSpecFunType sc tp) >>= \case - True -> return t - False -> monadifyTypedTerm sc t -ensureMonadicTerm sc t = monadifyTypedTerm sc t - --- | Normalizes the given 'TypedTerm's for calling 'Prover.askMRSolver' or --- 'Prover.refinementTerm' and ensures they are of the expected form. --- Additionally, if the second argument is @Just str@, prints out @str@ --- followed by an abridged version of the refinement represented by the two --- terms. -mrSolverNormalizeAndPrintArgs :: - SharedContext -> Maybe PPS.Doc -> - TypedTerm -> TypedTerm -> TopLevel (Term, Term) -mrSolverNormalizeAndPrintArgs sc printStr tt1 tt2 = - do mm <- io $ scGetModuleMap sc - let ?mm = mm - m1 <- ttTerm <$> ensureMonadicTerm sc tt1 - m2 <- ttTerm <$> ensureMonadicTerm sc tt2 - m1' <- io $ collapseEta <$> betaNormalize sc m1 - m2' <- io $ collapseEta <$> betaNormalize sc m2 - case printStr of - Nothing -> return () - Just str -> printOutLnTop Info $ PPS.render PPS.defaultOpts $ - "[MRSolver] " <> str <> ": " <> ppTmHead m1' <> - " |= " <> ppTmHead m2' - return (m1', m2') - where -- Turn a term of the form @\x1 ... xn -> f x1 ... xn@ into @f@ - collapseEta :: Term -> Term - collapseEta (asLambdaList -> (lamVars, - asApplyAll -> (t@(smallestLooseVar -> Nothing), - mapM asLocalVar -> Just argVars))) - | argVars == [(length lamVars - 1), (length lamVars - 2) .. 0] = t - collapseEta t = t - -- Pretty-print the name of the top-level function call, followed by - -- "..." if it is given any arguments, or just "..." if there is no - -- top-level call - ppTmHead :: (?mm :: ModuleMap) => Term -> PPS.Doc - ppTmHead (asLambdaList -> (_, - asApplyAll -> (t@( - Prover.asProjAll -> ( - Monadify.asTypedGlobalDef -> Just _, _)), args))) = - ppTerm PPS.defaultOpts t <> if length args > 0 then " ..." else "" - ppTmHead _ = "..." - --- | The calback to be used by MRSolver for making SMT queries -mrSolverAskSMT :: Set VarIndex -> Sequent -> TopLevel (SolverStats, SolveResult) -mrSolverAskSMT = applyProverToGoal [What4, Z3] [] (Prover.proveWhat4_z3 True) - --- | Given the result of calling 'Prover.askMRSolver' or --- 'Prover.refinementTerm', fails and prints out@`err@ followed by the second --- argument if the given result is @Left err@ for some @err@, or otherwise --- returns @a@ if the result is@`Right a@ for some @a@. Additionally, if the --- third argument is @Just str@, prints out @str@ on success (i.e. 'Right'). -mrSolverGetResultOrFail :: - Prover.MREnv -> - String {- The string to print out on failure -} -> - Maybe String {- The string to print out on success, if any -} -> - Either Prover.MRFailure a {- The result, printed out on error -} -> - TopLevel a -mrSolverGetResultOrFail env errStr succStr res = case res of - Left err | Prover.mreDebugLevel env == 0 -> - fail (Prover.showMRFailure env err ++ "\n[MRSolver] " ++ errStr) - Left err -> - -- we ignore the MRFailure context here since it will have already - -- been printed by the debug trace - fail (Prover.showMRFailureNoCtx env err ++ "\n[MRSolver] " ++ errStr) - Right a | Just s <- succStr -> - printOutLnTop Info s >> return a - Right a -> return a - --- | Invokes MRSolver to attempt to solve a focused goal of the form --- @(a1:A1) -> ... -> (an:An) -> refinesS_eq ...@, assuming the refinements --- in the given 'Refnset', and printing an error message and exiting if --- this cannot be done -mrSolver :: SV.SAWRefnset -> ProofScript () -mrSolver rs = execTactic $ Tactic $ \goal -> lift $ - getSharedContext >>= \sc -> - case sequentState (goalSequent goal) of - Unfocused -> fail "mrsolver: focus required" - HypFocus _ _ -> fail "mrsolver: cannot apply mrsolver in a hypothesis" - ConclFocus (Prover.asRefinesS . unProp -> - Just (Prover.RefinesS args ev rtp1 rtp2 t1 t2)) _ -> - do tp1 <- liftIO $ scGlobalApply sc "SpecM.SpecM" [ev, rtp1] - tp2 <- liftIO $ scGlobalApply sc "SpecM.SpecM" [ev, rtp2] - let tt1 = TypedTerm (TypedTermOther tp1) t1 - tt2 = TypedTerm (TypedTermOther tp2) t2 - (m1, m2) <- mrSolverNormalizeAndPrintArgs sc (Just $ "Tactic call") tt1 tt2 - env <- rwMRSolverEnv <$> get - time1 <- liftIO getCurrentTime - res <- Prover.askMRSolver sc env Nothing mrSolverAskSMT rs args m1 m2 - time2 <- liftIO getCurrentTime - let diff = show $ diffUTCTime time2 time1 - errStr = printf "Failure in %s" diff - succStr = printf "Success in %s" diff - (stats, mre) <- mrSolverGetResultOrFail env errStr (Just succStr) res - return ((), stats, [], leafEvidence $ MrSolverEvidence mre) - _ -> error "mrsolver: cannot apply mrsolver to a non-refinement goal" - --- | Add a proved refinement theorem to a given refinement set -addrefn :: Theorem -> SV.SAWRefnset -> TopLevel SV.SAWRefnset -addrefn thm rs = - getSharedContext >>= \sc -> - io (scGetModuleMap sc) >>= \mm -> - let ?mm = mm in - case Prover.asFunAssump (Just (thmNonce thm)) (unProp $ thmProp thm) of - Nothing -> fail "addrefn: theorem is not a refinement" - Just fassump -> pure (Prover.addFunAssump fassump rs) - --- | Add proved refinement theorems to a given refinement set -addrefns :: [Theorem] -> SV.SAWRefnset -> TopLevel SV.SAWRefnset -addrefns thms ss = foldM (flip addrefn) ss thms - --- | Set the debug level of the 'Prover.MREnv' -mrSolverSetDebug :: Int -> TopLevel () -mrSolverSetDebug dlvl = - modify (\rw -> rw { rwMRSolverEnv = - Prover.mrEnvSetDebugLevel dlvl (rwMRSolverEnv rw) }) - --- | Modify the 'PPOpts' of the current 'MREnv' to have a maximum printing depth -mrSolverSetDebugDepth :: Int -> TopLevel () -mrSolverSetDebugDepth depth = - modify (\rw -> rw { rwMRSolverEnv = (rwMRSolverEnv rw) { - Prover.mrePPOpts = (Prover.mrePPOpts (rwMRSolverEnv rw)) { - PPS.ppMaxDepth = Just depth }}}) - --- | Given a list of names and types representing variables over which to --- quantify as as well as two terms containing those variables, which may be --- terms or functions in the SpecM monad, construct the SAWCore term which is --- the refinement (@SpecM.refinesS@) of the given terms, with the given --- variables generalized with a Pi type. -refinesTerm :: [TypedTerm] -> TypedTerm -> TypedTerm -> TopLevel TypedTerm -refinesTerm vars tt1 tt2 = - do sc <- getSharedContext - tt1' <- lambdas vars tt1 - tt2' <- lambdas vars tt2 - (m1, m2) <- mrSolverNormalizeAndPrintArgs sc Nothing tt1' tt2' - env <- rwMRSolverEnv <$> get - time1 <- liftIO getCurrentTime - res <- Prover.refinementTerm sc env Nothing mrSolverAskSMT - Prover.emptyRefnset [] m1 m2 - time2 <- liftIO getCurrentTime - let diff = show $ diffUTCTime time2 time1 - errStr = printf "[MRSolver] Failed to build refinement term (%s)" diff - ttRes <- mrSolverGetResultOrFail env errStr Nothing res - io $ mkTypedTerm sc ttRes - -setMonadification :: SharedContext -> Text -> Text -> Bool -> TopLevel () -setMonadification sc cry_str saw_str poly_p = - do rw <- get - - -- Step 1: convert the first string to a Cryptol name - cry_nm <- - let ?fileReader = StrictBS.readFile in - liftIO (CEnv.resolveIdentifier - (rwCryptol rw) cry_str) >>= \case - Just n -> return n - Nothing -> fail $ Text.unpack $ "No such Cryptol identifer: " <> cry_str - cry_nmi <- liftIO $ Cryptol.importName cry_nm - - -- Step 2: get the monadified type for this Cryptol name - -- - -- FIXME: not sure if this is the correct way to get the type of a Cryptol - -- name, so we are falling back on just translating the name to SAW core - -- and monadifying its type there - cry_saw_tp <- - liftIO $ - case Map.lookup cry_nm (CEnv.eExtraTypes $ rwCryptol rw) of - Just schema -> - -- TextIO.putStrLn $ "Found Cryptol type for name: " <> show cry_str >> - importSchemaCEnv sc (rwCryptol rw) schema - Nothing - | Just cry_nm_trans <- Map.lookup cry_nm (CEnv.eTermEnv $ - rwCryptol rw) -> - -- TextIO.putStrLn $ "No Cryptol type for name: " <> cry_str >> - scTypeOf sc cry_nm_trans - _ -> fail $ Text.unpack $ "Could not find type for Cryptol name: " <> cry_str - cry_mon_tp <- - liftIO $ - Monadify.monadifyCompleteArgType sc (rwMonadify rw) cry_saw_tp poly_p - - -- Step 3: convert the second string to a typed SAW core term, and if it - -- has an existing macro, check that it has the same type as the type for - -- the cryptol name, or if no macro exists, check that it has the same - -- type as the monadified type for the Cryptol name and generate a macro - -- which maps the Cryptol name to the SAW core term - let saw_ident = parseIdent (Text.unpack saw_str) - saw_trm <- liftIO $ scGlobalDef sc saw_ident - saw_tp <- liftIO $ scTypeOf sc saw_trm - let (tp_to_check, macro) = - case Monadify.monEnvLookup (ModuleIdentifier saw_ident) (rwMonadify rw) of - Just existing_macro -> (cry_saw_tp, existing_macro) - Nothing -> (cry_mon_tp, - Monadify.argGlobalMacro cry_nmi saw_ident poly_p) - liftIO $ scCheckSubtype sc Nothing (SCTypedTerm saw_trm saw_tp) tp_to_check - - -- Step 4: Add the generated macro - put (rw { rwMonadify = Monadify.monEnvAdd cry_nmi macro (rwMonadify rw) }) - parseSharpSATResult :: String -> Maybe Integer parseSharpSATResult s = parse (lines s) where @@ -2543,3 +2322,21 @@ ghost_value ghost val = , MS.conditionContext = "" } addCondition (MS.SetupCond_Ghost md ghost val) + +-- | Based on the function of the same name in SAWCore.ParserUtils. +-- Unlike that function, this calls 'fail' instead of 'error'. +-- +-- XXX: we only need one; unify these once the error handling gets fixed. +readModuleFromFile :: FilePath -> TopLevel (Un.Module, ModuleName) +readModuleFromFile path = + do base <- liftIO getCurrentDirectory + txt <- liftIO $ TLIO.readFile path + case parseSAW base path txt of + Right m@(Un.Module (Un.PosPair _ mnm) _ _) -> pure (m, mnm) + Left err -> fail $ "Module parsing failed:\n" ++ show err + +load_sawcore_from_file :: FilePath -> TopLevel () +load_sawcore_from_file mod_filename = + do sc <- getSharedContext + (saw_mod, _) <- readModuleFromFile mod_filename + liftIO $ tcInsertModule sc saw_mod diff --git a/saw-central/src/SAWCentral/Crucible/Common/MethodSpec.hs b/saw-central/src/SAWCentral/Crucible/Common/MethodSpec.hs index 4a2dcf175b..385955306c 100644 --- a/saw-central/src/SAWCentral/Crucible/Common/MethodSpec.hs +++ b/saw-central/src/SAWCentral/Crucible/Common/MethodSpec.hs @@ -354,9 +354,9 @@ setupToTerm opts sc = typ <- lift $ scTypeOf sc et lift $ scAt sc lent typ art ixt - SetupStruct _ fs -> + SetupStruct _ _fs -> do st <- setupToTerm opts sc base - lift $ scTupleSelector sc st ind (length fs) + lift $ scTupleSelector sc st ind _ -> MaybeT $ return Nothing diff --git a/saw-central/src/SAWCentral/Crucible/LLVM/Builtins.hs b/saw-central/src/SAWCentral/Crucible/LLVM/Builtins.hs index c9b96aa049..3b1e07fc45 100644 --- a/saw-central/src/SAWCentral/Crucible/LLVM/Builtins.hs +++ b/saw-central/src/SAWCentral/Crucible/LLVM/Builtins.hs @@ -449,7 +449,7 @@ llvm_compositional_extract (Some lm) nm func_name lemmas checkSat setup tactic = extracted_func <- io $ scAbstractExts shared_context input_parameters - =<< scTuple shared_context output_values + =<< scTuple' shared_context output_values when ([] /= getAllExts extracted_func) $ fail "Non-functional simulation summary." @@ -461,9 +461,9 @@ llvm_compositional_extract (Some lm) nm func_name lemmas checkSat setup tactic = input_terms <- io $ traverse (scVariable shared_context) input_parameters applied_extracted_func <- io $ scApplyAll shared_context extracted_func_const input_terms applied_extracted_func_selectors <- - io $ forM [1 .. (length output_parameters)] $ \i -> + io $ forM [0 .. (length output_parameters - 1)] $ \i -> mkTypedTerm shared_context - =<< scTupleSelector shared_context applied_extracted_func i (length output_parameters) + =<< scTupleSelector' shared_context applied_extracted_func i (length output_parameters) let output_parameter_substitution = IntMap.fromList $ zip (map ecVarIndex output_parameters) (map ttTerm applied_extracted_func_selectors) diff --git a/saw-central/src/SAWCentral/Crucible/LLVM/FFI.hs b/saw-central/src/SAWCentral/Crucible/LLVM/FFI.hs index 551035deb3..3531d48160 100644 --- a/saw-central/src/SAWCentral/Crucible/LLVM/FFI.hs +++ b/saw-central/src/SAWCentral/Crucible/LLVM/FFI.hs @@ -255,7 +255,7 @@ setupInArg tenv = go Nothing -> pure ox pure (x, cryTerm) tupleInArgs (unzip -> (terms, inArgss)) = - (tupleOpenTerm' terms, concat inArgss) + (tupleOpenTerm terms, concat inArgss) -- | Do setup for the return value, returning a list of output arguments to pass -- to the LLVM function and a function that asserts functional correctness given @@ -308,7 +308,6 @@ setupOutArg tenv = go "out" -- represents records by tuples in canonical order (outArgss, posts) <- unzip <$> setupRecordArgs go name ffiTypeMap let canonFields = map fst $ canonicalFields ffiTypeMap - len = fromIntegral $ length canonFields post ret = zipWithM_ (\field p -> do let ix = fromIntegral @@ -316,7 +315,7 @@ setupOutArg tenv = go "out" Just i -> i Nothing -> panic "setupOutArg" ["Bad record field access"] - p (projTupleOpenTerm' len ix ret)) + p (projTupleOpenTerm ix ret)) (displayOrder ffiTypeMap) posts pure (concat outArgss, post) diff --git a/saw-central/src/SAWCentral/Crucible/LLVM/ResolveSetupValue.hs b/saw-central/src/SAWCentral/Crucible/LLVM/ResolveSetupValue.hs index e8f61209d9..4689057f64 100644 --- a/saw-central/src/SAWCentral/Crucible/LLVM/ResolveSetupValue.hs +++ b/saw-central/src/SAWCentral/Crucible/LLVM/ResolveSetupValue.hs @@ -868,7 +868,7 @@ resolveSAWTerm cc tp tm = Cryptol.TVTuple tps -> do st <- sawCoreState sym let sc = saw_ctx st - tms <- mapM (\i -> scTupleSelector sc tm i (length tps)) [1 .. length tps] + tms <- mapM (scTupleSelector sc tm) [0 .. length tps - 1] vals <- zipWithM (resolveSAWTerm cc) tps tms storTy <- case toLLVMType dl tp of @@ -1089,8 +1089,7 @@ memArrayToSawCoreTerm crucible_context endianess typed_term = do inner_saw_term <- liftIO $ scTupleSelector saw_context saw_term - (field_index + 1) - (length tuple_element_cryptol_types) + field_index setBytes tuple_element_cryptol_type inner_saw_term diff --git a/saw-central/src/SAWCentral/Crucible/LLVM/X86.hs b/saw-central/src/SAWCentral/Crucible/LLVM/X86.hs index 5fb1457f9a..14b72d3920 100644 --- a/saw-central/src/SAWCentral/Crucible/LLVM/X86.hs +++ b/saw-central/src/SAWCentral/Crucible/LLVM/X86.hs @@ -717,8 +717,8 @@ setupSimpleLoopFixpointFeature sym sc sawst cfg mvar func = arguments <- forM fixpoint_substitution_as_list $ \(MapF.Pair _ fixpoint_entry) -> toSC sym sawst $ Crucible.LLVM.Fixpoint.headerValue fixpoint_entry applied_func <- scApplyAll sc (ttTerm func) $ implicit_parameters ++ arguments - applied_func_selectors <- forM [1 .. (length fixpoint_substitution_as_list)] $ \i -> - scTupleSelector sc applied_func i (length fixpoint_substitution_as_list) + applied_func_selectors <- forM [0 .. (length fixpoint_substitution_as_list - 1)] $ \i -> + scTupleSelector' sc applied_func i (length fixpoint_substitution_as_list) result_substitution <- MapF.fromList <$> zipWithM (\(MapF.Pair variable _) applied_func_selector -> MapF.Pair variable <$> bindSAWTerm sym sawst (W4.exprType variable) applied_func_selector) @@ -738,7 +738,7 @@ setupSimpleLoopFixpointFeature sym sc sawst cfg mvar func = step_arguments <- forM fixpoint_substitution_as_list $ \(MapF.Pair _ fixpoint_entry) -> toSC sym sawst $ Crucible.LLVM.Fixpoint.bodyValue fixpoint_entry tail_applied_func <- scApplyAll sc (ttTerm func) $ implicit_parameters ++ step_arguments - explicit_parameters_tuple <- scTuple sc explicit_parameters + explicit_parameters_tuple <- scTuple' sc explicit_parameters let lhs = Prelude.last step_arguments w <- scNat sc 64 let implicit_parameter_head = @@ -748,7 +748,7 @@ setupSimpleLoopFixpointFeature sym sc sawst cfg mvar func = ["No implicit parameters"] rhs <- scBvMul sc w implicit_parameter_head =<< scBvNat sc w =<< scNat sc 128 loop_condition <- scBvULt sc w lhs rhs - output_tuple_type <- scTupleType sc =<< mapM (scTypeOf sc) explicit_parameters + output_tuple_type <- scTupleType' sc =<< mapM (scTypeOf sc) explicit_parameters loop_body <- scIte sc output_tuple_type loop_condition tail_applied_func explicit_parameters_tuple induction_step_condition <- scEq sc loop_body func_body @@ -795,10 +795,10 @@ setupSimpleLoopFixpointCHCFeature sym sc sawst cfg mvar func = do implicit_parameters <- mapM (scVariable sc) $ Set.toList $ foldMap getAllExtSet tms arguments <- forM fixpoint_substitution_as_list $ \(MapF.Pair _ fixpoint_entry) -> toSC sym sawst $ Crucible.LLVM.FixpointCHC.headerValue fixpoint_entry - arguments_tuple <- scTuple sc arguments + arguments_tuple <- scTuple' sc arguments applied_func <- scApplyAll sc (ttTerm func) $ implicit_parameters ++ [arguments_tuple] - applied_func_selectors <- forM [1 .. (length fixpoint_substitution_as_list)] $ \i -> - scTupleSelector sc applied_func i (length fixpoint_substitution_as_list) + applied_func_selectors <- forM [0 .. (length fixpoint_substitution_as_list - 1)] $ \i -> + scTupleSelector' sc applied_func i (length fixpoint_substitution_as_list) result_substitution <- MapF.fromList <$> zipWithM (\(MapF.Pair variable _) applied_func_selector -> MapF.Pair variable <$> bindSAWTerm sym sawst (W4.exprType variable) applied_func_selector) @@ -807,7 +807,7 @@ setupSimpleLoopFixpointCHCFeature sym sc sawst cfg mvar func = do explicit_parameters <- forM fixpoint_substitution_as_list $ \(MapF.Pair variable _) -> toSC sym sawst variable - explicit_parameters_tuple <- scTuple sc explicit_parameters + explicit_parameters_tuple <- scTuple' sc explicit_parameters maybe_fix_body <- scAsFixConstant sc (ttTerm func) inner_func <- @@ -819,11 +819,11 @@ setupSimpleLoopFixpointCHCFeature sym sc sawst cfg mvar func = do step_arguments <- forM fixpoint_substitution_as_list $ \(MapF.Pair _ fixpoint_entry) -> toSC sym sawst $ Crucible.LLVM.FixpointCHC.bodyValue fixpoint_entry - step_arguments_tuple <- scTuple sc step_arguments + step_arguments_tuple <- scTuple' sc step_arguments tail_applied_func <- scApplyAll sc (ttTerm func) $ implicit_parameters ++ [step_arguments_tuple] loop_condition <- toSC sym sawst condition - output_tuple_type <- scTupleType sc =<< mapM (scTypeOf sc) explicit_parameters + output_tuple_type <- scTupleType' sc =<< mapM (scTypeOf sc) explicit_parameters loop_body <- scIte sc output_tuple_type loop_condition tail_applied_func explicit_parameters_tuple induction_step_condition <- scEq sc loop_body func_body @@ -885,8 +885,8 @@ setupSimpleLoopInvariantFeature sym printFn loopNum sc sawst mdMap cfg mvar func \ (MapF.Pair _var (SimpleInvariant.InvariantEntry _init current)) -> toSC sym sawst current - initial_tuple <- scTuple sc initial_exprs - current_tuple <- scTuple sc current_exprs + initial_tuple <- scTuple' sc initial_exprs + current_tuple <- scTuple' sc current_exprs -- use the provided logging function to print the discovered -- implicit parameters diff --git a/saw-central/src/SAWCentral/Crucible/MIR/ResolveSetupValue.hs b/saw-central/src/SAWCentral/Crucible/MIR/ResolveSetupValue.hs index 358eabe201..93d97ce8af 100644 --- a/saw-central/src/SAWCentral/Crucible/MIR/ResolveSetupValue.hs +++ b/saw-central/src/SAWCentral/Crucible/MIR/ResolveSetupValue.hs @@ -1059,7 +1059,7 @@ resolveSAWTerm mcc tp tm = Cryptol.TVTuple tps -> do st <- sawCoreState sym let sc = saw_ctx st - tms <- traverse (\i -> scTupleSelector sc tm i (length tps)) [1 .. length tps] + tms <- traverse (scTupleSelector sc tm) [0 .. length tps - 1] vals <- zipWithM (resolveSAWTerm mcc) tps tms let mirTys = map (\(MIRVal shp _) -> shapeMirTy shp) vals -- TODO: get proper tuple layout diff --git a/saw-central/src/SAWCentral/MRSolver/Evidence.hs b/saw-central/src/SAWCentral/MRSolver/Evidence.hs deleted file mode 100644 index 558e518fd9..0000000000 --- a/saw-central/src/SAWCentral/MRSolver/Evidence.hs +++ /dev/null @@ -1,211 +0,0 @@ -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} - -{- | -Module : SAWCentral.MRSolver.Evidence -Copyright : Galois, Inc. 2023 -License : BSD3 -Maintainer : westbrook@galois.com -Stability : experimental -Portability : non-portable (language extensions) - -This module defines multiple outward facing components of MRSolver, most -notably the 'MREvidence' type which provides evidence for the truth of a -refinement proposition proved by MRSolver, and used in @Proof.hs@. This module -also defines the 'MREnv' type, the global MRSolver state. - -Note: In order to avoid circular dependencies, the 'FunAssump' type and its -dependents in this file ('Refnset' and 'MREvidence') are given a type -parameter @t@ which in practice always be 'TheoremNonce' from @Value.hs@. -The reason we cannot just import @Value.hs@ here directly is because the -'Refnset' type is used in @Value.hs@ - specifically, in the 'VRefnset' -constructor of the 'Value' datatype. --} - -module SAWCentral.MRSolver.Evidence where - -import Data.Foldable (foldMap') - -import Data.Map (Map) -import qualified Data.Map as Map - -import Data.HashMap.Lazy (HashMap) -import qualified Data.HashMap.Lazy as HashMap - -import Data.Set (Set) -import qualified Data.Set as Set - -import qualified SAWSupport.Pretty as PPS (Opts, defaultOpts) - -import SAWCore.Module (ModuleMap) -import SAWCore.Name (Name(..)) -import SAWCore.Term.Functor -import SAWCore.Recognizer -import CryptolSAWCore.Monadify -import SAWCentral.Prover.SolverStats - -import SAWCentral.MRSolver.Term - - ----------------------------------------------------------------------- --- * Function Refinement Assumptions ----------------------------------------------------------------------- - --- | A representation of a refinement proof goal, i.e., a term of the form: --- > (a1:A1) -> ... -> (an:An) -> refinesS ev rtp1 rtp2 t1 t2 -data RefinesS = RefinesS { - -- | The context of the refinement, i.e. @[(a1,A1), ..., (an,An)]@ - -- from the term above - refnCtx :: [(LocalName, Term)], - -- | The event type of the refinement, i.e. @ev@ above - refnEv :: Term, - -- | The LHS return type of the refinement, i.e. @rtp1@ above - refnRType1 :: Term, - -- | The RHS return type of the refinement, i.e. @rtp2@ above - refnRType2 :: Term, - -- | The LHS term of the refinement, i.e. @t1@ above - refnLHS :: Term, - -- | The RHS term of the refinement, i.e. @t2@ above - refnRHS :: Term -} - --- | Recognizes a term of the form: --- @(a1:A1) -> ... -> (an:An) -> refinesS ev1 ev2 stack1 stack2 rtp1 rtp2 t1 t2@ --- and returns: --- @RefinesS [(a1,A1), ..., (an,An)] ev1 ev2 stack1 stack2 rtp1 rtp2 t1 t2@ -asRefinesS :: Recognizer Term RefinesS -asRefinesS (asPiList -> (args, asApplyAll -> - (asGlobalDef -> Just "SpecM.refinesS", - [ev, rtp1, rtp2, - asApplyAll -> (asGlobalDef -> Just "SpecM.eqRR", _), - t1, t2]))) = - Just $ RefinesS args ev rtp1 rtp2 t1 t2 -asRefinesS (asPiList -> (_, asApplyAll -> (asGlobalDef -> Just "SpecM.refinesS", _))) = - error "FIXME: MRSolver does not yet accept refinesS goals with non-trivial return relation" -asRefinesS _ = Nothing - --- | The right-hand-side of a 'FunAssump': either a 'FunName' and arguments, if --- it is an opaque 'FunAsump', or a 'NormComp', if it is a rewrite 'FunAssump' -data FunAssumpRHS = OpaqueFunAssump FunName [Term] - | RewriteFunAssump Term - --- | An assumption that a named function refines some specification. This has --- the form --- --- > forall x1, ..., xn. F e1 ... ek |= m --- --- for some universal context @x1:T1, .., xn:Tn@, some list of argument --- expressions @ei@ over the universal @xj@ variables, and some right-hand side --- computation expression @m@. -data FunAssump t = FunAssump { - -- | The uvars that were in scope when this assumption was created - fassumpCtx :: MRVarCtx, - -- | The function on the left-hand-side - fassumpFun :: FunName, - -- | The argument expressions @e1, ..., en@ over the 'fassumpCtx' uvars - fassumpArgs :: [Term], - -- | The right-hand side upper bound @m@ over the 'fassumpCtx' uvars - fassumpRHS :: FunAssumpRHS, - -- | An optional annotation, which in the case of SAWScript, is always a - -- 'TheoremNonce' indicating from which 'Theorem' this assumption comes - fassumpAnnotation :: Maybe t -} - --- | Recognizes a term of the form: --- @(a1:A1) -> ... -> (an:An) -> refinesS ev rtp rtp eqRR (f b1 ... bm) t2@, --- and returns: @FunAssump f [a1,...,an] [b1,...,bm] rhs ann@, --- where @ann@ is the given argument and @rhs@ is either --- @OpaqueFunAssump g [c1,...,cl]@ if @t2@ is @g c1 ... cl@, --- or @RewriteFunAssump t2@ otherwise -asFunAssump :: (?mm :: ModuleMap) => Maybe t -> Recognizer Term (FunAssump t) -asFunAssump ann (asRefinesS -> Just (RefinesS args - (asGlobalDef -> Just "SpecM.VoidEv") - _ _ (asApplyAll -> (asGlobalFunName -> Just f1, args1)) - t2@(asApplyAll -> (asGlobalFunName -> mb_f2, args2)))) = - let rhs = maybe (RewriteFunAssump t2) (\f2 -> OpaqueFunAssump f2 args2) mb_f2 - in Just $ FunAssump { fassumpCtx = mrVarCtxFromOuterToInner args, - fassumpFun = f1, fassumpArgs = args1, - fassumpRHS = rhs, - fassumpAnnotation = ann } -asFunAssump _ _ = Nothing - - ----------------------------------------------------------------------- --- * Refinement Sets ----------------------------------------------------------------------- - --- | A set of refinements whose left-hand-sides are function applications, --- represented as 'FunAssump's. Internally, a map from the 'VarIndex'es of the --- LHS functions to 'FunAssump's describing the complete refinement. -type Refnset t = HashMap VarIndex (Map [TermProj] (FunAssump t)) - --- | The 'Refnset' with no refinements -emptyRefnset :: Refnset t -emptyRefnset = HashMap.empty - --- | Given a 'FunName' and a 'Refnset', return the 'FunAssump' which has --- the given 'FunName' as its LHS function, if possible -lookupFunAssump :: FunName -> Refnset t -> Maybe (FunAssump t) -lookupFunAssump (GlobalName (GlobalDef (nameIndex -> ix) _ _) projs) refSet = - HashMap.lookup ix refSet >>= Map.lookup projs -lookupFunAssump _ _ = Nothing - --- | Add a 'FunAssump' to a 'Refnset' -addFunAssump :: FunAssump t -> Refnset t -> Refnset t -addFunAssump fa@(fassumpFun -> GlobalName (GlobalDef (nameIndex -> ix) _ _) projs) = - HashMap.insertWith (\_ -> Map.insert projs fa) ix - (Map.singleton projs fa) -addFunAssump _ = error "Cannot insert a non-global name into a Refnset" - --- | Return the list of 'FunAssump's in a given 'Refnset' -listFunAssumps :: Refnset t -> [FunAssump t] -listFunAssumps = concatMap Map.elems . HashMap.elems - - ----------------------------------------------------------------------- --- * Mr Solver Environments ----------------------------------------------------------------------- - --- | A global MR Solver environment -data MREnv = MREnv { - -- | The debug level, which controls debug printing - mreDebugLevel :: Int, - -- | The options for pretty-printing to be used by MRSolver in error messages - -- and debug printing - mrePPOpts :: PPS.Opts -} - --- | The empty 'MREnv' -emptyMREnv :: MREnv -emptyMREnv = MREnv { mreDebugLevel = 0, mrePPOpts = PPS.defaultOpts } - --- | Set the debug level of a Mr Solver environment -mrEnvSetDebugLevel :: Int -> MREnv -> MREnv -mrEnvSetDebugLevel dlvl env = env { mreDebugLevel = dlvl } - - ----------------------------------------------------------------------- --- * Mr Solver Evidence ----------------------------------------------------------------------- - --- | An entry in 'MREvidence' indicating a usage of an SMT solver or a --- 'FunAssump' -data MREvidenceEntry t = MREUsedSolver !SolverStats !Term - | MREUsedFunAssump !t - --- | Records evidence for the truth of a refinement proposition proved by --- MRSolver. Currently, this is just a list of 'MREvidenceEntry's indicating --- each instance where MRSolver needed to use an SMT solver or a 'FunAssump'. --- FIXME: Have this data type actually provide evidence! i.e. have it keep --- track of each refinement theorem used by MRSolver along the way. -type MREvidence t = [MREvidenceEntry t] - --- | Verify that the given evidence in fact supports the given refinement --- proposition. Returns the identifiers of all the theorems depended on while --- checking evidence. --- FIXME: Actually take in a refinement to check against! -checkMREvidence :: Ord t => MREvidence t -> IO (Set t, SolverStats) -checkMREvidence = return . foldMap' checkEntry - where checkEntry (MREUsedSolver stats _) = (mempty, stats) - checkEntry (MREUsedFunAssump t) = (Set.singleton t, mempty) diff --git a/saw-central/src/SAWCentral/MRSolver/Monad.hs b/saw-central/src/SAWCentral/MRSolver/Monad.hs deleted file mode 100644 index 2056bcc54b..0000000000 --- a/saw-central/src/SAWCentral/MRSolver/Monad.hs +++ /dev/null @@ -1,1458 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingStrategies #-} - -{- | -Module : SAWCentral.MRSolver.Monad -Copyright : Galois, Inc. 2022 -License : BSD3 -Maintainer : westbrook@galois.com -Stability : experimental -Portability : non-portable (language extensions) - -This module defines the monad used by Mr. Solver ('MRM') as well as the core -monadic combinators for operating on terms. --} - -module SAWCentral.MRSolver.Monad where - -import Data.Maybe -import Data.List (find, findIndex, foldl') -import Data.IORef -import qualified Data.Text as T -import System.IO (hPutStrLn, stderr) -import Control.Monad (MonadPlus(..), foldM) -import Control.Monad.Catch (MonadThrow, MonadCatch) -import Control.Monad.Except (MonadError(..), ExceptT, runExceptT) -import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.Reader (MonadReader(..), ReaderT(..)) -import Control.Monad.State (MonadState(..), StateT(..), modify) -import Control.Monad.Trans.Class (MonadTrans(..)) -import Control.Monad.Trans.Maybe -import GHC.Generics - -import Data.Map (Map) -import qualified Data.Map as Map - -import Data.HashMap.Lazy (HashMap) -import qualified Data.HashMap.Lazy as HashMap - -import Data.Set (Set) -import qualified Data.Set as Set - -import Prettyprinter - -import qualified SAWSupport.Pretty as PPS (Doc, Opts, render) - -import SAWCore.Name (Name(..)) -import SAWCore.Term.Functor -import SAWCore.Term.Pretty -import SAWCore.SCTypeCheck -import SAWCore.SharedTerm -import SAWCore.Module (Def(..), ResolvedName(..), lookupVarIndexInMap) -import SAWCore.Recognizer -import CryptolSAWCore.Monadify - -import SAWCentral.Panic -import SAWCentral.Prover.SolverStats -import SAWCentral.Proof (Sequent, SolveResult) -import SAWCentral.Value (TopLevel) - -import SAWCentral.MRSolver.Term -import SAWCentral.MRSolver.Evidence - - ----------------------------------------------------------------------- --- * MR Solver Errors ----------------------------------------------------------------------- - --- | The context in which a failure occurred -data FailCtx - = FailCtxRefines NormComp NormComp - | FailCtxCoIndHyp CoIndHyp - | FailCtxMNF Term - | FailCtxProveRel Term Term - deriving Show - --- | That's MR. Failure to you -data MRFailure - = TermsNotEq Term Term - | TypesNotEq Type Type - | TypesNotUnifiable Type Type - | BindTypesNotUnifiable Type Type - | ReturnTypesNotEq Type Type - | FunNamesDoNotRefine FunName [Term] FunName [Term] - | CompsDoNotRefine NormComp NormComp - | ReturnNotError (Either Term Term) Term - | FunsNotEq FunName FunName - | CannotLookupFunDef FunName - | RecursiveUnfold FunName - | MalformedTpDescList Term - | MalformedDefs Term - | MalformedComp Term - | NotCompFunType Term Term - | AssertionNotProvable Term - | AssumptionNotProvable Term - | InvariantNotProvable FunName FunName Term - -- | A local variable binding - | MRFailureLocalVar LocalName MRFailure - -- | Information about the context of the failure - | MRFailureCtx FailCtx MRFailure - -- | Records a disjunctive branch we took, where both cases failed - | MRFailureDisj MRFailure MRFailure - deriving Show - --- | Remove the context from a 'MRFailure', i.e. remove all applications of the --- 'MRFailureLocalVar' and 'MRFailureCtx' constructors -mrFailureWithoutCtx :: MRFailure -> MRFailure -mrFailureWithoutCtx (MRFailureLocalVar x err) = - MRFailureLocalVar x (mrFailureWithoutCtx err) -mrFailureWithoutCtx (MRFailureCtx _ err) = mrFailureWithoutCtx err -mrFailureWithoutCtx (MRFailureDisj err1 err2) = - MRFailureDisj (mrFailureWithoutCtx err1) (mrFailureWithoutCtx err2) -mrFailureWithoutCtx err = err - --- | Pretty-print an object prefixed with a 'String' that describes it -prettyPrefix :: PrettyInCtx a => String -> a -> PPInCtxM PPS.Doc -prettyPrefix str a = - (pretty str <>) <$> nest 2 <$> (line <>) <$> prettyInCtx a - --- | Pretty-print two objects, prefixed with a 'String' and with a separator -prettyPrefixSep :: (PrettyInCtx a, PrettyInCtx b) => - String -> a -> String -> b -> PPInCtxM PPS.Doc -prettyPrefixSep d1 t2 d3 t4 = - prettyInCtx t2 >>= \d2 -> prettyInCtx t4 >>= \d4 -> - return $ group (pretty d1 <> nest 2 (line <> d2) <> line <> - pretty d3 <> nest 2 (line <> d4)) - --- | Apply 'vsep' to a list of pretty-printing computations -vsepM :: [PPInCtxM PPS.Doc] -> PPInCtxM PPS.Doc -vsepM = fmap vsep . sequence - -instance PrettyInCtx FailCtx where - prettyInCtx (FailCtxRefines m1 m2) = - group <$> nest 2 <$> - prettyPrefixSep "When proving refinement:" m1 "|=" m2 - prettyInCtx (FailCtxCoIndHyp hyp) = - group <$> nest 2 <$> - prettyPrefix "When doing co-induction with hypothesis:" hyp - prettyInCtx (FailCtxMNF t) = - group <$> nest 2 <$> vsepM [return "When normalizing computation:", - prettyInCtx t] - prettyInCtx (FailCtxProveRel t1 t2) = - group <$> nest 2 <$> vsepM [return "When proving terms equal:", - prettyInCtx t1, prettyInCtx t2] - -instance PrettyInCtx MRFailure where - prettyInCtx (TermsNotEq t1 t2) = - prettyPrefixSep "Could not prove terms equal:" t1 "and" t2 - prettyInCtx (TypesNotEq tp1 tp2) = - prettyPrefixSep "Types not equal:" tp1 "and" tp2 - prettyInCtx (TypesNotUnifiable tp1 tp2) = - prettyPrefixSep "Types cannot be unified:" tp1 "and" tp2 - prettyInCtx (BindTypesNotUnifiable tp1 tp2) = - prettyPrefixSep "Could not start co-induction because bind types cannot be unified:" tp1 "and" tp2 - prettyInCtx (ReturnTypesNotEq tp1 tp2) = - prettyPrefixSep "Could not form refinement because return types are not equal:" tp1 "and" tp2 - prettyInCtx (FunNamesDoNotRefine f1 args1 f2 args2) = - snd (prettyInCtxFunBindH f1 args1) >>= \d1 -> - snd (prettyInCtxFunBindH f2 args2) >>= \d2 -> - let prefix = "Could not prove function refinement:" in - let postfix = ["because:", - "- No matching assumptions could be found", - "- At least one side cannot be unfolded without fix"] in - return $ group (prefix <> nest 2 (line <> d1) <> line <> - "|=" <> nest 2 (line <> d2) <> line <> vsep postfix) - prettyInCtx (CompsDoNotRefine m1 m2) = - prettyPrefixSep "Could not prove refinement: " m1 "|=" m2 - prettyInCtx (ReturnNotError eith_terr t) = - let (lr_s, terr) = either ("left",) ("right",) eith_terr in - prettyPrefixSep "errorS:" terr (" on the " ++ lr_s ++ " does not match retS:") t - prettyInCtx (FunsNotEq nm1 nm2) = - vsepM [return "Named functions not equal:", - prettyInCtx nm1, prettyInCtx nm2] - prettyInCtx (CannotLookupFunDef nm) = - prettyPrefix "Could not find definition for function:" nm - prettyInCtx (RecursiveUnfold nm) = - prettyPrefix "Recursive unfolding of function inside its own body:" nm - prettyInCtx (MalformedTpDescList t) = - prettyPrefix "Not a list of type descriptions:" t - prettyInCtx (MalformedDefs t) = - prettyPrefix "Cannot handle multiFixS recursive definitions term:" t - prettyInCtx (MalformedComp t) = - prettyPrefix "Could not handle computation:" t - prettyInCtx (NotCompFunType tp t) = - prettyPrefixSep "Not a computation or computational function type:" tp - "for term:" t - prettyInCtx (AssertionNotProvable cond) = - prettyPrefix "Failed to prove assertion:" cond - prettyInCtx (AssumptionNotProvable cond) = - prettyPrefix "Failed to prove condition for `assuming`:" cond - prettyInCtx (InvariantNotProvable f g pre) = - prettyAppList [return "Could not prove loop invariant for functions", - prettyInCtx f, return "and", prettyInCtx g, - return ":", prettyInCtx pre] - prettyInCtx (MRFailureLocalVar x err) = - local (fmap (x:)) $ prettyInCtx err - prettyInCtx (MRFailureCtx ctx err) = - do pp1 <- prettyInCtx ctx - pp2 <- prettyInCtx err - return (pp1 <> line <> pp2) - prettyInCtx (MRFailureDisj err1 err2) = - prettyPrefixSep "Tried two comparisons:" err1 "Backtracking..." err2 - --- | Render a 'MRFailure' to a 'String' -showMRFailure :: MREnv -> MRFailure -> String -showMRFailure env = showInCtx (mrePPOpts env) emptyMRVarCtx - --- | Render a 'MRFailure' to a 'String' without its context (see --- 'mrFailureWithoutCtx') -showMRFailureNoCtx :: MREnv -> MRFailure -> String -showMRFailureNoCtx env = showMRFailure env . mrFailureWithoutCtx - - ----------------------------------------------------------------------- --- * MR Monad ----------------------------------------------------------------------- - --- | Classification info for what sort of variable an 'MRVar' is -data MRVarInfo - -- | An existential variable, that might be instantiated and that tracks - -- how many uvars were in scope when it was created. An occurrence of an - -- existential variable should always be applied to these uvars; this is - -- ensured by only allowing evars to be created by 'mrFreshEVar'. - = EVarInfo Int (Maybe Term) - -- | A recursive function bound by @multiFixS@, with its body - | CallVarInfo Term - -instance PrettyInCtx MRVarInfo where - prettyInCtx (EVarInfo _ maybe_t) = - prettyAppList [ return "EVar", parens <$> prettyInCtx maybe_t] - prettyInCtx (CallVarInfo t) = - prettyAppList [ return "CallVar", parens <$> prettyInCtx t] - --- | A map from 'MRVar's to their info -type MRVarMap = Map MRVar MRVarInfo - --- | Test if a 'Term' is an application of a 'Variable' to some arguments -asVariableApp :: Recognizer Term (ExtCns Term, [Term]) -asVariableApp (asApplyAll -> (asVariable -> Just ec, args)) = - return (ec, args) -asVariableApp _ = Nothing - --- | Recognize an evar applied to 0 or more arguments relative to a 'MRVarMap' --- along with its uvar context length and its instantiation, if any -asEVarApp :: MRVarMap -> Recognizer Term (MRVar, Int, [Term], Maybe Term) -asEVarApp var_map (asVariableApp -> Just (ec, args)) - | Just (EVarInfo clen maybe_inst) <- Map.lookup (MRVar ec) var_map = - Just (MRVar ec, clen, args, maybe_inst) -asEVarApp _ _ = Nothing - --- | A co-inductive hypothesis of the form: --- --- > forall x1, ..., xn. F y1 ... ym |= G z1 ... zl --- --- for some universal context @x1:T1, ..., xn:Tn@ and some lists of argument --- expressions @y1, ..., ym@ and @z1, ..., zl@ over the universal context. -data CoIndHyp = CoIndHyp { - -- | The uvars that were in scope when this assmption was created - coIndHypCtx :: MRVarCtx, - -- | The LHS function name - coIndHypLHSFun :: FunName, - -- | The RHS function name - coIndHypRHSFun :: FunName, - -- | The LHS argument expressions @y1, ..., ym@ over the 'coIndHypCtx' uvars - coIndHypLHS :: [Term], - -- | The RHS argument expressions @y1, ..., ym@ over the 'coIndHypCtx' uvars - coIndHypRHS :: [Term], - -- | The invariant for the left-hand arguments, as a closed function from - -- the left-hand arguments to @Bool@ - coIndHypInvariantLHS :: Maybe Term, - -- | The invariant for the right-hand arguments, as a closed function from - -- the left-hand arguments to @Bool@ - coIndHypInvariantRHS :: Maybe Term -} deriving Show - --- | Extract the @i@th argument on either the left- or right-hand side of a --- coinductive hypothesis -coIndHypArg :: CoIndHyp -> Either Int Int -> Term -coIndHypArg hyp (Left i) = (coIndHypLHS hyp) !! i -coIndHypArg hyp (Right i) = (coIndHypRHS hyp) !! i - --- | Set the @i@th argument on either the left- or right-hand side of a --- coinductive hypothesis to the given value -coIndHypSetArg :: CoIndHyp -> Either Int Int -> Term -> CoIndHyp -coIndHypSetArg hyp@(CoIndHyp {..}) (Left i) x = - hyp { coIndHypLHS = take i coIndHypLHS ++ x : drop (i+1) coIndHypLHS } -coIndHypSetArg hyp@(CoIndHyp {..}) (Right i) x = - hyp { coIndHypRHS = take i coIndHypRHS ++ x : drop (i+1) coIndHypRHS } - --- | Add a variable to the context of a coinductive hypothesis, returning the --- updated coinductive hypothesis and a 'Term' which is the new variable -coIndHypWithVar :: CoIndHyp -> LocalName -> Type -> MRM t (CoIndHyp, Term) -coIndHypWithVar (CoIndHyp ctx f1 f2 args1 args2 invar1 invar2) nm tp = - do var <- liftSC1 scLocalVar 0 - let ctx' = mrVarCtxAppend (singletonMRVarCtx nm tp) ctx - (args1', args2') <- liftTermLike 0 1 (args1, args2) - return (CoIndHyp ctx' f1 f2 args1' args2' invar1 invar2, var) - --- | A map from pairs of function names to co-inductive hypotheses over those --- names -type CoIndHyps = Map (FunName, FunName) CoIndHyp - -instance PrettyInCtx CoIndHyp where - prettyInCtx (CoIndHyp ctx f1 f2 args1 args2 invar1 invar2) = - prettyWithCtx ctx $ -- ignore whatever context we're in and use `ctx` instead - prettyAppList [prettyInCtx ctx, return ".", - (case invar1 of - Just f -> prettyTermApp f args1 - Nothing -> return "True"), return "=>", - (case invar2 of - Just f -> prettyTermApp f args2 - Nothing -> return "True"), return "=>", - prettyTermApp (funNameTerm f1) args1, - return "|=", - prettyTermApp (funNameTerm f2) args2] - --- | An assumption that something is equal to one of the constructors of a --- datatype, e.g. equal to @Left@ of some 'Term' or @Right@ of some 'Term' -data DataTypeAssump - = IsLeft Term | IsRight Term | IsNum Term | IsInf - deriving (Generic, Show, TermLike) - -instance PrettyInCtx DataTypeAssump where - prettyInCtx (IsLeft x) = prettyInCtx x >>= prettyPrefix "Left _ _" - prettyInCtx (IsRight x) = prettyInCtx x >>= prettyPrefix "Right _ _" - prettyInCtx (IsNum x) = prettyInCtx x >>= prettyPrefix "TCNum" - prettyInCtx IsInf = return "TCInf" - --- | A map from 'Term's to 'DataTypeAssump's over that term -type DataTypeAssumps = HashMap Term DataTypeAssump - --- | Parameters and locals for MR. Solver -data MRInfo t = MRInfo { - -- | Global shared context for building terms, etc. - mriSC :: SharedContext, - -- | SMT timeout for SMT calls made by Mr. Solver - mriSMTTimeout :: Maybe Integer, - -- | The top-level Mr Solver environment - mriEnv :: MREnv, - -- | The function to be used as the SMT backend for Mr. Solver, taking a set - -- of uninterpreted variables and a proposition to prove - mriAskSMT :: Set VarIndex -> Sequent -> TopLevel (SolverStats, SolveResult), - -- | The set of function refinements to assume - mriRefnset :: Refnset t, - -- | The current context of universal variables - mriUVars :: MRVarCtx, - -- | The current set of co-inductive hypotheses - mriCoIndHyps :: CoIndHyps, - -- | The current assumptions, which are conjoined into a single Boolean term; - -- note that these have the current UVars free - mriAssumptions :: Term, - -- | The current set of 'DataTypeAssump's - mriDataTypeAssumps :: DataTypeAssumps -} - --- | State maintained by MR. Solver -data MRState t = MRState { - -- | Cumulative stats on all solver runs made so far - mrsSolverStats :: SolverStats, - -- | The evidence object, which includes information about which - -- 'FunAssump's in 'mriRefnset' have been used so far - mrsEvidence :: MREvidence t, - -- | The existential and letrec-bound variables - mrsVars :: MRVarMap -} - --- | The exception type for MR. Solver, which is either a 'MRFailure' or a --- widening request -data MRExn = MRExnFailure MRFailure - -- | A widening request gives two recursive function names whose - -- coinductive assumption needs to be widened along with a list of - -- indices into the argument lists for these functions (in either - -- the arguments to the 'Left' or 'Right' function) that need to be - -- generalized - | MRExnWiden FunName FunName [Either Int Int] - deriving Show - --- | Mr. Monad, the monad used by MR. Solver, which has 'MRInfo' as as a --- shared environment, 'MRState' as state, and 'MRFailure' as an exception --- type, all over an 'IO' monad -newtype MRM t a = MRM { unMRM :: ReaderT (MRInfo t) (StateT (MRState t) - (ExceptT MRExn TopLevel)) a } - deriving newtype (Functor, Applicative, Monad, MonadIO, - MonadReader (MRInfo t), MonadState (MRState t), - MonadError MRExn, MonadThrow, MonadCatch) - -instance MonadTerm (MRM t) where - mkTermF = liftSC1 scTermF - liftTerm = liftSC3 incVars - substTerm = liftSC3 instantiateVarList - --- | Get the current value of 'mriSC' -mrSC :: MRM t SharedContext -mrSC = mriSC <$> ask - --- | Get the current value of 'mriSMTTimeout' -mrSMTTimeout :: MRM t (Maybe Integer) -mrSMTTimeout = mriSMTTimeout <$> ask - --- | Get the current value of 'mriUVars' -mrUVars :: MRM t MRVarCtx -mrUVars = mriUVars <$> ask - --- | Get the current function assumptions -mrRefnset :: MRM t (Refnset t) -mrRefnset = mriRefnset <$> ask - --- | Get the current value of 'mriCoIndHyps' -mrCoIndHyps :: MRM t CoIndHyps -mrCoIndHyps = mriCoIndHyps <$> ask - --- | Get the current value of 'mriAssumptions' -mrAssumptions :: MRM t Term -mrAssumptions = mriAssumptions <$> ask - --- | Get the current value of 'mriDataTypeAssumps' -mrDataTypeAssumps :: MRM t DataTypeAssumps -mrDataTypeAssumps = mriDataTypeAssumps <$> ask - --- | Call the SMT backend given by 'mriAskSMT' on a set of uninterpreted --- variables and a proposition to prove -mrAskSMT :: Set VarIndex -> Sequent -> MRM t (SolverStats, SolveResult) -mrAskSMT unints goal = do - askSMT <- mriAskSMT <$> ask - MRM $ lift $ lift $ lift $ askSMT unints goal - --- | Get the current debug level -mrDebugLevel :: MRM t Int -mrDebugLevel = mreDebugLevel <$> mriEnv <$> ask - --- | Get the current pretty-printing options -mrPPOpts :: MRM t PPS.Opts -mrPPOpts = mrePPOpts <$> mriEnv <$> ask - --- | Get the current value of 'mriEnv' -mrEnv :: MRM t MREnv -mrEnv = mriEnv <$> ask - --- | Get the current value of 'mrsSolverStats' -mrSolverStats :: MRM t SolverStats -mrSolverStats = mrsSolverStats <$> get - --- | Get the current value of 'mrsEvidence' -mrEvidence :: MRM t (MREvidence t) -mrEvidence = mrsEvidence <$> get - --- | Get the current value of 'mrsVars' -mrVars :: MRM t MRVarMap -mrVars = mrsVars <$> get - --- | Run a 'PPInCtxM' computation in the current context and with the current --- 'PPOpts' -mrPPInCtxM :: PPInCtxM a -> MRM t a -mrPPInCtxM m = mrPPOpts >>= \opts -> mrUVars >>= \ctx -> - return $ runPPInCtxM m opts ctx - --- | Pretty-print an object in the current context and with the current 'PPOpts' -mrPPInCtx :: PrettyInCtx a => a -> MRM t PPS.Doc -mrPPInCtx a = mrPPOpts >>= \opts -> mrUVars >>= \ctx -> - return $ ppInCtx opts ctx a - --- | Pretty-print an object in the current context and render to a 'String' with --- the current 'PPOpts' -mrShowInCtx :: PrettyInCtx a => a -> MRM t String -mrShowInCtx a = mrPPOpts >>= \opts -> mrUVars >>= \ctx -> - return $ showInCtx opts ctx a - - --- | Run an 'MRM' computation and return a result or an error, including the --- final state of 'mrsSolverStats' and 'mrsEvidence' -runMRM :: - SharedContext -> - MREnv {- ^ The Mr Solver environment -} -> - Maybe Integer {- ^ Timeout in milliseconds for each SMT call -} -> - (Set VarIndex -> Sequent -> TopLevel (SolverStats, SolveResult)) - {- ^ The callback to use for making SMT queries -} -> - Refnset t {- ^ Any additional refinements to be assumed by Mr Solver -} -> - MRM t a {- ^ The monadic computation to run -} -> - TopLevel (Either MRFailure (a, (SolverStats, MREvidence t))) -runMRM sc env timeout askSMT rs m = - do true_tm <- liftIO $ scBool sc True - let init_info = MRInfo { mriSC = sc, mriSMTTimeout = timeout, - mriEnv = env, mriAskSMT = askSMT, - mriRefnset = rs, - mriUVars = emptyMRVarCtx, - mriCoIndHyps = Map.empty, - mriAssumptions = true_tm, - mriDataTypeAssumps = HashMap.empty } - let init_st = MRState { mrsSolverStats = mempty, mrsEvidence = mempty, - mrsVars = Map.empty } - res <- runExceptT $ flip runStateT init_st $ - flip runReaderT init_info $ unMRM m - case res of - Right (a, st) -> return $ Right (a, (mrsSolverStats st, mrsEvidence st)) - Left (MRExnFailure failure) -> return $ Left failure - Left exn -> fail ("runMRM: unexpected internal exception: " ++ show exn) - --- | Run an 'MRM' computation and return a result or an error, discarding the --- final state -evalMRM :: - SharedContext -> - MREnv {- ^ The Mr Solver environment -} -> - Maybe Integer {- ^ Timeout in milliseconds for each SMT call -} -> - (Set VarIndex -> Sequent -> TopLevel (SolverStats, SolveResult)) - {- ^ The callback to use for making SMT queries -} -> - Refnset t {- ^ Any additional refinements to be assumed by Mr Solver -} -> - MRM t a {- ^ The monadic computation to eval -} -> - TopLevel (Either MRFailure a) -evalMRM sc env timeout askSMT rs = - fmap (fmap fst) . runMRM sc env timeout askSMT rs - --- | Run an 'MRM' computation and return a final state or an error, discarding --- the result -execMRM :: - SharedContext -> - MREnv {- ^ The Mr Solver environment -} -> - Maybe Integer {- ^ Timeout in milliseconds for each SMT call -} -> - (Set VarIndex -> Sequent -> TopLevel (SolverStats, SolveResult)) - {- ^ The callback to use for making SMT queries -} -> - Refnset t {- ^ Any additional refinements to be assumed by Mr Solver -} -> - MRM t a {- ^ The monadic computation to exec -} -> - TopLevel (Either MRFailure (SolverStats, MREvidence t)) -execMRM sc env timeout askSMT rs = - fmap (fmap snd) . runMRM sc env timeout askSMT rs - --- | Throw an 'MRFailure' -throwMRFailure :: MRFailure -> MRM t a -throwMRFailure = throwError . MRExnFailure - --- | Apply a function to any failure thrown by an 'MRM' computation -mapMRFailure :: (MRFailure -> MRFailure) -> MRM t a -> MRM t a -mapMRFailure f m = catchError m $ \case - MRExnFailure failure -> throwError $ MRExnFailure $ f failure - e -> throwError e - --- | Catch any 'MRFailure' raised by a computation -catchFailure :: MRM t a -> (MRFailure -> MRM t a) -> MRM t a -catchFailure m f = - m `catchError` \case - MRExnFailure failure -> f failure - e -> throwError e - --- | Try two different 'MRM' computations, combining their failures if needed. --- Note that the 'MRState' will reset if the first computation fails. -mrOr :: MRM t a -> MRM t a -> MRM t a -mrOr m1 m2 = - catchFailure m1 $ \err1 -> - catchFailure m2 $ \err2 -> - throwMRFailure $ MRFailureDisj err1 err2 - --- | Run an 'MRM' computation in an extended failure context -withFailureCtx :: FailCtx -> MRM t a -> MRM t a -withFailureCtx ctx = mapMRFailure (MRFailureCtx ctx) - -{- --- | Catch any errors thrown by a computation and coerce them to a 'Left' -catchErrorEither :: MonadError e m => m a -> m (Either e a) -catchErrorEither m = catchError (Right <$> m) (return . Left) --} - --- FIXME: replace these individual lifting functions with a more general --- typeclass like LiftTCM - --- | Lift a nullary SharedTerm computation into 'MRM' -liftSC0 :: (SharedContext -> IO a) -> MRM t a -liftSC0 f = mrSC >>= \sc -> liftIO (f sc) - --- | Lift a unary SharedTerm computation into 'MRM' -liftSC1 :: (SharedContext -> a -> IO b) -> a -> MRM t b -liftSC1 f a = mrSC >>= \sc -> liftIO (f sc a) - --- | Lift a binary SharedTerm computation into 'MRM' -liftSC2 :: (SharedContext -> a -> b -> IO c) -> a -> b -> MRM t c -liftSC2 f a b = mrSC >>= \sc -> liftIO (f sc a b) - --- | Lift a ternary SharedTerm computation into 'MRM' -liftSC3 :: (SharedContext -> a -> b -> c -> IO d) -> a -> b -> c -> MRM t d -liftSC3 f a b c = mrSC >>= \sc -> liftIO (f sc a b c) - --- | Lift a quaternary SharedTerm computation into 'MRM' -liftSC4 :: (SharedContext -> a -> b -> c -> d -> IO e) -> a -> b -> c -> d -> - MRM t e -liftSC4 f a b c d = mrSC >>= \sc -> liftIO (f sc a b c d) - --- | Lift a quinary SharedTerm computation into 'MRM' -liftSC5 :: (SharedContext -> a -> b -> c -> d -> e -> IO f) -> - a -> b -> c -> d -> e -> MRM t f -liftSC5 f a b c d e = mrSC >>= \sc -> liftIO (f sc a b c d e) - - ----------------------------------------------------------------------- --- * Functions for Building Terms ----------------------------------------------------------------------- - --- | Create a term representing an application of @Prelude.error@ -mrErrorTerm :: Term -> T.Text -> MRM t Term -mrErrorTerm a str = - do err_str <- liftSC1 scString str - liftSC2 scGlobalApply "Prelude.error" [a, err_str] - --- | Create a term representing an application of @Prelude.genBVVecFromVec@, --- where the default value argument is @Prelude.error@ of the given 'T.Text' -mrGenBVVecFromVec :: Term -> Term -> Term -> T.Text -> Term -> Term -> MRM t Term -mrGenBVVecFromVec m a v def_err_str n len = - do err_tm <- mrErrorTerm a def_err_str - liftSC2 scGlobalApply "Prelude.genBVVecFromVec" [m, a, v, err_tm, n, len] - --- | Create a term representing an application of @Prelude.genFromBVVec@, --- where the default value argument is @Prelude.error@ of the given 'T.Text' -mrGenFromBVVec :: Term -> Term -> Term -> Term -> T.Text -> Term -> MRM t Term -mrGenFromBVVec n len a v def_err_str m = - do err_tm <- mrErrorTerm a def_err_str - liftSC2 scGlobalApply "Prelude.genFromBVVec" [n, len, a, v, err_tm, m] - --- | Match a lambda of the form @(\i _ -> f i)@ as @f@ -asIndexWithProofFnTerm :: Recognizer Term (SharedContext -> IO Term) -asIndexWithProofFnTerm (asLambdaList -> ([(ix_nm, ix_tp), _], e)) - | not $ inBitSet 0 $ looseVars e - = Just $ \sc -> - do ix_var <- scLocalVar sc 0 - -- Substitute an error term for the proof variable and ix_var for ix in - -- the body e of the lambda - let s = [error "asGen(BV)VecTerm: unexpected var occurrence", ix_var] - e' <- instantiateVarList sc 0 s e - scLambda sc ix_nm ix_tp e' -asIndexWithProofFnTerm _ = Nothing - --- | Match a term of the form @gen n a f@ or @genWithProof n a (\i _ -> f i)@ -asGenVecTerm :: Recognizer Term (Term, Term, SharedContext -> IO Term) -asGenVecTerm (asApplyAll -> (isGlobalDef "Prelude.gen" -> Just _, - [n, a, f])) - = Just (n, a, const $ return f) -asGenVecTerm (asApplyAll -> (isGlobalDef "Prelude.genWithProof" -> Just _, - [n, a, asIndexWithProofFnTerm -> Just m_f])) - = Just (n, a, m_f) -asGenVecTerm _ = Nothing - --- | Match a term of the form @genBVVecNoPf n len a f@ or --- @genBVVec n len a (\i _ -> f i)@ -asGenBVVecTerm :: Recognizer Term (Term, Term, Term, SharedContext -> IO Term) -asGenBVVecTerm (asApplyAll -> (isGlobalDef "Prelude.genBVVecNoPf" -> Just _, - [n, len, a, f])) - = Just (n, len, a, const $ return f) -asGenBVVecTerm (asApplyAll -> (isGlobalDef "Prelude.genBVVec" -> Just _, - [n, len, a, asIndexWithProofFnTerm -> Just m_f])) - = Just (n, len, a, m_f) -asGenBVVecTerm _ = Nothing - --- | Index into a vector using the @at@ accessor, taking in the same 'Term' --- arguments as that function, but simplify when the vector is a term --- constructed from @gen@ or @genWithProof@ -mrAtVec :: Term -> Term -> Term -> Term -> MRM t Term -mrAtVec _ _ (asGenVecTerm -> Just (_, _, m_f)) ix = - liftSC0 m_f >>= \f -> mrApply f ix -mrAtVec len a v ix = - liftSC2 scGlobalApply "Prelude.at" [len, a, v, ix] - --- | Index into a vector using the @atBVVecNoPf@ accessor, taking in the same --- 'Term' arguments as that function, but simplify when the vector is a term --- constructed from @gen@ or @genWithProof@ -mrAtBVVec :: Term -> Term -> Term -> Term -> Term -> MRM t Term -mrAtBVVec _ _ _ (asGenBVVecTerm -> Just (_, _, _, m_f)) ix = - liftSC0 m_f >>= \f -> mrApply f ix -mrAtBVVec n len a v ix = - liftSC2 scGlobalApply "Prelude.atBVVecNoPf" [n, len, a, v, ix] - - ----------------------------------------------------------------------- --- * Monadic Operations on Terms ----------------------------------------------------------------------- - --- | Apply a 'TermProj' to perform a projection on a 'Term' -doTermProj :: Term -> TermProj -> MRM t Term -doTermProj (asPairValue -> Just (t, _)) TermProjLeft = return t -doTermProj (asPairValue -> Just (_, t)) TermProjRight = return t -doTermProj (asRecordValue -> Just t_map) (TermProjRecord fld) - | Just t <- Map.lookup fld t_map = return t -doTermProj t TermProjLeft = liftSC1 scPairLeft t -doTermProj t TermProjRight = liftSC1 scPairRight t -doTermProj t (TermProjRecord fld) = liftSC2 scRecordSelect t fld - --- | Apply a 'TermProj' to a type to get the output type of the projection, --- assuming that the type is already normalized -doTypeProj :: Term -> TermProj -> MRM t Term -doTypeProj (asPairType -> Just (tp1, _)) TermProjLeft = return tp1 -doTypeProj (asPairType -> Just (_, tp2)) TermProjRight = return tp2 -doTypeProj (asRecordType -> Just tp_map) (TermProjRecord fld) - | Just tp <- Map.lookup fld tp_map - = return tp -doTypeProj _ _ = - -- FIXME: better error message? This is an error and not an MRFailure because - -- we should only be projecting types for terms that we have already seen... - error "doTypeProj" - --- | Get and normalize the type of a 'FunName' -funNameType :: FunName -> MRM t Term -funNameType (CallSName var) = liftSC1 scWhnf $ mrVarType var -funNameType (EVarFunName var) = liftSC1 scWhnf $ mrVarType var -funNameType (GlobalName gd projs) = - liftSC1 scWhnf (globalDefType gd) >>= \gd_tp -> - foldM doTypeProj gd_tp projs - --- | Apply a 'Term' to a list of arguments and beta-reduce in Mr. Monad -mrApplyAll :: Term -> [Term] -> MRM t Term -mrApplyAll f args = liftSC2 scApplyAllBeta f args - --- | Apply a 'Term' to a single argument and beta-reduce in Mr. Monad -mrApply :: Term -> Term -> MRM t Term -mrApply f arg = mrApplyAll f [arg] - --- | Substitue a list of @N@ arguments into the body of an @N@-ary pi type -mrPiApplyAll :: Term -> [Term] -> MRM t Term -mrPiApplyAll tp args - | Just (_, body) <- asPiListN (length args) tp - = substTermLike 0 args body -mrPiApplyAll _ _ = panic "mrPiApplyAll" ["Too many arguments for pi type"] - --- | Return the unit type as a 'Type' -mrUnitType :: MRM t Type -mrUnitType = Type <$> liftSC0 scUnitType - --- | Build a constructor application in Mr. Monad -mrCtorApp :: Ident -> [Term] -> MRM t Term -mrCtorApp = liftSC2 scGlobalApply - --- | Build a 'Term' for a global in Mr. Monad -mrGlobalTerm :: Ident -> MRM t Term -mrGlobalTerm = liftSC1 scGlobalDef - --- | Build a 'Term' for a global and unfold the global -mrGlobalTermUnfold :: Ident -> MRM t Term -mrGlobalTermUnfold ident = - (defBody <$> liftSC1 scRequireDef ident) >>= \case - Just body -> return body - Nothing -> panic "mrGlobalTermUnfold" ["Definition " <> identText ident <> - " does not have a body"] - --- | Apply a named global to a list of arguments and beta-reduce in Mr. Monad -mrApplyGlobal :: Ident -> [Term] -> MRM t Term -mrApplyGlobal f args = mrGlobalTerm f >>= \t -> mrApplyAll t args - --- | Build an arrow type @a -> b@ using a return type @b@ that does not have an --- additional free deBruijn index for the input -mrArrowType :: LocalName -> Term -> Term -> MRM t Term -mrArrowType n tp_in tp_out = - liftSC3 scPi n tp_in =<< liftTermLike 0 1 tp_out - --- | Build the bitvector type @Vec n Bool@ from natural number term @n@ -mrBvType :: Term -> MRM t Term -mrBvType n = - do bool_tp <- liftSC0 scBoolType - liftSC2 scVecType n bool_tp - --- | Build the equality proposition @Eq a t1 t2@ -mrEqProp :: Term -> Term -> Term -> MRM t Term -mrEqProp tp t1 t2 = liftSC2 scGlobalApply "Prelude.Eq" [tp,t1,t2] - --- | Like 'scBvConst', but if given a bitvector literal it is converted to a --- natural number literal -mrBvToNat :: Term -> Term -> MRM t Term -mrBvToNat _ (asArrayValue -> Just (asBoolType -> Just _, - mapM asBool -> Just bits)) = - liftSC1 scNat $ foldl' (\n bit -> if bit then 2*n+1 else 2*n) 0 bits -mrBvToNat n len = liftSC2 scGlobalApply "Prelude.bvToNat" [n, len] - --- | Given a bit-width 'Term' and a natural number 'Term', return a bitvector --- 'Term' of the given bit-width only if we can can do so without truncation --- (i.e. only if we can ensure the given natural is in range) -mrBvNatInRange :: Term -> Term -> MRM t (Maybe Term) -mrBvNatInRange (asNat -> Just w) (asUnsignedConcreteBvToNat -> Just v) - | v < 2 ^ w = Just <$> liftSC2 scBvLit w (toInteger v) -mrBvNatInRange w (asBvToNat -> Just (w', bv)) = - mrBvCastInRange w w' bv -mrBvNatInRange w (asApplyAll -> (asGlobalDef -> Just "Prelude.intToNat", - [i])) = case i of - (asApplyAll -> (asGlobalDef -> Just "Prelude.natToInt", [v])) -> - mrBvNatInRange w v - (asApplyAll -> (asGlobalDef -> Just "Prelude.bvToInt", [w', bv])) -> - mrBvCastInRange w w' bv - _ -> return Nothing -mrBvNatInRange _ _ = return Nothing - --- | Given two bit-width 'Term's and a bitvector 'Term' of the second bit-width, --- return a bitvector 'Term' of the first bit-width only if we can can do so --- without truncation (i.e. only if we can ensure the given bitvector is in --- range) -mrBvCastInRange :: Term -> Term -> Term -> MRM t (Maybe Term) -mrBvCastInRange w1_t w2_t bv = - do w1_w2_cvt <- mrConvertible w1_t w2_t - if w1_w2_cvt then return $ Just bv - else case (asNat w1_t, asNat w1_t, asUnsignedConcreteBv bv) of - (Just w1, _, Just v) | v < 2 ^ w1 -> - Just <$> liftSC2 scBvLit w1 (toInteger v) - (Just w1, Just w2, _) | w1 > w2 -> - do w1_sub_w2_t <- liftSC1 scNat (w1 - w2) - Just <$> liftSC3 scBvUExt w2_t w1_sub_w2_t bv - _ -> return Nothing - --- | Get the current context of uvars as a list of variable names and their --- types as SAW core 'Term's, with the least recently bound uvar first, i.e., in --- the order as seen \"from the outside\" -mrUVarsOuterToInner :: MRM t [(LocalName,Term)] -mrUVarsOuterToInner = mrVarCtxOuterToInner <$> mrUVars - --- | Get the current context of uvars as a list of variable names and their --- types as SAW core 'Term's, with the most recently bound uvar first, i.e., in --- the order as seen \"from the inside\" -mrUVarsInnerToOuter :: MRM t [(LocalName,Term)] -mrUVarsInnerToOuter = mrVarCtxInnerToOuter <$> mrUVars - --- | Get the type of a 'Term' in the current uvar context -mrTypeOf :: Term -> MRM t Term -mrTypeOf t = - -- NOTE: scTypeOf' wants the type context in the most recently bound var first - -- mrDebugPPPrefix 3 "mrTypeOf:" t >> - mrUVarsInnerToOuter >>= \ctx -> liftSC2 scTypeOf' (map snd ctx) t - --- | Check if two 'Term's are convertible in the 'MRM' monad -mrConvertible :: Term -> Term -> MRM t Bool -mrConvertible = liftSC4 scConvertibleEval scTypeCheckWHNF True - --- | Take a 'FunName' @f@ for a monadic function of type @vars -> SpecM a@ and --- compute the type @SpecM [args/vars]a@ of @f@ applied to @args@. Return the --- type @[args/vars]a@ that @SpecM@ is applied to, along with its event type. -mrFunOutType :: FunName -> [Term] -> MRM t (EvTerm, Term) -mrFunOutType fname args = - do app <- mrApplyAll (funNameTerm fname) args - r_tp <- mrTypeOf app >>= liftSC1 scWhnf - case asSpecM r_tp of - Just (ev, tp) -> return (ev, tp) - Nothing -> throwMRFailure (NotCompFunType r_tp app) - --- | Turn a 'LocalName' into one not in a list, adding a suffix if necessary -uniquifyName :: LocalName -> [LocalName] -> LocalName -uniquifyName nm nms | notElem nm nms = nm -uniquifyName nm nms = - case find (flip notElem nms) $ - map (T.append nm . T.pack . show) [(0::Int) ..] of - Just nm' -> nm' - Nothing -> error "uniquifyName" - --- | Turn a list of 'LocalName's into one names not in a list, adding suffixes --- if necessary -uniquifyNames :: [LocalName] -> [LocalName] -> [LocalName] -uniquifyNames [] _ = [] -uniquifyNames (nm:nms) nms_other = - let nm' = uniquifyName nm nms_other in - nm' : uniquifyNames nms (nm' : nms_other) - --- | Build a lambda term with the lifting (in the sense of 'incVars') of an --- MR Solver term --- NOTE: The types in the given context can have earlier variables in the --- context free. Thus, if passing a list of types all in the same context, later --- types should be lifted. -mrLambdaLift :: TermLike tm => [(LocalName,Term)] -> tm -> - ([Term] -> tm -> MRM t Term) -> MRM t Term -mrLambdaLift [] t f = f [] t -mrLambdaLift ctx t f = - do -- uniquifyNames doesn't care about the order of the names in its second, - -- argument, thus either inner-to-outer or outer-to-inner would work - nms <- uniquifyNames (map fst ctx) <$> map fst <$> mrUVarsInnerToOuter - let ctx' = zipWith (\nm (_,tp) -> (nm,tp)) nms ctx - vars <- reverse <$> mapM (liftSC1 scLocalVar) [0 .. length ctx - 1] - t' <- liftTermLike 0 (length ctx) t - f vars t' >>= liftSC2 scLambdaList ctx' - --- Specialized versions of mrLambdaLift that expect a certain number of Term --- arguments. As an alternative, we could change the type of mrLambdaLift to --- take a length-indexed vector instead (thereby avoiding partial pattern --- matches), but that is probably overkill for our needs. - --- | Call 'mrLambdaLift' with exactly one 'Term' argument. -mrLambdaLift1 :: TermLike tm => (LocalName,Term) -> tm -> - (Term -> tm -> MRM t Term) -> MRM t Term -mrLambdaLift1 (nm,tp) t f = - mrLambdaLift [(nm,tp)] t $ \vars t' -> - case vars of - [v] -> f v t' - _ -> panic "mrLambdaLift1" ["Expected exactly one Term argument"] - --- | Call 'mrLambdaLift' with exactly two 'Term' arguments which are both in the --- same context. (To create two lambdas where the type of the second variable --- depends on the value of the first, use 'mrLambdaLift' directly.) -mrLambdaLift2 :: TermLike tm => (LocalName,Term) -> (LocalName,Term) -> tm -> - (Term -> Term -> tm -> MRM t Term) -> MRM t Term -mrLambdaLift2 (nm1,tp1) (nm2,tp2) t f = - liftTermLike 0 1 tp2 >>= \tp2' -> - mrLambdaLift [(nm1,tp1), (nm2,tp2')] t $ \vars t' -> - case vars of - [v1, v2] -> f v1 v2 t' - _ -> panic "mrLambdaLift2" ["Expected exactly two Term arguments"] - --- | Run a MR Solver computation in a context extended with a universal --- variable, which is passed as a 'Term' to the sub-computation. Note that any --- assumptions made in the sub-computation will be lost when it completes. -withUVar :: LocalName -> Type -> (Term -> MRM t a) -> MRM t a -withUVar nm tp m = withUVars (singletonMRVarCtx nm tp) $ \case - [v] -> m v - _ -> panic "withUVar" ["impossible"] - --- | Run a MR Solver computation in a context extended with a universal variable --- and pass it the lifting (in the sense of 'incVars') of an MR Solver term -withUVarLift :: TermLike tm => LocalName -> Type -> tm -> - (Term -> tm -> MRM t a) -> MRM t a -withUVarLift nm tp t m = - withUVar nm tp (\x -> liftTermLike 0 1 t >>= m x) - --- | Run a MR Solver computation in a context extended with a list of universal --- variables, passing 'Term's for those variables to the supplied computation. -withUVars :: MRVarCtx -> ([Term] -> MRM t a) -> MRM t a -withUVars (mrVarCtxLength -> 0) f = f [] -withUVars ctx f = - do -- for uniquifyNames, we want to consider the oldest names first, thus we - -- must pass the first argument in outer-to-inner order. uniquifyNames - -- doesn't care about the order of the names in its second, argument, thus - -- either inner-to-outer or outer-to-inner would work - let ctx_l = mrVarCtxOuterToInner ctx - nms <- uniquifyNames (map fst ctx_l) <$> map fst <$> mrUVarsInnerToOuter - let ctx_u = mrVarCtxFromOuterToInner $ zip nms $ map snd ctx_l - -- lift all the variables in our assumptions by the number of new uvars - -- we're adding (we do not have to lift the types in our uvar context - -- itself, since each type is in the context of all older uvars - see the - -- definition of MRVarCtx) - assumps' <- mrAssumptions >>= liftTerm 0 (mrVarCtxLength ctx) - dataTypeAssumps' <- mrDataTypeAssumps >>= mapM (liftTermLike 0 (mrVarCtxLength ctx)) - -- make terms for our new uvars, extend the context, and continue - vars <- reverse <$> mapM (liftSC1 scLocalVar) [0 .. mrVarCtxLength ctx - 1] - local (\info -> info { mriUVars = mrVarCtxAppend ctx_u (mriUVars info), - mriAssumptions = assumps', - mriDataTypeAssumps = dataTypeAssumps' }) $ - mapM (\t -> (t,) <$> mrTypeOf t) vars >>= \vars_with_types -> - mrDebugPPPrefix 3 "withUVars:" vars_with_types >> - foldr (\nm m -> mapMRFailure (MRFailureLocalVar nm) m) (f vars) nms - --- | Run a MR Solver in a top-level context, i.e., with no uvars or assumptions -withNoUVars :: MRM t a -> MRM t a -withNoUVars m = - do true_tm <- liftSC1 scBool True - local (\info -> info { mriUVars = emptyMRVarCtx, mriAssumptions = true_tm, - mriDataTypeAssumps = HashMap.empty }) m - --- | Run a MR Solver in a context of only the specified UVars, no others - --- note that this also clears all assumptions -withOnlyUVars :: MRVarCtx -> MRM t a -> MRM t a -withOnlyUVars vars m = withNoUVars $ withUVars vars $ const m - --- | Build 'Term's for all the uvars currently in scope, ordered from least to --- most recently bound -getAllUVarTerms :: MRM t [Term] -getAllUVarTerms = - (mrVarCtxLength <$> mrUVars) >>= \len -> - mapM (liftSC1 scLocalVar) [len-1, len-2 .. 0] - --- | Lambda-abstract all the current uvars out of a 'Term', with the least --- recently bound variable being abstracted first -lambdaUVarsM :: Term -> MRM t Term -lambdaUVarsM t = mrUVarsOuterToInner >>= \ctx -> liftSC2 scLambdaList ctx t - --- | Pi-abstract all the current uvars out of a 'Term', with the least recently --- bound variable being abstracted first -piUVarsM :: Term -> MRM t Term -piUVarsM t = mrUVarsOuterToInner >>= \ctx -> liftSC2 scPiList ctx t - --- | Instantiate all uvars in a term using the supplied function -instantiateUVarsM :: forall a t. TermLike a => - (LocalName -> Term -> MRM t Term) -> a -> MRM t a -instantiateUVarsM f a = - do ctx <- mrUVarsOuterToInner - -- Remember: the uvar context is outermost to innermost, so we bind - -- variables from left to right, substituting earlier ones into the types - -- of later ones, but all substitutions are in reverse order, since - -- substTerm and friends like innermost bindings first - let helper :: [Term] -> [(LocalName,Term)] -> MRM t [Term] - helper tms [] = return tms - helper tms ((nm,tp):vars) = - do tp' <- substTerm 0 tms tp - tm <- f nm tp' - helper (tm:tms) vars - ecs <- helper [] ctx - substTermLike 0 ecs a - --- | Convert an 'MRVar' to a 'Term', applying it to all the uvars in scope -mrVarTerm :: MRVar -> MRM t Term -mrVarTerm (MRVar ec) = - do var_tm <- liftSC1 scVariable ec - vars <- getAllUVarTerms - liftSC2 scApplyAll var_tm vars - --- | Create a dummy proof term of the specified type, which can be open but --- should be of @Prop@ sort, by creating an 'ExtCns' axiom. This is sound as --- long as we only use the resulting term in computation branches where we know --- the proposition holds. -mrDummyProof :: Term -> MRM t Term -mrDummyProof tp = mrFreshVar "pf" tp >>= mrVarTerm - --- | Get the 'VarInfo' associated with a 'MRVar' -mrVarInfo :: MRVar -> MRM t (Maybe MRVarInfo) -mrVarInfo var = Map.lookup var <$> mrVars - --- | Convert an 'ExtCns' to a 'FunName' -extCnsToFunName :: ExtCns Term -> MRM t FunName -extCnsToFunName ec = - do let var = MRVar ec - mm <- liftSC0 scGetModuleMap - let ?mm = mm - mrVarInfo var >>= \case - Just (EVarInfo _ _) -> return $ EVarFunName var - Just (CallVarInfo _) -> return $ CallSName var - Nothing - | Just glob <- asTypedGlobalDef (Unshared $ Variable ec) -> - return $ GlobalName glob [] - _ -> error "extCnsToFunName: unreachable" - --- | Get the body of a global definition, raising an 'error' if none is found -mrGlobalDefBody :: Ident -> MRM t Term -mrGlobalDefBody ident = liftSC1 scFindDef ident >>= \case - Just (defBody -> Just body) -> pure body - _ -> error $ "mrGlobalDefBody: global has no definition: " ++ show ident - --- | Get the body of a function @f@ if it has one -mrFunNameBody :: FunName -> MRM t (Maybe Term) -mrFunNameBody (CallSName var) = - mrVarInfo var >>= \case - Just (CallVarInfo body) -> return $ Just body - _ -> error "mrFunBody: unknown letrec var" -mrFunNameBody (GlobalName glob projs) = - do mm <- liftSC0 scGetModuleMap - case lookupVarIndexInMap (nameIndex (globalDefName glob)) mm of - Just (ResolvedDef (defBody -> Just body)) -> - Just <$> foldM doTermProj body projs - _ -> pure Nothing -mrFunNameBody (EVarFunName _) = return Nothing - --- | Get the body of a function @f@ applied to some arguments, if possible -mrFunBody :: FunName -> [Term] -> MRM t (Maybe Term) -mrFunBody f args = mrFunNameBody f >>= \case - Just body -> Just <$> mrApplyAll body args - Nothing -> return Nothing - --- | Get the body of a function @f@ applied to some arguments, as per --- 'mrFunBody', and also return whether its body recursively calls itself, as --- per 'mrCallsFun' -mrFunBodyRecInfo :: FunName -> [Term] -> MRM t (Maybe (Term, Bool)) -mrFunBodyRecInfo f args = - mrFunNameBody f >>= \case - Just body -> do - body_applied <- mrApplyAll body args - is_recursive <- mrCallsFun f body - return $ Just (body_applied, is_recursive) - Nothing -> return Nothing - --- | Test if a 'Term' contains, after possibly unfolding some functions, a call --- to a given function @f@ again -mrCallsFun :: FunName -> Term -> MRM t Bool -mrCallsFun f t0 = - do mm <- liftSC0 scGetModuleMap - let ?mm = mm - let fn recurse seen t = - let onFunName g = mrFunNameBody g >>= \case - _ | f == g -> return True - Just body | Set.notMember g seen -> recurse (Set.insert g seen) body - _ -> return False - in case t of - (asVariable -> Just ec) -> extCnsToFunName ec >>= onFunName - (asGlobalFunName -> Just g) -> onFunName g - (unwrapTermF -> tf) -> - foldM (\b t' -> if b then return b else recurse seen t') False tf - memoFixTermFunAccum fn Set.empty t0 - - ----------------------------------------------------------------------- --- * Monadic Operations on Mr. Solver State ----------------------------------------------------------------------- - --- | Make a fresh 'MRVar' of a given type, which must be closed, i.e., have no --- free uvars -mrFreshVarCl :: LocalName -> Term -> MRM t MRVar -mrFreshVarCl nm tp = MRVar <$> liftSC2 scFreshEC nm tp - --- | Make a fresh 'MRVar' of type @(u1:tp1) -> ... (un:tpn) -> tp@, where the --- @ui@ are all the current uvars -mrFreshVar :: LocalName -> Term -> MRM t MRVar -mrFreshVar nm tp = piUVarsM tp >>= mrFreshVarCl nm - --- | Set the info associated with an 'MRVar', assuming it has not been set -mrSetVarInfo :: MRVar -> MRVarInfo -> MRM t () -mrSetVarInfo var info = - mrDebugPPInCtxM 3 (prettyWithCtx emptyMRVarCtx $ - prettyPrefixSep "mrSetVarInfo" var "=" info) >> - (modify $ \st -> - st { mrsVars = - Map.alter (\case - Just _ -> error "mrSetVarInfo" - Nothing -> Just info) - var (mrsVars st) }) - --- | Make a fresh existential variable of the given type, abstracting out all --- the current uvars and returning the new evar applied to all current uvars -mrFreshEVar :: LocalName -> Type -> MRM t Term -mrFreshEVar nm (Type tp) = - do var <- mrFreshVar nm tp - ctx_len <- mrVarCtxLength <$> mrUVars - mrSetVarInfo var (EVarInfo ctx_len Nothing) - mrVarTerm var - --- | Return a fresh sequence of existential variables from a 'MRVarCtx'. --- Return the new evars all applied to the current uvars. -mrFreshEVars :: MRVarCtx -> MRM t [Term] -mrFreshEVars = helper [] . mrVarCtxOuterToInner where - -- Return fresh evars for the suffix of a context of variable names and types, - -- where the supplied Terms are evars that have already been generated for the - -- earlier part of the context, and so must be substituted into the remaining - -- types in the context. Since we want to make fresh evars for the oldest - -- variables first, the second argument must be in outer-to-inner order. - helper :: [Term] -> [(LocalName,Term)] -> MRM t [Term] - helper evars [] = return evars - helper evars ((nm,tp):ctx) = - do evar <- substTerm 0 evars tp >>= mrFreshEVar nm . Type - helper (evar:evars) ctx - --- | Set the value of an evar to a closed term -mrSetEVarClosed :: MRVar -> Term -> MRM t () -mrSetEVarClosed var val = - do val_tp <- mrTypeOf val - -- NOTE: need to instantiate any evars in the type of var, to ensure the - -- following subtyping check will succeed - var_tp <- mrSubstEVars $ mrVarType var - -- FIXME: catch subtyping errors and report them as being evar failures - eith_err <- - liftSC2 (runTCM $ checkSubtype (SCTypedTerm val val_tp) var_tp) Nothing [] - case eith_err of - Left _ -> - error ("mrSetEVarClosed: incorrect instantiation for evar " ++ - showMRVar var ++ - "\nexpected type:\n" ++ showTerm var_tp ++ - "\nactual type:\n" ++ showTerm val_tp) - Right _ -> return () - modify $ \st -> - st { mrsVars = - Map.alter - (\case - Just (EVarInfo clen Nothing) -> Just $ EVarInfo clen (Just val) - Just (EVarInfo _ (Just _)) -> - error "Setting existential variable: variable already set!" - _ -> error "Setting existential variable: not an evar!") - var (mrsVars st) } - - --- | Try to set the value of the application @X e1 .. en@ of evar @X@ to an --- expression @e@ by trying to set @X@ to @\ x1 ... xn -> e@. This only works if --- each free uvar @xi@ in @e@ is one of the arguments @ej@ to @X@ (though it --- need not be the case that @i=j@). Return whether this succeeded. -mrTrySetAppliedEVar :: MRVar -> [Term] -> Term -> MRM t Bool -mrTrySetAppliedEVar evar args t = - -- Get the first N argument variables of the type of evar, where N is the - -- length of args; note that evar can have more than N arguments if t is a - -- higher-order term - let (take (length args) -> evar_vars, _) = asPiList (mrVarType evar) in - -- Get all the free variables of t - let free_vars = bitSetElems (looseVars t) in - -- For each free var of t, find an arg equal to it - case mapM (\i -> findIndex (\case - (asLocalVar -> Just j) -> i == j - _ -> False) args) free_vars of - Just fv_arg_ixs - -- Check to make sure we have the right number of args - | length args == length evar_vars -> do - -- Build a list of the input vars x1 ... xn as terms, noting that the - -- first variable is the least recently bound and so has the highest - -- deBruijn index - let arg_ixs = reverse [0 .. length args - 1] - arg_vars <- mapM (liftSC1 scLocalVar) arg_ixs - - -- For each free variable of t, we substitute the corresponding - -- variable xi, substituting error terms for the variables that are - -- not free (since we have nothing else to substitute for them) - let var_map = zip free_vars fv_arg_ixs - let subst_vars = if free_vars == [] then [] else - [0 .. maximum free_vars] - let subst = flip map subst_vars $ \i -> - maybe (error - ("mrTrySetAppliedEVar: unexpected free variable " - ++ show i ++ " in term\n" ++ showTerm t)) - (arg_vars !!) (lookup i var_map) - body <- substTerm 0 subst t - - -- Now instantiate evar to \x1 ... xn -> body - evar_inst <- liftSC2 scLambdaList evar_vars body - mrSetEVarClosed evar evar_inst - return True - - _ -> return False - - --- | Replace all evars in a 'Term' with their instantiations when they have one -mrSubstEVars :: Term -> MRM t Term -mrSubstEVars = memoFixTermFun $ \recurse t -> - do var_map <- mrVars - case t of - -- If t is an instantiated evar, recurse on its instantiation - (asEVarApp var_map -> Just (_, _, args, Just t')) -> - mrApplyAll t' args >>= recurse - -- If t is anything else, recurse on its immediate subterms - _ -> traverseSubterms recurse t - --- | Replace all evars in a 'Term' with their instantiations when they have one --- and \"lower\" those that do not. Lowering an evar in this context means --- replacing each occurrence @X x1 .. xn@ of an evar @X@ applied to its context --- of uvars with a fresh 'ExtCns' variable @Y@. This must be done after --- 'instantiateUVarsM' has replaced all uvars with fresh 'ExtCns' variables, --- which ensures that @X x1 .. xn@ is actually a closed, top-level term since --- each @xi@ is now an 'ExtCns'. This is necessary so @X x1 .. xn@ can be --- replaced by an 'ExtCns' @Y@, which is always closed. The idea of lowering is --- that @X@ should always occur applied to these same values, so really we can --- just treat the entire expression @X x1 .. xn@ as a single unknown value, --- rather than worrying about how @X@ depends on its inputs. -mrSubstLowerEVars :: Term -> MRM t Term -mrSubstLowerEVars t_top = - do var_map <- mrVars - lower_map <- liftIO $ newIORef Map.empty - flip memoFixTermFun t_top $ \recurse t -> - case t of - -- If t is an instantiated evar, recurse on its instantiation - (asEVarApp var_map -> Just (_, _, args, Just t')) -> - mrApplyAll t' args >>= recurse - -- If t is an uninstantiated evar, look up or create its lowering as a - -- variable, making sure it is applied to evars for its arguments - (asEVarApp var_map -> Just (evar, clen, args, Nothing)) -> - do let (cargs, args') = splitAt clen args - let my_panic :: () -> a - my_panic () = - panic "mrSubstLowerEVars" - ["Unexpected evar application: " <> T.pack (show t)] - let cargs_ec = fromMaybe (my_panic ()) $ mapM asVariable cargs - t' <- (Map.lookup evar <$> liftIO (readIORef lower_map)) >>= \case - Just (y, cargs_expected) -> - if cargs_ec == cargs_expected then return y else my_panic () - Nothing -> - do y_tp <- mrPiApplyAll (mrVarType evar) cargs - y <- liftSC2 scFreshGlobal (T.pack $ showMRVar evar) y_tp - liftIO $ modifyIORef' lower_map $ - Map.insert evar (y,cargs_ec) - return y - mrApplyAll t' args' >>= recurse - -- If t is anything else, recurse on its immediate subterms - _ -> traverseSubterms recurse t - --- | Replace all evars in a 'Term' with their instantiations, returning --- 'Nothing' if we hit an uninstantiated evar -mrSubstEVarsStrict :: Term -> MRM t (Maybe Term) -mrSubstEVarsStrict top_t = - runMaybeT $ flip memoFixTermFun top_t $ \recurse t -> - do var_map <- lift mrVars - case t of - -- If t is an instantiated evar, recurse on its instantiation - (asEVarApp var_map -> Just (_, _, args, Just t')) -> - lift (mrApplyAll t' args) >>= recurse - -- If t is an uninstantiated evar, return Nothing - (asEVarApp var_map -> Just (_, _, _, Nothing)) -> - mzero - -- If t is anything else, recurse on its immediate subterms - _ -> traverseSubterms recurse t - --- | Makes 'mrSubstEVarsStrict' be marked as used -_mrSubstEVarsStrict :: Term -> MRM t (Maybe Term) -_mrSubstEVarsStrict = mrSubstEVarsStrict - --- | Get the 'CoIndHyp' for a pair of 'FunName's, if there is one -mrGetCoIndHyp :: FunName -> FunName -> MRM t (Maybe CoIndHyp) -mrGetCoIndHyp nm1 nm2 = Map.lookup (nm1, nm2) <$> mrCoIndHyps - --- | Run a compuation under an additional co-inductive assumption -withCoIndHyp :: CoIndHyp -> MRM t a -> MRM t a -withCoIndHyp hyp m = - do mrDebugPPInCtxM 2 (prettyWithCtx emptyMRVarCtx $ - prettyPrefix "withCoIndHyp" hyp) - hyps' <- Map.insert (coIndHypLHSFun hyp, - coIndHypRHSFun hyp) hyp <$> mrCoIndHyps - local (\info -> info { mriCoIndHyps = hyps' }) m - --- | Generate fresh evars for the context of a 'CoIndHyp' and --- substitute them into its arguments and right-hand side -instantiateCoIndHyp :: CoIndHyp -> MRM t ([Term], [Term]) -instantiateCoIndHyp (CoIndHyp {..}) = - do evars <- mrFreshEVars coIndHypCtx - lhs <- substTermLike 0 evars coIndHypLHS - rhs <- substTermLike 0 evars coIndHypRHS - return (lhs, rhs) - --- | Apply the invariants of a 'CoIndHyp' to their respective arguments, --- yielding @Bool@ conditions, using the constant @True@ value when an --- invariant is absent -applyCoIndHypInvariants :: CoIndHyp -> MRM t (Term, Term) -applyCoIndHypInvariants hyp = - let apply_invariant :: Maybe Term -> [Term] -> MRM t Term - apply_invariant (Just (asLambdaList -> (vars, phi))) args - | length vars == length args - -- NOTE: applying to a list of arguments == substituting the reverse - -- of that list, because the first argument corresponds to the - -- greatest deBruijn index - = substTerm 0 (reverse args) phi - apply_invariant (Just _) _ = - error "applyCoIndHypInvariants: wrong number of arguments for invariant!" - apply_invariant Nothing _ = liftSC1 scBool True in - do invar1 <- apply_invariant (coIndHypInvariantLHS hyp) (coIndHypLHS hyp) - invar2 <- apply_invariant (coIndHypInvariantRHS hyp) (coIndHypRHS hyp) - return (invar1, invar2) - --- | Look up the 'FunAssump' for a 'FunName', if there is one -mrGetFunAssump :: FunName -> MRM t (Maybe (FunAssump t)) -mrGetFunAssump nm = lookupFunAssump nm <$> mrRefnset - --- | Run a computation under the additional assumption that a named function --- applied to a list of arguments refines a given right-hand side, all of which --- are 'Term's that can have the current uvars free -withFunAssump :: FunName -> [Term] -> Term -> MRM t a -> MRM t a -withFunAssump fname args rhs m = - do k <- mkCompFunReturn <$> mrFunOutType fname args - mrDebugPPPrefixSep 1 "withFunAssump" (FunBind fname args k) - "|=" rhs - ctx <- mrUVars - rs <- mrRefnset - let assump = FunAssump ctx fname args (RewriteFunAssump rhs) Nothing - let rs' = addFunAssump assump rs - local (\info -> info { mriRefnset = rs' }) m - --- | Get the invariant hint associated with a function name, by unfolding the --- name and checking if its body has the form --- --- > \ x1 ... xn -> invariantHint a phi m --- --- If so, return @\ x1 ... xn -> phi@ as a term with the @xi@ variables free. --- Otherwise, return 'Nothing'. Note that this function will also look past --- any initial @bindS ... (assertFiniteS ...)@ applications. -mrGetInvariant :: FunName -> MRM t (Maybe Term) -mrGetInvariant nm = - mrFunNameBody nm >>= \case - Just body -> mrGetInvariantBody body - _ -> return Nothing - --- | The main loop of 'mrGetInvariant', which operates on a function body -mrGetInvariantBody :: Term -> MRM t (Maybe Term) -mrGetInvariantBody tm = case asApplyAll tm of - -- go inside any top-level lambdas - (asLambda -> Just (nm, tp, body), []) -> - do body' <- liftSC1 betaNormalize body - mb_phi <- mrGetInvariantBody body' - liftSC3 scLambda nm tp `mapM` mb_phi - -- always beta-reduce - (f@(asLambda -> Just _), args) -> - do tm' <- mrApplyAll f args - mrGetInvariantBody tm' - -- go inside any top-level applications of of bindS ... (assertFiniteS ...) - (isGlobalDef "SpecM.bindS" -> Just (), - [_, _, _, - (asApplyAll -> (isGlobalDef "CryptolM.assertFiniteS" -> Just (), - [_, (asGlobalApply "Cryptol.TCNum" -> Just [_])])), - k]) -> - do pf <- liftSC1 scGlobalDef "Prelude.TrueI" - body <- mrApplyAll k [pf] - mrGetInvariantBody body - -- otherwise, return Just iff there is a top-level invariant hint - (isGlobalDef "SpecM.invariantHint" -> Just (), - [_, phi, _]) -> return $ Just phi - _ -> return Nothing - --- | Add an assumption of type @Bool@ to the current path condition while --- executing a sub-computation -withAssumption :: Term -> MRM t a -> MRM t a -withAssumption phi m = - do mrDebugPPPrefix 1 "withAssumption" phi - assumps <- mrAssumptions - assumps' <- liftSC2 scAnd phi assumps - local (\info -> info { mriAssumptions = assumps' }) m - --- | Remove any existing assumptions and replace them with a Boolean term -withOnlyAssumption :: Term -> MRM t a -> MRM t a -withOnlyAssumption phi m = - do mrDebugPPPrefix 1 "withOnlyAssumption" phi - local (\info -> info { mriAssumptions = phi }) m - --- | Add a 'DataTypeAssump' to the current context while executing a --- sub-computations -withDataTypeAssump :: Term -> DataTypeAssump -> MRM t a -> MRM t a -withDataTypeAssump x assump m = - do mrDebugPPPrefixSep 1 "withDataTypeAssump" x "==" assump - dataTypeAssumps' <- HashMap.insert x assump <$> mrDataTypeAssumps - local (\info -> info { mriDataTypeAssumps = dataTypeAssumps' }) m - --- | Get the 'DataTypeAssump' associated to the given term, if one exists -mrGetDataTypeAssump :: Term -> MRM t (Maybe DataTypeAssump) -mrGetDataTypeAssump x = HashMap.lookup x <$> mrDataTypeAssumps - --- | Record a use of an SMT solver (for tracking 'SolverStats' and 'MRSolverEvidence') -recordUsedSolver :: SolverStats -> Term -> MRM t () -recordUsedSolver stats prop = - modify $ \st -> st { mrsSolverStats = stats <> mrsSolverStats st, - mrsEvidence = MREUsedSolver stats prop : mrsEvidence st } - --- | Record a use of a 'FunAssump' (for 'MRSolverEvidence') -recordUsedFunAssump :: FunAssump t -> MRM t () -recordUsedFunAssump (fassumpAnnotation -> Just t) = - modify $ \st -> st { mrsEvidence = MREUsedFunAssump t : mrsEvidence st } -recordUsedFunAssump _ = return () - - ----------------------------------------------------------------------- --- * Functions for Debug Output ----------------------------------------------------------------------- - --- | Print a 'String' to 'stderr' if the debug level is at least the supplied --- 'Int' -mrDebugPrint :: Int -> String -> MRM t () -mrDebugPrint i str = - mrDebugLevel >>= \lvl -> - if lvl >= i then liftIO (hPutStrLn stderr str) else return () - --- | Print a document to 'stderr' if the debug level is at least the supplied --- 'Int' -mrDebugPretty :: Int -> PPS.Doc -> MRM t () -mrDebugPretty i pp = - mrPPOpts >>= \opts -> - mrDebugPrint i (PPS.render opts pp) - --- | Print to 'stderr' the result of running a 'PPInCtxM' computation in the --- current context and with the current 'PPOpts' if the current debug level is --- at least the supplied 'Int' -mrDebugPPInCtxM :: Int -> PPInCtxM PPS.Doc -> MRM t () -mrDebugPPInCtxM i m = mrDebugPretty i =<< mrPPInCtxM m - --- | Pretty-print an object to 'stderr' in the current context and with the --- current 'PPOpts' if the current debug level is at least the supplied 'Int' -mrDebugPPInCtx :: PrettyInCtx a => Int -> a -> MRM t () -mrDebugPPInCtx i a = mrDebugPretty i =<< mrPPInCtx a - --- | Pretty-print the result of 'prettyPrefix' to 'stderr' in the --- current context and with the current 'PPOpts' if the debug level is at least --- the 'Int' provided -mrDebugPPPrefix :: PrettyInCtx a => Int -> String -> a -> MRM t () -mrDebugPPPrefix i pre a = - mrDebugPPInCtxM i $ group <$> nest 2 <$> prettyPrefix pre a - --- | Pretty-print the result of 'prettyPrefixSep' to 'stderr' in the current --- context and with the current 'PPOpts' if the debug level is at least the --- 'Int' provided -mrDebugPPPrefixSep :: (PrettyInCtx a, PrettyInCtx b) => - Int -> String -> a -> String -> b -> MRM t () -mrDebugPPPrefixSep i pre a1 sp a2 = - mrDebugPPInCtxM i $ group <$> nest 2 <$> prettyPrefixSep pre a1 sp a2 diff --git a/saw-central/src/SAWCentral/MRSolver/SMT.hs b/saw-central/src/SAWCentral/MRSolver/SMT.hs deleted file mode 100644 index bbc3be75c0..0000000000 --- a/saw-central/src/SAWCentral/MRSolver/SMT.hs +++ /dev/null @@ -1,995 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UndecidableInstances #-} - -{- | -Module : SAWCentral.MRSolver.SMT -Copyright : Galois, Inc. 2022 -License : BSD3 -Maintainer : westbrook@galois.com -Stability : experimental -Portability : non-portable (language extensions) - -This module implements the interface between Mr. Solver and an SMT solver, -namely 'mrProvable' and 'mrProveEq'. --} - -module SAWCentral.MRSolver.SMT where - -import Data.Maybe -import qualified Data.Text as Text -import Data.Text (Text) -import qualified Data.Vector as V -import Numeric.Natural (Natural) -import Control.Monad (MonadPlus(..), (>=>), (<=<), when, unless, foldM) -import Control.Monad.Catch (throwM, catch) -import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.Trans.Class (MonadTrans(..)) -import Control.Monad.Trans.Maybe -import GHC.Generics - -import Data.Map (Map) -import qualified Data.Map as Map -import qualified Data.Set as Set - -import Prettyprinter -import Data.Reflection -import Data.Parameterized.BoolRepr - -import qualified SAWSupport.Pretty as PPS (render) - -import SAWCore.Term.Functor -import SAWCore.Term.Pretty -import SAWCore.SharedTerm -import SAWCore.Recognizer - -import SAWCore.Module (Def(..)) -import SAWCore.Prim (widthNat, EvalError(..)) -import qualified SAWCore.Prim as Prim -import SAWCore.Simulator (SimulatorConfig, evalSharedTerm) -import SAWCore.Simulator.Value -import SAWCore.Simulator.TermModel -import SAWCore.Simulator.Prims -import SAWCore.FiniteValue - -import SAWCentral.Panic -import SAWCentral.Proof (termToProp, propToTerm, prettyProp, propToSequent, SolveResult(..)) - -import SAWCentral.MRSolver.Term -import SAWCentral.MRSolver.Monad - - ----------------------------------------------------------------------- --- * Normalizing terms for SMT ----------------------------------------------------------------------- - -type TmPrim = Prim TermModel - --- | Convert a vec value to a 'Term' -vecValToTerm :: SharedContext -> SimulatorConfig TermModel -> - TValue TermModel -> Value TermModel -> IO (Maybe Term) -vecValToTerm sc cfg tp (VVector vs) = - do let ?recordEC = \_ec -> return () - tp' <- readBackTValue sc cfg tp - vs' <- traverse (readBackValue sc cfg tp <=< force) (V.toList vs) - Just <$> scVectorReduced sc tp' vs' -vecValToTerm _ _ _ (VExtra (VExtraTerm _tp tm)) = return $ Just tm -vecValToTerm _ _ _ _ = return $ Nothing - --- | A primitive function that expects a term of the form @gen n a f@ and the --- function argument @f@ to the supplied function -primGenVec :: SharedContext -> SimulatorConfig TermModel -> - TValue TermModel -> (Term -> TmPrim) -> TmPrim -primGenVec sc cfg tp = - PrimFilterFun "primGenVec" $ \v -> lift (vecValToTerm sc cfg tp v) >>= \case - (Just (asGenVecTerm -> Just (_, _, f_m))) -> lift $ f_m sc - _ -> mzero - --- | Convert a Boolean value to a 'Term' -boolValToTerm :: SharedContext -> Value TermModel -> IO Term -boolValToTerm _ (VBool (Left tm)) = return tm -boolValToTerm sc (VBool (Right b)) = scBool sc b -boolValToTerm _ (VExtra (VExtraTerm _tp tm)) = return tm -boolValToTerm _ v = error ("boolValToTerm: unexpected value: " ++ show v) - --- | Convert a bitvector value to a 'Term' -bvValToTerm :: SharedContext -> Value TermModel -> IO Term -bvValToTerm _ (VWord (Left (_,tm))) = return tm -bvValToTerm sc (VWord (Right bv)) = - scBvConst sc (fromIntegral (Prim.width bv)) (Prim.unsigned bv) -bvValToTerm sc (VVector vs) = - do vs' <- traverse (boolValToTerm sc <=< force) (V.toList vs) - bool_tp <- scBoolType sc - scVectorReduced sc bool_tp vs' -bvValToTerm _ (VExtra (VExtraTerm _tp tm)) = return tm -bvValToTerm _ v = error ("bvValToTerm: unexpected value: " ++ show v) - --- | Convert a natural number value to a 'Term' -natValToTerm :: SharedContext -> Value TermModel -> IO Term -natValToTerm sc (VNat n) = scNat sc n -natValToTerm sc (VBVToNat w bv_val) = - do bv_tm <- bvValToTerm sc bv_val - scBvToNat sc (fromIntegral w) bv_tm -natValToTerm _ (VExtra (VExtraTerm _ n)) = return n -natValToTerm _ v = error ("natValToTerm: unexpected value: " ++ show v) - --- | A primitive function that expects a 'Term' of type @Nat@ -primNatTermFun :: SharedContext -> (Term -> TmPrim) -> TmPrim -primNatTermFun sc = - PrimFilterFun "primNatTermFun" $ \v -> lift (natValToTerm sc v) - --- | A primitive that returns a global as a term -primGlobal :: SharedContext -> Ident -> TmPrim -primGlobal sc glob = - Prim $ do tp <- scTypeOfIdent sc glob - tp_tp <- scTypeOf sc tp >>= scWhnf sc - s <- case asSort tp_tp of - Just s -> return s - Nothing -> fail "primGlobal: expected sort" - VExtra <$> VExtraTerm (VTyTerm s tp) <$> scGlobalDef sc glob - --- | A primitive that unfolds a global -primUnfold :: SharedContext -> SimulatorConfig TermModel -> Ident -> TmPrim -primUnfold sc cfg glob = - Prim $ evalSharedTerm cfg =<< fmap (fromJust . defBody) (scRequireDef sc glob) - -mkReflProof :: SharedContext -> Bool -> IO TmValue -mkReflProof sc b = - do b_trm <- scBool sc b - bool_tp <- scBoolType sc - refl_trm <- scGlobalApply sc "Prelude.Refl" [bool_tp, b_trm] - eq_tp <- scGlobalApply sc "Prelude.Eq" [bool_tp, b_trm, b_trm] - return $ VExtra $ VExtraTerm (VTyTerm propSort eq_tp) refl_trm - -mkDummyProofValue :: Text -> IO (Thunk TermModel) -mkDummyProofValue op = - delay $ return $ panic op ["Unexpected evaluation of proof object"] - -iteWithProofOp :: SharedContext -> SimulatorConfig TermModel -> TmPrim -iteWithProofOp sc cfg = - tvalFun $ \tp -> - boolFun $ \b_val -> - strictFun $ \x_fun -> - strictFun $ \y_fun -> - Prim $ - case b_val of - Right b -> mkReflProof sc b >>= apply x_fun . ready - Left b_trm -> - do let ?recordEC = \_ec -> return () - eq_true <- mkDummyProofValue "iteWithProofOp / true" - x <- apply x_fun eq_true - x_trm <- readBackValue sc cfg tp x - eq_false <- mkDummyProofValue "iteWithProofOp / false" - y <- apply y_fun eq_false - y_trm <- readBackValue sc cfg tp y - tp_trm <- readBackTValue sc cfg tp - ite_trm <- scIte sc tp_trm b_trm x_trm y_trm - return $ VExtra $ VExtraTerm tp ite_trm - --- | Implementations of primitives for normalizing Mr Solver terms --- FIXME: eventually we need to add the current event type to this list -smtNormPrims :: SharedContext -> SimulatorConfig TermModel -> - Map Ident TmPrim -> Map Ident TmPrim -smtNormPrims sc cfg = Map.union $ Map.fromList - [ - -- Override the usual behavior of @gen@, @genWithProof@, and @VoidEv@ so - -- they are not evaluated or unfolded - ("Prelude.gen", primGlobal sc "Prelude.gen"), - ("Prelude.genWithProof", primGlobal sc "Prelude.genWithProof"), - ("SpecM.VoidEv", primGlobal sc "SpecM.VoidEv"), - ("SpecM.SpecM", primGlobal sc "SpecM.SpecM"), - - -- Normalize an application of @atwithDefault@ to a @gen@ term into an - -- application of the body of the gen term to the index. Note that this - -- implicitly assumes that the index is always in bounds, MR solver always - -- checks that before it creates an indexing term. - ("Prelude.atWithDefault", - PrimFun $ \_len -> tvalFun $ \a -> PrimFun $ \_errVal -> - primGenVec sc cfg a $ \f -> primNatTermFun sc $ \ix -> - Prim (do tm <- scApplyBeta sc f ix - tm' <- smtNorm sc tm - return $ VExtra $ VExtraTerm a tm') - ), - - -- Normalize an application of @atWithProof@ to a @gen@ term by applying the - -- function of the @gen@ to the index - ("Prelude.atWithProof", - PrimFun $ \_len -> tvalFun $ \a -> primGenVec sc cfg a $ \f -> - primNatTermFun sc $ \ix -> PrimFun $ \_pf -> - Prim (do tm <- scApplyBeta sc f ix - tm' <- smtNorm sc tm - return $ VExtra $ VExtraTerm a tm') - ), - - -- Override iteWithProof so it unfolds to a normal ite with dummy proof objects - ("Prelude.iteWithProof", iteWithProofOp sc cfg) - ] - --- | A version of 'mrNormTerm' in the 'IO' monad, and which does not add any --- debug output. This is used to re-enter the normalizer from inside the --- primitives. -smtNorm :: SharedContext -> Term -> IO Term -smtNorm sc t = - scGetModuleMap sc >>= \modmap -> - normalizeSharedTerm' sc modmap (smtNormPrims sc) Map.empty Set.empty t - --- | Normalize a 'Term' using some Mr Solver specific primitives -mrNormTerm :: Term -> MRM t Term -mrNormTerm t = - mrDebugPrint 2 "Normalizing term:" >> - mrDebugPPInCtx 2 t >> - liftSC1 smtNorm t - --- | Normalize an open term by wrapping it in lambdas, normalizing, and then --- removing those lambdas -mrNormOpenTerm :: Term -> MRM t Term -mrNormOpenTerm body = - do length_ctx <- mrVarCtxLength <$> mrUVars - fun_term <- lambdaUVarsM body - normed_fun <- mrNormTerm fun_term - return (peel_lambdas length_ctx normed_fun) - where - peel_lambdas :: Int -> Term -> Term - peel_lambdas 0 t = t - peel_lambdas i (asLambda -> Just (_, _, t)) = peel_lambdas (i-1) t - peel_lambdas _ _ = error "mrNormOpenTerm: unexpected non-lambda term!" - - ----------------------------------------------------------------------- --- * Checking Provability with SMT ----------------------------------------------------------------------- - --- | Test if a closed Boolean term is \"provable\", i.e., its negation is --- unsatisfiable, using an SMT solver. By \"closed\" we mean that it contains no --- uvars or 'MRVar's. --- --- FIXME: use the timeout! -mrProvableRaw :: Term -> MRM t Bool -mrProvableRaw prop_term = - do sc <- mrSC - prop <- liftSC1 termToProp prop_term - unints <- Set.map ecVarIndex <$> getAllExtSet <$> liftSC1 propToTerm prop - nenv <- liftIO (scGetNamingEnv sc) - opts <- mrPPOpts - mrDebugPrint 2 ("Calling SMT solver with proposition: " ++ - prettyProp opts nenv prop) - -- If there are any saw-core `error`s in the term, this will throw a - -- Haskell error - in this case we want to just return False, not stop - -- execution - smt_res <- - (Right <$> mrAskSMT unints (propToSequent prop)) - `catch` \case - UserError msg -> return $ Left msg - e -> throwM e - case smt_res of - Left msg -> - mrDebugPrint 2 ("SMT solver encountered a saw-core error term: " ++ msg) - >> return False - Right (stats, SolveUnknown) -> - mrDebugPrint 2 "SMT solver response: unknown" >> - recordUsedSolver stats prop_term >> return False - Right (stats, SolveCounterexample cex) -> - mrDebugPrint 2 "SMT solver response: not provable" >> - mrDebugPrint 3 ("Counterexample:" ++ concatMap (\(x,v) -> - "\n - " ++ show (ppName $ ecNameInfo x) ++ - " = " ++ PPS.render opts (ppFirstOrderValue opts v)) cex) >> - recordUsedSolver stats prop_term >> return False - Right (stats, SolveSuccess _) -> - mrDebugPrint 2 "SMT solver response: provable" >> - recordUsedSolver stats prop_term >> return True - --- | Test if a Boolean term over the current uvars is provable given the current --- assumptions -mrProvable :: Term -> MRM t Bool -mrProvable (asBool -> Just b) = return b -mrProvable bool_tm = - do mrUVars >>= mrDebugPPPrefix 3 "mrProvable uvars:" - assumps <- mrAssumptions - prop <- liftSC2 scImplies assumps bool_tm >>= liftSC1 scEqTrue - prop_inst <- instantiateUVarsM instUVar prop >>= mrSubstLowerEVars - mrNormTerm prop_inst >>= mrProvableRaw - where -- | Create a new global variable of the given name and type - instUVar :: LocalName -> Term -> MRM t Term - instUVar nm = - liftSC1 scWhnf >=> liftSC2 scFreshEC nm >=> liftSC1 scVariable - - ----------------------------------------------------------------------- --- * Unifying BVVec and Vec Lengths ----------------------------------------------------------------------- - --- | The length of a vector, given as either ... -data VecLength = ConstBVVecLen Natural Natural - | ConstNatVecLen Natural Natural - | SymBVVecLen Natural Term - | SymNatVecLen Term - deriving (Generic, Show, TermLike) - -instance PrettyInCtx VecLength where - prettyInCtx (ConstBVVecLen n len) = - prettyAppList [return "ConstBVVecLen", prettyInCtx n, prettyInCtx len] - prettyInCtx (ConstNatVecLen n len) = - prettyAppList [return "ConstNatVecLen", prettyInCtx n, prettyInCtx len] - prettyInCtx (SymBVVecLen n len) = - prettyAppList [return "SymBVVecLen", prettyInCtx n, parens <$> prettyInCtx len] - prettyInCtx (SymNatVecLen len) = - prettyAppList [return "SymNatVecLen", parens <$> prettyInCtx len] - --- | Convert a natural number expression to a 'VecLength' -asVecLen :: Term -> VecLength -asVecLen (asBvToNatKnownW -> Just (n, len)) - | Just len' <- asUnsignedConcreteBv len = ConstBVVecLen n len' - | otherwise = SymBVVecLen n len -asVecLen (asUnsignedConcreteBvToNat -> Just len) = - ConstNatVecLen (widthNat len) len -asVecLen len = SymNatVecLen len - --- | Recognize a @BVVec@, @Vec@, or @mseq (TCNum ...)@ vector with length --- represented as a 'VecLength' -asVecTypeWithLen :: Recognizer Term (VecLength, Term) -asVecTypeWithLen (asApplyAll -> (isGlobalDef "Prelude.BVVec" -> Just (), - [asNat -> Just n, len, a])) - | Just len' <- asUnsignedConcreteBv len = Just (ConstBVVecLen n len', a) - | otherwise = Just (SymBVVecLen n len, a) -asVecTypeWithLen (asVectorType -> Just (len, a)) = Just (asVecLen len, a) -asVecTypeWithLen (asApplyAll -> (isGlobalDef "SpecM.mseq" -> Just (), - [_, asNum -> Just (Left len), a])) = - Just (asVecLen len, a) -asVecTypeWithLen _ = Nothing - --- | Convert a 'VecLength' into either a 'Term' of bitvector type with the given --- 'Natural' bit-width if the 'VecLength' has an associated bit-width, or into a --- 'Term' of nat type otherwise -mrVecLenAsBVOrNatTerm :: VecLength -> MRM t (Either (Natural, Term) Term) -mrVecLenAsBVOrNatTerm (ConstBVVecLen n len) = - (Left . (n,)) <$> liftSC2 scBvLit n (fromIntegral len) -mrVecLenAsBVOrNatTerm (ConstNatVecLen n len) = - (Left . (n,)) <$> liftSC2 scBvLit n (fromIntegral len) -mrVecLenAsBVOrNatTerm (SymBVVecLen n len) = - return $ Left (n, len) -mrVecLenAsBVOrNatTerm (SymNatVecLen len) = - return $ Right len - --- | Get the type of an index bounded by a 'VecLength' -mrVecLenIxType :: VecLength -> MRM t Term -mrVecLenIxType vlen = mrVecLenAsBVOrNatTerm vlen >>= \case - Left (n, _) -> liftSC1 scBitvector n - Right _ -> liftSC0 scNatType - --- | Construct the proposition that the given 'Term' of type 'mrVecLenIxType' --- is less than the given 'VecLength' -mrVecLenIxBound :: VecLength -> Term -> MRM t Term -mrVecLenIxBound vlen ix = mrVecLenAsBVOrNatTerm vlen >>= \case - Left (n, len) -> liftSC1 scNat n >>= \n' -> - liftSC2 scGlobalApply "Prelude.bvult" [n', ix, len] - Right len -> liftSC2 scGlobalApply "Prelude.ltNat" [ix, len] - --- | Test if two vector lengths are equal, and if so, generalize them to use the --- same index type as returned by 'mrVecLenIxType' -mrVecLenUnify :: VecLength -> VecLength -> MRM t (Maybe (VecLength, VecLength)) -mrVecLenUnify (ConstBVVecLen n1 len1) (ConstBVVecLen n2 len2) - | n1 == n2 && len1 == len2 - = return $ Just (ConstBVVecLen n1 len1, ConstBVVecLen n2 len2) -mrVecLenUnify (ConstBVVecLen n1 len1) (ConstNatVecLen n2 len2) - | n2 < n1 && len1 == len2 - = return $ Just (ConstBVVecLen n1 len1, ConstNatVecLen n1 len2) -mrVecLenUnify (ConstNatVecLen n1 len1) (ConstBVVecLen n2 len2) - | n1 < n2 && len1 == len2 - = return $ Just (ConstNatVecLen n2 len1, ConstBVVecLen n2 len2) -mrVecLenUnify (ConstNatVecLen n1 len1) (ConstNatVecLen n2 len2) - | len1 == len2, nMax <- max n1 n2 - = return $ Just (ConstNatVecLen nMax len1, ConstNatVecLen nMax len2) -mrVecLenUnify vlen1@(SymBVVecLen n1 len1) vlen2@(SymBVVecLen n2 len2) - | n1 == n2 - = mrProveEq len1 len2 >>= \case - True -> return $ Just (vlen1, vlen2) - False -> return Nothing -mrVecLenUnify (SymNatVecLen len1) (SymNatVecLen len2) = - mrProveEq len1 len2 >>= \case - True -> return $ Just (SymNatVecLen len1, SymNatVecLen len2) - False -> return Nothing -mrVecLenUnify _ _ = return Nothing - --- | Given a vector length, element type, and generating function, return the --- associated vector formed using the appropritate @gen@ function -mrVecLenGen :: VecLength -> Term -> Term -> MRM t Term -mrVecLenGen (ConstBVVecLen n len) tp f = - do n_tm <- liftSC1 scNat n - len_tm <- liftSC2 scBvLit n (fromIntegral len) - mrApplyGlobal "Prelude.genBVVecNoPf" [n_tm, len_tm, tp, f] -mrVecLenGen (ConstNatVecLen n len) tp f = - do n_tm <- liftSC1 scNat n - len_tm <- liftSC1 scNat len - nat_tp <- liftSC0 scNatType - f' <- mrLambdaLift1 ("ix", nat_tp) f $ \x f' -> - liftSC2 scBvNat n_tm x >>= mrApply f' - mrApplyGlobal "Prelude.gen" [len_tm, tp, f'] -mrVecLenGen (SymBVVecLen n len) tp f = - do n_tm <- liftSC1 scNat n - mrApplyGlobal "Prelude.genBVVecNoPf" [n_tm, len, tp, f] -mrVecLenGen (SymNatVecLen len) tp f = - do mrApplyGlobal "Prelude.gen" [len, tp, f] - --- | Given a vector length, element type, vector of that length and type, and an --- index of type 'mrVecLenIxType', index into the vector -mrVecLenAt :: VecLength -> Term -> Term -> Term -> MRM t Term -mrVecLenAt (ConstBVVecLen n len) tp v ix = - do n_tm <- liftSC1 scNat n - len_tm <- liftSC2 scBvLit n (fromIntegral len) - mrAtBVVec n_tm len_tm tp v ix -mrVecLenAt (ConstNatVecLen n len) tp v ix = - do len_tm <- liftSC1 scNat len - ix' <- liftSC2 scBvToNat n ix - mrAtVec len_tm tp v ix' -mrVecLenAt (SymBVVecLen n len) tp v ix = - do n_tm <- liftSC1 scNat n - mrAtBVVec n_tm len tp v ix -mrVecLenAt (SymNatVecLen len) tp v ix = - do mrAtVec len tp v ix - - ----------------------------------------------------------------------- --- * SMT-Friendly Representations ----------------------------------------------------------------------- - --- | A representation of some subset of the elements of a type @tp@ as elements --- of some other type @tp_r@. The idea is that the type @tp_r@ is easier to --- represent in SMT solvers. --- --- This is captured formally with a function @r@ from elements of the --- representation type @tp_r@ to the elements of type @tp@ that they represent --- along with an equivalence relation @eq_r@ on @tp_r@ such that @r@ is --- injective when viewed as a morphism from @eq_r@ to the natural equivalence --- relation @equiv@ of @tp@. In more detail, this means that @eq_r@ holds --- between two inputs to @r@ iff @equiv@ holds between their outputs. Note that --- an injective representation need not be surjective, meaning there could be --- elements of @tp@ that it cannot represent. -data InjectiveRepr - -- | The identity representation of @(tp,equiv)@ by itself. Only applies to - -- non-vector types, as vectors should be represented by one of the vector - -- representations. - = InjReprId - -- | A representation of a numeric type (@Num@, @Nat@, or @Vec n Bool@) by - -- another numeric type defined as the composition of one or more injective - -- numeric representations. NOTE: we do not expect numeric representations - -- to occur inside other representations like those for pairs and vectors - | InjReprNum [InjNumRepr] - -- | A representation of the pair type @tp1 * tp2@ by @tp_r1 * tp_r2@ using - -- representations of @tp1@ and @tp2@ - | InjReprPair InjectiveRepr InjectiveRepr - -- | A representation of the vector type @Vec len tp@ by the functional type - -- @tp_len -> tp_r@ from indices to elements of the representation type - -- @tp_r@ of @tp@, given a representation of @tp@ by @tp_r@, where the index - -- type @tp_len@ is determined by the 'VecLength' - | InjReprVec VecLength Term InjectiveRepr - deriving (Generic, Show, TermLike) - --- | A representation of a numeric type (@Num@, @Nat@, or @Vec n Bool@) by --- another numeric type defined as an injective function -data InjNumRepr - -- | The @TCNum@ constructor as a representation of @Num@ by @Nat@ - = InjNatToNum - -- | The @bvToNat@ function as a representation of @Nat@ by @Vec n Bool@ - | InjBVToNat Natural - deriving (Generic, Show, TermLike) - -instance PrettyInCtx InjectiveRepr where - prettyInCtx InjReprId = return "InjReprId" - prettyInCtx (InjReprNum steps) = - prettyAppList [return "InjReprNum", list <$> mapM prettyInCtx steps] - prettyInCtx (InjReprPair r1 r2) = - prettyAppList [return "InjReprPair", parens <$> prettyInCtx r1, - parens <$> prettyInCtx r2] - prettyInCtx (InjReprVec n tp repr) = - prettyAppList [return "InjReprVec", parens <$> prettyInCtx n, - parens <$> prettyInCtx tp, - parens <$> prettyInCtx repr] - -instance PrettyInCtx InjNumRepr where - prettyInCtx InjNatToNum = return "InjNatToNum" - prettyInCtx (InjBVToNat n) = - prettyAppList [return "InjBVToNat", prettyInCtx n] - --- | Smart constructor for pair representations, that combines a pair of --- identity representations into an identity representation on the pair type -injReprPair :: InjectiveRepr -> InjectiveRepr -> InjectiveRepr -injReprPair InjReprId InjReprId = InjReprId -injReprPair repr1 repr2 = InjReprPair repr1 repr2 - --- | Test if there is a non-identity numeric representation from the first to --- the second type -findNumRepr :: Term -> Term -> Maybe InjectiveRepr -findNumRepr (asBitvectorType -> Just n) (asNumType -> Just ()) = - Just $ InjReprNum [InjBVToNat n, InjNatToNum] -findNumRepr (asBitvectorType -> Just n) (asNatType -> Just ()) = - Just $ InjReprNum [InjBVToNat n] -findNumRepr (asNatType -> Just ()) (asNumType -> Just ()) = - Just $ InjReprNum [InjNatToNum] -findNumRepr _ _ = Nothing - --- | Compose two injective representations, assuming that they do compose, i.e., --- that the output type of the first equals the input type of the second -injReprComp :: InjectiveRepr -> InjectiveRepr -> InjectiveRepr -injReprComp InjReprId r = r -injReprComp r InjReprId = r -injReprComp (InjReprNum steps1) (InjReprNum steps2) = - InjReprNum (steps1 ++ steps2) -injReprComp (InjReprPair r1_l r1_r) (InjReprPair r2_l r2_r) = - InjReprPair (injReprComp r1_l r2_l) (injReprComp r1_r r2_r) -injReprComp r1 r2 = - panic "injReprComp" [ - "Representations do not compose: " <> - Text.pack (show r1) <> " and " <> Text.pack (show r2) - ] - --- | Apply a 'InjectiveRepr' to convert an element of the representation type --- @tp_r@ to the type @tp@ that it represents -mrApplyRepr :: InjectiveRepr -> Term -> MRM t Term -mrApplyRepr InjReprId t = return t -mrApplyRepr (InjReprNum steps) t_top = foldM applyStep t_top steps where - applyStep t InjNatToNum = liftSC2 scGlobalApply "Cryptol.TCNum" [t] - applyStep t (InjBVToNat n) = liftSC2 scBvToNat n t -mrApplyRepr (InjReprPair repr1 repr2) t = - do t1 <- mrApplyRepr repr1 =<< doTermProj t TermProjLeft - t2 <- mrApplyRepr repr2 =<< doTermProj t TermProjRight - liftSC2 scPairValueReduced t1 t2 -mrApplyRepr (InjReprVec vlen tp repr) t = - do ix_tp <- mrVecLenIxType vlen - f <- mrLambdaLift1 ("ix", ix_tp) (repr, t) $ \x (repr', t') -> - mrApplyRepr repr' =<< mrApply t' x - mrVecLenGen vlen tp f - -newtype MaybeTerm b = MaybeTerm { unMaybeTerm :: If b Term () } - --- | Apply a monadic 'Term' operation to a 'MaybeTerm' -mapMaybeTermM :: Monad m => BoolRepr b -> (Term -> m Term) -> MaybeTerm b -> - m (MaybeTerm b) -mapMaybeTermM TrueRepr f (MaybeTerm t) = MaybeTerm <$> f t -mapMaybeTermM FalseRepr _ _ = return $ MaybeTerm () - --- | Apply a binary monadic 'Term' operation to a 'MaybeTerm' -map2MaybeTermM :: Monad m => BoolRepr b -> (Term -> Term -> m Term) -> - MaybeTerm b -> MaybeTerm b -> m (MaybeTerm b) -map2MaybeTermM TrueRepr f (MaybeTerm t1) (MaybeTerm t2) = MaybeTerm <$> f t1 t2 -map2MaybeTermM FalseRepr _ _ _ = return $ MaybeTerm () - -instance Given (BoolRepr b) => TermLike (MaybeTerm b) where - mapTermLike = mapMaybeTermM given - --- | Construct an injective representation for a type @tp@ and an optional term --- @tm@ of that type, returning the representation type @tp_r@, the optional --- term @tm_r@ that represents @tm@, and the representation itself. If there is --- a choice, choose the representation that works best for SMT solvers. -mkInjRepr :: BoolRepr b -> Term -> MaybeTerm b -> - MRM t (Term, MaybeTerm b, InjectiveRepr) -mkInjRepr TrueRepr _ (MaybeTerm (asNum -> Just (Left t))) = - do nat_tp <- liftSC0 scNatType - (tp_r, tm_r, r) <- mkInjRepr TrueRepr nat_tp (MaybeTerm t) - return (tp_r, tm_r, injReprComp r (InjReprNum [InjNatToNum])) -mkInjRepr TrueRepr _ (MaybeTerm (asBvToNatKnownW -> Just (n, t))) = - do bv_tp <- liftSC1 scBitvector n - return (bv_tp, MaybeTerm t, InjReprNum [InjBVToNat n]) -mkInjRepr b (asPairType -> Just (tp1, tp2)) t = - do tm1 <- mapMaybeTermM b (flip doTermProj TermProjLeft) t - tm2 <- mapMaybeTermM b (flip doTermProj TermProjRight) t - (tp_r1, tm_r1, r1) <- mkInjRepr b tp1 tm1 - (tp_r2, tm_r2, r2) <- mkInjRepr b tp2 tm2 - tp_r <- liftSC2 scPairType tp_r1 tp_r2 - tm_r <- map2MaybeTermM b (liftSC2 scPairValueReduced) tm_r1 tm_r2 - return (tp_r, tm_r, InjReprPair r1 r2) - -mkInjRepr b (asVecTypeWithLen -> Just (vlen, tp@(asBoolType -> Nothing))) tm = - do ix_tp <- mrVecLenIxType vlen - -- NOTE: these return values from mkInjRepr all have ix free - (tp_r', tm_r', r') <- - give b $ - withUVarLift "ix" (Type ix_tp) (vlen,tp,tm) $ \ix (vlen',tp',tm') -> - do tm_elem <- - mapMaybeTermM b (\tm'' -> mrVecLenAt vlen' tp' tm'' ix) tm' - mkInjRepr b tp' tm_elem - -- r' should not have ix free, so it should be ok to substitute an error - -- term for ix... - r <- substTermLike 0 [error - "mkInjRepr: unexpected free ix variable in repr"] r' - tp_r <- liftSC3 scPi "ix" ix_tp tp_r' - tm_r <- mapMaybeTermM b (liftSC3 scLambda "ix" ix_tp) tm_r' - return (tp_r, tm_r, InjReprVec vlen tp r) - -mkInjRepr _ tp tm = return (tp, tm, InjReprId) - - --- | Specialization of 'mkInjRepr' with no element of the represented type -mkInjReprType :: Term -> MRM t (Term, InjectiveRepr) -mkInjReprType tp = - (\(tp_r,_,repr) -> (tp_r,repr)) <$> mkInjRepr FalseRepr tp (MaybeTerm ()) - --- | Specialization of 'mkInjRepr' with an element of the represented type -mkInjReprTerm :: Term -> Term -> MRM t (Term, Term, InjectiveRepr) -mkInjReprTerm tp trm = - (\(tp_r, tm, repr) -> (tp_r, unMaybeTerm tm, repr)) <$> - mkInjRepr TrueRepr tp (MaybeTerm trm) - - --- | Given two representations @r1@ and @r2@ along with their representation --- types @tp_r1@ and @tp_r2, try to unify their representation types, yielding --- new versions of those representations. That is, try to find a common type --- @tp_r@ and representations @r1'@ and @r2'@ such that the following picture --- holds: --- --- > tp1 tp2 --- > ^ ^ --- > r1 | | r2 --- > tp_r1 tp_r2 --- > ^ ^ --- > r1' \ / r2' --- > \ / --- > tp_r --- -injUnifyReprTypes :: Term -> InjectiveRepr -> Term -> InjectiveRepr -> - MaybeT (MRM t) (Term, InjectiveRepr, InjectiveRepr) - --- If there is a numeric coercion from one side to the other, use it to unify --- the two input representations -injUnifyReprTypes tp1 r1 tp2 r2 - | Just r2' <- findNumRepr tp1 tp2 - = return (tp1, r1, injReprComp r2' r2) -injUnifyReprTypes tp1 r1 tp2 r2 - | Just r1' <- findNumRepr tp2 tp1 - = return (tp2, injReprComp r1' r1, r2) - --- If both representations are the identity, make sure the repr types are equal -injUnifyReprTypes tp1 InjReprId tp2 InjReprId = - do tps_eq <- lift $ mrConvertible tp1 tp2 - if tps_eq then return (tp1, InjReprId, InjReprId) - else mzero - --- For pair representations, unify the two sides, treating an identity --- representation as a pair of identity representations -injUnifyReprTypes tp1 (InjReprPair r1l r1r) tp2 (InjReprPair r2l r2r) - | Just (tp1l, tp1r) <- asPairType tp1 - , Just (tp2l, tp2r) <- asPairType tp2 = - do (tp_r_l, r1l', r2l') <- injUnifyReprTypes tp1l r1l tp2l r2l - (tp_r_r, r1r', r2r') <- injUnifyReprTypes tp1r r1r tp2r r2r - tp_r <- lift $ liftSC2 scPairType tp_r_l tp_r_r - return (tp_r, InjReprPair r1l' r1r', InjReprPair r2l' r2r') -injUnifyReprTypes tp1 InjReprId tp2 r2 - | isJust (asPairType tp1) - = injUnifyReprTypes tp1 (InjReprPair InjReprId InjReprId) tp2 r2 -injUnifyReprTypes tp1 r1 tp2 InjReprId - | isJust (asPairType tp2) - = injUnifyReprTypes tp1 r1 tp2 (InjReprPair InjReprId InjReprId) - --- For vector types, check that the lengths are equal and unify the element --- representations. Note that if either side uses a natural number length --- instead of a bitvector length, both sides will need to, since we don't --- currently have representation that can cast from a bitvector length to an --- equal natural number length -injUnifyReprTypes _ (InjReprVec len1 tp1 r1) _ (InjReprVec len2 tp2 r2) = - do (len1', len2') <- MaybeT $ mrVecLenUnify len1 len2 - ix_tp <- lift $ mrVecLenIxType len1' - (tp_r, r1', r2') <- injUnifyReprTypes tp1 r1 tp2 r2 - tp_r_fun <- lift $ mrArrowType "ix" ix_tp tp_r - return (tp_r_fun, InjReprVec len1' tp1 r1', InjReprVec len2' tp2 r2') - -injUnifyReprTypes _ _ _ _ = mzero - - --- | Given two types @tp1@ and @tp2@, try to find a common type @tp@ that --- injectively represents both of them. Pictorially, the result looks like this: --- --- > tp1 tp2 --- > ^ ^ --- > r1 \ / r2 --- > \ / --- > tp --- --- where @r1@ and @r2@ are injective representations. The representations should --- be maximal, meaning that they represent as much of @tp1@ and @tp2@ as --- possible. If there is such a @tp@, return it along with the representations --- @r1@ and @r2@. Otherwise, return 'Nothing', meaning the unification failed. -injUnifyTypes :: Term -> Term -> - MRM t (Maybe (Term, InjectiveRepr, InjectiveRepr)) -injUnifyTypes tp1 tp2 = - do (tp_r1, r1) <- mkInjReprType tp1 - (tp_r2, r2) <- mkInjReprType tp2 - runMaybeT $ injUnifyReprTypes tp_r1 r1 tp_r2 r2 - - --- | Use one injective representations @r1@ to restrict the domain of another --- injective representation @r2@, yielding an injective representation with the --- same representation type as @r1@ and the same type being represented as @r2@. --- Pictorially this looks like this: --- --- > tp1 tp2 --- > ^ ^ --- > \ / r2 --- > r1 \ / --- > \ tpr2 --- > \ ^ --- > \ / r2'' --- > tpr1 --- --- The return value is the composition of @r2''@ and @r2@. It is an error if --- this diagram does not exist. -injReprRestrict :: Term -> InjectiveRepr -> Term -> InjectiveRepr -> - MRM t InjectiveRepr - --- If tp1 and tp2 are numeric types with a representation from tp1 to tp2, we --- can pre-compose that representation with r2 -injReprRestrict tp1 _ tp2 r2 - | Just r2'' <- findNumRepr tp1 tp2 - = return $ injReprComp r2'' r2 - --- In all other cases, the only repr that pre-composes with r2 is the identity --- repr, so we just return r2 -injReprRestrict _ _ _ r2 = return r2 - - --- | Take in a type @tp_r1@, a term @tm1@ of type @tp_r1@, an injective --- representation @r1@ with @tp_r1@ as its representation type, and a type @tp2@ --- with an element @tm2@, and try to find a type @tp_r'@ and a term @tm'@ of --- type @tp_r'@ that represents both @r1 tm1@ and @tm2@ using representations --- @r1'@ and @r2'@, repsectively. That is, @r1'@ should represent @tp1@ and --- @r2'@ should represent @tp2@, both with the same representation type @tp_r'@, --- and should satisfy --- --- > r1' tm' = r1 tm1 and r2' tm' = tm2 --- --- In pictures the result should look like this: --- --- > r1 tm1 tm2::tp2 --- > ^ ^ --- > r1 | / --- > | / --- > tm1::tp_r1 / r2' --- > ^ / --- > r1'' \ / --- > \ / --- > tm'::tp_r' --- --- where @r1'@ is the composition of @r1''@ and @r1@. -injUnifyRepr :: Term -> Term -> InjectiveRepr -> Term -> Term -> - MRM t (Maybe (Term, Term, InjectiveRepr, InjectiveRepr)) - --- If there is a numeric repr r2 from tp_r1 to tp2, then that's our r2', --- assuming that r2 tm1 = tm2 -injUnifyRepr tp_r1 tm1 r1 tp2 tm2 - | Just r2 <- findNumRepr tp_r1 tp2 = - do r2_tm1 <- mrApplyRepr r2 tm1 - eq_p <- mrProveEq r2_tm1 tm2 - if eq_p then - return (Just (tp_r1, tm1, r1, r2)) - else return Nothing - --- If there is a numeric repr r1'' from tp2 to tp_r1, then we pre-compose that --- with r1 and use the identity for r2', assuming r1'' tm2 = tm1 -injUnifyRepr tp_r1 tm1 r1 tp2 tm2 - | Just r1'' <- findNumRepr tp2 tp_r1 = - do r1_tm2 <- mrApplyRepr r1'' tm2 - eq_p <- mrProveEq tm1 r1_tm2 - if eq_p then - return (Just (tp2, tm2, injReprComp r1'' r1, InjReprId)) - else return Nothing - --- Otherwise, build a representation r2 for tm2, check that its representation --- type equals tp_r1, and check that r1 tm1 is related to tm2 -injUnifyRepr tp_r1 tm1 r1 tp2 tm2 = - do (tp_r2, _, r2) <- mkInjReprTerm tp2 tm2 - tps_eq <- mrConvertible tp_r1 tp_r2 - if not tps_eq then return Nothing else - do r1_tm1 <- mrApplyRepr r1 tm1 - rel <- mrProveEq r1_tm1 tm2 - if rel then return (Just (tp_r1, tm1, r1, r2)) else - return Nothing - - ----------------------------------------------------------------------- --- * Checking Equality with SMT ----------------------------------------------------------------------- - --- | Build a Boolean 'Term' stating that two 'Term's are equal. This is like --- 'scEq' except that it works on open terms. -mrEq :: Term -> Term -> MRM t Term -mrEq t1 t2 = mrTypeOf t1 >>= \case - (asSimpleEq -> Just eqf) -> liftSC2 eqf t1 t2 - _ -> error "mrEq: unsupported type" - --- | Recognize a nat, bool, integer, bitvector, or num type as the function --- which builds a boolean 'Term' stating that two terms of that type are equal -asSimpleEq :: Recognizer Term (SharedContext -> Term -> Term -> IO Term) -asSimpleEq (asNatType -> Just _) = Just $ scEqualNat -asSimpleEq (asBoolType -> Just _) = Just $ scBoolEq -asSimpleEq (asIntegerType -> Just _) = Just $ scIntEq -asSimpleEq (asSymBitvectorType -> Just n) = Just $ flip scBvEq n -asSimpleEq (asNumType -> Just ()) = Just $ \sc t1 t2 -> - scGlobalApply sc "Cryptol.tcEqual" [t1, t2] -asSimpleEq _ = Nothing - --- | A 'Term' in an extended context of universal variables, which are listed --- \"outside in\", meaning the highest deBruijn index comes first -data TermInCtx = TermInCtx [(LocalName,Term)] Term - --- | Lift a binary operation on 'Term's to one on 'TermInCtx's -liftTermInCtx2 :: (SharedContext -> Term -> Term -> IO Term) -> - TermInCtx -> TermInCtx -> MRM t TermInCtx -liftTermInCtx2 op (TermInCtx ctx1 t1) (TermInCtx ctx2 t2) = - do - -- Insert the variables in ctx2 into the context of t1 starting at index 0, - -- by lifting its variables starting at 0 by length ctx2 - t1' <- liftTermLike 0 (length ctx2) t1 - -- Insert the variables in ctx1 into the context of t1 starting at index - -- length ctx2, by lifting its variables starting at length ctx2 by length - -- ctx1 - t2' <- liftTermLike (length ctx2) (length ctx1) t2 - TermInCtx (ctx1++ctx2) <$> liftSC2 op t1' t2' - --- | Extend the context of a 'TermInCtx' with additional universal variables --- bound \"outside\" the 'TermInCtx' -extTermInCtx :: [(LocalName,Term)] -> TermInCtx -> TermInCtx -extTermInCtx ctx (TermInCtx ctx' t) = TermInCtx (ctx++ctx') t - --- | Run an 'MRM t' computation in the context of a 'TermInCtx', passing in the --- 'Term' -withTermInCtx :: TermInCtx -> (Term -> MRM t a) -> MRM t a -withTermInCtx (TermInCtx [] tm) f = f tm -withTermInCtx (TermInCtx ((nm,tp):ctx) tm) f = - withUVar nm (Type tp) $ const $ withTermInCtx (TermInCtx ctx tm) f - --- | Prove that two terms are equal, returning true on success and instantiating --- evars if necessary - the same as @mrProveRel Nothing@ -mrProveEq :: Term -> Term -> MRM t Bool -mrProveEq = mrProveRel Nothing - --- | Prove that two terms are equal, throwing an error if this is not possible --- and instantiating evars if necessary - the same as @mrAssertProveRel Nothing@ -mrAssertProveEq :: Term -> Term -> MRM t () -mrAssertProveEq = mrAssertProveRel Nothing - --- | A relation over two terms, the second and fourth arguments, and their --- respective types, the first and third arguments -type MRRel t a = Term -> Term -> Term -> Term -> MRM t a - --- | Prove that two terms are related via a relation, if given, on terms of --- SpecFun type (as in 'isSpecFunType') or via equality otherwise, returning --- false if this is not possible and instantiating evars if necessary -mrProveRel :: Maybe (MRRel t ()) -> Term -> Term -> MRM t Bool -mrProveRel piRel t1 t2 = mrProveRelH piRel t1 t2 >>= \case - Left err -> mrDebugPPPrefix 2 "mrProveRel Failure:" err >> return False - Right res -> do - mrDebugPrint 2 $ "mrProveRel: " ++ if res then "Success" else "Failure" - return res - --- | Prove that two terms are related via a relation, if given, on terms of --- SpecFun type (as in 'isSpecFunType') or via equality otherwise, throwing an --- error if this is not possible and instantiating evars if necessary -mrAssertProveRel :: Maybe (MRRel t ()) -> Term -> Term -> MRM t () -mrAssertProveRel piRel t1 t2 = mrProveRelH piRel t1 t2 >>= \case - Left err -> throwMRFailure (MRFailureCtx (FailCtxProveRel t1 t2) err) - Right success -> unless success $ throwMRFailure (TermsNotEq t1 t2) - --- | The implementation of 'mrProveRel' and 'mrAssertProveRel' -mrProveRelH :: Maybe (MRRel t ()) -> Term -> Term -> MRM t (Either MRFailure Bool) -mrProveRelH piRel t1 t2 = - do mrDebugPPPrefixSep 2 "mrProveRel" t1 "~=" t2 - tp1 <- mrTypeOf t1 >>= mrSubstEVars - tp2 <- mrTypeOf t2 >>= mrSubstEVars - ts_eq <- mrConvertible t1 t2 - if ts_eq then return $ Right True - else mrRelTerm piRel tp1 t1 tp2 t2 >>= - mapM (\cond_in_ctx -> withTermInCtx cond_in_ctx mrProvable) - --- | The main workhorse for 'mrProveRel' and 'mrProveRel': build a Boolean term --- over zero or more universally quantified variables expressing that the two --- given terms of the two given types are related -mrRelTerm :: Maybe (MRRel t ()) -> MRRel t (Either MRFailure TermInCtx) -mrRelTerm piRel tp1 t1 tp2 t2 = - do varmap <- mrVars - tp1' <- liftSC1 scWhnf tp1 - tp2' <- liftSC1 scWhnf tp2 - mrRelTerm' varmap piRel tp1' t1 tp2' t2 - --- | The body of 'mrRelTerm' --- NOTE: Don't call this function recursively, call 'mrRelTerm' -mrRelTerm' :: Map MRVar MRVarInfo -> Maybe (MRRel t ()) -> - MRRel t (Either MRFailure TermInCtx) - --- If t1 is an instantiated evar, substitute and recurse -mrRelTerm' var_map piRel tp1 (asEVarApp var_map -> Just (_, _, args, Just f)) tp2 t2 = - mrApplyAll f args >>= \t1' -> mrRelTerm piRel tp1 t1' tp2 t2 - --- If t1 is an uninstantiated evar, ensure the types are equal and instantiate --- it with t2 -mrRelTerm' var_map _ tp1 (asEVarApp var_map -> Just (evar, _, args, Nothing)) tp2 t2 = - do tps_are_eq <- mrConvertible tp1 tp2 - unless tps_are_eq $ throwMRFailure (TypesNotEq (Type tp1) (Type tp2)) - t2' <- mrSubstEVars t2 - success <- mrTrySetAppliedEVar evar args t2' - when success $ - mrDebugPPPrefixSep 1 "setting evar" evar "to" t2 - Right <$> TermInCtx [] <$> liftSC1 scBool success - --- If t2 is an instantiated evar, substitute and recurse -mrRelTerm' var_map piRel tp1 t1 tp2 (asEVarApp var_map -> Just (_, _, args, Just f)) = - mrApplyAll f args >>= \t2' -> mrRelTerm piRel tp1 t1 tp2 t2' - --- If t2 is an uninstantiated evar, ensure the types are equal and instantiate --- it with t1 -mrRelTerm' var_map _ tp1 t1 tp2 (asEVarApp var_map -> Just (evar, _, args, Nothing)) = - do tps_are_eq <- mrConvertible tp1 tp2 - unless tps_are_eq $ throwMRFailure (TypesNotEq (Type tp1) (Type tp2)) - t1' <- mrSubstEVars t1 - success <- mrTrySetAppliedEVar evar args t1' - when success $ - mrDebugPPPrefixSep 1 "setting evar" evar "to" t1 - Right <$> TermInCtx [] <$> liftSC1 scBool success - --- For unit types, always return true -mrRelTerm' _ _ (asTupleType -> Just []) _ (asTupleType -> Just []) _ = - Right <$> TermInCtx [] <$> liftSC1 scBool True - --- For nat, bool, integer, bitvector, or num type types, use asSimpleEq -mrRelTerm' _ _ tp1@(asSimpleEq -> Just eqf) t1 tp2 t2 = - do tps_are_eq <- mrConvertible tp1 tp2 - unless tps_are_eq $ throwMRFailure (TypesNotEq (Type tp1) (Type tp2)) - t1' <- mrSubstEVars t1 - t2' <- mrSubstEVars t2 - Right <$> TermInCtx [] <$> liftSC2 eqf t1' t2' - --- For BVVec types, prove all projections are related by quantifying over an --- index variable and proving the projections at that index are related -mrRelTerm' _ piRel tp1@(asVecTypeWithLen -> Just (vlen1, tpA1)) t1 - tp2@(asVecTypeWithLen -> Just (vlen2, tpA2)) t2 = - mrVecLenUnify vlen1 vlen2 >>= \case - Just (vlen1', vlen2') -> - mrVecLenIxType vlen1' >>= \ix_tp -> - withUVarLift "ix" (Type ix_tp) (vlen1',vlen2',tpA1,tpA2,t1,t2) $ - \ix (vlen1'',vlen2'',tpA1',tpA2',t1',t2') -> - do ix_bound <- mrVecLenIxBound vlen1'' ix - t1_prj <- mrVecLenAt vlen1'' tpA1' t1' ix - t2_prj <- mrVecLenAt vlen2'' tpA2' t2' ix - mrRelTerm piRel tpA1' t1_prj tpA2' t2_prj >>= mapM (\cond -> - extTermInCtx [("ix",ix_tp)] <$> - liftTermInCtx2 scImplies (TermInCtx [] ix_bound) cond) - Nothing -> throwMRFailure (TypesNotEq (Type tp1) (Type tp2)) - --- For pair types, prove both the left and right projections are related -mrRelTerm' _ piRel (asPairType -> Just (tpL1, tpR1)) t1 - (asPairType -> Just (tpL2, tpR2)) t2 = - do t1L <- liftSC1 scPairLeft t1 - t2L <- liftSC1 scPairLeft t2 - t1R <- liftSC1 scPairRight t1 - t2R <- liftSC1 scPairRight t2 - mb_condL <- mrRelTerm piRel tpL1 t1L tpL2 t2L - mb_condR <- mrRelTerm piRel tpR1 t1R tpR2 t2R - sequence $ liftTermInCtx2 scAnd <$> mb_condL <*> mb_condR - -mrRelTerm' _ piRel tp1 t1 tp2 t2 = - mrSC >>= \sc -> - liftIO (isSpecFunType sc tp1) >>= \tp1_is_specFun -> - liftIO (isSpecFunType sc tp2) >>= \tp2_is_specFun -> - case piRel of - -- If given a relation, on terms of SpecFun type return True iff the - -- relation returns without raising a 'MRFailure' - Just piRel' | tp1_is_specFun, tp2_is_specFun -> - (piRel' tp1 t1 tp2 t2 >> Right <$> TermInCtx [] <$> liftSC1 scBool True) - `catchFailure` \err -> return $ Left err - -- Otherwise, return True iff the terms are convertible - _ -> do - tps_are_eq <- mrConvertible tp1 tp2 - unless tps_are_eq $ throwMRFailure (TypesNotEq (Type tp1) (Type tp2)) - tms_are_eq <- mrConvertible t1 t2 - if tms_are_eq then Right <$> TermInCtx [] <$> liftSC1 scBool True - else return $ Left $ TermsNotEq t1 t2 diff --git a/saw-central/src/SAWCentral/MRSolver/Solver.hs b/saw-central/src/SAWCentral/MRSolver/Solver.hs deleted file mode 100644 index af7239b916..0000000000 --- a/saw-central/src/SAWCentral/MRSolver/Solver.hs +++ /dev/null @@ -1,1496 +0,0 @@ -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE RankNTypes #-} - --- This is to stop GHC 8.8.4's pattern match checker exceeding its limit when --- checking the pattern match in the 'CompTerm' case of 'normComp' -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ <= 808 -{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-} -#endif - -{- | -Module : SAWCentral.MRSolver.Solver -Copyright : Galois, Inc. 2022 -License : BSD3 -Maintainer : westbrook@galois.com -Stability : experimental -Portability : non-portable (language extensions) - -This module implements a monadic-recursive solver, for proving that one monadic -term refines another. The algorithm works on the "monadic normal form" of -computations, which uses the following laws to simplify binds, where @either@ is -the sum elimination function defined in the SAW core prelude: - -> retS x >>= k = k x -> errorS str >>= k = errorM -> (m >>= k1) >>= k2 = m >>= \x -> k1 x >>= k2 -> (existsS f) >>= k = existsM (\x -> f x >>= k) -> (forallS f) >>= k = forallM (\x -> f x >>= k) -> (assumingS b m) >>= k = assumingM b (m >>= k) -> (assertingS b m) >>= k = assertingM b (m >>= k) -> (orS m1 m2) >>= k = orM (m1 >>= k) (m2 >>= k) -> (if b then m1 else m2) >>= k = if b then m1 >>= k else m2 >>= k -> (either f1 f2 e) >>= k = either (\x -> f1 x >>= k) (\x -> f2 x >>= k) e - -The resulting computations are in one of the following forms: - -> returnM e | errorM str | existsM f | forallM f | assumingS b m | -> assertingS b m | orM m1 m2 | if b then m1 else m2 | either f1 f2 e | -> F e1 ... en | F e1 ... en >>= k - -The form @F e1 ... en@ refers to a recursively-defined function or a function -variable that has been locally bound by a @FixS@. Either way, monadic -normalization does not attempt to normalize these functions. - -The algorithm maintains a context of three sorts of variables: @FixS@-bound -variables, existential variables, and universal variables. Universal variables -are represented as free SAW core variables, while the other two forms of -variable are represented as SAW core 'ExtCns's terms, which are essentially -axioms that have been generated internally. These 'ExtCns's are Skolemized, -meaning that they take in as arguments all universal variables that were in -scope when they were created. The context also maintains a partial substitution -for the existential variables, as they become instantiated with values, and it -additionally remembers the bodies / unfoldings of the @FixS@-bound variables. - -The goal of the solver at any point is of the form @C |- m1 |= m2@, meaning that -we are trying to prove @m1@ refines @m2@ in context @C@. This proceeds by cases: - -> C |- retS e1 |= retS e2: prove C |- e1 = e2 -> -> C |- errorS str1 |= errorS str2: vacuously true -> -> C |- if b then m1' else m1'' |= m2: prove C,b=true |- m1' |= m2 and -> C,b=false |- m1'' |= m2, skipping either case where C,b=X is unsatisfiable; -> -> C |- m1 |= if b then m2' else m2'': similar to the above -> -> C |- either T U (SpecM V) f1 f2 e |= m: prove C,x:T,e=inl x |- f1 x |= m and -> C,y:U,e=inl y |- f2 y |= m, again skippping any case with unsatisfiable context; -> -> C |- m |= either T U (SpecM V) f1 f2 e: similar to previous -> -> C |- m |= forallS f: make a new universal variable x and recurse -> -> C |- existsS f |= m: make a new universal variable x and recurse (existential -> elimination uses universal variables and vice-versa) -> -> C |- m |= existsS f: make a new existential variable x and recurse -> -> C |- forallS f |= m: make a new existential variable x and recurse -> -> C |- m |= orS m1 m2: try to prove C |- m |= m1, and if that fails, backtrack and -> prove C |- m |= m2 -> -> C |- orS m1 m2 |= m: prove both C |- m1 |= m and C |- m2 |= m -> -> C |- FixS fdef args |= m: create a FixS-bound variable F bound to (fdef F) and -> recurse on fdef F args |= m -> -> C |- m |= FixS fdef args: similar to previous case -> -> C |- F e1 ... en >>= k |= F e1' ... en' >>= k': prove C |- ei = ei' for each i -> and then prove k x |= k' x for new universal variable x -> -> C |- F e1 ... en >>= k |= F' e1' ... em' >>= k': -> -> * If we have an assumption that forall x1 ... xj, F a1 ... an |= F' a1' .. am', -> prove ei = ai and ei' = ai' and then that C |- k x |= k' x for fresh uvar x -> -> * If we have an assumption that forall x1, ..., xn, F e1'' ... en'' |= m' for -> some ei'' and m', match the ei'' against the ei by instantiating the xj with -> fresh evars, and if this succeeds then recursively prove C |- m' >>= k |= RHS -> -> (We don't do this one right now) -> * If we have an assumption that forall x1', ..., xn', m |= F e1'' ... en'' for -> some ei'' and m', match the ei'' against the ei by instantiating the xj with -> fresh evars, and if this succeeds then recursively prove C |- LHS |= m' >>= k' -> -> * If either side is a definition whose unfolding does not contain FixS or any -> related operations, unfold it -> -> * If F and F' have the same return type, add an assumption forall uvars in scope -> that F e1 ... en |= F' e1' ... em' and unfold both sides, recursively proving -> that F_body e1 ... en |= F_body' e1' ... em'. Then also prove k x |= k' x for -> fresh uvar x. -> -> * Otherwise we don't know to "split" one of the sides into a bind whose -> components relate to the two components on the other side, so just fail --} - -module SAWCentral.MRSolver.Solver where - -import Data.Maybe -import qualified Data.Text as T -import Data.List (find, findIndices) -import Data.Foldable (foldlM) -import Data.Bits (shiftL) -import Control.Monad (void, foldM, forM, zipWithM, zipWithM_, (>=>)) -import Control.Monad.Except (MonadError(..)) -import qualified Data.Map as Map -import qualified Data.Text as Text -import Data.Set (Set) - -import SAWCore.Module (Def(..), ResolvedName(..), ctorNumParams, lookupVarIndexInMap) -import SAWCore.Name -import SAWCore.Term.Functor -import SAWCore.SharedTerm -import SAWCore.Recognizer - -import SAWCentral.Panic -import SAWCentral.Prover.SolverStats -import SAWCentral.Proof (Sequent, SolveResult) -import SAWCentral.Value (TopLevel) - -import SAWCentral.MRSolver.Term -import SAWCentral.MRSolver.Evidence -import SAWCentral.MRSolver.Monad -import SAWCentral.MRSolver.SMT - - ----------------------------------------------------------------------- --- * Normalizing and Matching on Terms ----------------------------------------------------------------------- - --- FIXME: move these to Recognizer.hs - --- | Recognize an equality proposition over Booleans -asBoolEq :: Recognizer Term (Term,Term) -asBoolEq (asEq -> Just ((asBoolType -> Just ()), e1, e2)) = Just (e1, e2) -asBoolEq _ = Nothing - --- | Match a right-nested series of pairs. This is similar to 'asTupleValue' --- except that it expects a unit value to always be at the end. -asNestedPairs :: Recognizer Term [Term] -asNestedPairs (asPairValue -> Just (x, asNestedPairs -> Just xs)) = Just (x:xs) -asNestedPairs (asFTermF -> Just UnitValue) = Just [] -asNestedPairs _ = Nothing - --- | Recognize a term of the form @Cons _ x1 (Cons _ x2 (... (Nil _)))@ -asList :: Recognizer Term [Term] -asList (asGlobalApply "Prelude.Nil" -> Just [_]) = pure [] -asList (asGlobalApply "Prelude.Cons" -> Just [_, hd, tl]) = (hd:) <$> asList tl -asList _ = Nothing - --- | Apply a SAW core term of type @MultiFixBodies@ to a list of monadic --- functions bound for the functions it is defining, and return the bodies for --- those definitions. That is, take a term of the form --- --- > \F1 F2 ... Fn -> (f1, (f2, ... (fn, ()))) --- --- that defines corecursive functions @f1@ through @fn@ using function variables --- @F1@ through @Fn@ to represent recursive calls and apply that term to --- function variables for @F1@ throughh @Fn@, returning @f1@ through @fn@. -mrApplyMFixBodies :: Term -> [Term] -> MRM t [Term] -mrApplyMFixBodies defs_tm fun_tms = - do mm <- liftSC0 scGetModuleMap - let mbody = - case asConstant defs_tm of - Nothing -> Nothing - Just nm -> - case lookupVarIndexInMap (nameIndex nm) mm of - Just (ResolvedDef d) -> defBody d - _ -> Nothing - case mbody of - Just body -> - -- If defs is a constant, unfold it - mrApplyMFixBodies body fun_tms - Nothing -> - do defs_app <- mrApplyAll defs_tm fun_tms - case asNestedPairs defs_app of - Just defs -> return defs - Nothing -> throwMRFailure (MalformedDefs defs_tm) - --- | Bind fresh function variables for a @LetRecS@ or @MultiFixS@ whose types --- are given in the supplied list (which should all be monadic function types) --- and whose bodies are monadic functions that can corecursively call those same --- fresh function variables. In order to represent this corecursion, the bodies --- are specified by a function that takes in SAW core terms for the newly bound --- functions and returns their bodies. -mrFreshCallVars :: [Term] -> ([Term] -> MRM t [Term]) -> MRM t [MRVar] -mrFreshCallVars fun_tps bodies_f = - do - -- Bind fresh function variables with the types given by fun_tps - fun_vars <- mapM (mrFreshVar "F") fun_tps - fun_tms <- mapM mrVarTerm fun_vars - - -- Pass the newly-bound functions to bodies_f to generate the corecursive - -- function bodies, and lift them out of the current uvars - bodies <- bodies_f fun_tms >>= mapM lambdaUVarsM - - -- Remember the body associated with each fresh function constant - zipWithM_ (\f body -> mrSetVarInfo f (CallVarInfo body)) fun_vars bodies - - -- Finally, return the fresh function variables - return fun_vars - - --- | Bind a single fresh function variable for a @FixS@ with a given type (which --- must be a monadic type) and a body that can be corecursive in the function --- variable itself -mrFreshCallVar :: Term -> (Term -> MRM t Term) -> MRM t MRVar -mrFreshCallVar fun_tp body_f = - mrFreshCallVars [fun_tp] - (\case - [v] -> (: []) <$> body_f v - _ -> panic "mrFreshCallVar" ["Expected one function variable"]) >>= \case - [ret] -> return ret - _ -> panic "mrFreshCallVar" ["Expected on return variable"] - - --- | Normalize a 'Term' of monadic type to monadic normal form -normCompTerm :: Term -> MRM t NormComp -normCompTerm = normComp . CompTerm - --- | Normalize a computation to monadic normal form, assuming any 'Term's it --- contains have already been normalized with respect to beta and projections --- (but constants need not be unfolded) -normComp :: Comp -> MRM t NormComp -normComp (CompReturn t) = return $ RetS t -normComp (CompBind m f) = - do norm <- normComp m - normBind norm f -normComp (CompTerm t) = - (>>) (mrDebugPPPrefix 3 "normCompTerm:" t) $ - liftSC0 scGetModuleMap >>= \mm -> - let ?mm = mm in - withFailureCtx (FailCtxMNF t) $ - case asApplyAll t of - (f@(asLambda -> Just _), args@(_:_)) -> - mrApplyAll f args >>= normCompTerm - (isGlobalDef "SpecM.retS" -> Just (), [_, _, x]) -> - return $ RetS x - (isGlobalDef "SpecM.bindS" -> Just (), [ev, _, _, m, f]) -> - do norm <- normCompTerm m - normBind norm (CompFunTerm (EvTerm ev) f) - (isGlobalDef "SpecM.errorS" -> Just (), [_, _, str]) -> - return (ErrorS str) - (isGlobalDef "Prelude.ite" -> Just (), [_, cond, then_tm, else_tm]) -> - return $ Ite cond (CompTerm then_tm) (CompTerm else_tm) - (isGlobalDef "Prelude.iteWithProof" -> Just (), [_, cond, then_f, else_f]) -> - do bool_tp <- liftSC0 scBoolType - then_tm <- - (liftSC1 scBool >=> mrEqProp bool_tp cond >=> mrDummyProof >=> - liftSC2 scApply then_f) True - else_tm <- - (liftSC1 scBool >=> mrEqProp bool_tp cond >=> mrDummyProof >=> - liftSC2 scApply else_f) False - return $ Ite cond (CompTerm then_tm) (CompTerm else_tm) - (isGlobalDef "Prelude.either" -> Just (), - [ltp, rtp, (asSpecM -> Just (ev, _)), f, g, eith]) -> - return $ Eithers [(Type ltp, CompFunTerm ev f), - (Type rtp, CompFunTerm ev g)] eith - (isGlobalDef "Prelude.eithers" -> Just (), - [_, (matchEitherElims -> Just elims), eith]) -> - return $ Eithers elims eith - (isGlobalDef "Prelude.maybe" -> Just (), - [tp, (asSpecM -> Just (ev, _)), m, f, mayb]) -> - do tp' <- case asApplyAll tp of - -- Always unfold: is_bvult, is_bvule - (tpf@(asGlobalDef -> Just ident), args) - | ident `elem` ["Prelude.is_bvult", "Prelude.is_bvule"] - , Just nm <- asConstant tpf -> - do body <- requireDefBody ident nm - mrApplyAll body args - _ -> return tp - return $ MaybeElim (Type tp') (CompTerm m) (CompFunTerm ev f) mayb - (isGlobalDef "SpecM.orS" -> Just (), [_, _, m1, m2]) -> - return $ OrS (CompTerm m1) (CompTerm m2) - (isGlobalDef "SpecM.assertBoolS" -> Just (), [ev, cond]) -> - do unit_tp <- mrUnitType - return $ AssertBoolBind cond (CompFunReturn (EvTerm ev) unit_tp) - (isGlobalDef "SpecM.assumeBoolS" -> Just (), [ev, cond]) -> - do unit_tp <- mrUnitType - return $ AssumeBoolBind cond (CompFunReturn (EvTerm ev) unit_tp) - (isGlobalDef "SpecM.existsS" -> Just (), [ev, tp]) -> - do unit_tp <- mrUnitType - return $ ExistsBind (Type tp) (CompFunReturn (EvTerm ev) unit_tp) - (isGlobalDef "SpecM.forallS" -> Just (), [ev, tp]) -> - do unit_tp <- mrUnitType - return $ ForallBind (Type tp) (CompFunReturn (EvTerm ev) unit_tp) - (isGlobalDef "SpecM.FixS" -> Just (), _ev:_tp_d:body:args) -> - do - -- Bind a fresh function var for the new recursive function, getting the - -- type of the new function as the input type of body, which should have - -- type specFun E T -> specFun E T - body_tp <- mrTypeOf body - fun_tp <- case asPi body_tp of - Just (_, tp_in, _) -> return tp_in - Nothing -> throwMRFailure (MalformedDefs body) - fun_var <- mrFreshCallVar fun_tp (mrApply body) - - -- Return the function variable applied to args as a normalized - -- computation, noting that it must be applied to all of the uvars as - -- well as the args - let var = CallSName fun_var - all_args <- (++ args) <$> getAllUVarTerms - FunBind var all_args <$> mkCompFunReturn <$> - mrFunOutType var all_args - - {- -FIXME HERE NOW: match a tuple projection of a MultiFixS - - (isGlobalDef "SpecM.MultiFixS" -> Just (), ev:tp_ds:defs:args) -> - do - -- Bind fresh function vars for the new recursive functions - fun_vars <- mrFreshCallVars ev tp_ds defs - -- Return the @i@th variable to args as a normalized computation, noting - -- that it must be applied to all of the uvars as well as the args - let var = CallSName (fun_vars !! (fromIntegral i)) - all_args <- (++ args) <$> getAllUVarTerms - FunBind var all_args <$> mkCompFunReturn <$> - mrFunOutType var all_args -} - - (isGlobalDef "SpecM.LetRecS" -> Just (), [ev,tp_ds,_,defs,body]) -> - do - -- First compute the types of the recursive functions being bound by - -- mapping @tpElem@ to the type descriptions, and bind functions of - -- those types - tpElem_fun <- mrGlobalTerm "SpecM.tpElem" - fun_tps <- case asList tp_ds of - Just ds -> mapM (\d -> mrApplyAll tpElem_fun [ev, d]) ds - Nothing -> throwMRFailure (MalformedTpDescList tp_ds) - - -- Bind fresh function vars for the new recursive functions - fun_vars <- mrFreshCallVars fun_tps (mrApplyMFixBodies defs) - fun_tms <- mapM mrVarTerm fun_vars - - -- Continue normalizing body applied to those fresh function vars - body_app <- mrApplyAll body fun_tms - normCompTerm body_app - - -- Treat forNatLtThenS like FixS with a body of forNatLtThenSBody - (isGlobalDef "SpecM.forNatLtThenS" -> Just (), [ev,st,ret,n,f,k,s0]) -> - do - -- Bind a fresh function with type Nat -> st -> SpecM E ret - type_f <- mrGlobalTermUnfold "SpecM.forNatLtThenSBodyType" - fun_tp <- mrApplyAll type_f [ev,st,ret] - - -- Build the function for applying forNatLtThenSBody to its arguments to - -- define the body of the recursive definition, including the invariant - -- argument that is bound to the current assumptions - invar <- mrAssumptions - body_fun_tm <- mrGlobalTermUnfold "SpecM.forNatLtThenSBody" - let body_f rec_fun = - mrApplyAll body_fun_tm [ev,st,ret,n,f,k,invar,rec_fun] - - -- Bind a fresh function var for the new recursive function - fun_var <- mrFreshCallVar fun_tp body_f - - -- Return the function variable applied to 0 and s0 as a normalized - -- computation, noting that it must be applied to all of the uvars as - -- well as the args - let var = CallSName fun_var - z <- liftSC1 scNat 0 - all_args <- (++ [z,s0]) <$> getAllUVarTerms - FunBind var all_args <$> mkCompFunReturn <$> - mrFunOutType var all_args - - - -- Convert `vecMapM (bvToNat ...)` into `bvVecMapInvarM`, with the - -- invariant being the current set of assumptions - (asGlobalDef -> Just "CryptolM.vecMapM", [_a, _b, (asBvToNat -> Just (_w, _n)), - _f, _xs]) -> - error "FIXME HERE NOW: need SpecM version of vecMapM" - {- - do invar <- mrAssumptions - liftSC2 scGlobalApply "CryptolM.bvVecMapInvarM" - [a, b, w, n, f, xs, invar] >>= normCompTerm - -} - - -- Convert `atM (bvToNat ...) ... (bvToNat ...)` into the unfolding of - -- `bvVecAtM` - (asGlobalDef -> Just "CryptolM.atM", [ev, (asBvToNat -> Just (w, n)), - a, xs, i_nat]) -> - do body <- mrGlobalDefBody "CryptolM.bvVecAtM" - liftSC1 scWhnf i_nat >>= mrBvNatInRange w >>= \case - Just i -> mrApplyAll body [ev, w, n, a, xs, i] - >>= normCompTerm - _ -> throwMRFailure (MalformedComp t) - - -- Convert `atM n ... xs (bvToNat ...)` for a constant `n` into the - -- unfolding of `bvVecAtM` after converting `n` to a bitvector constant - -- and applying `genBVVecFromVec` to `xs` - (asGlobalDef -> Just "CryptolM.atM", [ev, n_tm@(asNat -> Just n), - a@(asBoolType -> Nothing), xs, - (asBvToNat -> - Just (w_tm@(asNat -> Just w), - i))]) -> - do body <- mrGlobalDefBody "CryptolM.bvVecAtM" - if n < 1 `shiftL` fromIntegral w then do - n' <- liftSC2 scBvLit w (toInteger n) - xs' <- mrGenBVVecFromVec n_tm a xs "normComp (atM)" w_tm n' - mrApplyAll body [ev, w_tm, n', a, xs', i] >>= normCompTerm - else throwMRFailure (MalformedComp t) - - -- Convert `updateM (bvToNat ...) ... (bvToNat ...)` into the unfolding of - -- `bvVecUpdateM` - (asGlobalDef -> Just "CryptolM.updateM", [ev, (asBvToNat -> Just (w, n)), - a, xs, i_nat, x]) -> - do body <- mrGlobalDefBody "CryptolM.bvVecUpdateM" - liftSC1 scWhnf i_nat >>= mrBvNatInRange w >>= \case - Just i -> mrApplyAll body [ev, w, n, a, xs, i, x] - >>= normCompTerm - _ -> throwMRFailure (MalformedComp t) - - -- Convert `updateM n ... xs (bvToNat ...)` for a constant `n` into the - -- unfolding of `bvVecUpdateM` after converting `n` to a bitvector constant - -- and applying `genBVVecFromVec` to `xs` - (asGlobalDef -> Just "CryptolM.updateM", [ev, n_tm@(asNat -> Just n), - a@(asBoolType -> Nothing), xs, - (asBvToNat -> - Just (w_tm@(asNat -> Just w), - i)), x]) -> - do body <- mrGlobalDefBody "CryptolM.fromBVVecUpdateM" - if n < 1 `shiftL` fromIntegral w then do - n' <- liftSC2 scBvLit w (toInteger n) - xs' <- mrGenBVVecFromVec n_tm a xs "normComp (updateM)" w_tm n' - err_tm <- mrErrorTerm a "normComp (updateM)" - mrApplyAll body [ev, w_tm, n', a, xs', i, x, err_tm, n_tm] - >>= normCompTerm - else throwMRFailure (MalformedComp t) - - -- Always unfold: sawLet, Num_rec, invariantHint, assumingS, assertingS, - -- forNatLtThenSBody, vecMapM, vecMapBindM, seqMapM - (f@(asGlobalDef -> Just ident), args) - | ident `elem` - ["Prelude.sawLet", "Prelude.ifWithProof", "Prelude.iteWithProof", - "Cryptol.Num_rec", "SpecM.invariantHint", - "SpecM.assumingS", "SpecM.assertingS", "SpecM.forNatLtThenSBody", - "CryptolM.vecMapM", "CryptolM.vecMapBindM", "CryptolM.seqMapM"] - , Just nm <- asConstant f -> - do body <- requireDefBody ident nm - mrApplyAll body args >>= normCompTerm - - -- Always unfold recursors applied to constructors - (asRecursorApp -> Just (rc, crec, _, arg), args) - | (asConstant -> Just c, cargs) <- asApplyAll arg -> - do case lookupVarIndexInMap (nameIndex c) mm of - Just (ResolvedCtor ctor) -> - do let cargs' = drop (ctorNumParams ctor) cargs - hd' <- liftSC4 scReduceRecursor rc crec c cargs' - >>= liftSC1 betaNormalize - t' <- mrApplyAll hd' args - normCompTerm t' - _ -> throwMRFailure (MalformedComp t) - - -- Always unfold record selectors applied to record values (after scWhnf) - (asRecordSelector -> Just (r, fld), args) -> - do r' <- liftSC1 scWhnf r - case asRecordValue r' of - Just (Map.lookup fld -> Just f) -> do t' <- mrApplyAll f args - normCompTerm t' - _ -> throwMRFailure (MalformedComp t) - - -- For a Variable, we have to check what sort of variable it is - -- FIXME: substitute for evars if they have been instantiated - ((asVariable -> Just ec), args) -> - do fun_name <- extCnsToFunName ec - FunBind fun_name args <$> mkCompFunReturn <$> - mrFunOutType fun_name args - - ((asGlobalFunName -> Just f), args) -> - FunBind f args <$> mkCompFunReturn <$> mrFunOutType f args - - _ -> throwMRFailure (MalformedComp t) - - -requireDefBody :: Ident -> Name -> MRM t Term -requireDefBody ident nm = - do mm <- liftSC0 scGetModuleMap - case lookupVarIndexInMap (nameIndex nm) mm of - Just (ResolvedDef (defBody -> Just t)) -> pure t - _ -> panic "normComp" ["Missing definition for constant " <> identText ident] - --- | Bind a computation in whnf with a function, and normalize -normBind :: NormComp -> CompFun -> MRM t NormComp -normBind (RetS t) k = applyNormCompFun k t -normBind (ErrorS msg) _ = return (ErrorS msg) -normBind (Ite cond comp1 comp2) k = - return $ Ite cond (CompBind comp1 k) (CompBind comp2 k) -normBind (Eithers elims t) k = - return $ Eithers (map (\(tp,f) -> (tp, compFunComp f k)) elims) t -normBind (MaybeElim tp m f t) k = - return $ MaybeElim tp (CompBind m k) (compFunComp f k) t -normBind (OrS comp1 comp2) k = - return $ OrS (CompBind comp1 k) (CompBind comp2 k) -normBind (AssertBoolBind cond f) k = - return $ AssertBoolBind cond (compFunComp f k) -normBind (AssumeBoolBind cond f) k = - return $ AssumeBoolBind cond (compFunComp f k) -normBind (ExistsBind tp f) k = return $ ExistsBind tp (compFunComp f k) -normBind (ForallBind tp f) k = return $ ForallBind tp (compFunComp f k) -normBind (FunBind f args k1) k2 - -- Turn `bvVecMapInvarM ... >>= k` into `bvVecMapInvarBindM ... k` - {- - | GlobalName (globalDefString -> "CryptolM.bvVecMapInvarM") [] <- f - , (a:b:args_rest) <- args = - do f' <- mrGlobalDef "CryptolM.bvVecMapInvarBindM" - cont <- compFunToTerm (compFunComp k1 k2) - c <- compFunReturnType k2 - return $ FunBind f' ((a:b:c:args_rest) ++ [cont]) - (CompFunReturn (Type c)) - -- Turn `bvVecMapInvarBindM ... k1 >>= k2` into - -- `bvVecMapInvarBindM ... (composeM ... k1 k2)` - | GlobalName (globalDefString -> "CryptolM.bvVecMapInvarBindM") [] <- f - , (args_pre, [cont]) <- splitAt 8 args = - do cont' <- compFunToTerm (compFunComp (compFunComp (CompFunTerm cont) k1) k2) - c <- compFunReturnType k2 - return $ FunBind f (args_pre ++ [cont']) (CompFunReturn (Type c)) - | otherwise -} = return $ FunBind f args (compFunComp k1 k2) - --- | Bind a 'Term' for a computation with a function and normalize -normBindTerm :: Term -> CompFun -> MRM t NormComp -normBindTerm t f = normCompTerm t >>= \m -> normBind m f - -{- --- | Get the return type of a 'CompFun' -compFunReturnType :: CompFun -> MRM t Term -compFunReturnType (CompFunTerm _ t) = mrTypeOf t -compFunReturnType (CompFunComp _ g) = compFunReturnType g -compFunReturnType (CompFunReturn _ _) = error "FIXME" --} - --- | Apply a computation function to a term argument to get a computation -applyCompFun :: CompFun -> Term -> MRM t Comp -applyCompFun (CompFunComp f g) t = - -- (f >=> g) t == f t >>= g - do comp <- applyCompFun f t - return $ CompBind comp g -applyCompFun (CompFunReturn _ _) t = - return $ CompReturn t -applyCompFun (CompFunTerm _ f) t = CompTerm <$> mrApplyAll f [t] - --- | Convert a 'CompFun' into a 'Term' -compFunToTerm :: CompFun -> MRM t Term -compFunToTerm (CompFunTerm _ t) = return t -compFunToTerm (CompFunComp f g) = - do f' <- compFunToTerm f - g' <- compFunToTerm g - f_tp <- mrTypeOf f' - g_tp <- mrTypeOf g' - case (f_tp, g_tp) of - (asPi -> Just (_, a, asSpecM -> Just (ev, b)), - asPi -> Just (_, _, asSpecM -> Just (_, c))) -> - -- we explicitly unfold @SpecM.composeS@ here so @mrApplyAll@ will - -- beta-reduce - let nm = maybe "ret_val" id (compFunVarName f) in - mrLambdaLift1 (nm, a) (b, c, f', g') $ \arg (b', c', f'', g'') -> - do app <- mrApplyAll f'' [arg] - liftSC2 scGlobalApply "SpecM.bindS" [unEvTerm ev, - b', c', app, g''] - _ -> error "compFunToTerm: type(s) not of the form: a -> SpecM b" -compFunToTerm (CompFunReturn ev (Type a)) = - mrLambdaLift1 ("ret_val", a) a $ \ret_val a' -> - liftSC2 scGlobalApply "SpecM.retS" [unEvTerm ev, a', ret_val] - -{- --- | Convert a 'Comp' into a 'Term' -compToTerm :: Comp -> MRM t Term -compToTerm (CompTerm t) = return t -compToTerm (CompReturn t) = - do tp <- mrTypeOf t - liftSC2 scGlobalApply "SpecM.retS" [tp, t] -compToTerm (CompBind m (CompFunReturn _)) = compToTerm m -compToTerm (CompBind m f) = - do m' <- compToTerm m - f' <- compFunToTerm f - mrTypeOf f' >>= \case - (asPi -> Just (_, a, asSpecM -> Just b)) -> - liftSC2 scGlobalApply "SpecM.bindS" [a, b, m', f'] - _ -> error "compToTerm: type not of the form: a -> SpecM b" --} - --- | Apply a 'CompFun' to a term and normalize the resulting computation -applyNormCompFun :: CompFun -> Term -> MRM t NormComp -applyNormCompFun f arg = applyCompFun f arg >>= normComp - - --- | Convert a 'FunAssumpRHS' to a 'NormComp' -mrFunAssumpRHSAsNormComp :: FunAssumpRHS -> MRM t NormComp -mrFunAssumpRHSAsNormComp (OpaqueFunAssump f args) = - FunBind f args <$> mkCompFunReturn <$> mrFunOutType f args -mrFunAssumpRHSAsNormComp (RewriteFunAssump rhs) = normCompTerm rhs - - --- | Match a term as a static list of eliminators for an Eithers type -matchEitherElims :: Term -> Maybe [EitherElim] -matchEitherElims (asGlobalApply "Prelude.FunsTo_Nil" -> Just [_]) = Just [] -matchEitherElims (asGlobalApply "Prelude.FunsTo_Cons" -> Just [asSpecM -> Just (ev, _), tp, f, rest]) = - ((Type tp, CompFunTerm ev f):) <$> - matchEitherElims rest -matchEitherElims _ = Nothing - --- | Construct the type @Eithers tps@ eliminated by a list of 'EitherElim's -elimsEithersType :: [EitherElim] -> MRM t Type -elimsEithersType elims = - Type <$> - (do f <- mrGlobalTerm "Prelude.Eithers" - tps <- - foldr - (\(Type tp,_) restM -> - restM >>= \rest -> mrCtorApp "Prelude.LS_Cons" [tp,rest]) - (mrCtorApp "Prelude.LS_Nil" []) - elims - mrApply f tps) - - -{- FIXME: do these go away? --- | Lookup the definition of a function or throw a 'CannotLookupFunDef' if this is --- not allowed, either because it is a global function we are treating as opaque --- or because it is a locally-bound function variable -mrLookupFunDef :: FunName -> MRM t Term -mrLookupFunDef f@(GlobalName _) = throwMRFailure (CannotLookupFunDef f) -mrLookupFunDef f@(LocalName var) = - mrVarInfo var >>= \case - Just (FunVarInfo body) -> return body - Just _ -> throwMRFailure (CannotLookupFunDef f) - Nothing -> error "mrLookupFunDef: unknown variable!" - --- | Unfold a call to function @f@ in term @f args >>= g@ -mrUnfoldFunBind :: FunName -> [Term] -> Mark -> CompFun -> MRM t Comp -mrUnfoldFunBind f _ mark _ | inMark f mark = throwMRFailure (RecursiveUnfold f) -mrUnfoldFunBind f args mark g = - do f_def <- mrLookupFunDef f - CompBind <$> - (CompMark <$> (CompTerm <$> liftSC2 scApplyAll f_def args) - <*> (return $ singleMark f `mappend` mark)) - <*> return g --} - -{- -FIXME HERE: maybe each FunName should stipulate whether it is recursive or -not, so that mrRefines can unfold the non-recursive ones early but wait on -handling the recursive ones --} - - ----------------------------------------------------------------------- --- * Handling Coinductive Hypotheses ----------------------------------------------------------------------- - --- | Prove the invariant of a coinductive hypothesis -proveCoIndHypInvariant :: CoIndHyp -> MRM t () -proveCoIndHypInvariant hyp = - do (invar1, invar2) <- applyCoIndHypInvariants hyp - invar <- liftSC2 scAnd invar1 invar2 - success <- mrProvable invar - if success then return () else - throwMRFailure $ - InvariantNotProvable (coIndHypLHSFun hyp) (coIndHypRHSFun hyp) invar - --- | Co-inductively prove the refinement --- --- > forall x1, ..., xn. preF y1 ... ym -> preG z1 ... zl -> --- > F y1 ... ym |= G z1 ... zl@ --- --- where @F@ and @G@ are the given 'FunName's, @y1, ..., ym@ and @z1, ..., zl@ --- are the given argument lists, @x1, ..., xn@ is the current context of uvars, --- and @invarF@ and @invarG@ are the invariants associated with @F@ and @G@, --- respectively. This proof is performed by coinductively assuming the --- refinement holds and proving the refinement with the definitions of @F@ and --- @G@ unfolded to their bodies. Note that this refinement is performed with --- /only/ the invariants @invarF@ and @invarG@ as assumptions; all other --- assumptions are thrown away. If while running the refinement computation a --- 'CoIndHypMismatchWidened' error is reached with the given names, the state is --- restored and the computation is re-run with the widened hypothesis. -mrRefinesCoInd :: FunName -> [Term] -> FunName -> [Term] -> MRM t () -mrRefinesCoInd f1 args1 f2 args2 = - do ctx <- mrUVars - preF1 <- mrGetInvariant f1 - preF2 <- mrGetInvariant f2 - let hyp = CoIndHyp ctx f1 f2 args1 args2 preF1 preF2 - proveCoIndHypInvariant hyp - proveCoIndHyp [] hyp - --- | Prove the refinement represented by a 'CoIndHyp' coinductively. This is the --- main loop implementing 'mrRefinesCoInd'. See that function for documentation. -proveCoIndHyp :: [[Either Int Int]] -> CoIndHyp -> MRM t () -proveCoIndHyp prev_specs hyp = withFailureCtx (FailCtxCoIndHyp hyp) $ - do let f1 = coIndHypLHSFun hyp - f2 = coIndHypRHSFun hyp - args1 = coIndHypLHS hyp - args2 = coIndHypRHS hyp - mrDebugPPInCtxM 1 (prettyWithCtx emptyMRVarCtx $ - prettyPrefix "proveCoIndHyp" hyp) - lhs <- fromMaybe (error "proveCoIndHyp") <$> mrFunBody f1 args1 - rhs <- fromMaybe (error "proveCoIndHyp") <$> mrFunBody f2 args2 - (invar1, invar2) <- applyCoIndHypInvariants hyp - invar <- liftSC2 scAnd invar1 invar2 - (withOnlyUVars (coIndHypCtx hyp) $ withOnlyAssumption invar $ - withCoIndHyp hyp $ mrRefines lhs rhs) `catchError` \case - MRExnWiden nm1' nm2' new_vars - | f1 == nm1' && f2 == nm2' && elem new_vars prev_specs -> - -- This should never happen, since it means that generalizing - -- new_vars led to the exact same arguments not unifying, but at - -- least one more should unify when we generalize - panic "proveCoIndHyp" ["Generalization loop detected!"] - | f1 == nm1' && f2 == nm2' -> - -- NOTE: the state automatically gets reset here because we defined - -- MRM t with ExceptT at a lower level than StateT - do mrDebugPPPrefixSep 1 "Widening recursive assumption for" nm1' "|=" nm2' - hyp' <- generalizeCoIndHyp hyp new_vars - proveCoIndHyp (new_vars:prev_specs) hyp' - e -> throwError e - --- | Test that a coinductive hypothesis for the given function names matches the --- given arguments, otherwise throw an exception saying that widening is needed -matchCoIndHyp :: CoIndHyp -> [Term] -> [Term] -> MRM t () -matchCoIndHyp hyp args1 args2 = - do mrDebugPPPrefix 1 "matchCoIndHyp" hyp - (args1', args2') <- instantiateCoIndHyp hyp - mrDebugPPPrefixSep 3 "matchCoIndHyp args" args1 "," args2 - mrDebugPPPrefixSep 3 "matchCoIndHyp args'" args1' "," args2' - eqs1 <- zipWithM mrProveEqBiRef args1' args1 - eqs2 <- zipWithM mrProveEqBiRef args2' args2 - if and (eqs1 ++ eqs2) then return () else - throwError $ MRExnWiden (coIndHypLHSFun hyp) (coIndHypRHSFun hyp) - (map Left (findIndices not eqs1) ++ map Right (findIndices not eqs2)) - proveCoIndHypInvariant hyp - --- | Generalize a coinductive hypothesis of the form --- --- > forall x1..xn. f args_l |= g args_r --- --- by replacing some of the arguments with fresh variables that are added to the --- coinductive hypothesis, i.e., to the list @x1..xn@ of quantified variables. --- The arguments that need to be generalized are given by index on either the --- left- or right-hand list of arguments. Any of the arguments being generalized --- that are equivalent (in the sense of 'mrProveRel') get generalized to the --- same fresh variable, so we preserve as much equality as we can between --- arguments being generalized. Note that generalized arguments are not unified --- with non-generalized arguments, since they are being generalized because they --- didn't match the non-generalized arguments in some refinement call that the --- solver tried to make and couldn't. -generalizeCoIndHyp :: CoIndHyp -> [Either Int Int] -> MRM t CoIndHyp -generalizeCoIndHyp hyp [] = return hyp -generalizeCoIndHyp hyp all_specs@(arg_spec_0:arg_specs) = - withOnlyUVars (coIndHypCtx hyp) $ do - withNoUVars $ mrDebugPPPrefixSep 2 "generalizeCoIndHyp with indices" - all_specs "on" hyp - -- Get the arg and type associated with the first arg_spec and build an - -- injective representation for it, keeping track of the representation term - -- and type - let arg_tm_0 = coIndHypArg hyp arg_spec_0 - arg_tp_0 <- mrTypeOf arg_tm_0 >>= mrNormOpenTerm - (tp_r0, tm_r0, repr0) <- mkInjReprTerm arg_tp_0 arg_tm_0 - - -- Attempt to unify the representation of arg 0 with each of the arg_specs - -- being generalized using injUnifyRepr. When unification succeeds, this could - -- result in a more specific representation type, so use injReprRestrict to - -- update the representations of all the arguments that have already been - -- unified with arg 0 - (tp_r, _, repr, eq_args, arg_reprs, uneq_args) <- - foldM - (\(tp_r, tm_r, repr, eq_args, arg_reprs, uneq_args) arg_spec -> - do let arg_tm = coIndHypArg hyp arg_spec - arg_tp <- mrTypeOf arg_tm >>= mrNormOpenTerm - unify_res <- injUnifyRepr tp_r tm_r repr arg_tp arg_tm - case unify_res of - Just (tp_r',tm_r',repr',arg_repr) -> - -- If unification succeeds, add arg to the list of eq_args and add - -- its repr to the list of arg_reprs, and restrict the previous - -- arg_reprs to use the new representation type tp_r' - do arg_reprs' <- mapM (injReprRestrict tp_r' repr' tp_r) arg_reprs - return (tp_r', tm_r', repr', - arg_spec:eq_args, arg_repr:arg_reprs', uneq_args) - Nothing -> - -- If unification fails, add arg_spec to the list of uneq_args - return (tp_r, tm_r, repr, eq_args, arg_reprs, arg_spec:uneq_args)) - (tp_r0, tm_r0, repr0, [], [], []) - arg_specs - - -- Now we generalize the arguments that unify with arg_spec0 by adding a new - -- variable z of type tp_r to hyp and setting each arg in eq_args to the - -- result of applying its corresponding repr to z - (hyp', var) <- coIndHypWithVar hyp "z" (Type tp_r) - arg_reprs' <- liftTermLike 0 1 (repr:arg_reprs) - hyp'' <- foldlM (\hyp_i (arg_spec_i, repr_i) -> - coIndHypSetArg hyp_i arg_spec_i <$> mrApplyRepr repr_i var) - hyp' (zip (arg_spec_0:eq_args) arg_reprs') - -- We finish by recursing on any remaining arg_specs - generalizeCoIndHyp hyp'' uneq_args - - ----------------------------------------------------------------------- --- * Decidable Propositions ----------------------------------------------------------------------- - --- | A function for assuming a proposition or its negation, that also lifts a --- 'TermLike' argument in the sense of 'withUVarLift' -newtype AssumpFun t = AssumpFun { appAssumpFun :: - forall tm a. TermLike tm => - Bool -> tm -> (tm -> MRM t a) -> MRM t a } - --- | Test if a 'Term' is a propostion that has a corresponding Boolean SAW core --- term that decides it; e.g., IsLtNat n m is a Prop that corresponds to the --- Boolean expression ltNat n m. If so, return the Boolean expression -asBoolProp :: Term -> Maybe (MRM t Term) -asBoolProp (asEq -> Just (asSimpleEq -> Just eqf, e1, e2)) = - Just $ liftSC2 eqf e1 e2 -asBoolProp (asApplyAll -> (isGlobalDef "Prelude.IsLtNat" -> Just (), [n,m])) = - Just $ liftSC2 scLtNat n m -asBoolProp _ = Nothing - --- | Test if a 'Term' is a propostion that MR solver can decide, i.e., test if --- it or its negation holds. If so, return: a function to decide the propostion, --- that returns 'Just' of a Boolean iff the proposition definitely does or does --- not hold; and a function to assume the proposition or its negation in a --- sub-computation. This latter function also takes a 'TermLike' that it will --- lift in the sense of 'withUVarLift' in the sub-computation. -asDecProp :: Term -> Maybe (MRM t (Maybe Bool, AssumpFun t)) -asDecProp (asBoolProp -> Just condM) = - Just $ - do cond <- condM - not_cond <- liftSC1 scNot cond - let assumeM b tm m = withAssumption (if b then cond else not_cond) (m tm) - mrProvable cond >>= \case - True -> return (Just True, AssumpFun assumeM) - False -> - mrProvable not_cond >>= \case - True -> return (Just False, AssumpFun assumeM) - False -> return (Nothing, AssumpFun assumeM) -asDecProp (asIsFinite -> Just n) = - Just $ - do n_norm <- mrNormOpenTerm n - maybe_assump <- mrGetDataTypeAssump n_norm - -- The assumption function that requires b == req, in which case it is just - -- the identity, and otherwise panics - let requireIdAssumeM req b tm m = - if req == b then m tm else - panic "asDecProp" ["Unexpected inconsistent assumption"] - case (maybe_assump, asNum n_norm) of - (_, Just (Left _)) -> - return (Just True, AssumpFun (requireIdAssumeM True)) - (_, Just (Right _)) -> - return (Just False, AssumpFun (requireIdAssumeM False)) - (Just (IsNum _), _) -> - return (Just True, AssumpFun (requireIdAssumeM True)) - (Just IsInf, _) -> - return (Just False, AssumpFun (requireIdAssumeM False)) - _ -> - return (Nothing, - AssumpFun $ \b tm m -> - if b then - (liftSC0 scNatType >>= \nat_tp -> - (withUVarLift "n" (Type nat_tp) (n_norm, tm) $ \n_nat (n', tm') -> - withDataTypeAssump n' (IsNum n_nat) (m tm'))) - else - withDataTypeAssump n_norm IsInf (m tm)) -asDecProp _ = Nothing - - ----------------------------------------------------------------------- --- * Mr Solver Himself (He Identifies as Male) ----------------------------------------------------------------------- - --- | An object that can be converted to a normalized computation -class ToNormComp a where - toNormComp :: a -> MRM t NormComp - -instance ToNormComp NormComp where - toNormComp = return -instance ToNormComp Comp where - toNormComp = normComp -instance ToNormComp Term where - toNormComp = normComp . CompTerm - --- | Prove that the left-hand computation refines the right-hand one. See the --- rules described at the beginning of this module. -mrRefines :: (ToNormComp a, ToNormComp b) => a -> b -> MRM t () -mrRefines t1 t2 = - do m1 <- toNormComp t1 - m2 <- toNormComp t2 - mrDebugPPPrefixSep 1 "mrRefines" m1 "|=" m2 - -- ctx <- reverse . map (\(a,Type b) -> (a,b)) <$> mrUVars - -- mrDebugPPPrefix 2 "in context:" $ ppCtx ctx - withFailureCtx (FailCtxRefines m1 m2) $ mrRefines' m1 m2 - --- | Helper function that applies 'mrRefines' to a pair -mrRefinesPair :: (ToNormComp a, ToNormComp b) => (a, b) -> MRM t () -mrRefinesPair (a,b) = mrRefines a b - --- | The main implementation of 'mrRefines' -mrRefines' :: NormComp -> NormComp -> MRM t () - -mrRefines' (RetS e1) (RetS e2) = mrAssertProveEqBiRef e1 e2 -mrRefines' (ErrorS _) (ErrorS _) = return () -mrRefines' (RetS e) (ErrorS err) = throwMRFailure (ReturnNotError (Right err) e) -mrRefines' (ErrorS err) (RetS e) = throwMRFailure (ReturnNotError (Left err) e) - -mrRefines' (MaybeElim (Type prop_tp@(asDecProp -> Just decPropM)) m1 f1 _) m2 = - decPropM >>= \case - (Just True, AssumpFun assumeM) -> - do m1' <- mrDummyProof prop_tp >>= applyNormCompFun f1 - assumeM True (m1',m2) mrRefinesPair - (Just False, AssumpFun assumeM) -> assumeM False (m1,m2) mrRefinesPair - (Nothing, AssumpFun assumeM) -> - do m1' <- mrDummyProof prop_tp >>= applyNormCompFun f1 - assumeM True (m1',m2) mrRefinesPair - assumeM False (m1,m2) mrRefinesPair - -mrRefines' m1 (MaybeElim (Type prop_tp@(asDecProp -> Just decPropM)) m2 f2 _) = - decPropM >>= \case - (Just True, AssumpFun assumeM) -> - do m2' <- mrDummyProof prop_tp >>= applyNormCompFun f2 - assumeM True (m1,m2') mrRefinesPair - (Just False, AssumpFun assumeM) -> assumeM False (m1,m2) mrRefinesPair - (Nothing, AssumpFun assumeM) -> - do m2' <- mrDummyProof prop_tp >>= applyNormCompFun f2 - assumeM True (m1,m2') mrRefinesPair - assumeM False (m1,m2) mrRefinesPair - -mrRefines' (Ite cond1 m1 m1') m2 = - liftSC1 scNot cond1 >>= \not_cond1 -> - mrProvable cond1 >>= \cond1_true_pv-> - mrProvable not_cond1 >>= \cond1_false_pv -> - case (cond1_true_pv, cond1_false_pv) of - (True, _) -> mrRefines m1 m2 - (_, True) -> mrRefines m1' m2 - _ -> withAssumption cond1 (mrRefines m1 m2) >> - withAssumption not_cond1 (mrRefines m1' m2) -mrRefines' m1 (Ite cond2 m2 m2') = - liftSC1 scNot cond2 >>= \not_cond2 -> - mrProvable cond2 >>= \cond2_true_pv-> - mrProvable not_cond2 >>= \cond2_false_pv -> - case (cond2_true_pv, cond2_false_pv) of - (True, _) -> mrRefines m1 m2 - (_, True) -> mrRefines m1 m2' - _ -> withAssumption cond2 (mrRefines m1 m2) >> - withAssumption not_cond2 (mrRefines m1 m2') - -mrRefines' (Eithers [] _) _ = return () -mrRefines' _ (Eithers [] _) = return () -mrRefines' (Eithers [(_,f)] t1) m2 = - applyNormCompFun f t1 >>= \m1 -> - mrRefines m1 m2 -mrRefines' m1 (Eithers [(_,f)] t2) = - applyNormCompFun f t2 >>= \m2 -> - mrRefines m1 m2 - -mrRefines' (Eithers ((tp,f1):elims) t1) m2 = - mrNormOpenTerm t1 >>= \t1' -> - mrGetDataTypeAssump t1' >>= \mb_assump -> - case (mb_assump, asEither t1') of - (_, Just (Left x)) -> applyNormCompFun f1 x >>= flip mrRefines m2 - (_, Just (Right x)) -> mrRefines (Eithers elims x) m2 - (Just (IsLeft x), _) -> applyNormCompFun f1 x >>= flip mrRefines m2 - (Just (IsRight x), _) -> mrRefines (Eithers elims x) m2 - _ -> let lnm = maybe "x_left" id (compFunVarName f1) - rnm = "x_right" in - elimsEithersType elims >>= \elims_tp -> - withUVarLift lnm tp (f1, t1', m2) (\x (f1', t1'', m2') -> - applyNormCompFun f1' x >>= withDataTypeAssump t1'' (IsLeft x) - . flip mrRefines m2') >> - withUVarLift rnm elims_tp (elims, t1', m2) - (\x (elims', t1'', m2') -> - withDataTypeAssump t1'' (IsRight x) (mrRefines (Eithers elims' x) m2')) - -mrRefines' m1 (Eithers ((tp,f2):elims) t2) = - mrNormOpenTerm t2 >>= \t2' -> - mrGetDataTypeAssump t2' >>= \mb_assump -> - case (mb_assump, asEither t2') of - (_, Just (Left x)) -> applyNormCompFun f2 x >>= mrRefines m1 - (_, Just (Right x)) -> mrRefines m1 (Eithers elims x) - (Just (IsLeft x), _) -> applyNormCompFun f2 x >>= mrRefines m1 - (Just (IsRight x), _) -> mrRefines m1 (Eithers elims x) - _ -> let lnm = maybe "x_left" id (compFunVarName f2) - rnm = "x_right" in - elimsEithersType elims >>= \elims_tp -> - withUVarLift lnm tp (f2, t2', m1) (\x (f2', t2'', m1') -> - applyNormCompFun f2' x >>= withDataTypeAssump t2'' (IsLeft x) - . mrRefines m1') >> - withUVarLift rnm elims_tp (elims, t2', m1) - (\x (elims', t2'', m1') -> - withDataTypeAssump t2'' (IsRight x) (mrRefines m1' (Eithers elims' x))) - -mrRefines' m1 (AssumeBoolBind cond2 k2) = - do m2 <- liftSC0 scUnitValue >>= applyCompFun k2 - not_cond2 <- liftSC1 scNot cond2 - cond2_true_pv <- mrProvable cond2 - cond2_false_pv <- mrProvable not_cond2 - case (cond2_true_pv, cond2_false_pv) of - (True, _) -> mrRefines m1 m2 - (_, True) -> return () - _ -> withAssumption cond2 $ mrRefines m1 m2 -mrRefines' (AssertBoolBind cond1 k1) m2 = - do m1 <- liftSC0 scUnitValue >>= applyCompFun k1 - cond1_str <- mrShowInCtx cond1 - let err_txt = "mrRefines failed assertion: " <> T.pack cond1_str - m1' <- ErrorS <$> liftSC1 scString err_txt - not_cond1 <- liftSC1 scNot cond1 - cond1_true_pv <- mrProvable cond1 - cond1_false_pv <- mrProvable not_cond1 - case (cond1_true_pv, cond1_false_pv) of - (True, _) -> mrRefines m1 m2 - (_, True) -> mrRefines m1' m2 - _ -> withAssumption cond1 $ mrRefines m1 m2 - -mrRefines' m1 (ForallBind tp f2) = - let nm = maybe "x" id (compFunVarName f2) in - mrNormOpenTerm (typeTm tp) >>= mkInjReprType >>= \(tp', r) -> - withUVarLift nm (Type tp') (m1,f2) $ \x (m1',f2') -> - mrApplyRepr r x >>= \x' -> - applyNormCompFun f2' x' >>= \m2' -> - mrRefines m1' m2' -mrRefines' (ExistsBind tp f1) m2 = - let nm = maybe "x" id (compFunVarName f1) in - mrNormOpenTerm (typeTm tp) >>= mkInjReprType >>= \(tp', r) -> - withUVarLift nm (Type tp') (f1,m2) $ \x (f1',m2') -> - mrApplyRepr r x >>= \x' -> - applyNormCompFun f1' x' >>= \m1' -> - mrRefines m1' m2' - -mrRefines' m1 (OrS m2 m2') = - mrOr (mrRefines m1 m2) (mrRefines m1 m2') -mrRefines' (OrS m1 m1') m2 = - mrRefines m1 m2 >> mrRefines m1' m2 - --- FIXME: the following cases don't work unless we either allow evars to be set --- to NormComps or we can turn NormComps back into terms -mrRefines' m1@(FunBind (EVarFunName _) _ _) m2 = - throwMRFailure (CompsDoNotRefine m1 m2) -mrRefines' m1 m2@(FunBind (EVarFunName _) _ _) = - throwMRFailure (CompsDoNotRefine m1 m2) -{- -mrRefines' (FunBind (EVarFunName evar) args (CompFunReturn _)) m2 = - mrGetEVar evar >>= \case - Just f -> - (mrApplyAll f args >>= normCompTerm) >>= \m1' -> - mrRefines m1' m2 - Nothing -> mrTrySetAppliedEVar evar args m2 --} - -mrRefines' (FunBind f args1 k1) (FunBind f' args2 k2) - | f == f' && length args1 == length args2 = - zipWithM_ mrAssertProveEqBiRef args1 args2 >> - mrFunOutType f args1 >>= \(_, tp) -> - mrRefinesFun tp k1 tp k2 - -mrRefines' m1@(FunBind f1 args1 k1) - m2@(FunBind f2 args2 k2) = - liftSC0 scGetModuleMap >>= \mm -> - let ?mm = mm in - mrFunOutType f1 args1 >>= mapM mrNormOpenTerm >>= \(_, tp1) -> - mrFunOutType f2 args2 >>= mapM mrNormOpenTerm >>= \(_, tp2) -> - injUnifyTypes tp1 tp2 >>= \mb_convs -> - mrFunBodyRecInfo f1 args1 >>= \maybe_f1_body -> - mrFunBodyRecInfo f2 args2 >>= \maybe_f2_body -> - mrGetCoIndHyp f1 f2 >>= \maybe_coIndHyp -> - mrGetFunAssump f1 >>= \maybe_fassump -> - case (maybe_coIndHyp, maybe_fassump) of - - -- If we have a co-inductive assumption that f1 args1' |= f2 args2': - -- * If it is convertible to our goal, continue and prove that k1 |= k2 - -- * If it can be widened with our goal, restart the current proof branch - -- with the widened hypothesis (done by throwing a - -- 'CoIndHypMismatchWidened' error for 'proveCoIndHyp' to catch) - -- * Otherwise, throw a 'CoIndHypMismatchFailure' error. - (Just hyp, _) -> - matchCoIndHyp hyp args1 args2 >> - mrRefinesFun tp1 k1 tp2 k2 - - -- If we have an opaque FunAssump that f1 args1' refines f2 args2', then - -- prove that args1 = args1', args2 = args2', and then that k1 refines k2 - (_, Just fa@(FunAssump ctx _ args1' (OpaqueFunAssump f2' args2') _)) | f2 == f2' -> - do mrDebugPPInCtxM 2 $ prettyWithCtx ctx $ - prettyAppList [return "mrRefines using opaque FunAssump:", - prettyInCtx ctx, return ".", - prettyTermApp (funNameTerm f1) args1', - return "|=", - prettyTermApp (funNameTerm f2) args2'] - evars <- mrFreshEVars ctx - (args1'', args2'') <- substTermLike 0 evars (args1', args2') - zipWithM_ mrAssertProveEqBiRef args1'' args1 - zipWithM_ mrAssertProveEqBiRef args2'' args2 - recordUsedFunAssump fa >> mrRefinesFun tp1 k1 tp2 k2 - - -- If we have an opaque FunAssump that f1 refines some f /= f2, and f2 - -- unfolds and is not recursive in itself, unfold f2 and recurse - (_, Just fa@(FunAssump _ _ _ (OpaqueFunAssump _ _) _)) - | Just (f2_body, False) <- maybe_f2_body -> - normBindTerm f2_body k2 >>= \m2' -> - recordUsedFunAssump fa >> mrRefines m1 m2' - - -- If we have a rewrite FunAssump, or we have an opaque FunAssump that - -- f1 args1' refines some f args where f /= f2 and f2 does not match the - -- case above, treat either case like we have a rewrite FunAssump and prove - -- that args1 = args1' and then that f args refines m2 - (_, Just fa@(FunAssump ctx _ args1' rhs _)) -> - do let fassump_tp_str = case fassumpRHS fa of - OpaqueFunAssump _ _ -> "opaque" - RewriteFunAssump _ -> "rewrite" - mrDebugPPInCtxM 2 $ prettyWithCtx ctx $ - prettyAppList [return ("mrRefines rewriting by " <> fassump_tp_str - <> " FunAssump:"), - prettyInCtx ctx, return ".", - prettyTermApp (funNameTerm f1) args1', - return "|=", - case rhs of - OpaqueFunAssump f2' args2' -> - prettyTermApp (funNameTerm f2') args2' - RewriteFunAssump rhs_tm -> - prettyInCtx rhs_tm] - rhs' <- mrFunAssumpRHSAsNormComp rhs - evars <- mrFreshEVars ctx - (args1'', rhs'') <- substTermLike 0 evars (args1', rhs') - zipWithM_ mrAssertProveEqBiRef args1'' args1 - -- It's important to instantiate the evars here so that rhs is well-typed - -- when bound with k1 - rhs''' <- mapTermLike mrSubstEVars rhs'' - m1' <- normBind rhs''' k1 - recordUsedFunAssump fa >> mrRefines m1' m2 - - -- If f1 unfolds and is not recursive in itself, unfold it and recurse - _ | Just (f1_body, False) <- maybe_f1_body -> - normBindTerm f1_body k1 >>= \m1' -> mrRefines m1' m2 - - -- If f2 unfolds and is not recursive in itself, unfold it and recurse - _ | Just (f2_body, False) <- maybe_f2_body -> - normBindTerm f2_body k2 >>= \m2' -> mrRefines m1 m2' - - -- If we don't have a co-inducitve hypothesis for f1 and f2, don't have an - -- assumption that f1 refines some specification, both f1 and f2 are recursive - -- and have return types which can be injectively unified, then try to - -- coinductively prove that f1 args1 |= f2 args2 under the assumption that - -- f1 args1 |= f2 args2, and then try to prove that k1 |= k2 - _ | Just _ <- maybe_f1_body - , Just _ <- maybe_f2_body -> - case mb_convs of - Just _ -> mrRefinesCoInd f1 args1 f2 args2 >> mrRefinesFun tp1 k1 tp2 k2 - _ -> throwMRFailure (BindTypesNotUnifiable (Type tp1) (Type tp2)) - - -- If we cannot line up f1 and f2, then making progress here would require us - -- to somehow split either m1 or m2 into some bind m' >>= k' such that m' is - -- related to the function call on the other side and k' is related to the - -- continuation on the other side, but we don't know how to do that, so give - -- up - _ -> throwMRFailure (FunNamesDoNotRefine f1 args1 f2 args2) - -mrRefines' m1@(FunBind f1 args1 k1) m2 = - mrGetFunAssump f1 >>= \case - - -- If we have an assumption that f1 args' refines some rhs, then prove that - -- args1 = args' and then that rhs refines m2 - Just fa@(FunAssump ctx _ args1' rhs _) -> - do rhs' <- mrFunAssumpRHSAsNormComp rhs - evars <- mrFreshEVars ctx - (args1'', rhs'') <- substTermLike 0 evars (args1', rhs') - zipWithM_ mrAssertProveEqBiRef args1'' args1 - -- It's important to instantiate the evars here so that rhs is well-typed - -- when bound with k1 - rhs''' <- mapTermLike mrSubstEVars rhs'' - m1' <- normBind rhs''' k1 - recordUsedFunAssump fa >> mrRefines m1' m2 - - -- Otherwise, see if we can unfold f1 - Nothing -> - liftSC0 scGetModuleMap >>= \mm -> - let ?mm = mm in - mrFunBodyRecInfo f1 args1 >>= \case - - -- If f1 unfolds and is not recursive in itself, unfold it and recurse - Just (f1_body, False) -> - normBindTerm f1_body k1 >>= \m1' -> mrRefines m1' m2 - - -- Otherwise we would have to somehow split m2 into some computation of the - -- form m2' >>= k2 where f1 args1 |= m2' and k1 |= k2, but we don't know how - -- to do this splitting, so give up - _ -> mrRefines'' m1 m2 - -mrRefines' m1 m2@(FunBind f2 args2 k2) = - liftSC0 scGetModuleMap >>= \mm -> - let ?mm = mm in - mrFunBodyRecInfo f2 args2 >>= \case - - -- If f2 unfolds and is not recursive in itself, unfold it and recurse - Just (f2_body, False) -> - normBindTerm f2_body k2 >>= \m2' -> mrRefines m1 m2' - - -- If f2 unfolds but is recursive, and k2 is the trivial continuation, meaning - -- m2 is just f2 args2, use the law of coinduction to prove m1 |= f2 args2 by - -- proving m1 |= f2_body under the assumption that m1 |= f2 args2 - {- FIXME: implement something like this - Just (f2_body, True) - | CompFunReturn _ <- k2 -> - withFunAssumpR m1 f2 args2 $ - -} - - -- Otherwise we would have to somehow split m1 into some computation of the - -- form m1' >>= k1 where m1' |= f2 args2 and k1 |= k2, but we don't know how - -- to do this splitting, so give up - _ -> mrRefines'' m1 m2 - -mrRefines' m1 m2 = mrRefines'' m1 m2 - --- | The cases of 'mrRefines' which must occur after the ones in 'mrRefines''. --- For example, the rules that introduce existential variables need to go last, --- so that they can quantify over as many universals as possible -mrRefines'' :: NormComp -> NormComp -> MRM t () - -mrRefines'' m1 (AssertBoolBind cond2 k2) = - do m2 <- liftSC0 scUnitValue >>= applyCompFun k2 - cond2_pv <- mrProvable cond2 - if cond2_pv then mrRefines m1 m2 - else throwMRFailure (AssertionNotProvable cond2) -mrRefines'' (AssumeBoolBind cond1 k1) m2 = - do m1 <- liftSC0 scUnitValue >>= applyCompFun k1 - cond1_pv <- mrProvable cond1 - if cond1_pv then mrRefines m1 m2 - else throwMRFailure (AssumptionNotProvable cond1) - -mrRefines'' m1 (ExistsBind tp f2) = - do let nm = maybe "x" id (compFunVarName f2) - tp' <- mrNormOpenTerm (typeTm tp) - evars <- forM (fromMaybe [tp'] (asTupleType tp')) $ \tp_i -> - mkInjReprType tp_i >>= \(tp_i', r) -> - mrFreshEVar nm (Type tp_i') >>= mrApplyRepr r - x <- liftSC1 scTuple evars - m2' <- applyNormCompFun f2 x - mrRefines m1 m2' -mrRefines'' (ForallBind tp f1) m2 = - do let nm = maybe "x" id (compFunVarName f1) - tp' <- mrNormOpenTerm (typeTm tp) - evars <- forM (fromMaybe [tp'] (asTupleType tp')) $ \tp_i -> - mkInjReprType tp_i >>= \(tp_i', r) -> - mrFreshEVar nm (Type tp_i') >>= mrApplyRepr r - x <- liftSC1 scTuple evars - m1' <- applyNormCompFun f1 x - mrRefines m1' m2 - --- If none of the above cases match, then fail -mrRefines'' m1 m2 = throwMRFailure (CompsDoNotRefine m1 m2) - --- | Prove that one function refines another for all inputs -mrRefinesFun :: Term -> CompFun -> Term -> CompFun -> MRM t () -mrRefinesFun tp1 f1 tp2 f2 = - do mrDebugPPPrefixSep 1 "mrRefinesFun on types:" tp1 "," tp2 - f1' <- compFunToTerm f1 >>= liftSC1 scWhnf - f2' <- compFunToTerm f2 >>= liftSC1 scWhnf - mrDebugPPPrefixSep 1 "mrRefinesFun" f1' "|=" f2' - let nm1 = maybe "call_ret_val" id (compFunVarName f1) - nm2 = maybe "call_ret_val" id (compFunVarName f2) - f1'' <- mrLambdaLift1 (nm1, tp1) f1' $ flip mrApply - f2'' <- mrLambdaLift1 (nm2, tp2) f2' $ flip mrApply - piTp1 <- mrTypeOf f1'' >>= mrNormOpenTerm - piTp2 <- mrTypeOf f2'' >>= mrNormOpenTerm - mrRefinesFunH mrRefines [] piTp1 f1'' piTp2 f2'' - --- | Prove that two functions both refine another for all inputs -mrBiRefinesFuns :: MRRel t () -mrBiRefinesFuns piTp1 f1 piTp2 f2 = - mrDebugPPPrefixSep 1 "mrBiRefinesFuns" f1 "=|=" f2 >> - mrNormOpenTerm piTp1 >>= \piTp1' -> - mrNormOpenTerm piTp2 >>= \piTp2' -> - mrRefinesFunH mrRefines [] piTp1' f1 piTp2' f2 >> - mrRefinesFunH mrRefines [] piTp2' f2 piTp1' f1 - --- | Prove that two terms are related via bi-refinement on terms of SpecFun --- type (as in 'isSpecFunType') or via equality otherwise, returning false if --- this is not possible and instantiating evars if necessary -mrProveEqBiRef :: Term -> Term -> MRM t Bool -mrProveEqBiRef = mrProveRel (Just mrBiRefinesFuns) - --- | Prove that two terms are related via bi-refinement on terms of SpecFun --- type (as in 'isSpecFunType') or via equality otherwise, throwing an error if --- this is not possible and instantiating evars if necessary -mrAssertProveEqBiRef :: Term -> Term -> MRM t () -mrAssertProveEqBiRef = mrAssertProveRel (Just mrBiRefinesFuns) - - --- | The main loop of 'mrRefinesFun', 'askMRSolver': given a function that --- attempts to prove refinement between two computational terms, i.e., terms of --- type @SpecM a@ and @SpecM b@ for some types @a@ and @b@, attempt to prove --- refinement between two monadic functions. The list of 'Term's argument --- contains all the variables that have so far been abstracted by --- 'mrRefinesFunH', and the remaining 'Term's are the left-hand type, left-hand --- term of that type, right-hand type, and right-hand term of that type for the --- refinement we are trying to prove. --- --- This function works by abstracting over arguments of the left- and right-hand --- sides, as determined by their types, and applying the functions to these --- variables until we get terms of non-functional monadic type, that are passed --- to the supplied helper function. Proposition arguments in the form of --- equality on Boolean values can occur on either side, and are added as --- assumptions to the refinement. Regular non-proof arguments must occur on both --- sides, and are added as a single variable that is passed to both sides. This --- means that these regular argument types must be either equal or --- injectively unifiable with 'injUnifyTypes'. -mrRefinesFunH :: (Term -> Term -> MRM t a) -> [Term] -> MRRel t a - --- Ignore units on either side -mrRefinesFunH k vars (asPi -> Just (_, asTupleType -> Just [], _)) t1 piTp2 t2 = - do u <- liftSC0 scUnitValue - t1' <- mrApplyAll t1 [u] - piTp1' <- mrTypeOf t1' - mrRefinesFunH k vars piTp1' t1' piTp2 t2 -mrRefinesFunH k vars piTp1 t1 (asPi -> Just (_, asTupleType -> Just [], _)) t2 = - do u <- liftSC0 scUnitValue - t2' <- mrApplyAll t2 [u] - piTp2' <- mrTypeOf t2' - mrRefinesFunH k vars piTp1 t1 piTp2' t2' - --- Introduce equalities on either side as assumptions -mrRefinesFunH k vars (asPi -> Just (nm1, tp1@(asBoolEq -> - Just (b1, b2)), _)) t1 piTp2 t2 = - liftSC2 scBoolEq b1 b2 >>= \eq -> - withAssumption eq $ - let nm = maybe "p" id $ find ((/=) '_' . Text.head) - $ [nm1] ++ catMaybes [ asLambdaName t1 ] in - withUVarLift nm (Type tp1) (vars,t1,piTp2,t2) $ \var (vars',t1',piTp2',t2') -> - do t1'' <- mrApplyAll t1' [var] - piTp1' <- mrTypeOf t1'' - mrRefinesFunH k (var : vars') piTp1' t1'' piTp2' t2' -mrRefinesFunH k vars piTp1 t1 (asPi -> Just (nm2, tp2@(asBoolEq -> - Just (b1, b2)), _)) t2 = - liftSC2 scBoolEq b1 b2 >>= \eq -> - withAssumption eq $ - let nm = maybe "p" id $ find ((/=) '_' . Text.head) - $ [nm2] ++ catMaybes [ asLambdaName t2 ] in - withUVarLift nm (Type tp2) (vars,piTp1,t1,t2) $ \var (vars',piTp1',t1',t2') -> - do t2'' <- mrApplyAll t2' [var] - piTp2' <- mrTypeOf t2'' - mrRefinesFunH k (var : vars') piTp1' t1' piTp2' t2'' - --- We always curry pair values before introducing them (NOTE: we do this even --- when the have the same types to ensure we never have to unify a projection --- of an evar with a non-projected value, e.g. evar.1 == val) --- FIXME: Only do this if we have corresponding pairs on both sides? -mrRefinesFunH k vars (asPi -> Just (nm1, asPairType -> Just (tpL1, tpR1), _)) t1 - (asPi -> Just (nm2, asPairType -> Just (tpL2, tpR2), _)) t2 = - do t1'' <- mrLambdaLift2 (nm1, tpL1) (nm1, tpR1) t1 $ \prj1 prj2 t1' -> - liftSC2 scPairValue prj1 prj2 >>= mrApply t1' - t2'' <- mrLambdaLift2 (nm2, tpL2) (nm2, tpR2) t2 $ \prj1 prj2 t2' -> - liftSC2 scPairValue prj1 prj2 >>= mrApply t2' - piTp1' <- mrTypeOf t1'' - piTp2' <- mrTypeOf t2'' - mrRefinesFunH k vars piTp1' t1'' piTp2' t2'' -mrRefinesFunH k vars (asPi -> Just (nm1, asPairType -> Just (tpL1, tpR1), _)) t1 tp2 t2 = - do t1'' <- mrLambdaLift2 (nm1, tpL1) (nm1, tpR1) t1 $ \prj1 prj2 t1' -> - liftSC2 scPairValue prj1 prj2 >>= mrApply t1' - piTp1' <- mrTypeOf t1'' - mrRefinesFunH k vars piTp1' t1'' tp2 t2 -mrRefinesFunH k vars tp1 t1 (asPi -> Just (nm2, asPairType -> Just (tpL2, tpR2), _)) t2 = - do t2'' <- mrLambdaLift2 (nm2, tpL2) (nm2, tpR2) t2 $ \prj1 prj2 t2' -> - liftSC2 scPairValue prj1 prj2 >>= mrApply t2' - piTp2' <- mrTypeOf t2'' - mrRefinesFunH k vars tp1 t1 piTp2' t2'' - -mrRefinesFunH k vars (asPi -> Just (nm1, tp1, _)) t1 - (asPi -> Just (nm2, tp2, _)) t2 = - injUnifyTypes tp1 tp2 >>= \case - -- If we can find injective conversions from from a type @tp@ to @tp1@ and - -- @tp2@, introduce a variable of type @tp@, apply both conversions to it, - -- and substitute the results on the left and right sides, respectively - Just (tp, r1, r2) -> - mrDebugPPPrefixSep 3 "mrRefinesFunH calling findInjConvs" tp1 "," tp2 >> - mrDebugPPPrefix 3 "mrRefinesFunH got type" tp >> - let nm = maybe "x" id $ find ((/=) '_' . Text.head) - $ [nm1, nm2] ++ catMaybes [ asLambdaName t1 - , asLambdaName t2 ] in - withUVarLift nm (Type tp) (vars,r1,r2,t1,t2) $ \var (vars',r1',r2',t1',t2') -> - do tm1 <- mrApplyRepr r1' var - tm2 <- mrApplyRepr r2' var - t1'' <- mrApplyAll t1' [tm1] - t2'' <- mrApplyAll t2' [tm2] - piTp1' <- mrTypeOf t1'' >>= liftSC1 scWhnf - piTp2' <- mrTypeOf t2'' >>= liftSC1 scWhnf - mrRefinesFunH k (var : vars') piTp1' t1'' piTp2' t2'' - -- Otherwise, error - Nothing -> throwMRFailure (TypesNotUnifiable (Type tp1) (Type tp2)) - --- Error if we don't have the same number of arguments on both sides --- FIXME: Add a specific error for this case -mrRefinesFunH _ _ (asPi -> Just (_,tp1,_)) _ (asPi -> Nothing) _ = - liftSC0 scUnitType >>= \utp -> - throwMRFailure (TypesNotEq (Type tp1) (Type utp)) -mrRefinesFunH _ _ (asPi -> Nothing) _ (asPi -> Just (_,tp2,_)) _ = - liftSC0 scUnitType >>= \utp -> - throwMRFailure (TypesNotEq (Type utp) (Type tp2)) - --- Error if either side's return type is not SpecM -mrRefinesFunH _ _ tp1@(asSpecM -> Nothing) t1 _ _ = - throwMRFailure (NotCompFunType tp1 t1) -mrRefinesFunH _ _ _ _ tp2@(asSpecM -> Nothing) t2 = - throwMRFailure (NotCompFunType tp2 t2) - --- This case means we must be proving refinement on two SpecM computations, so --- call the helper function k -mrRefinesFunH k _ _ t1 _ t2 = k t1 t2 - - ----------------------------------------------------------------------- --- * External Entrypoints ----------------------------------------------------------------------- - --- | The continuation passed to 'mrRefinesFunH' in 'askMRSolver' - normalizes --- both resulting terms using 'normCompTerm' then calls the given monadic --- function -askMRSolverH :: (NormComp -> NormComp -> MRM t a) -> Term -> Term -> MRM t a -askMRSolverH f t1 t2 = - do mrUVars >>= mrDebugPPPrefix 1 "askMRSolverH uvars:" - m1 <- normCompTerm t1 - m2 <- normCompTerm t2 - f m1 m2 - --- | Test two monadic, recursive terms for refinement -askMRSolver :: - SharedContext -> - MREnv {- ^ The Mr Solver environment -} -> - Maybe Integer {- ^ Timeout in milliseconds for each SMT call -} -> - (Set VarIndex -> Sequent -> TopLevel (SolverStats, SolveResult)) - {- ^ The callback to use for making SMT queries -} -> - Refnset t {- ^ Any additional refinements to be assumed by Mr Solver -} -> - [(LocalName, Term)] {- ^ Any universally quantified variables in scope -} -> - Term -> Term -> TopLevel (Either MRFailure (SolverStats, MREvidence t)) -askMRSolver sc env timeout askSMT rs args t1 t2 = - execMRM sc env timeout askSMT rs $ - withUVars (mrVarCtxFromOuterToInner args) $ \_ -> - do tp1 <- liftSC1 scTypeOf t1 >>= mrNormOpenTerm - tp2 <- liftSC1 scTypeOf t2 >>= mrNormOpenTerm - mrDebugPPPrefixSep 1 "mr_solver" t1 "|=" t2 - mrRefinesFunH (askMRSolverH mrRefines) [] tp1 t1 tp2 t2 - --- | Helper function for 'refinementTerm': returns the proposition stating that --- one 'Term' refines another, after quantifying over all current 'mrUVars' with --- Pi types. Note that this assumes both terms have the same event types; if --- they do not a saw-core typechecking error will be raised. -refinementTermH :: Term -> Term -> MRM t Term -refinementTermH t1 t2 = - do (EvTerm ev, tp1) <- fromJust . asSpecM <$> mrTypeOf t1 - (EvTerm _, tp2) <- fromJust . asSpecM <$> mrTypeOf t2 - -- FIXME: Add a direct way to check that the types are related, instead of - -- calling 'mrRelTerm' on dummy variables and ignoring the result - withUVarLift "ret_val" (Type tp1) (tp1,tp2) $ \x1 (tp1',tp2') -> - withUVarLift "ret_val" (Type tp2') (tp1',tp2',x1) $ \x2 (tp1'',tp2'',x1') -> - do tp1''' <- mrSubstEVars tp1'' - tp2''' <- mrSubstEVars tp2'' - void $ mrRelTerm Nothing tp1''' x1' tp2''' x2 - rr <- liftSC2 scGlobalApply "SpecM.eqRR" [tp1] - ref_tm <- liftSC2 scGlobalApply "SpecM.refinesS" [ev, tp1, tp1, rr, t1, t2] - uvars <- mrUVarsOuterToInner - liftSC2 scPiList uvars ref_tm - --- | Build the proposition stating that one function term refines another, after --- quantifying over all the given arguments as well as any additional arguments --- needed to fully apply the given terms, and adding any calls to @assertS@ on --- the right hand side needed for unifying the arguments generated when fully --- applying the given terms -refinementTerm :: - SharedContext -> - MREnv {- ^ The Mr Solver environment -} -> - Maybe Integer {- ^ Timeout in milliseconds for each SMT call -} -> - (Set VarIndex -> Sequent -> TopLevel (SolverStats, SolveResult)) - {- ^ The callback to use for making SMT queries -} -> - Refnset t {- ^ Any additional refinements to be assumed by Mr Solver -} -> - [(LocalName, Term)] {- ^ Any universally quantified variables in scope -} -> - Term -> Term -> TopLevel (Either MRFailure Term) -refinementTerm sc env timeout askSMT rs args t1 t2 = - evalMRM sc env timeout askSMT rs $ - withUVars (mrVarCtxFromOuterToInner args) $ \_ -> - do tp1 <- liftSC1 scTypeOf t1 >>= mrNormOpenTerm - tp2 <- liftSC1 scTypeOf t2 >>= mrNormOpenTerm - mrRefinesFunH refinementTermH [] tp1 t1 tp2 t2 diff --git a/saw-central/src/SAWCentral/MRSolver/Term.hs b/saw-central/src/SAWCentral/MRSolver/Term.hs deleted file mode 100644 index 86a8b16cc0..0000000000 --- a/saw-central/src/SAWCentral/MRSolver/Term.hs +++ /dev/null @@ -1,636 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE EmptyCase #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} - -{- | -Module : SAWCentral.MRSolver.Term -Copyright : Galois, Inc. 2022 -License : BSD3 -Maintainer : westbrook@galois.com -Stability : experimental -Portability : non-portable (language extensions) - -This module defines the representation of terms used in Mr. Solver and various -utility functions for operating on terms and term representations. The main -datatype is 'NormComp', which represents the result of one step of monadic -normalization - see @Solver.hs@ for the description of this normalization. --} - -module SAWCentral.MRSolver.Term where - -import Data.String -import Data.IORef -import Control.Monad (foldM) -import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.Reader (MonadReader(..), Reader, runReader) -import Control.Monad.Trans (MonadTrans(..)) -import Control.Monad.Trans.Maybe -import qualified Data.IntMap as IntMap -import Numeric.Natural (Natural) -import GHC.Generics - -import Prettyprinter -import Data.Text (Text, unpack) - -import qualified SAWSupport.Pretty as PPS (Doc, Opts, render) - -import SAWCore.Module (ModuleMap) -import SAWCore.Name (Name(..)) -import SAWCore.Term.Functor -import SAWCore.Term.Pretty -import SAWCore.SharedTerm -import SAWCore.Recognizer hiding ((:*:)) -import CryptolSAWCore.Monadify - - ----------------------------------------------------------------------- --- * MR Solver Term Representation ----------------------------------------------------------------------- - --- | Recognize a nested pi type with at least @N@ arguments, returning the --- context of those first @N@ arguments and the body -asPiListN :: Int -> Recognizer Term ([(LocalName,Term)], Term) -asPiListN 0 tp = Just ([], tp) -asPiListN i (asPi -> Just (x, tp, body)) = - fmap (\(ctx, body') -> ((x,tp):ctx, body')) $ asPiListN (i-1) body -asPiListN _ _ = Nothing - --- | A variable used by the MR solver -newtype MRVar = MRVar { unMRVar :: ExtCns Term } deriving (Eq, Show, Ord) - --- | Get the type of an 'MRVar' -mrVarType :: MRVar -> Term -mrVarType = ecType . unMRVar - --- | Print the string name of an 'MRVar' -showMRVar :: MRVar -> String -showMRVar = show . ppName . ecNameInfo . unMRVar - --- | A tuple or record projection of a 'Term' -data TermProj = TermProjLeft | TermProjRight | TermProjRecord FieldName - deriving (Eq, Ord, Show) - --- | Recognize a 'Term' as 0 or more projections -asProjAll :: Term -> (Term, [TermProj]) -asProjAll (asRecordSelector -> Just ((asProjAll -> (t, projs)), fld)) = - (t, TermProjRecord fld:projs) -asProjAll (asPairSelector -> Just ((asProjAll -> (t, projs)), isRight)) - | isRight = (t, TermProjRight:projs) - | not isRight = (t, TermProjLeft:projs) -asProjAll t = (t, []) - --- | Names of functions to be used in computations, which are either names bound --- by @multiFixS@ for recursive calls to fixed-points, existential variables, or --- (possibly projections of) of global named constants -data FunName - = CallSName MRVar | EVarFunName MRVar | GlobalName GlobalDef [TermProj] - deriving (Eq, Ord, Show) - --- | Recognize a 'Term' as (possibly a projection of) a global name -asTypedGlobalProj :: (?mm :: ModuleMap) => Recognizer Term (GlobalDef, [TermProj]) -asTypedGlobalProj (asProjAll -> ((asTypedGlobalDef -> Just glob), projs)) = - Just (glob, projs) -asTypedGlobalProj _ = Nothing - --- | Recognize a 'Term' as (possibly a projection of) a global name -asGlobalFunName :: (?mm :: ModuleMap) => Recognizer Term FunName -asGlobalFunName (asTypedGlobalProj -> Just (glob, projs)) = - Just $ GlobalName glob projs -asGlobalFunName _ = Nothing - --- | Convert a 'FunName' to an unshared term, for printing -funNameTerm :: FunName -> Term -funNameTerm (CallSName var) = Unshared $ Variable $ unMRVar var -funNameTerm (EVarFunName var) = Unshared $ Variable $ unMRVar var -funNameTerm (GlobalName gdef []) = globalDefTerm gdef -funNameTerm (GlobalName gdef (TermProjLeft:projs)) = - Unshared $ FTermF $ PairLeft $ funNameTerm (GlobalName gdef projs) -funNameTerm (GlobalName gdef (TermProjRight:projs)) = - Unshared $ FTermF $ PairRight $ funNameTerm (GlobalName gdef projs) -funNameTerm (GlobalName gdef (TermProjRecord fname:projs)) = - Unshared $ FTermF $ RecordProj (funNameTerm (GlobalName gdef projs)) fname - --- | A term specifically known to be of type @sort i@ for some @i@ -newtype Type = Type { typeTm :: Term } deriving (Generic, Show) - --- | A context of variables, with names and types. To avoid confusion as to --- how variables are ordered, do not use this type's constructor directly. --- Instead, use the combinators defined below. -newtype MRVarCtx = MRVarCtx [(LocalName,Type)] - -- ^ Internally, we store these names and types in order - -- from innermost to outermost variable, see - -- 'mrVarCtxInnerToOuter' - deriving (Generic, Show) - --- | Build an empty context of variables -emptyMRVarCtx :: MRVarCtx -emptyMRVarCtx = MRVarCtx [] - --- | Build a context with a single variable of the given name and type -singletonMRVarCtx :: LocalName -> Type -> MRVarCtx -singletonMRVarCtx nm tp = MRVarCtx [(nm,tp)] - --- | Add a context of new variables (the first argument) to an existing context --- (the second argument). The new variables to add must be in the existing --- context, i.e. all the types in the first argument must be in the context of --- the second argument. -mrVarCtxAppend :: MRVarCtx -> MRVarCtx -> MRVarCtx -mrVarCtxAppend (MRVarCtx ctx1) (MRVarCtx ctx2) = MRVarCtx (ctx1 ++ ctx2) - --- | Return the number of variables in the given context -mrVarCtxLength :: MRVarCtx -> Int -mrVarCtxLength (MRVarCtx ctx) = length ctx - --- | Return a list of the names and types of the variables in the given --- context in order from innermost to outermost, i.e., where element @i@ --- corresponds to deBruijn index @i@, and each type is in the context of --- all the variables which come after it in the list (i.e. all the variables --- which come after a type in the list are free in that type). In other words, --- the list is ordered from newest to oldest variable. -mrVarCtxInnerToOuter :: MRVarCtx -> [(LocalName,Term)] -mrVarCtxInnerToOuter (MRVarCtx ctx) = map (\(nm, Type tp) -> (nm, tp)) ctx - --- | Build a context of variables from a list of names and types in innermost --- to outermost order - see 'mrVarCtxInnerToOuter'. -mrVarCtxFromInnerToOuter :: [(LocalName,Term)] -> MRVarCtx -mrVarCtxFromInnerToOuter = MRVarCtx . map (\(nm,tp) -> (nm, Type tp)) - --- | Return a list of the names and types of the variables in the given --- context in order from outermost to innermost, i.e., where element @i@ --- corresponds to deBruijn index @len - i@, and each type is in the context of --- all the variables which come before it in the list (i.e. all the variables --- which come before a type in the list are free in that type). In other words, --- the list is ordered from oldest to newest variable. -mrVarCtxOuterToInner :: MRVarCtx -> [(LocalName,Term)] -mrVarCtxOuterToInner = reverse . mrVarCtxInnerToOuter - --- | Build a context of variables from a list of names and types in outermost --- to innermost order - see 'mrVarCtxOuterToInner'. -mrVarCtxFromOuterToInner :: [(LocalName,Term)] -> MRVarCtx -mrVarCtxFromOuterToInner = mrVarCtxFromInnerToOuter . reverse - --- | A Haskell representation of a @SpecM@ in \"monadic normal form\" -data NormComp - = RetS Term -- ^ A term @retS _ _ a x@ - | ErrorS Term -- ^ A term @errorS _ _ a str@ - | Ite Term Comp Comp -- ^ If-then-else computation - | Eithers [EitherElim] Term -- ^ A multi-way sum elimination - | MaybeElim Type Comp CompFun Term -- ^ A maybe elimination - | OrS Comp Comp -- ^ an @orS@ computation - | AssertBoolBind Term CompFun -- ^ the bind of an @assertBoolS@ computation - | AssumeBoolBind Term CompFun -- ^ the bind of an @assumeBoolS@ computation - | ExistsBind Type CompFun -- ^ the bind of an @existsS@ computation - | ForallBind Type CompFun -- ^ the bind of a @forallS@ computation - | FunBind FunName [Term] CompFun - -- ^ Bind a monadic function with @N@ arguments, possibly wrapped in a call - -- to @liftStackS@, in an @a -> SpecM b@ term - deriving (Generic, Show) - --- | An eliminator for an @Eithers@ type is a pair of the type of the disjunct --- and a function from that type to the output type -type EitherElim = (Type,CompFun) - --- | A wrapper around 'Term' to designate it as a @SpecM@ event type -newtype EvTerm = EvTerm { unEvTerm :: Term } deriving (Generic, Show) - --- | A computation function of type @a -> SpecM b@ for some @a@ and @b@ -data CompFun - -- | An arbitrary term - = CompFunTerm EvTerm Term - -- | A special case for the term @\ (x:a) -> returnM a x@ - | CompFunReturn EvTerm Type - -- | The monadic composition @f >=> g@ - | CompFunComp CompFun CompFun - deriving (Generic, Show) - --- | Apply 'CompFunReturn' to a pair of an event type and a return type -mkCompFunReturn :: (EvTerm, Term) -> CompFun -mkCompFunReturn (ev, tp) = CompFunReturn ev $ Type tp - --- | Compose two 'CompFun's, simplifying if one is a 'CompFunReturn' -compFunComp :: CompFun -> CompFun -> CompFun -compFunComp (CompFunReturn _ _) f = f -compFunComp f (CompFunReturn _ _) = f -compFunComp f g = CompFunComp f g - --- | If a 'CompFun' contains an explicit lambda-abstraction, then return the --- textual name bound by that lambda -compFunVarName :: CompFun -> Maybe LocalName -compFunVarName (CompFunTerm _ t) = asLambdaName t -compFunVarName (CompFunComp f _) = compFunVarName f -compFunVarName _ = Nothing - --- | If a 'CompFun' contains an explicit lambda-abstraction, then return the --- input type for it -compFunInputType :: CompFun -> Maybe Type -compFunInputType (CompFunTerm _ (asLambda -> Just (_, tp, _))) = Just $ Type tp -compFunInputType (CompFunComp f _) = compFunInputType f -compFunInputType (CompFunReturn _ t) = Just t -compFunInputType _ = Nothing - --- | Get the @SpecM@ event type from a 'CompFun' -compFunEventType :: CompFun -> EvTerm -compFunEventType (CompFunTerm ev _) = ev -compFunEventType (CompFunReturn ev _) = ev -compFunEventType (CompFunComp f _) = compFunEventType f - --- | A computation of type @SpecM a@ for some @a@ -data Comp = CompTerm Term | CompBind Comp CompFun | CompReturn Term - deriving (Generic, Show) - --- | Match a type as being of the form @SpecM E a@ for some @E@ and @a@ -asSpecM :: Term -> Maybe (EvTerm, Term) -asSpecM (asApplyAll -> (isGlobalDef "SpecM.SpecM" -> Just (), [ev, tp])) = - return (EvTerm ev, tp) -asSpecM _ = fail "not a SpecM type, or event type is not closed!" - --- | Test if a type normalizes to a monadic function type of 0 or more arguments -isSpecFunType :: SharedContext -> Term -> IO Bool -isSpecFunType sc t = scWhnf sc t >>= \case - (asPiList -> (_, asSpecM -> Just _)) -> return True - _ -> return False - - ----------------------------------------------------------------------- --- * Useful 'Recognizer's for 'Term's ----------------------------------------------------------------------- - --- | Recognize a 'Term' as an application of @bvToNat@ with a statically-known --- natural number bit width -asBvToNatKnownW :: Recognizer Term (Natural, Term) -asBvToNatKnownW (asBvToNat -> Just (asNat -> Just n, t)) = Just (n, t) -asBvToNatKnownW _ = Nothing - --- | Recognize a term as a @Left@ or @Right@ -asEither :: Recognizer Term (Either Term Term) -asEither (asGlobalApply "Prelude.Left" -> Just [_, _, x]) = pure $ Left x -asEither (asGlobalApply "Prelude.Right" -> Just [_, _, x]) = pure $ Right x -asEither _ = Nothing - --- | Recognize the @Num@ type -asNumType :: Recognizer Term () -asNumType = isGlobalDef "Cryptol.Num" - --- | Recognize a term as a @TCNum n@ or @TCInf@ -asNum :: Recognizer Term (Either Term ()) -asNum (asGlobalApply "Cryptol.TCNum" -> Just [n]) = pure $ Left n -asNum (asGlobalApply "Cryptol.TCInf" -> Just []) = pure $ Right () -asNum _ = Nothing - --- | Recognize a term as being of the form @isFinite n@ -asIsFinite :: Recognizer Term Term -asIsFinite (asApp -> Just (isGlobalDef "CryptolM.isFinite" -> Just (), n)) = - Just n -asIsFinite _ = Nothing - --- | Recognize a term as being of the form @IsLtNat m n@ -asIsLtNat :: Recognizer Term (Term, Term) -asIsLtNat (asApplyAll -> (isGlobalDef "Prelude.IsLtNat" -> Just (), [m, n])) = - Just (m, n) -asIsLtNat _ = Nothing - --- | Recognize a bitvector type with a potentially symbolic length -asSymBitvectorType :: Recognizer Term Term -asSymBitvectorType (asVectorType -> Just (n, asBoolType -> Just ())) = Just n -asSymBitvectorType _ = Nothing - --- | Like 'asLambda', but only return's the lambda-bound variable's 'LocalName' -asLambdaName :: Recognizer Term LocalName -asLambdaName (asLambda -> Just (nm, _, _)) = Just nm -asLambdaName _ = Nothing - ----------------------------------------------------------------------- --- * 'MonadTerm' type class ----------------------------------------------------------------------- - --- | The class of monads that can build terms and substitute into them -class Monad m => MonadTerm m where - mkTermF :: TermF Term -> m Term - liftTerm :: DeBruijnIndex -> DeBruijnIndex -> Term -> m Term - substTerm :: DeBruijnIndex -> [Term] -> Term -> m Term - -- ^ NOTE: the first term in the list is substituted for the most - -- recently-bound variable, i.e., deBruijn index 0 - -instance (MonadTerm m) => MonadTerm (MaybeT m) where - mkTermF = lift . mkTermF - liftTerm n i t = lift $ liftTerm n i t - substTerm n s t = lift $ substTerm n s t - ----------------------------------------------------------------------- --- * Utility Functions for Transforming 'Term's ----------------------------------------------------------------------- - --- | Transform the immediate subterms of a term using the supplied function -traverseSubterms :: MonadTerm m => (Term -> m Term) -> Term -> m Term -traverseSubterms f (unwrapTermF -> tf) = traverse f tf >>= mkTermF - --- | Like 'memoFixTermFun', but threads through an accumulating argument -memoFixTermFunAccum :: MonadIO m => - ((b -> Term -> m a) -> b -> Term -> m a) -> - b -> Term -> m a -memoFixTermFunAccum f acc_top term_top = - do table_ref <- liftIO $ newIORef IntMap.empty - let go acc t@(STApp { stAppIndex = ix }) = - liftIO (readIORef table_ref) >>= \table -> - case IntMap.lookup ix table of - Just ret -> return ret - Nothing -> - do ret <- f go acc t - liftIO $ modifyIORef' table_ref (IntMap.insert ix ret) - return ret - go acc t = f go acc t - go acc_top term_top - --- | Build a recursive memoized function for tranforming 'Term's. Take in a --- function @f@ that intuitively performs one step of the transformation and --- allow it to recursively call the memoized function being defined by passing --- it as the first argument to @f@. -memoFixTermFun :: MonadIO m => ((Term -> m a) -> Term -> m a) -> Term -> m a -memoFixTermFun f = memoFixTermFunAccum (f .) () - - ----------------------------------------------------------------------- --- * Lifting MR Solver Terms ----------------------------------------------------------------------- - --- | Apply 'liftTerm' to all component terms in a 'TermLike' object -liftTermLike :: (TermLike a, MonadTerm m) => - DeBruijnIndex -> DeBruijnIndex -> a -> m a -liftTermLike i n = mapTermLike (liftTerm i n) - --- | Apply 'substTerm' to all component terms in a 'TermLike' object -substTermLike :: (TermLike a, MonadTerm m) => - DeBruijnIndex -> [Term] -> a -> m a -substTermLike i s = mapTermLike (substTerm i s) - --- | A term-like object is one that supports monadically mapping over all --- component terms. This is mainly used for lifting and substitution - see --- @liftTermLike@ and @substTermLike@. This class can be derived using --- @DeriveAnyClass@. -class TermLike a where - mapTermLike :: MonadTerm m => (Term -> m Term) -> a -> m a - - -- Default instance for @DeriveAnyClass@ - default mapTermLike :: (Generic a, GTermLike (Rep a), MonadTerm m) => - (Term -> m Term) -> a -> m a - mapTermLike f = fmap to . gMapTermLike f . from - --- | A generic version of 'TermLike' for @DeriveAnyClass@, based on: --- https://hackage.haskell.org/package/base-4.16.0.0/docs/GHC-Generics.html#g:12 -class GTermLike f where - gMapTermLike :: MonadTerm m => (Term -> m Term) -> f p -> m (f p) - --- | 'TermLike' on empty types -instance GTermLike V1 where - gMapTermLike _ = \case {} - --- | 'TermLike' on unary types -instance GTermLike U1 where - gMapTermLike _ U1 = return U1 - --- | 'TermLike' on sums -instance (GTermLike f, GTermLike g) => GTermLike (f :+: g) where - gMapTermLike f (L1 a) = L1 <$> gMapTermLike f a - gMapTermLike f (R1 b) = R1 <$> gMapTermLike f b - --- | 'TermLike' on products -instance (GTermLike f, GTermLike g) => GTermLike (f :*: g) where - gMapTermLike f (a :*: b) = (:*:) <$> gMapTermLike f a <*> gMapTermLike f b - --- | 'TermLike' on fields -instance TermLike a => GTermLike (K1 i a) where - gMapTermLike f (K1 a) = K1 <$> mapTermLike f a - --- | 'GTermLike' ignores meta-information -instance GTermLike a => GTermLike (M1 i c a) where - gMapTermLike f (M1 a) = M1 <$> gMapTermLike f a - -deriving instance _ => TermLike (a,b) -deriving instance _ => TermLike (a,b,c) -deriving instance _ => TermLike (a,b,c,d) -deriving instance _ => TermLike (a,b,c,d,e) -deriving instance _ => TermLike (a,b,c,d,e,f) -deriving instance _ => TermLike (a,b,c,d,e,f,g) --- NOTE: longer tuple types not supported by GHC 8.10 --- deriving instance _ => TermLike (a,b,c,d,e,f,g,i) -deriving instance _ => TermLike [a] -deriving instance TermLike () - -instance TermLike Term where - mapTermLike f = f - -instance TermLike FunName where - mapTermLike _ = return -instance TermLike LocalName where - mapTermLike _ = return -instance TermLike Natural where - mapTermLike _ = return - -deriving anyclass instance TermLike Type -deriving anyclass instance TermLike EvTerm -deriving instance TermLike NormComp -deriving instance TermLike CompFun -deriving instance TermLike Comp - - ----------------------------------------------------------------------- --- * Pretty-Printing MR Solver Terms ----------------------------------------------------------------------- - --- | The monad for pretty-printing in a context of SAW core variables. The --- context is in innermost-to-outermost order, i.e. from newest to oldest --- variable (see 'mrVarCtxInnerToOuter' for more detail on this ordering). --- --- NOTE: By convention, functions which return something of type 'PPInCtxM' --- have the prefix @pretty@ (e.g. 'prettyInCtx', 'prettyTermApp') and --- functions which return something of type 'PPS.Doc' have the prefix @pp@ --- (e.g. 'ppInCtx', 'ppTermAppInCtx'). This latter convention is consistent with --- the rest of saw-script (e.g. 'ppTerm' defined in @SAWCore.Term.Pretty@, --- 'ppFirstOrderValue' defined in @SAWCore.FiniteValue@). -newtype PPInCtxM a = PPInCtxM (Reader (PPS.Opts, [LocalName]) a) - deriving newtype (Functor, Applicative, Monad, - MonadReader (PPS.Opts, [LocalName])) - --- | Locally set the context of SAW core variables for a 'PPInCtxM' computation -prettyWithCtx :: MRVarCtx -> PPInCtxM a -> PPInCtxM a -prettyWithCtx ctx = local (fmap $ const $ map fst $ mrVarCtxInnerToOuter ctx) - --- | Run a 'PPInCtxM' computation in the given 'MRVarCtx' context and 'PPS.Opts' -runPPInCtxM :: PPInCtxM a -> PPS.Opts -> MRVarCtx -> a -runPPInCtxM (PPInCtxM m) opts ctx = - runReader m (opts, map fst $ mrVarCtxInnerToOuter ctx) - --- | Pretty-print an object in a SAW core context with the given 'PPS.Opts' -ppInCtx :: PrettyInCtx a => PPS.Opts -> MRVarCtx -> a -> PPS.Doc -ppInCtx opts ctx a = runPPInCtxM (prettyInCtx a) opts ctx - --- | Pretty-print an object in a SAW core context and render to a 'String' with --- the given 'PPS.Opts' -showInCtx :: PrettyInCtx a => PPS.Opts -> MRVarCtx -> a -> String -showInCtx opts ctx a = PPS.render opts $ runPPInCtxM (prettyInCtx a) opts ctx - --- | A generic function for pretty-printing an object in a SAW core context of --- locally-bound names -class PrettyInCtx a where - prettyInCtx :: a -> PPInCtxM PPS.Doc - -instance PrettyInCtx Term where - prettyInCtx t = do (opts, ctx) <- ask - return $ ppTermInCtx opts ctx t - --- | Combine a list of pretty-printed documents like applications are combined -prettyAppList :: [PPInCtxM PPS.Doc] -> PPInCtxM PPS.Doc -prettyAppList = fmap (group . hang 2 . vsep) . sequence - --- | Pretty-print the application of a 'Term' -prettyTermApp :: Term -> [Term] -> PPInCtxM PPS.Doc -prettyTermApp f_top args = - prettyInCtx $ foldl (\f arg -> Unshared $ App f arg) f_top args - --- | Pretty-print the application of a 'Term' in a SAW core context with the --- given 'PPS.Opts' -ppTermAppInCtx :: PPS.Opts -> MRVarCtx -> Term -> [Term] -> PPS.Doc -ppTermAppInCtx opts ctx f_top args = - runPPInCtxM (prettyTermApp f_top args) opts ctx - -instance PrettyInCtx MRVarCtx where - prettyInCtx ctx_top = do - (opts, _) <- ask - return $ align $ sep $ helper opts [] $ mrVarCtxOuterToInner ctx_top - where helper :: PPS.Opts -> [LocalName] -> [(LocalName,Term)] -> [PPS.Doc] - helper _ _ [] = [] - helper opts ns [(n, tp)] = - [ppTermInCtx opts (n:ns) (Unshared $ LocalVar 0) <> ":" <> - ppTermInCtx opts ns tp] - helper opts ns ((n, tp):ctx) = - (ppTermInCtx opts (n:ns) (Unshared $ LocalVar 0) <> ":" <> - ppTermInCtx opts ns tp <> ",") : (helper opts (n:ns) ctx) - -instance PrettyInCtx PPS.Doc where - prettyInCtx pp = return pp - -instance PrettyInCtx Type where - prettyInCtx (Type t) = prettyInCtx t - -instance PrettyInCtx MRVar where - prettyInCtx (MRVar ec) = return $ ppName $ ecNameInfo ec - -instance PrettyInCtx a => PrettyInCtx [a] where - prettyInCtx xs = list <$> mapM prettyInCtx xs - -instance {-# OVERLAPPING #-} PrettyInCtx String where - prettyInCtx str = return $ fromString str - -instance PrettyInCtx Text where - prettyInCtx str = return $ fromString $ unpack str - -instance PrettyInCtx Int where - prettyInCtx i = return $ viaShow i - -instance PrettyInCtx Natural where - prettyInCtx i = return $ viaShow i - -instance PrettyInCtx a => PrettyInCtx (Maybe a) where - prettyInCtx (Just x) = (<+>) "Just" <$> prettyInCtx x - prettyInCtx Nothing = return "Nothing" - -instance (PrettyInCtx a, PrettyInCtx b) => PrettyInCtx (Either a b) where - prettyInCtx (Left a) = (<+>) "Left" <$> prettyInCtx a - prettyInCtx (Right b) = (<+>) "Right" <$> prettyInCtx b - -instance (PrettyInCtx a, PrettyInCtx b) => PrettyInCtx (a,b) where - prettyInCtx (x, y) = (\x' y' -> parens (x' <> "," <> y')) <$> prettyInCtx x - <*> prettyInCtx y - -instance PrettyInCtx TermProj where - prettyInCtx TermProjLeft = return (pretty '.' <> "1") - prettyInCtx TermProjRight = return (pretty '.' <> "2") - prettyInCtx (TermProjRecord fld) = return (pretty '.' <> pretty fld) - -instance PrettyInCtx FunName where - prettyInCtx (CallSName var) = prettyInCtx var - prettyInCtx (EVarFunName var) = prettyInCtx var - prettyInCtx (GlobalName g projs) = - foldM (\pp proj -> (pp <>) <$> prettyInCtx proj) (ppName $ - nameInfo $ globalDefName g) projs - -instance PrettyInCtx Comp where - prettyInCtx (CompTerm t) = prettyInCtx t - prettyInCtx (CompBind c f) = - prettyAppList [prettyInCtx c, return ">>=", prettyInCtx f] - prettyInCtx (CompReturn t) = - prettyAppList [return "retS", return "_", - parens <$> prettyInCtx t] - -instance PrettyInCtx CompFun where - prettyInCtx (CompFunTerm _ t) = prettyInCtx t - prettyInCtx (CompFunReturn _ t) = - prettyAppList [return "retS", return "_", - parens <$> prettyInCtx t] - prettyInCtx (CompFunComp f g) = - prettyAppList [prettyInCtx f, return ">=>", prettyInCtx g] - -instance PrettyInCtx NormComp where - prettyInCtx (RetS t) = - prettyAppList [return "retS", return "_", return "_", - parens <$> prettyInCtx t] - prettyInCtx (ErrorS str) = - prettyAppList [return "errorS", return "_", return "_", - parens <$> prettyInCtx str] - prettyInCtx (Ite cond t1 t2) = - prettyAppList [return "ite", return "_", parens <$> prettyInCtx cond, - parens <$> prettyInCtx t1, parens <$> prettyInCtx t2] - prettyInCtx (Eithers elims eith) = - prettyAppList [return "eithers", return (parens "SpecM _ _"), - prettyInCtx (map snd elims), parens <$> prettyInCtx eith] - prettyInCtx (MaybeElim tp m f mayb) = - prettyAppList [return "maybe", parens <$> prettyInCtx tp, - return (parens "SpecM _ _"), parens <$> prettyInCtx m, - parens <$> prettyInCtx f, parens <$> prettyInCtx mayb] - prettyInCtx (OrS t1 t2) = - prettyAppList [return "orS", return "_", return "_", - parens <$> prettyInCtx t1, parens <$> prettyInCtx t2] - prettyInCtx (AssertBoolBind cond k) = - prettyAppList [return "assertBoolS", return "_", - parens <$> prettyInCtx cond, return ">>=", - parens <$> prettyInCtx k] - prettyInCtx (AssumeBoolBind cond k) = - prettyAppList [return "assumeBoolS", return "_", - parens <$> prettyInCtx cond, return ">>=", - parens <$> prettyInCtx k] - prettyInCtx (ExistsBind tp k) = - prettyAppList [return "existsS", return "_", prettyInCtx tp, - return ">>=", parens <$> prettyInCtx k] - prettyInCtx (ForallBind tp k) = - prettyAppList [return "forallS", return "_", prettyInCtx tp, - return ">>=", parens <$> prettyInCtx k] - prettyInCtx (FunBind f args (CompFunReturn _ _)) = - snd $ prettyInCtxFunBindH f args - prettyInCtx (FunBind f args k) - | (g, m) <- prettyInCtxFunBindH f args = - prettyAppList [g <$> m, return ">>=", prettyInCtx k] - --- | A helper function for the 'FunBind' case of 'prettyInCtx'. Returns the --- string you would get if the associated 'CompFun' is 'CompFunReturn', as well --- as a 'PPS.Doc' function (which is either 'id' or 'parens') to apply in the --- case where the associated 'CompFun' is something else. -prettyInCtxFunBindH :: FunName -> [Term] -> - (PPS.Doc -> PPS.Doc, PPInCtxM PPS.Doc) -prettyInCtxFunBindH f [] = (id, prettyInCtx f) -prettyInCtxFunBindH f args = (parens,) $ - prettyTermApp (funNameTerm f) args diff --git a/saw-central/src/SAWCentral/Proof.hs b/saw-central/src/SAWCentral/Proof.hs index 3cbb2a94dc..5e17720074 100644 --- a/saw-central/src/SAWCentral/Proof.hs +++ b/saw-central/src/SAWCentral/Proof.hs @@ -173,7 +173,6 @@ import What4.ProgramLoc (ProgramLoc) import SAWCentral.Position import SAWCentral.Prover.SolverStats -import qualified SAWCentral.MRSolver.Evidence as MRSolver import SAWCentral.Crucible.Common as Common import qualified SAWCore.Simulator.TermModel as TM import qualified SAWCoreWhat4.What4 as W4Sim @@ -1088,11 +1087,6 @@ data Evidence -- sequent calculus axiom, which connects a hypothesis to a conclusion. | AxiomEvidence - -- | Evidence generated by running the @mrsolver@ tactic. - -- FIXME: Add a @[Evidence]@ here when MRSolver is updated to support - -- returning unsolved goals. - | MrSolverEvidence !(MRSolver.MREvidence TheoremNonce) - -- | The the proposition proved by a given theorem. thmProp :: Theorem -> Prop thmProp Theorem{ _thmProp = p } = p @@ -1721,17 +1715,6 @@ checkEvidence sc what4PushMuxOps = \e p -> do ] return (mempty, ProvedTheorem mempty) - MrSolverEvidence mre -> - case sequentState sqt of - ConclFocus _p _mkSqt -> - do (d, stats) <- MRSolver.checkMREvidence mre - -- FIXME: Check that p actually does match the MRSolverEvidence - return (d, ProvedTheorem stats) - _ -> fail $ unlines $ - [ "MRSolver evidence requires a conclusion-focused sequent" - , prettySequent PPS.defaultOpts nenv sqt - ] - CutEvidence p ehyp egl -> do d1 <- check nenv ehyp (addHypothesis p sqt) d2 <- check nenv egl (addNewFocusedConcl p sqt) diff --git a/saw-central/src/SAWCentral/Prover/Exporter.hs b/saw-central/src/SAWCentral/Prover/Exporter.hs index 80e346d0d6..c3cda8581e 100644 --- a/saw-central/src/SAWCentral/Prover/Exporter.hs +++ b/saw-central/src/SAWCentral/Prover/Exporter.hs @@ -74,9 +74,6 @@ import Lang.JVM.ProcessUtils (readProcessExitIfFailure) import CryptolSAWCore.CryptolEnv (initCryptolEnv, loadCryptolModule, ImportPrimitiveOptions(..), mkCryEnv) import CryptolSAWCore.Prelude (cryptolModule, scLoadPreludeModule, scLoadCryptolModule) -import CryptolSAWCore.PreludeM (cryptolMModule, specMModule, - scLoadSpecMModule, scLoadCryptolMModule) -import CryptolSAWCore.Monadify (defaultMonEnv, monadifyCryptolModule) import SAWCore.ExternalFormat(scWriteExternal) import SAWCore.FiniteValue import SAWCore.Module (emptyModule, moduleDecls) @@ -366,12 +363,9 @@ writeVerilogSAT path satq = getSharedContext >>= \sc -> io $ flattenSValue :: IsSymExprBuilder sym => sym -> W4Sim.SValue sym -> IO [Some (W4.SymExpr sym)] flattenSValue _ (Sim.VBool b) = return [Some b] flattenSValue _ (Sim.VWord (W4Sim.DBV w)) = return [Some w] -flattenSValue sym (Sim.VPair l r) = - do lv <- Sim.force l - rv <- Sim.force r - ls <- flattenSValue sym lv - rs <- flattenSValue sym rv - return (ls ++ rs) +flattenSValue sym (Sim.VTuple thunks) = + do vs <- traverse Sim.force (V.toList thunks) + concat <$> traverse (flattenSValue sym) vs flattenSValue sym (Sim.VVector ts) = do vs <- mapM Sim.force ts let getBool (Sim.VBool b) = Just b @@ -450,23 +444,6 @@ withImportCryptolPrimitivesForSAWCore config@(Coq.TranslationConfiguration { Coq ] } -withImportSpecM :: - Coq.TranslationConfiguration -> Coq.TranslationConfiguration -withImportSpecM config@(Coq.TranslationConfiguration { Coq.postPreamble }) = - config { Coq.postPreamble = postPreamble ++ unlines - [ "From CryptolToCoq Require Import SpecM." - ] - } - -withImportSpecMPrimitivesForSAWCore :: - Coq.TranslationConfiguration -> Coq.TranslationConfiguration -withImportSpecMPrimitivesForSAWCore config@(Coq.TranslationConfiguration { Coq.postPreamble }) = - config { Coq.postPreamble = postPreamble ++ unlines - [ "From CryptolToCoq Require Import SpecMPrimitivesForSAWCore." - ] - } - - withImportCryptolPrimitivesForSAWCoreExtra :: Coq.TranslationConfiguration -> Coq.TranslationConfiguration withImportCryptolPrimitivesForSAWCoreExtra config@(Coq.TranslationConfiguration { Coq.postPreamble }) = @@ -511,8 +488,6 @@ writeCoqProp name notations skips path t = -- | Write out a representation of a Cryptol module in Gallina syntax for Coq. writeCoqCryptolModule :: - -- | Translate the "monadified" version of the module when 'True' - Bool -> -- | Path to module to export FilePath -> -- | Path for output Coq file @@ -523,7 +498,7 @@ writeCoqCryptolModule :: -- | List of identifiers to skip during translation [Text] -> TopLevel () -writeCoqCryptolModule mon inputFile outputFile notations skips = io $ do +writeCoqCryptolModule inputFile outputFile notations skips = io $ do sc <- mkSharedContext () <- scLoadPreludeModule sc () <- scLoadCryptolModule sc @@ -535,7 +510,6 @@ writeCoqCryptolModule mon inputFile outputFile notations skips = io $ do cry_env <- mkCryEnv env mm <- scGetModuleMap sc let ?mm = mm - cm' <- if mon then fst <$> monadifyCryptolModule sc cry_env defaultMonEnv cm else return cm let cryptolPreludeDecls = map Coq.Ident $ mapMaybe Coq.moduleDeclName (moduleDecls cryptolPrimitivesForSAWCoreModule) @@ -546,7 +520,7 @@ writeCoqCryptolModule mon inputFile outputFile notations skips = io $ do withImportSAWCorePrelude $ coqTranslationConfiguration notations skips let nm = Coq.Ident (takeBaseName inputFile) - res <- Coq.translateCryptolModule sc cry_env nm configuration cryptolPreludeDecls cm' + res <- Coq.translateCryptolModule sc cry_env nm configuration cryptolPreludeDecls cm case res of Left e -> putStrLn $ show e Right cmDoc -> @@ -574,42 +548,25 @@ writeCoqSAWCorePrelude outputFile notations skips = do writeFile outputFile (show . vcat $ [ Coq.preamble configuration, doc ]) writeCoqCryptolPrimitivesForSAWCore :: - FilePath -> FilePath -> FilePath -> + FilePath -> [(Text, Text)] -> [Text] -> IO () -writeCoqCryptolPrimitivesForSAWCore cryFile specMFile cryMFile notations skips = do +writeCoqCryptolPrimitivesForSAWCore cryFile notations skips = do sc <- mkSharedContext () <- scLoadPreludeModule sc () <- scLoadCryptolModule sc - () <- scLoadSpecMModule sc - () <- scLoadCryptolMModule sc () <- scLoadModule sc (emptyModule (mkModuleName ["CryptolPrimitivesForSAWCore"])) m <- scFindModule sc nameOfCryptolPrimitivesForSAWCoreModule - m_spec <- scFindModule sc (Un.moduleName specMModule) - m_mon <- scFindModule sc (Un.moduleName cryptolMModule) mm <- scGetModuleMap sc let configuration = withImportSAWCorePreludeExtra $ withImportSAWCorePrelude $ coqTranslationConfiguration notations skips - let configuration_spec = - withImportCryptolPrimitivesForSAWCore $ - withImportSpecM configuration - let configuration_mon = - withImportSpecMPrimitivesForSAWCore configuration let doc = Coq.translateSAWModule configuration mm m writeFile cryFile (show . vcat $ [ Coq.preamble configuration , doc ]) - let doc_spec = Coq.translateSAWModule configuration_spec mm m_spec - writeFile specMFile (show . vcat $ [ Coq.preamble configuration_spec - , doc_spec - ]) - let doc_mon = Coq.translateSAWModule configuration_mon mm m_mon - writeFile cryMFile (show . vcat $ [ Coq.preamble configuration_mon - , doc_mon - ]) -- | Tranlsate a SAWCore term into an AIG bitblastPrim :: (AIG.IsAIG l g) => AIG.Proxy l g -> SharedContext -> Term -> IO (AIG.Network l g) diff --git a/saw-central/src/SAWCentral/Prover/MRSolver.hs b/saw-central/src/SAWCentral/Prover/MRSolver.hs deleted file mode 100644 index 5a79aaec71..0000000000 --- a/saw-central/src/SAWCentral/Prover/MRSolver.hs +++ /dev/null @@ -1,23 +0,0 @@ -{- | -Module : SAWCentral.Prover.MRSolver -Description : The SAW monadic-recursive solver (Mr. Solver) -Copyright : Galois, Inc. 2022 -License : BSD3 -Maintainer : westbrook@galois.com -Stability : experimental -Portability : non-portable (language extensions) --} - -module SAWCentral.Prover.MRSolver - (askMRSolver, refinementTerm, - MRFailure(..), showMRFailure, showMRFailureNoCtx, - RefinesS(..), asRefinesS, - FunAssump(..), FunAssumpRHS(..), asFunAssump, - Refnset, emptyRefnset, addFunAssump, - MREnv(..), emptyMREnv, mrEnvSetDebugLevel, - asProjAll, isSpecFunType) where - -import SAWCentral.MRSolver.Term -import SAWCentral.MRSolver.Evidence -import SAWCentral.MRSolver.Monad -import SAWCentral.MRSolver.Solver diff --git a/saw-central/src/SAWCentral/SBVParser.hs b/saw-central/src/SAWCentral/SBVParser.hs index ddcddb8460..838ed577c3 100644 --- a/saw-central/src/SAWCentral/SBVParser.hs +++ b/saw-central/src/SAWCentral/SBVParser.hs @@ -270,7 +270,7 @@ scTyp sc (TRecord fields) = splitInputs :: SharedContext -> Typ -> Term -> IO [Term] splitInputs _sc TBool x = return [x] splitInputs sc (TTuple ts) x = - do xs <- mapM (\i -> scTupleSelector sc x i (length ts)) [1 .. length ts] + do xs <- mapM (scTupleSelector sc x) [0 .. length ts - 1] yss <- sequence (zipWith (splitInputs sc) ts xs) return (concat yss) splitInputs _ (TVec _ TBool) x = return [x] diff --git a/saw-central/src/SAWCentral/Value.hs b/saw-central/src/SAWCentral/Value.hs index 8d2f4fb4bd..445c633c32 100644 --- a/saw-central/src/SAWCentral/Value.hs +++ b/saw-central/src/SAWCentral/Value.hs @@ -31,20 +31,16 @@ module SAWCentral.Value ( -- used by SAWCentral.Builtins, SAWScript.Interpreter, SAWServer.SAWServer SAWSimpset, - -- used by SAWCentral.Builtins, SAWScript.Interpreter - SAWRefnset, -- used by SAWCentral.Builtins AIGNetwork(..), -- used by SAWCentral.Prover.Exporter, SAWCentral.Builtins, -- SAWScript.Interpreter and more, SAWServer.SAWServer AIGProxy(..), - -- used by SAWCentral.Crucible.LLVM.Builtins, SAWScript.HeapsterBuiltins + -- used by SAWCentral.Crucible.LLVM.Builtins SAW_CFG(..), - -- used by SAWScript.Interpreter, SAWScript.HeapsterBuiltins, + -- used by SAWScript.Interpreter -- SAWServer.SAWServer, SAWServer.*CrucibleSetup BuiltinContext(..), - -- used by SAWScript.HeapsterBuiltins (and the Value type) - HeapsterEnv(..), -- used by SAWCentral.Builtins.hs, and appears in the Value type and showsSatResult SatResult(..), -- used by SAWCentral.Bisimulation, SAWCentral.Builtins, SAWScript.REPL.Monad @@ -206,9 +202,7 @@ import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Reader (ReaderT(..), ask, asks) import Control.Monad.State (StateT(..), MonadState(..), gets, modify) import Control.Monad.Trans.Class (MonadTrans(lift)) -import Data.IORef import Data.Foldable(foldrM) -import Data.List ( intersperse ) import Data.List.Extra ( dropEnd ) import qualified Data.Map as M import Data.Map ( Map ) @@ -248,8 +242,6 @@ import SAWCentral.Options (Options, printOutLn, Verbosity(..)) import qualified SAWCentral.Options as Opt import SAWCentral.Proof import SAWCentral.Prover.SolverStats -import SAWCentral.MRSolver.Term (funNameTerm, mrVarCtxInnerToOuter, ppTermAppInCtx) -import SAWCentral.MRSolver.Evidence as MRSolver import SAWCentral.SolverCache import SAWCentral.Crucible.LLVM.Skeleton import SAWCentral.X86 (X86Unsupported(..), X86Error(..)) @@ -259,13 +251,11 @@ import SAWCentral.Yosys.State (YosysSequential) import SAWCore.Name (ecShortName, DisplayNameEnv, emptyDisplayNameEnv) import CryptolSAWCore.CryptolEnv as CEnv -import CryptolSAWCore.Monadify as Monadify import SAWCore.FiniteValue (FirstOrderValue, ppFirstOrderValue) import SAWCore.Rewriter (Simpset, lhsRewriteRule, rhsRewriteRule, listRules) import SAWCore.SharedTerm import qualified SAWCore.Term.Pretty as SAWCorePP import CryptolSAWCore.TypedTerm -import SAWCore.Term.Functor (ModuleName) import qualified SAWCore.Simulator.Concrete as Concrete import qualified Cryptol.Eval as C @@ -291,9 +281,6 @@ import qualified Mir.Mir as MIR import What4.ProgramLoc (ProgramLoc(..)) -import Heapster.Permissions -import Heapster.SAWTranslation (ChecksFlag,SomeTypedCFG(..)) - -- Values ---------------------------------------------------------------------- data BuiltinWrapper @@ -542,7 +529,6 @@ data Value -- Like a VTopLevel, except in the other monad. | VProofScript SS.Pos RefChain (ProofScript Value) | VSimpset SAWSimpset - | VRefnset SAWRefnset | VTheorem Theorem | VBisimTheorem BisimTheorem ----- @@ -577,7 +563,6 @@ data Value | VLLVMModule (Some CMSLLVM.LLVMModule) | VMIRModule RustModule | VMIRAdt MIR.Adt - | VHeapsterEnv HeapsterEnv | VSatResult SatResult | VProofResult ProofResult | VUninterp Uninterp @@ -590,7 +575,6 @@ data Value | VYosysTheorem YosysTheorem type SAWSimpset = Simpset TheoremNonce -type SAWRefnset = MRSolver.Refnset TheoremNonce data AIGNetwork where AIGNetwork :: (Typeable l, Typeable g, AIG.IsAIG l g) => AIG.Network l g -> AIGNetwork @@ -606,29 +590,6 @@ data BuiltinContext = BuiltinContext { biSharedContext :: SharedContext , biBasicSS :: SAWSimpset } --- | All the context maintained by Heapster -data HeapsterEnv = HeapsterEnv { - heapsterEnvSAWModule :: ModuleName, - -- ^ The SAW module containing all our Heapster definitions - heapsterEnvPermEnvRef :: IORef PermEnv, - -- ^ The current permissions environment - heapsterEnvLLVMModules :: [Some CMSLLVM.LLVMModule], - -- ^ The list of underlying 'LLVMModule's that we are translating - heapsterEnvTCFGs :: IORef [Some SomeTypedCFG], - -- ^ The typed CFGs for output debugging/IDE info - heapsterEnvDebugLevel :: IORef DebugLevel, - -- ^ The current debug level - heapsterEnvChecksFlag :: IORef ChecksFlag - -- ^ Whether translation checks are currently enabled - } - -showHeapsterEnv :: HeapsterEnv -> String -showHeapsterEnv env = - concat $ intersperse "\n\n" $ - map (\some_lm -> case some_lm of - Some lm -> CMSLLVM.showLLVMModule lm) $ - heapsterEnvLLVMModules env - data SatResult = Unsat SolverStats | Sat SolverStats [(ExtCns Term, FirstOrderValue)] @@ -673,22 +634,6 @@ showSimpset opts ss = , PP.pretty '=' PP.<+> ppTerm (rhsRewriteRule r) ]) ppTerm t = SAWCorePP.ppTerm opts t --- | Pretty-print a 'Refnset' to a 'String' -showRefnset :: PPS.Opts -> MRSolver.Refnset a -> String -showRefnset opts ss = - unlines ("Refinements" : "=============" : map (show . ppFunAssump) - (MRSolver.listFunAssumps ss)) - where - ppFunAssump (MRSolver.FunAssump ctx f args rhs _) = - PP.pretty '*' PP.<+> - (PP.nest 2 $ PP.fillSep - [ ppTermAppInCtx opts ctx (funNameTerm f) args - , PP.pretty ("|=" :: String) PP.<+> ppFunAssumpRHS ctx rhs ]) - ppFunAssumpRHS ctx (OpaqueFunAssump f args) = - ppTermAppInCtx opts ctx (funNameTerm f) args - ppFunAssumpRHS ctx (RewriteFunAssump rhs) = - SAWCorePP.ppTermInCtx opts (map fst $ mrVarCtxInnerToOuter ctx) rhs - -- XXX the precedence in here needs to be cleaned up showsPrecValue :: PPS.Opts -> DisplayNameEnv -> Int -> Value -> ShowS showsPrecValue opts nenv p v = @@ -733,7 +678,6 @@ showsPrecValue opts nenv p v = v1' . showString " >>= " . v2' VTopLevel {} -> showString "<>" VSimpset ss -> showString (showSimpset opts ss) - VRefnset ss -> showString (showRefnset opts ss) VProofScript {} -> showString "<>" VTheorem thm -> showString "Theorem " . @@ -753,7 +697,6 @@ showsPrecValue opts nenv p v = VLLVMModule (Some m) -> showString (CMSLLVM.showLLVMModule m) VMIRModule m -> shows (PP.pretty (m^.rmCS^.collection)) VMIRAdt adt -> shows (PP.pretty adt) - VHeapsterEnv env -> showString (showHeapsterEnv env) VJavaClass c -> shows (prettyClass c) VProofResult r -> showsProofResult opts r VSatResult r -> showsSatResult opts r @@ -881,7 +824,7 @@ data TopLevelRW = -- either passed around or the position in the current AST -- element, and those positions should be used instead. , rwPosition :: SS.Pos - + -- | The current stack trace. The most recent frame is at the front. , rwStackTrace :: Trace @@ -889,8 +832,6 @@ data TopLevelRW = , rwJavaCodebase :: JavaCodebase -- ^ Current state of Java sub-system. - , rwMonadify :: Monadify.MonadifyEnv - , rwMRSolverEnv :: MRSolver.MREnv , rwProofs :: [Value] {- ^ Values, generated anywhere, that represent proofs. -} , rwPPOpts :: PPS.Opts , rwSharedContext :: SharedContext diff --git a/saw-central/src/SAWCentral/Yosys/Cell.hs b/saw-central/src/SAWCentral/Yosys/Cell.hs index 89a01b8c4b..8961eefeca 100644 --- a/saw-central/src/SAWCentral/Yosys/Cell.hs +++ b/saw-central/src/SAWCentral/Yosys/Cell.hs @@ -263,8 +263,8 @@ primCellToMap sc c args = case c ^. cellType of fun <- liftIO . SC.scAbstractExts sc [bitEC, accEC] =<< do bit <- liftIO $ SC.scVariable sc bitEC acc <- liftIO $ SC.scVariable sc accEC - idx <- liftIO $ SC.scPairLeft sc acc - aval <- liftIO $ SC.scPairRight sc acc + idx <- liftIO $ SC.scTupleSelector sc acc 0 + aval <- liftIO $ SC.scTupleSelector sc acc 1 bval <- liftIO $ SC.scAtWithDefault sc swidth widthBv aval splitb idx newidx <- liftIO $ SC.scAddNat sc idx width newval <- liftIO $ SC.scIte sc widthBv bit bval aval @@ -272,7 +272,7 @@ primCellToMap sc c args = case c ^. cellType of scFoldr <- liftIO . SC.scGlobalDef sc $ SC.mkIdent SC.preludeName "foldr" resPair <- liftIO $ SC.scApplyAll sc scFoldr [bool, accTy, swidth, fun, defaultAcc, ts] - res <- liftIO $ SC.scPairRight sc resPair + res <- liftIO $ SC.scTupleSelector sc resPair 1 output $ CellTerm res (connWidthNat "A") (connSigned "Y") CellTypeBmux -> do ia <- input "A" diff --git a/saw-central/src/SAWCentral/Yosys/Utils.hs b/saw-central/src/SAWCentral/Yosys/Utils.hs index e5c91e1d55..3e3ef3d8c4 100644 --- a/saw-central/src/SAWCentral/Yosys/Utils.hs +++ b/saw-central/src/SAWCentral/Yosys/Utils.hs @@ -192,7 +192,7 @@ cryptolRecordSelect :: m SC.Term cryptolRecordSelect sc fields r nm = case List.elemIndex nm ord of - Just i -> liftIO $ SC.scTupleSelector sc r (i + 1) (length ord) + Just i -> liftIO $ SC.scTupleSelector sc r i Nothing -> throw . YosysError $ mconcat [ "Could not build record selector term for field name \"" , nm diff --git a/saw-core-aig/src/SAWCoreAIG/BitBlast.hs b/saw-core-aig/src/SAWCoreAIG/BitBlast.hs index 5765cfd02c..e307e65901 100644 --- a/saw-core-aig/src/SAWCoreAIG/BitBlast.hs +++ b/saw-core-aig/src/SAWCoreAIG/BitBlast.hs @@ -129,11 +129,8 @@ flattenBValue (VWord lv) = return lv flattenBValue (VExtra (BStream _ _)) = error "SAWCoreAIG.BitBlast.flattenBValue: BStream" flattenBValue (VVector vv) = AIG.concat <$> traverse (flattenBValue <=< force) (V.toList vv) -flattenBValue VUnit = return $ AIG.concat [] -flattenBValue (VPair x y) = do - vx <- flattenBValue =<< force x - vy <- flattenBValue =<< force y - return $ AIG.concat [vx, vy] +flattenBValue (VTuple xs) = + AIG.concat <$> mapM (flattenBValue <=< force) (V.toList xs) flattenBValue (VRecordValue elems) = do AIG.concat <$> mapM (flattenBValue <=< force . snd) elems flattenBValue _ = error $ unwords ["SAWCoreAIG.BitBlast.flattenBValue: unsupported value"] diff --git a/saw-core-coq/coq/_CoqProject b/saw-core-coq/coq/_CoqProject index 410aba5b65..f631698827 100644 --- a/saw-core-coq/coq/_CoqProject +++ b/saw-core-coq/coq/_CoqProject @@ -3,12 +3,7 @@ generated/CryptolToCoq/SAWCorePrelude.v generated/CryptolToCoq/CryptolPrimitivesForSAWCore.v -generated/CryptolToCoq/SpecMPrimitivesForSAWCore.v -# generated/CryptolToCoq/CryptolMPrimitivesForSAWCore.v -handwritten/CryptolToCoq/SpecM.v -# handwritten/CryptolToCoq/CompM.v -# handwritten/CryptolToCoq/CompMExtra.v handwritten/CryptolToCoq/CoqVectorsExtra.v handwritten/CryptolToCoq/CryptolPrimitivesForSAWCoreExtra.v handwritten/CryptolToCoq/SAWCoreBitvectors.v @@ -17,6 +12,5 @@ handwritten/CryptolToCoq/SAWCorePrelude_proofs.v handwritten/CryptolToCoq/SAWCorePreludeExtra.v handwritten/CryptolToCoq/SAWCoreScaffolding.v handwritten/CryptolToCoq/SAWCoreVectorsAsCoqVectors.v -# handwritten/CryptolToCoq/SpecMExtra.v handwritten/CryptolToCoq/Everything.v diff --git a/saw-core-coq/coq/handwritten/CryptolToCoq/CompM.v b/saw-core-coq/coq/handwritten/CryptolToCoq/CompM.v deleted file mode 100644 index 2d2da52efb..0000000000 --- a/saw-core-coq/coq/handwritten/CryptolToCoq/CompM.v +++ /dev/null @@ -1,939 +0,0 @@ -(*** - *** A version of the computation monad using the option-set monad - ***) - -From Coq Require Import Program.Basics. -From Coq Require Export Morphisms Setoid. -From Coq Require Import Strings.String. -From EnTree Require Export Ref.SpecM. - -(*** - *** The Monad Typeclasses - ***) - -(* The monad equivalence relation *) -Class MonadEqOp (M:Type -> Type) : Type := - eqM : forall {A}, M A -> M A -> Prop. - -Infix "~=" := eqM (at level 70, no associativity). - -(* The class for the monadic return operation *) -Class MonadReturnOp (M:Type -> Type) : Type := - returnM : forall {A}, A -> M A. - -(* The class for the monadic bind operation *) -Class MonadBindOp (M:Type -> Type) : Type := - bindM : forall {A B}, M A -> (A -> M B) -> M B. - -Infix ">>=" := bindM (at level 58, left associativity). -Notation "m1 >> m2" := (m1 >>= fun _ => m2) (at level 58, left associativity). - -(* A monad is a collection of monad operations that satisfy the monad laws *) -Class Monad M `{MonadEqOp M} `{MonadReturnOp M} `{MonadBindOp M} : Prop := - { Equivalence_eqM :> forall A, Equivalence (eqM (A:=A)); - Proper_bindM :> forall A B, - Proper (eqM (A:=A) ==> (pointwise_relation A (eqM (A:=B))) ==> eqM) bindM; - returnM_bindM : forall A B a (f:A -> M B), returnM a >>= f ~= f a; - bindM_returnM : forall A (m:M A), m >>= (fun x => returnM x) ~= m; - bindM_bindM : forall A B C (m:M A) (f:A -> M B) (g:B -> M C), - (m >>= f) >>= g ~= m >>= (fun x => f x >>= g) }. - -(* This is not strictly necessary, but it speed up rewriting w.r.t. eq *) -Instance Proper_eq_bindM A B `{Monad} : - Proper (eq ==> (pointwise_relation A (@eq (M B))) ==> eqM) bindM. -Proof. - intros m1 m2 e_m; rewrite e_m. - intros f1 f2 ef; eapply Proper_bindM; [ reflexivity | ]. - intros a; rewrite (ef _). reflexivity. -Qed. - - -(** Monads with Errors **) - -(* The error operation *) -Class MonadErrorOp (M:Type -> Type) : Type := - errorM : forall {A}, string -> M A. - -(* A monad with errors *) -Class MonadError M `{Monad M} `{MonadErrorOp M} : Prop := - { errorM_bindM : forall A B str (f:A -> M B), errorM str >>= f ~= errorM str }. - - -(** Monads with Fixed-points **) - -(* The domain ordering for a fixed-point monad *) -Class MonadLeqOp (M:Type -> Type) : Type := - leqM : forall {A}, M A -> M A -> Prop. - -(* The class for the fixed-point operation *) -Class MonadFixOp (M:Type -> Type) : Type := - fixM : forall {A B}, ((forall (a:A), M (B a)) -> (forall (a:A), M (B a))) -> - (forall (a:A), M (B a)). - -(* Typeclass for dependent functions that respect the domain order *) -(* FIXME: this doesn't need to be a typeclass *) -Class ProperFixFun {A B M} `{MonadLeqOp M} - (F:(forall (a:A), M (B a)) -> (forall (a:A), M (B a))) : Prop := - { properFixFun : forall f1 f2, (forall a, leqM (f1 a) (f2 a)) -> - (forall a, leqM (F f1 a) (F f2 a)) }. - -Class MonadFix M `{Monad M} `{MonadLeqOp M} `{MonadFixOp M} : Prop := - { PreOrder_leqM :> forall A, PreOrder (leqM (A:=A)); - (* FIXME: does this need Properness of F? - Proper_fixM :> forall A B, - Proper (((eq ==> eqM) ==> eq ==> eqM) ==> eq ==> eqM) (fixM (A:=A) (B:=B)); *) - eqM_leqM : forall A (m1 m2:M A), m1 ~= m2 <-> leqM m1 m2 /\ leqM m2 m1; - fixM_F_fixM : forall A (B:A -> Type) (F:(forall a, M (B a)) -> (forall a, M (B a))) - {prp:ProperFixFun F} a, - eqM (fixM F a) (F (fixM F) a) - }. - - -(*** - *** The Set Monad - ***) - -(* The set monad = the sets over a given type *) -Polymorphic Definition SetM (A:Type) : Type := A -> Prop. - -(* Equivalence of two sets = they contain the same elements *) -Instance MonadEqOp_SetM : MonadEqOp SetM := - fun A m1 m2 => forall a, m1 a <-> m2 a. - -Instance Equivalence_SetM_eqM A : Equivalence (@eqM SetM _ A). -Proof. - split. - { intros m a; reflexivity. } - { intros m1 m2 eq_m a. symmetry. apply eq_m. } - { intros m1 m2 m3 eq12 eq23 a. transitivity (m2 a); [ apply eq12 | apply eq23 ]. } -Qed. - -(* Return for the set monad = the set with a single element *) -Instance MonadReturnOp_SetM : MonadReturnOp SetM := - fun A a a' => a = a'. - -(* Bind for the set monad = set map + union *) -Instance MonadBindOp_SetM : MonadBindOp SetM := - fun A B m f b => exists2 a, m a & f a b. - -Instance Monad_SetM : Monad SetM. -Proof. - split; intros. - { typeclasses eauto. } - { intros m1 m2 Rm f1 f2 Rf b; split; unfold bindM; intros [ a in_m in_fa ]; - exists a; try (apply Rm; assumption); - try apply (Rf a); assumption. } - { split; unfold bindM, returnM; intro. - { destruct H as [ x in_a in_fa ]. rewrite in_a. assumption. } - { exists a; [ reflexivity | assumption ]. } } - { split; unfold bindM, returnM; intro. - { destruct H as [ x in_a in_fa ]. rewrite <- in_fa. assumption. } - { exists a; [ assumption | reflexivity ]. } } - { split; unfold bindM; intro. - { destruct H as [ y [ x in_m in_fx ] in_gy ]. exists x; try assumption. - exists y; assumption. } - { destruct H as [ x in_m [ y in_fx in_gy ]]. exists y; try assumption. - exists x; assumption. } } -Qed. - - -Instance MonadLeqOp_SetM : MonadLeqOp SetM := - fun A m1 m2 => forall a, m1 a -> m2 a. - -(* The class for the fixed-point operation *) -Instance MonadFixOp_SetM : MonadFixOp SetM := - fun A B F a b => forall f, (forall a', leqM (F f a') (f a')) -> f a b. - -(* Helper for splitting eqM on SetM into to leqM requirements *) -Lemma split_SetM_eqM A (m1 m2:SetM A) : leqM m1 m2 -> leqM m2 m1 -> eqM m1 m2. -Proof. - intros l12 l21 a; split; [ apply l12 | apply l21 ]. -Qed. - -(* Helper for proving that fixM is a fixed-point: that fixM F is F-closed *) -Lemma SetM_fixM_F_closed {A B} F {prp:ProperFixFun (A:=A) (B:=B) F} a : - leqM (F (fixM F) a) (fixM F a). -Proof. - intros b in_F_fixM f f_F_closed. apply f_F_closed. - refine (properFixFun (F:=F) (fixM F) f _ a _ in_F_fixM). - intros a' b' in_fixM_b'. apply (in_fixM_b' f f_F_closed). -Qed. - -(* Helper for proving that fixM is a fixed-point: that fixM F is <= any F-closed f *) -Lemma SetM_fixM_leq_F_closed A B (F:(forall (a:A), SetM (B a)) -> forall a, SetM (B a)) f : - (forall a, leqM (F f a) (f a)) -> forall a, leqM (fixM F a) (f a). -Proof. - intros f_F_closed a b fixM_ab. apply (fixM_ab f f_F_closed). -Qed. - - -Instance MonadFix_SetM : MonadFix SetM. -Proof. - split. - { intro A; split. - { intros m a m_a; assumption. } - { intros m1 m2 m3 l12 l23 a m1_a. apply l23. apply l12. assumption. } } - (* FIXME: finish proving that fixM is Proper - { intros A B F1 F2 RF a1 a2 Ra b. rewrite Ra. - split; intro Fab; apply Fab; intros a' b' F_fixM_a'b'. - { apply Fab. *) - { intros A m1 m2; split. - { intros eq12; split; intro a; destruct (eq12 a); assumption. } - { intros [leq12 leq21] a; split; [ apply leq12 | apply leq21 ]. } } - { intros A B F prp a. apply split_SetM_eqM. - { revert a. apply SetM_fixM_leq_F_closed. intro a. - apply properFixFun. intro a'. apply SetM_fixM_F_closed. assumption. } - { apply SetM_fixM_F_closed. assumption. } } -Qed. - - -(*** - *** The Option Monad Transformer - ***) - -(* The option transformer just adds "option" around the type A *) -Polymorphic Definition OptionT (M:Type -> Type) (A:Type) : Type := M (option A). - -(* Equivalence in OptionT is just the underlying equivlence *) -Instance MonadEqOp_OptionT M `{MonadEqOp M} : MonadEqOp (OptionT M) := - fun A m1 m2 => eqM (A:=option A) m1 m2. - -(* Return for the option monad = underlying return of Some *) -Instance MonadReturnOp_OptionT M `{MonadReturnOp M} : MonadReturnOp (OptionT M) := - fun A a => returnM (Some a). - -(* Bind for the option monad = pattern-match *) -Instance MonadBindOp_OptionT M `{MonadReturnOp M} `{MonadBindOp M} : MonadBindOp (OptionT M) := - fun A B m f => - bindM (A:=option A) m - (fun opt_a => - match opt_a with - | Some a => f a - | None => returnM None - end). - -Instance Monad_OptionT M `{Monad M} : Monad (OptionT M). -Proof. - split. - { intro A; apply (Equivalence_eqM (option A)). } - { intros A B m1 m2 Rm f1 f2 Rf. - apply (Proper_bindM (M:=M)); [ assumption | ]. - intros opt_a; destruct opt_a; [ apply Rf | ]; reflexivity. } - { intros. - unfold returnM, MonadReturnOp_OptionT, bindM, MonadBindOp_OptionT. - unfold eqM, MonadEqOp_OptionT. - rewrite (returnM_bindM (M:=M)). reflexivity. } - { intros. - unfold returnM, MonadReturnOp_OptionT, bindM, MonadBindOp_OptionT. - unfold eqM, MonadEqOp_OptionT. - etransitivity; [ | apply (bindM_returnM (M:=M)) ]. - apply Proper_bindM; [ reflexivity | ]. - intros opt; destruct opt; reflexivity. } - { intros. - unfold returnM, MonadReturnOp_OptionT, bindM, MonadBindOp_OptionT; - unfold eqM, MonadEqOp_OptionT. - rewrite (bindM_bindM (M:=M)). - apply Proper_bindM; [ reflexivity | ]. - intros opt_a; destruct opt_a. - { apply Proper_bindM; [ reflexivity | ]. - intros opt_b; destruct opt_b; reflexivity. } - { rewrite returnM_bindM. reflexivity. } } -Qed. - - -Instance MonadErrorOp_OptionT M `{MonadReturnOp M} : MonadErrorOp (OptionT M) := - fun A _ => returnM None. - -Instance MonadError_OptionT M `{Monad M} : MonadError (OptionT M). -Proof. - split. - { intros. - unfold errorM, MonadErrorOp_OptionT, bindM, MonadBindOp_OptionT. - rewrite returnM_bindM. reflexivity. } -Qed. - - -Instance MonadLeqOp_OptionT M `{MonadLeqOp M} : MonadLeqOp (OptionT M) := - fun A m1 m2 => leqM (M:=M) m1 m2. - -Instance MonadFixOp_OptionT M `{MonadFixOp M} : MonadFixOp (OptionT M) := - fun A B F a => fixM (M:=M) F a. - -Instance MonadFix_OptionT M `{MonadFix M} : MonadFix (OptionT M). -Proof. - split. - { intros A; apply (PreOrder_leqM (M:=M)). } - { intros. apply (eqM_leqM (M:=M)). } - { intros. apply (fixM_F_fixM (M:=M) _ (fun a => option (B a))). - constructor. apply (properFixFun (ProperFixFun:=prp)). } -Qed. - - -(*** - *** The Set of Sets Monad - ***) - -(* -FIXME: can we get this to work as a predicate monad for SetM? -- The hard part is defining bindM: the current version fails associativity - because it requires finding a choice function -- I could imagine P >> Q is the union over all Q a for any a in mA in P, or the - union_(s in P) (intersection_(a in s) (Q a)) -- But all of these have issues! -- e.g., if P contains the empty set, so should P >>= Q! - -(* A SetSetM computation is a set of subsets of a type *) -Definition SetSetM (A:Type) := SetM A -> Prop. - -(* Close off a SetSetM under extensional equivalence *) -Definition inSetSetM {A} (P:SetSetM A) : SetSetM A := - fun m => exists2 m', m' ~= m & P m'. - -(* Equivalence of two sets = they contain the same elements *) -Instance MonadEqOp_SetSetM : MonadEqOp SetSetM := - fun A P1 P2 => forall m, inSetSetM P1 m <-> inSetSetM P2 m. - -Instance Proper_eqM_inSetSetM {A} : - Proper (eqM ==> eqM ==> iff) (inSetSetM (A:=A)). -Proof. - intros P1 P2 eqP m1 m2 eqm. - split; intros [ m' eq_m' in_m' ]; apply eqP; exists m'; try assumption. - - transitivity m1; assumption. - - transitivity m2; [ | symmetry ]; assumption. -Qed. - -Instance Equivalence_SetSetM_eqM A : Equivalence (eqM (M:=SetSetM) (A:=A)). -Proof. - split. - { intros m a; reflexivity. } - { intros m1 m2 eq_m a. symmetry. apply eq_m. } - { intros m1 m2 m3 eq12 eq23 a. etransitivity; [ apply eq12 | apply eq23 ]. } -Qed. - -Instance MonadReturnOp_SetSetM : MonadReturnOp SetSetM := - fun A a m => m ~= returnM a. - -Lemma SetSetM_returnM A (m:SetM A) a : - inSetSetM (returnM a) m <-> m ~= returnM a. -Proof. - split. - - intros [ m' eq_m' in_P ]. transitivity m'; [ symmetry; assumption | apply in_P ]. - - intro e_m; exists (returnM a); [ symmetry; assumption | intro; reflexivity ]. -Qed. - -Instance MonadBindOp_SetSetM : MonadBindOp SetSetM := - fun A B P Q m => - exists2 mA, inSetSetM P mA & - exists2 f, (forall a, mA a -> inSetSetM (Q a) (f a)) & - m ~= mA >>= f. - -Lemma SetSetM_bindM_elim {A B P} {Q:A -> SetSetM B} {m} : - inSetSetM (P >>= Q) m -> - exists2 mA, inSetSetM P mA & - exists2 f, (forall a, mA a -> inSetSetM (Q a) (f a)) & m ~= mA >>= f. -Proof. - intros [ m' eq_m [ mA in_P_mA [ f in_Q_f eq_m' ]]]. - exists mA; [ assumption | ]. - exists f; [ apply in_Q_f | ]. - rewrite <- eq_m; assumption. -Qed. - - -Lemma SetSetM_bindM_intro {A B P} {Q:A -> SetSetM B} {m} mA f : - inSetSetM P mA -> (forall a, mA a -> inSetSetM (Q a) (f a)) -> m ~= mA >>= f -> - inSetSetM (P >>= Q) m. -Proof. - intros [ mA' eq_mA in_mA' ] in_Q_f eq_m. - exists (mA >>= f); [ symmetry; assumption | ]. - exists mA; [ exists mA'; assumption | ]. - exists f; [ | reflexivity ]. apply in_Q_f. -Qed. - -Instance Monad_SetSetM : Monad SetSetM. -Proof. - split; intros. - { typeclasses eauto. } - { intros P1 P2 RP Q1 Q2 RQ m; split; - intros [ m' eq_m [ mA in_P_mA [ f in_Q_f eq_m' ] ] ]; - exists m'; try assumption; exists mA; try (apply RP; assumption); - exists f; try assumption; - intros a in_mA; apply (RQ a a eq_refl); apply in_Q_f; assumption. } - { intro m; split. - { intro in_m. - destruct (SetSetM_bindM_elim in_m) as [ mA in_mA [ g in_g eq_m ]]. - rewrite eq_m. - rewrite SetSetM_returnM in in_mA. rewrite in_mA. rewrite returnM_bindM. - apply in_g. rewrite (in_mA a). apply eq_refl. } - { intro in_m. apply (SetSetM_bindM_intro (returnM a) (fun _ => m)). - - apply SetSetM_returnM; reflexivity. - - intros a' eq_a_a'; compute in eq_a_a'. rewrite <- eq_a_a'. assumption. - - rewrite returnM_bindM. reflexivity. } } - { intro s; split. - { intro in_s. - destruct (SetSetM_bindM_elim in_s) as [ mA in_mA [ g in_g eq_s ]]. - assert (eq_s_mA : s ~= mA); [ | rewrite eq_s_mA; assumption ]. - transitivity (mA >>= g); [ assumption | ]. - transitivity (mA >>= returnM); [ | apply bindM_returnM ]. - intro a; split; intros [ a' in_a' in_f_a' ]; exists a'; try assumption. - - destruct (in_g a' in_a') as [ s' eq_s' in_s']. - rewrite <- (in_s' a). rewrite (eq_s' a). assumption. - - destruct (in_g a' in_a') as [ s' eq_s' in_s']. - rewrite <- (eq_s' a). apply in_s'. assumption. } - { intros [ s' eq_s' in_m_s' ]. exists s'; [ assumption | ]. - exists s'; [ exists s'; [ reflexivity | assumption ] | ]. - exists returnM; [ | symmetry; apply bindM_returnM ]. - intros a in_s'. exists (returnM a); [ reflexivity | ]. - intro a'; reflexivity. } } - { intro sC; split; intro in_sC. - { destruct (SetSetM_bindM_elim in_sC) as [ sB in_sB [ sg in_sg eq_sC ]]. - destruct (SetSetM_bindM_elim in_sB) as [ sA in_sA [ sf in_sf eq_sB ]]. - apply (SetSetM_bindM_intro sA (fun x => sf x >>= sg)); try assumption; - [ | rewrite eq_sC; rewrite eq_sB; rewrite bindM_bindM; reflexivity ]. - intros a in_a. - apply (SetSetM_bindM_intro (sf a) sg); [ apply in_sf; assumption | | reflexivity ]. - intros b in_b. apply in_sg. rewrite (eq_sB b). - exists a; assumption. } - { destruct (SetSetM_bindM_elim in_sC) as [ sA in_sA [ sfg in_sfg eq_sC ]]. - apply (SetSetM_bindM_intro sA sfg). - - - admit. } } - - apply (SetSetM_bindM_intro sA sfg); try assumption. - - destruct (SetSetM_bindM_elim in_sB) as [ sA in_sA [ sf in_sf eq_sB ]]. - - intros [ sC' eq_sC' [ sB [ sB' eq_sB' [ sA eq_sA in_sA ] ] eq_sB ] ]. destruct in_sC'. - *) - - -(*** - *** The Computation Monad = the Option-Set Monad - ***) - -Polymorphic Definition CompM : Type -> Type := OptionT SetM. - - -(*** - *** Letrec and Mutual Fixed-points in CompM - ***) - -(* An inductive description of a type A1 -> A2 -> ... -> An -> CompM B *) -(* -Inductive LetRecType : Type := -| LRT_Ret (B:Type) : LetRecType -| LRT_Fun (A:Type) (lrtF:A -> LetRecType) : LetRecType -. -*) -Definition LetRecType := SpecM.LetRecType. - -(* Convert a LetRecType to the type it represents *) -Fixpoint lrtToType (lrt:LetRecType) : Type := - match lrt with - | LRT_Ret B => CompM B - | LRT_Fun A lrtF => forall a, lrtToType (lrtF a) - end. - -(* Convert the argument types of a LetRecType to their "flat" version of the -form { x1:A1 & { x2:A2 & ... { xn:An & unit } ... }} *) -Fixpoint lrtToFlatArgs (lrt:LetRecType) : Type := - match lrt with - | LRT_Ret _ => unit - | LRT_Fun A lrtF => sigT (fun (a:A) => lrtToFlatArgs (lrtF a)) - end. - -(* Get the dependent return type fun (args:lrtToFlatArgs) => B x.1 ... of -a LetRecType in terms of the flat arguments *) -Fixpoint lrtToFlatRet (lrt:LetRecType) : lrtToFlatArgs lrt -> Type := - match lrt return lrtToFlatArgs lrt -> Type with - | LRT_Ret B => fun _ => B - | LRT_Fun A lrtF => - fun args => lrtToFlatRet (lrtF (projT1 args)) (projT2 args) - end. - -(* Extract out the "flat" version of a LetRecType *) -Definition lrtToFlatType lrt := - forall (args:lrtToFlatArgs lrt), CompM (lrtToFlatRet lrt args). - -(* "Flatten" a function described by a LetRecType *) -Fixpoint flattenLRTFun lrt : lrtToType lrt -> lrtToFlatType lrt := - match lrt return lrtToType lrt -> lrtToFlatType lrt with - | LRT_Ret _ => fun f _ => f - | LRT_Fun A lrtF => - fun f args => flattenLRTFun (lrtF (projT1 args)) (f (projT1 args)) (projT2 args) - end. - -(* "Unflatten" a function described by a LetRecType *) -Fixpoint unflattenLRTFun lrt : lrtToFlatType lrt -> lrtToType lrt := - match lrt return lrtToFlatType lrt -> lrtToType lrt with - | LRT_Ret _ => fun f => f tt - | LRT_Fun A lrtF => - fun f a => unflattenLRTFun (lrtF a) (fun args => f (existT _ a args)) - end. - -(* A list of types (FIXME: use a Coq list?) *) -Inductive LetRecTypes : Type := -| LRT_Nil : LetRecTypes -| LRT_Cons : LetRecType -> LetRecTypes -> LetRecTypes -. - -(* Construct type type (F1, (F2, ... (Fn, unit) .. )) from a LetRecTypes list of -descriptions of the types F1, ..., Fn *) -Fixpoint lrtTupleType (lrts:LetRecTypes) : Type := - match lrts with - | LRT_Nil => unit - | LRT_Cons lrt lrts' => prod (lrtToType lrt) (lrtTupleType lrts') - end. - -(* Construct type type F1 -> ... -> Fn -> B from a LetRecTypes list of -descriptions of the types F1, ..., Fn *) -Fixpoint lrtPi (lrts:LetRecTypes) (B:Type) : Type := - match lrts with - | LRT_Nil => B - | LRT_Cons lrt lrts' => lrtToType lrt -> lrtPi lrts' B - end. - -(* Construct a multi-arity function of type lrtPi lrts B from one of type -lrtTupleType lrts -> B *) -Fixpoint lrtLambda {lrts B} : (lrtTupleType lrts -> B) -> lrtPi lrts B := - match lrts return (lrtTupleType lrts -> B) -> lrtPi lrts B with - | LRT_Nil => fun F => F tt - | LRT_Cons _ lrts' => fun F f => lrtLambda (fun fs => F (f, fs)) - end. - -(* Apply a multi-arity function of type lrtPi lrts B to an lrtTupleType lrts *) -Fixpoint lrtApply {lrts B} : lrtPi lrts B -> lrtTupleType lrts -> B := - match lrts return lrtPi lrts B -> lrtTupleType lrts -> B with - | LRT_Nil => fun F _ => F - | LRT_Cons _ lrts' => fun F fs => lrtApply (F (fst fs)) (snd fs) - end. - -(* Build a multi-argument fixed-point of type A1 -> ... -> An -> CompM B *) -Definition multiArgFixM (lrt:LetRecType) (F:lrtToType lrt -> - lrtToType lrt) : lrtToType lrt := - unflattenLRTFun - lrt - (fixM (fun f => flattenLRTFun lrt (F (unflattenLRTFun lrt f)))). - -(* Construct a mutual fixed-point over tuples of LRT functions *) -Fixpoint multiTupleFixM (lrts:LetRecTypes) : (lrtTupleType lrts -> lrtTupleType lrts) -> - lrtTupleType lrts := - match lrts return (lrtTupleType lrts -> lrtTupleType lrts) -> lrtTupleType lrts with - | LRT_Nil => fun _ => tt - | LRT_Cons lrt lrts' => - fun F => - let f1 := multiArgFixM lrt (fun f => fst (F (f, multiTupleFixM lrts' (fun fs => snd (F (f, fs)))))) in - (f1, multiTupleFixM lrts' (fun fs => snd (F (f1, fs)))) - end. - -(* A nicer version of multiTupleFixM that abstracts the functions one at a time *) -Definition multiFixM {lrts:LetRecTypes} - (F:lrtPi lrts (lrtTupleType lrts)) : lrtTupleType lrts := - multiTupleFixM lrts (fun fs => lrtApply F fs). - -(* A letrec construct for binding 0 or more mutually recursive functions *) -Definition letRecM (lrts : LetRecTypes) {B} (F: lrtPi lrts (lrtTupleType lrts)) - (body:lrtPi lrts (CompM B)) : CompM B := - lrtApply body (multiFixM F). - - -(*** - *** Refinement Proofs - ***) - -Definition refinesM {A} (m1 m2:CompM A) : Prop := forall a, m1 a -> m2 a. - -Infix "|=" := refinesM (at level 70, no associativity). - -Instance PreOrder_refinesM A : PreOrder (refinesM (A:=A)). -Proof. - split. - { intros m a in_a; assumption. } - { intros m1 m2 m3 R12 R23 a in_m1. apply R23. apply R12. assumption. } -Qed. - -Instance Proper_eqM_refinesM A : Proper (eqM ==> eqM ==> iff) (refinesM (A:=A)). -Proof. - intros m1 m1' e1 m2 m2' e2. - split; intros R12 a in_a; apply e2; apply R12; apply e1; assumption. -Qed. - -Instance Proper_refinesM_bindM A B : - Proper (refinesM ==> (pointwise_relation A refinesM) ==> refinesM) (bindM (A:=A) (B:=B)). -Proof. - intros m1 m2 Rm f1 f2 Rf opt_b [ opt_a in_opt_a in_opt_b ]. - exists opt_a; [ apply Rm; assumption | ]. - destruct opt_a; [ | assumption ]. - apply (Rf a); assumption. -Qed. - -Lemma refinesM_returnM A (a1 a2:A) : a1 = a2 -> returnM a1 |= returnM a2. -Proof. - intro e; rewrite e. reflexivity. -Qed. - -Lemma refinesM_errorM_returnM A s (a:A) : ~ errorM s |= returnM a. -Proof. - intro H; vm_compute in H. - apply (fun H => H None eq_refl) in H. - discriminate H. -Qed. - -Lemma refinesM_returnM_errorM A (a:A) s : ~ returnM a |= errorM s. -Proof. - intro H; vm_compute in H. - apply (fun H => H (Some a) eq_refl) in H. - discriminate H. -Qed. - -(* If a monadic function f is F-closed w.r.t. the refinement relation, then the -least fixed-point of F refines f *) -Lemma refinesM_fixM_l A B (F : (forall (a:A), CompM (B a)) -> - (forall (a:A), CompM (B a))) f : - (forall a, F f a |= f a) -> forall a, fixM F a |= f a. -Proof. - intros F_closed a opt_b in_fix. - apply in_fix. intros a' opt_b' in_F. apply F_closed. apply in_F. -Qed. - -Lemma refinesM_fixM_lr A B (F G : (forall (a:A), CompM (B a)) -> - (forall (a:A), CompM (B a))) : - (forall f a, F f a |= G f a) -> forall a, fixM F a |= fixM G a. -Proof. - intros leq_FG a opt_b in_fixF f G_closed. - apply (refinesM_fixM_l _ _ F); [ | assumption ]. - intros a' opt_b' in_F. apply G_closed. apply leq_FG. assumption. -Qed. - -(* Lift refinesM to monadic functions *) -Fixpoint refinesFun {lrt} : relation (lrtToType lrt) := - match lrt return relation (lrtToType lrt) with - | LRT_Ret B => refinesM - | LRT_Fun A lrtF => forall_relation (fun a => @refinesFun (lrtF a)) - end. - -Instance PreOrder_refinesFun lrt : PreOrder (@refinesFun lrt). -Proof. - induction lrt. - - apply PreOrder_refinesM. - - split. - { intros f a. reflexivity. } - { intros f1 f2 f3 H1 H2 a. transitivity (f2 a); [ apply H1 | apply H2 ]. } -Qed. - -Instance subrelation_forall_const_pointwise A B (R : relation B) - : subrelation (forall_relation (fun _ => R)) (pointwise_relation A R). -Proof. vm_compute; auto. Qed. - -(* A convenient specialization of refinesFun *) -Definition refinesFun1 {A} {B:A -> Type} : (forall a, CompM (B a)) -> (forall a, CompM (B a)) -> Prop := - refinesFun (lrt:=LRT_Fun _ (fun _ => LRT_Ret _)). - -(* Lift refinesM to tuples of monadic functions *) -Fixpoint refinesFunTuple {lrts} : relation (lrtTupleType lrts) := - match lrts return relation (lrtTupleType lrts) with - | LRT_Nil => fun _ _ => True - | LRT_Cons lrt lrts' => - fun tup1 tup2 => refinesFun (fst tup1) (fst tup2) /\ - refinesFunTuple (snd tup1) (snd tup2) - end. - -Fixpoint respectfulLRTPi {lrts} {B} : relation (lrtPi lrts (CompM B)) := - match lrts with - | LRT_Nil => refinesM - | LRT_Cons _ _ => respectful refinesFun respectfulLRTPi - end. - -(* `ProperLRTFun F` is just `Proper (refinesFun ==> ... ==> refinesFun ==> refinesM) F` *) -Class ProperLRTFun {lrts} {B} (F : lrtPi lrts (CompM B)) : Prop := - { properLRTFun : Proper respectfulLRTPi F }. - -(* All constant functions are proper *) -Instance ProperLRTFun_const lrts B b : @ProperLRTFun lrts B (lrtLambda (fun _ => b)). -Proof. - split; induction lrts; vm_compute; intros; assumption. -Qed. - -(* FIXME Get rid of this *) -Instance ProperLRTFun_any lrts B F : @ProperLRTFun lrts B F. -Proof. - admit. (* FIXME *) -Admitted. - -Instance Proper_lrtApply lrts B - : Proper (respectfulLRTPi ==> refinesFunTuple ==> refinesM) (@lrtApply lrts (CompM B)). -Proof. - unfold Proper, respectful; intros F G H1 fs gs H2. - induction lrts; simpl in F,G,H1,fs,gs,H2; simpl. - - exact H1. - - destruct fs as [f fs]; destruct gs as [g gs]; destruct H2 as [H2 H3]; simpl in *. - apply IHlrts. - + unfold respectful in H1. - apply H1. - assumption. - + assumption. -Qed. - -Lemma refinesFunTuple_multiFixM lrts (F:lrtPi lrts (lrtTupleType lrts)) tup : - refinesFunTuple (lrtApply F tup) tup -> refinesFunTuple (multiFixM F) tup. -Proof. - admit. (* FIXME *) -Admitted. - -Lemma refinesFun_multiFixM_fst lrt (F:lrtPi (LRT_Cons lrt LRT_Nil) - (lrtTupleType (LRT_Cons lrt LRT_Nil))) f - (ref_f:refinesFun (fst (F f)) f) : - refinesFun (fst (multiFixM F)) f. -Proof. - refine (proj1 (refinesFunTuple_multiFixM (LRT_Cons lrt LRT_Nil) _ (f, tt) _)). - split; [ | constructor ]. - apply ref_f. -Qed. - -Lemma letRecM_Nil B F P : @letRecM LRT_Nil B F P = P. -Proof. - reflexivity. -Qed. - -Lemma refinesM_letRecM_Nil_l B F P Q : P |= Q -> @letRecM LRT_Nil B F P |= Q. -Proof. - rewrite letRecM_Nil. trivial. -Qed. - -Lemma multiFixM_const lrts fs - : multiFixM (lrts:=lrts) (lrtLambda (fun _ => fs)) = fs. -Proof. - admit. (* FIXME *) -Admitted. - -Lemma refinesM_letRecM_const_r lrts B (F : lrtPi lrts (lrtTupleType lrts)) - (G : lrtTupleType lrts) (P Q : lrtPi lrts (CompM B)) - `{ProperLRTFun _ _ P} `{ProperLRTFun _ _ Q} - : refinesFunTuple (multiFixM F) G -> - lrtApply P G |= lrtApply Q G -> - @letRecM lrts B F P |= @letRecM lrts B (lrtLambda (fun _ => G)) Q. -Proof. - destruct H as [ProperP]; destruct H0 as [ProperQ]. - intros. - unfold letRecM. - rewrite H, H0, multiFixM_const. - reflexivity. -Qed. - -Lemma lrtApply_const lrts B (b : B) (F : lrtTupleType lrts) - : lrtApply (lrts:=lrts) (lrtLambda (fun _ => b)) F = b. -Proof. - induction lrts. - - reflexivity. - - destruct F as [ F0 F1 ]. - simpl; rewrite (IHlrts F1). - reflexivity. -Qed. - -Lemma refinesM_letRecM_match_r lrts B F P Q `{ProperLRTFun _ _ P} - : forall (G : lrtTupleType lrts), - @letRecM lrts B F P |= @letRecM lrts B (lrtLambda (fun _ => G)) (lrtLambda (fun _ => Q)) -> - @letRecM lrts B F P |= Q. -Proof. - intros. - rewrite H0. - unfold letRecM. - rewrite lrtApply_const. - reflexivity. -Qed. - -Lemma refinesM_if_l {A} (m1 m2:CompM A) b P : - (b = true -> m1 |= P) -> (b = false -> m2 |= P) -> - (if b then m1 else m2) |= P. -Proof. - intros ref1 ref2; destruct b; [ apply ref1 | apply ref2 ]; reflexivity. -Qed. - -Lemma refinesM_if_r {A} (m1 m2:CompM A) b P : - (b = true -> P |= m1) -> (b = false -> P |= m2) -> - P |= (if b then m1 else m2). -Proof. - intros ref1 ref2; destruct b; [ apply ref1 | apply ref2 ]; reflexivity. -Qed. - -Lemma simpl_letRecM0 B F body : @letRecM LRT_Nil B F body = body. -Proof. - reflexivity. -Qed. - -Lemma refinesM_sigT_rect_l {A1 A2 B} F P (s: {x:A1 & A2 x}) : - (forall a1 a2, s = existT _ a1 a2 -> F a1 a2 |= P) -> - sigT_rect (fun _ => CompM B) F s |= P. -Proof. - destruct s; intros. - apply H. reflexivity. -Qed. - -Lemma refinesM_sigT_rect_r {A1 A2 B} F P (s: {x:A1 & A2 x}) : - (forall a1 a2, s = existT _ a1 a2 -> P |= F a1 a2) -> - P |= sigT_rect (fun _ => CompM B) F s. -Proof. - destruct s; intros. - apply H. reflexivity. -Qed. - - -(** Existential Specifications **) - -Definition existsM {A B} (P: A -> CompM B) : CompM B := - fun b => exists a, P a b. - -Lemma refinesM_existsM_r {A B} (P: A -> CompM B) m a : - m |= (P a) -> m |= (existsM P). -Proof. - intros r b in_b. exists a. apply r. assumption. -Qed. - -Lemma refinesM_existsM_l A B (P: A -> CompM B) Q : - (forall a, P a |= Q) -> existsM P |= Q. -Proof. - intros r b [ a in_b ]. apply (r a). assumption. -Qed. - -Lemma refinesM_existsM_lr A B (P Q : A -> CompM B) : - (forall a, P a |= Q a) -> existsM P |= existsM Q. -Proof. - intros r b [ a in_b ]. exists a. apply r. assumption. -Qed. - -Lemma existsM_bindM A B C (P: A -> CompM B) (Q: B -> CompM C) : - (existsM P) >>= Q ~= existsM (fun x => P x >>= Q). -Proof. - intros c; split. - - intros [ opt_b [ a in_b ] in_c ]. exists a. exists opt_b; assumption. - - intros [ a [ opt_b in_b in_c ] ]. exists opt_b; [ | assumption ]. - exists a; assumption. -Qed. - -Definition noErrorsSpec {A} : CompM A := existsM (fun a => returnM a). -Arguments noErrorsSpec /. - - -(** Universal Specifications **) - -Definition forallM {A B} (P: A -> CompM B) : CompM B := - fun b => forall a, P a b. - -Lemma refinesM_forallM_r {A B} P (Q: A -> CompM B) : - (forall a, P |= (Q a)) -> P |= (forallM Q). -Proof. - intros r b in_b a. apply r. assumption. -Qed. - -Lemma refinesM_forallM_l {A B} (P: A -> CompM B) Q a : - P a |= Q -> forallM P |= Q. -Proof. - intros r b in_b. apply r. apply in_b. -Qed. - -(* NOTE: the other direction does not hold *) -Lemma forallM_bindM A B C (P: A -> CompM B) (Q: B -> CompM C) : - refinesM ((forallM P) >>= Q) (forallM (fun x => P x >>= Q)). -Proof. - intros c [ opt_b H ] a. exists opt_b; [ apply (H _) | assumption ]. -Qed. - - -(** Conjuctive and disjunctive specifications **) - -Definition orM {A} (m1 m2 : CompM A) : CompM A := - fun b => m1 b \/ m2 b. - -Lemma refinesM_orM_r {A} (m1 m2 : CompM A) P : - P |= m1 \/ P |= m2 -> P |= (orM m1 m2). -Proof. - intros r b in_b; destruct r; [ left | right ]; apply H; assumption. -Qed. - -Lemma refinesM_orM_l {A} (m1 m2 : CompM A) P : - m1 |= P -> m2 |= P -> orM m1 m2 |= P. -Proof. - intros r1 r2 b in_b; destruct in_b; [ apply r1 | apply r2 ]; assumption. -Qed. - -Lemma orM_bindM A B (m1 m2 : CompM A) (P : A -> CompM B) : - (orM m1 m2) >>= P ~= orM (m1 >>= P) (m2 >>= P). -Proof. - intros c; split. - - intros [ opt_b [ r1 | r2 ] in_c ]; [ left | right ]; exists opt_b; assumption. - - intros [ [ opt_b in_b in_c ] | [ opt_b in_b in_c ] ]; (exists opt_b; [ | assumption ]); - [ left | right ]; assumption. -Qed. - -Definition andM {A} (m1 m2:CompM A) : CompM A := - fun b => m1 b /\ m2 b. - -Lemma refinesM_andM_r {A} (m1 m2 : CompM A) P : - P |= m1 -> P |= m2 -> P |= andM m1 m2. -Proof. - intros r1 r2 b in_b. split; [ apply r1 | apply r2 ]; assumption. -Qed. - -Lemma refinesM_andM_l {A} (m1 m2 : CompM A) P : - m1 |= P \/ m2 |= P -> andM m1 m2 |= P. -Proof. - intros r b in_b; destruct r; destruct in_b; apply H; assumption. -Qed. - -Lemma andM_bindM A B (m1 m2 : CompM A) (P : A -> CompM B) : - refinesM ((andM m1 m2) >>= P) (andM (m1 >>= P) (m2 >>= P)). -Proof. - intros c [ opt_b [ r1 r2 ] in_c ]; split; exists opt_b; assumption. -Qed. - - -(** Assertions and Assumptions **) - -Definition assertM (P:Prop) : CompM unit := - existsM (fun pf:P => returnM tt). - -Definition assertingM {A} (P:Prop) (m:CompM A) : CompM A := - assertM P >> m. - -Definition assertM_eq (P:Prop) (pf:P) : assertM P ~= returnM tt. -Proof. - intro opt_a; split. - - intros [ _ H ]; assumption. - - intros H. exists pf. assumption. -Qed. - -Lemma refinesM_bindM_assertM_r {A} (P:Prop) (m1 m2: CompM A) : - P -> m1 |= m2 -> m1 |= assertM P >> m2. -Proof. - intro pf; rewrite (assertM_eq P pf). rewrite returnM_bindM. intro; assumption. -Qed. - -Lemma refinesM_bindM_assertM_l {A} (P:Prop) (m1 m2: CompM A) : - (P -> m1 |= m2) -> assertM P >> m1 |= m2. -Proof. - intro H. unfold assertM; rewrite existsM_bindM. - apply refinesM_existsM_l. - rewrite returnM_bindM; assumption. -Qed. - -Definition assumingM {A} (P:Prop) (m:CompM A) : CompM A := - forallM (fun pf:P => m). - -Lemma refinesM_assumingM_r {A} (P:Prop) (m1 m2: CompM A) : - (P -> m1 |= m2) -> m1 |= assumingM P m2. -Proof. - apply refinesM_forallM_r. -Qed. - -Lemma refinesM_assumingM_l {A} (P:Prop) (m1 m2 : CompM A) : - P -> m1 |= m2 -> assumingM P m1 |= m2. -Proof. - apply refinesM_forallM_l. -Qed. - -(* NOTE: the other direction does not hold *) -Lemma assumingM_bindM {A B} (P:Prop) (m: CompM A) (Q: A -> CompM B) : - refinesM ((assumingM P m) >>= Q) (assumingM P (m >>= Q)). -Proof. - apply forallM_bindM. -Qed. diff --git a/saw-core-coq/coq/handwritten/CryptolToCoq/CompMExtra.v b/saw-core-coq/coq/handwritten/CryptolToCoq/CompMExtra.v deleted file mode 100644 index 87966b38e8..0000000000 --- a/saw-core-coq/coq/handwritten/CryptolToCoq/CompMExtra.v +++ /dev/null @@ -1,993 +0,0 @@ -(*** - *** Extra Proofs for CompM that Rely on SAWCorePrelude - ***) - -From Coq Require Import Logic. -From Coq Require Program.Equality. -From Coq Require Import Strings.String. -From CryptolToCoq Require Import SAWCorePrelude. -From CryptolToCoq Require Import SAWCoreScaffolding. -From CryptolToCoq Require Import SAWCoreVectorsAsCoqVectors. -From CryptolToCoq Require Export CompM. - -(* A duplicate from `Program.Equality`, because importing that - module directly gives us a conflict with the `~=` notation... *) -Tactic Notation "dependent" "destruction" ident(H) := - Equality.do_depelim' ltac:(fun hyp => idtac) ltac:(fun hyp => Equality.do_case hyp) H. - -(*** - *** Some useful Ltac - ***) - -(* Ltac get_last_hyp tt := *) -(* match goal with H: _ |- _ => constr:(H) end. *) - -Tactic Notation "unfold_projs" := - cbn [ Datatypes.fst Datatypes.snd projT1 ]. - -Tactic Notation "unfold_projs" "in" constr(N) := - cbn [ Datatypes.fst Datatypes.snd projT1 ] in N. - -Tactic Notation "unfold_projs" "in" "*" := - cbn [ Datatypes.fst Datatypes.snd projT1 ] in *. - -Ltac split_prod_hyps := - repeat match goal with - | H: _ /\ _ |- _ => destruct H as [?H ?H] - | p: { _ : _ & _ } |- _ => destruct p as [?p ?p] - | p: _ * _ |- _ => destruct p as [?p ?p] - | u: unit |- _ => destruct u - | u: True |- _ => destruct u - end. - -Ltac split_prod_goal := - repeat match goal with - | |- _ /\ _ => split - | |- { _ : _ & _ } => split - | |- _ * _ => split - | |- unit => exact tt - | |- True => trivial - end. - - -(*** - *** Extra lemmas about refinement that rely on SAWCorePrelude - ***) - -Lemma refinesM_either_l {A B C} (f:A -> CompM C) (g:B -> CompM C) eith P : - (forall a, eith = SAWCorePrelude.Left _ _ a -> f a |= P) -> - (forall b, eith = SAWCorePrelude.Right _ _ b -> g b |= P) -> - SAWCorePrelude.either _ _ _ f g eith |= P. -Proof. - destruct eith; intros; simpl. - - apply H; reflexivity. - - apply H0; reflexivity. -Qed. - -Lemma refinesM_either_r {A B C} (f:A -> CompM C) (g:B -> CompM C) eith P : - (forall a, eith = SAWCorePrelude.Left _ _ a -> P |= f a) -> - (forall b, eith = SAWCorePrelude.Right _ _ b -> P |= g b) -> - P |= SAWCorePrelude.either _ _ _ f g eith. -Proof. - destruct eith; intros; simpl. - - apply H; reflexivity. - - apply H0; reflexivity. -Qed. - -Lemma refinesM_eithers_nil_l {A} P eith : - SAWCorePrelude.eithers (CompM A) (SAWCorePrelude.FunsTo_Nil _) eith |= P. -Proof. - apply SAWCorePrelude.efq; assumption. -Qed. - -Lemma refinesM_eithers_nil_r {A} P eith : - P |= SAWCorePrelude.eithers (CompM A) (SAWCorePrelude.FunsTo_Nil _) eith. -Proof. - apply SAWCorePrelude.efq; assumption. -Qed. - -Lemma refinesM_eithers_one_l {A B} (f:A -> CompM B) eith P : - f eith |= P -> - SAWCorePrelude.eithers - (CompM B) - (SAWCorePrelude.FunsTo_Cons _ _ f (SAWCorePrelude.FunsTo_Nil _)) - eith - |= P. -Proof. - intro r; apply r. -Qed. - -Lemma refinesM_eithers_one_r {A B} (f:A -> CompM B) eith P : - P |= f eith -> - P |= - SAWCorePrelude.eithers - (CompM B) - (SAWCorePrelude.FunsTo_Cons _ _ f (SAWCorePrelude.FunsTo_Nil _)) - eith. -Proof. - intro r; apply r. -Qed. - -Lemma refinesM_eithers_cons_l - {A B C} (f:A -> CompM C) (g:B -> CompM C) elims eith P : - (forall a, eith = SAWCorePrelude.Left _ _ a -> f a |= P) -> - (forall eith', - eith = SAWCorePrelude.Right _ _ eith' -> - SAWCorePrelude.eithers _ (SAWCorePrelude.FunsTo_Cons _ _ g elims) eith' |= P) -> - SAWCorePrelude.eithers - (CompM C) - (SAWCorePrelude.FunsTo_Cons _ _ f (SAWCorePrelude.FunsTo_Cons _ _ g elims)) - eith - |= P. -Proof. - destruct eith; intros; simpl. - - apply H; reflexivity. - - apply H0; reflexivity. -Qed. - -Lemma refinesM_eithers_cons_r - {A B C} (f:A -> CompM C) (g:B -> CompM C) elims eith P : - (forall a, eith = SAWCorePrelude.Left _ _ a -> P |= f a) -> - (forall eith', - eith = SAWCorePrelude.Right _ _ eith' -> - P |= SAWCorePrelude.eithers _ (SAWCorePrelude.FunsTo_Cons _ _ g elims) eith') -> - P |= - SAWCorePrelude.eithers - (CompM C) - (SAWCorePrelude.FunsTo_Cons _ _ f (SAWCorePrelude.FunsTo_Cons _ _ g elims)) - eith. -Proof. - destruct eith; intros; simpl. - - apply H; reflexivity. - - apply H0; reflexivity. -Qed. - -Lemma refinesM_maybe_l {A B} (x : CompM B) (f : A -> CompM B) mb P : - (mb = SAWCorePrelude.Nothing _ -> x |= P) -> - (forall a, mb = SAWCorePrelude.Just _ a -> f a |= P) -> - SAWCorePrelude.maybe _ _ x f mb |= P. -Proof. - destruct mb; intros; simpl. - - apply H; reflexivity. - - apply H0; reflexivity. -Qed. - -Lemma refinesM_maybe_r {A B} (x : CompM B) (f : A -> CompM B) mb P : - (mb = SAWCorePrelude.Nothing _ -> P |= x) -> - (forall a, mb = SAWCorePrelude.Just _ a -> P |= f a) -> - P |= SAWCorePrelude.maybe _ _ x f mb. -Proof. - destruct mb; intros; simpl. - - apply H; reflexivity. - - apply H0; reflexivity. -Qed. - -Lemma returnM_if A (b : bool) (x y : A) : - @returnM CompM _ A (if b then x else y) ~= if b then returnM x else returnM y. -Proof. destruct b. setoid_reflexivity. setoid_reflexivity. Qed. - -Lemma refinesM_returnM_if_l A (b : bool) (x y : A) P : - ((if b then returnM x else returnM y) |= P) -> - (returnM (if b then x else y) |= P). -Proof. rewrite returnM_if. trivial. Qed. - -Lemma refinesM_returnM_if_r A (b : bool) (x y : A) P : - (P |= (if b then returnM x else returnM y)) -> - (P |= returnM (if b then x else y)). -Proof. rewrite returnM_if. trivial. Qed. - -Lemma returnM_injective : forall (A : Type) (x y : A), - returnM (M:=CompM) x ~= returnM y -> x = y. -Proof. - intros. destruct (H (Some x)). - assert (Some y = Some x); [ apply H0; reflexivity | ]. - inversion H2. reflexivity. -Qed. - - -(*** - *** Automation for proving refinement - ***) - -Create HintDb refinesM. -Create HintDb refinesFun. - -Hint Extern 999 (_ |= _) => shelve : refinesM. - -Hint Resolve refinesM_letRecM_Nil_l : refinesM. - -Hint Extern 1 (@letRecM ?lrts _ _ _ |= @letRecM ?lrts _ (lrtLambda (fun _ => _)) _) => - apply refinesM_letRecM_const_r; try apply ProperLRTFun_any; -try (apply refinesFunTuple_multiFixM; unfold refinesFunTuple; split_prod_goal); -unfold lrtApply, lrtLambda; unfold_projs : refinesM. - -Inductive ArgName := Any | SAWLet | Either | Maybe | SigT | If | If0 | - Assert | Assuming | Exists | Forall. -Ltac argName n := - match n with - | Any => fresh "a" - | SAWLet => fresh "e_let" - | Either => fresh "e_either" - | Maybe => fresh "e_maybe" - | SigT => fresh "e_either" - | If => fresh "e_if" - | Assert => fresh "e_assert" - | Assuming => fresh "e_assuming" - | Exists => fresh "e_exists" - | Forall => fresh "e_forall" - end. - -Definition IntroArg (n : ArgName) A (goal : A -> Prop) := forall a, goal a. - -Hint Opaque IntroArg : refinesM refinesFun. - -Definition FreshIntroArg (n : ArgName) A (goal : A -> Prop) := IntroArg n A goal. - -Hint Opaque FreshIntroArg : refinesM refinesFun. - -Hint Extern 999 (FreshIntroArg _ _ _) => unfold FreshIntroArg : refinesFun. - -Lemma IntroArg_fold n A goal : forall a, IntroArg n A goal -> goal a. -Proof. intros a H; exact (H a). Qed. - -(* Lemma IntroArg_unfold n A (goal : A -> Prop) : (forall a, goal a) -> IntroArg n A goal. *) -(* Proof. unfold IntroArg; intro H; exact H. Qed. *) - -Ltac IntroArg_intro e := intro e; unfold_projs in *. - -Ltac IntroArg_forget := let e := fresh in intro e; clear e. - -Lemma IntroArg_and n P Q (goal : P /\ Q -> Prop) - : IntroArg n P (fun p => FreshIntroArg n Q (fun q => goal (conj p q))) -> IntroArg n _ goal. -Proof. intros H [ p q ]; apply H. Qed. - -Lemma IntroArg_or n P Q (goal : P \/ Q -> Prop) - : IntroArg n P (fun p => goal (or_introl p)) -> - IntroArg n Q (fun q => goal (or_intror q)) -> IntroArg n _ goal. -Proof. intros Hl Hr [ p | q ]; [ apply Hl | apply Hr ]. Qed. - -Lemma IntroArg_sigT n A P (goal : {a : A & P a} -> Prop) - : IntroArg n A (fun a => FreshIntroArg n (P a) (fun p => goal (existT _ a p))) -> IntroArg n _ goal. -Proof. intros H [ a p ]; apply H. Qed. - -Lemma IntroArg_prod n P Q (goal : P * Q -> Prop) - : IntroArg n P (fun p => FreshIntroArg n Q (fun q => goal (pair p q))) -> IntroArg n _ goal. -Proof. intros H [ p q ]; apply H. Qed. - -Lemma IntroArg_sum n P Q (goal : P + Q -> Prop) - : IntroArg n P (fun p => goal (inl p)) -> - IntroArg n Q (fun q => goal (inr q)) -> IntroArg n _ goal. -Proof. intros Hl Hr [ p | q ]; [ apply Hl | apply Hr ]. Qed. - -Lemma IntroArg_unit n (goal : unit -> Prop) : goal tt -> IntroArg n _ goal. -Proof. intros H []. apply H. Qed. - -Lemma IntroArg_eq_sigT_const n A B (a a' : A) (b b' : B) (goal : Prop) - : IntroArg n (a = a') (fun _ => FreshIntroArg n (b = b') (fun _ => goal)) -> - IntroArg n (existT _ a b = existT _ a' b') (fun _ => goal). -Proof. intros H eq; apply H; injection eq; eauto. Qed. - -Lemma IntroArg_eq_prod_const n P Q (p p' : P) (q q' : Q) (goal : Prop) - : IntroArg n (p = p') (fun _ => FreshIntroArg n (q = q') (fun _ => goal)) -> - IntroArg n (pair p q = pair p' q') (fun _ => goal). -Proof. intros H eq; apply H; injection eq; eauto. Qed. - -Lemma IntroArg_eq_Left_const n A B (x y : A) (goal : Prop) - : IntroArg n (x = y) (fun _ => goal) -> - IntroArg n (SAWCorePrelude.Left A B x = SAWCorePrelude.Left A B y) (fun _ => goal). -Proof. intros H eq; apply H; injection eq; eauto. Qed. -Lemma IntroArg_eq_Right_const n A B (x y : B) (goal : Prop) - : IntroArg n (x = y) (fun _ => goal) -> - IntroArg n (SAWCorePrelude.Right A B x = SAWCorePrelude.Right A B y) (fun _ => goal). -Proof. intros H eq; apply H; injection eq; eauto. Qed. -Lemma IntroArg_eq_Left_Right n A B (x : A) (y : B) goal - : IntroArg n (SAWCorePrelude.Left A B x = SAWCorePrelude.Right A B y) goal. -Proof. intros eq; discriminate eq. Qed. -Lemma IntroArg_eq_Right_Left n A B (x : A) (y : B) goal - : IntroArg n (SAWCorePrelude.Right A B y = SAWCorePrelude.Left A B x) goal. -Proof. intros eq; discriminate eq. Qed. - -Lemma IntroArg_eq_Just_const n A (x y : A) (goal : Prop) - : IntroArg n (x = y) (fun _ => goal) -> - IntroArg n (SAWCorePrelude.Just _ x = SAWCorePrelude.Just _ y) (fun _ => goal). -Proof. intros H eq; apply H; injection eq; eauto. Qed. -Lemma IntroArg_eq_Just_Nothing n A (x : A) goal - : IntroArg n (SAWCorePrelude.Just _ x = SAWCorePrelude.Nothing _) goal. -Proof. intros eq; discriminate eq. Qed. -Lemma IntroArg_eq_Nothing_Just n A (y : A) goal - : IntroArg n (SAWCorePrelude.Nothing _ = SAWCorePrelude.Just _ y) goal. -Proof. intros eq; discriminate eq. Qed. - -(* Hint Resolve IntroArg_and IntroArg_or IntroArg_sigT IntroArg_prod IntroArg_sum *) -(* IntroArg_unit IntroArg_eq_sigT_const IntroArg_eq_prod_const *) -(* IntroArg_eq_Left_const IntroArg_eq_Right_const *) -(* IntroArg_eq_Left_Right IntroArg_eq_Right_Left *) -(* IntroArg_eq_Just_const IntroArg_eq_Just_Nothing_const *) -(* IntroArg_eq_Nothing_Just_const | 1 : refinesFun. *) - -Ltac IntroArg_intro_dependent_destruction n := - let e := argName n in - IntroArg_intro e; dependent destruction e. - -(* Hint Extern 1 (IntroArg ?n (eq (SAWCorePrelude.Nothing _) (SAWCorePrelude.Nothing _)) _) => *) -(* IntroArg_forget : refinesFun. *) -(* Hint Extern 1 (IntroArg ?n (eq true true) _) => *) -(* IntroArg_intro_dependent_destruction n : refinesFun. *) -(* Hint Extern 1 (IntroArg ?n (eq false false) _) => *) -(* IntroArg_intro_dependent_destruction n : refinesFun. *) -(* Hint Extern 1 (IntroArg ?n (eq true false) _) => *) -(* IntroArg_intro_dependent_destruction n : refinesFun. *) -(* Hint Extern 1 (IntroArg ?n (eq false true) _) => *) -(* IntroArg_intro_dependent_destruction n : refinesFun. *) -(* Hint Extern 1 (IntroArg ?n (@eq unit _ _) _) => *) -(* IntroArg_forget : refinesFun. *) - -Ltac IntroArg_base_tac n A g := - lazymatch A with - | _ /\ _ => simple apply IntroArg_and - | _ \/ _ => simple apply IntroArg_or - (* | { _ : _ & _ } => simple apply IntroArg_sigT *) - (* | prod _ _ => simple apply IntroArg_prod *) - | sum _ _ => simple apply IntroArg_sum - | unit => simple apply IntroArg_unit - | existT _ _ _ = existT _ _ _ => simple apply IntroArg_eq_sigT_const - | pair _ _ = pair _ _ => simple apply IntroArg_eq_prod_const - | SAWCorePrelude.Left _ _ _ = SAWCorePrelude.Left _ _ _ => simple apply IntroArg_eq_Left_const - | SAWCorePrelude.Right _ _ _ = SAWCorePrelude.Right _ _ _ => simple apply IntroArg_eq_Right_const - | SAWCorePrelude.Left _ _ _ = SAWCorePrelude.Right _ _ _ => simple apply IntroArg_eq_Left_Right - | SAWCorePrelude.Right _ _ _ = SAWCorePrelude.Left _ _ _ => simple apply IntroArg_eq_Right_Left - | SAWCorePrelude.Just _ _ = SAWCorePrelude.Just _ _ => simple apply IntroArg_eq_Just_const - | SAWCorePrelude.Just _ _ = SAWCorePrelude.Nothing _ => simple apply IntroArg_eq_Just_Nothing - | SAWCorePrelude.Nothing _ = SAWCorePrelude.Just _ _ => simple apply IntroArg_eq_Nothing_Just - | SAWCorePrelude.Nothing _ = SAWCorePrelude.Nothing _ => IntroArg_forget - | true = true => IntroArg_intro_dependent_destruction n - | false = false => IntroArg_intro_dependent_destruction n - | true = false => IntroArg_intro_dependent_destruction n - | false = true => IntroArg_intro_dependent_destruction n - | @eq unit _ _ => IntroArg_forget - end. - -Hint Extern 1 (IntroArg ?n ?A ?g) => IntroArg_base_tac n A g : refinesFun. - -Ltac IntroArg_rewrite_bool_eq n := - let e := fresh in - IntroArg_intro e; repeat rewrite e in *; - apply (IntroArg_fold n _ _ e); clear e. - -Hint Extern 2 (IntroArg ?n (@eq bool _ _) _) => - progress (IntroArg_rewrite_bool_eq n) : refinesFun. - -Hint Extern 4 (IntroArg SAWLet _ _) => - let e := argName SAWLet in IntroArg_intro e : refinesFun. -Hint Extern 5 (IntroArg ?n (?x = ?y) _) => - let e := argName n in IntroArg_intro e; -try first [ is_var x; subst x | is_var y; subst y ] : refinesFun. -Hint Extern 6 (IntroArg ?n _ _) => - let e := argName n in IntroArg_intro e : refinesFun. - -Definition refinesM_sawLet_const_l {A B} (x : A) (m : CompM B) P : - m |= P -> sawLet_def _ _ x (fun _ => m) |= P := fun pf => pf. -Definition refinesM_sawLet_const_r {A B} (x : A) (m : CompM B) P : - P |= m -> P |= sawLet_def _ _ x (fun _ => m) := fun pf => pf. - -Definition refinesM_sawLet_bv_l_IntroArg {w B} x (m : bitvector w -> CompM B) P : - (FreshIntroArg Any _ (fun a => - FreshIntroArg SAWLet (a = x) (fun _ => m a |= P))) -> - sawLet_def _ _ x m |= P. -Proof. do 3 intro; eapply H; eauto. Qed. -Definition refinesM_sawLet_bv_r_IntroArg {w B} x (m : bitvector w -> CompM B) P : - (FreshIntroArg Any _ (fun a => - FreshIntroArg SAWLet (a = x) (fun _ => P |= m a))) -> - P |= sawLet_def _ _ x m. -Proof. do 3 intro; eapply H; eauto. Qed. - -Definition refinesM_sawLet_unfold_l {A B} (x : A) (m : A -> CompM B) P : - m x |= P -> sawLet_def _ _ x m |= P := fun pf => pf. -Definition refinesM_sawLet_unfold_r {A B} (x : A) (m : A -> CompM B) P : - P |= m x -> P |= sawLet_def _ _ x m := fun pf => pf. - -Ltac refinesM_sawLet_l := - first [ simple apply refinesM_sawLet_const_l - | simple apply refinesM_sawLet_bv_l_IntroArg - | simple apply refinesM_sawLet_unfold_l ]. -Ltac refinesM_sawLet_r := - first [ simple apply refinesM_sawLet_const_r - | simple apply refinesM_sawLet_bv_r_IntroArg - | simple apply refinesM_sawLet_unfold_r ]. - -Hint Extern 1 (sawLet_def _ _ _ _ |= _) => refinesM_sawLet_l : refinesM. -Hint Extern 1 (_ |= sawLet_def _ _ _ _ ) => refinesM_sawLet_r : refinesM. - -Definition refinesM_either_l_IntroArg {A B C} (f:A -> CompM C) (g:B -> CompM C) eith P : - (FreshIntroArg Any _ (fun a => - FreshIntroArg Either (eith = SAWCorePrelude.Left _ _ a) (fun _ => f a |= P))) -> - (FreshIntroArg Any _ (fun b => - FreshIntroArg Either (eith = SAWCorePrelude.Right _ _ b) (fun _ => g b |= P))) -> - SAWCorePrelude.either _ _ _ f g eith |= P := refinesM_either_l f g eith P. -Definition refinesM_either_r_IntroArg {A B C} (f:A -> CompM C) (g:B -> CompM C) eith P : - (FreshIntroArg Any _ (fun a => - FreshIntroArg Either (eith = SAWCorePrelude.Left _ _ a) (fun _ => P |= f a))) -> - (FreshIntroArg Any _ (fun b => - FreshIntroArg Either (eith = SAWCorePrelude.Right _ _ b) (fun _ => P |= g b))) -> - P |= SAWCorePrelude.either _ _ _ f g eith := refinesM_either_r f g eith P. - -Hint Extern 1 (SAWCorePrelude.either _ _ _ _ _ _ |= _) => - simple apply refinesM_either_l_IntroArg : refinesM. -Hint Extern 1 (_ |= SAWCorePrelude.either _ _ _ _ _ _) => - simple apply refinesM_either_r_IntroArg : refinesM. - - -Definition refinesM_eithers_cons_l_IntroArg - {A B C} (f:A -> CompM C) (g:B -> CompM C) elims eith P : - (FreshIntroArg Any _ (fun a => - FreshIntroArg Either (eith = SAWCorePrelude.Left _ _ a) (fun _ => f a |= P))) -> - (FreshIntroArg Any _ (fun eith' => - FreshIntroArg Either (eith = SAWCorePrelude.Right _ _ eith') - (fun _ => SAWCorePrelude.eithers _ (SAWCorePrelude.FunsTo_Cons _ _ g elims) eith' |= P))) -> - SAWCorePrelude.eithers - (CompM C) - (SAWCorePrelude.FunsTo_Cons _ _ f (SAWCorePrelude.FunsTo_Cons _ _ g elims)) - eith - |= P := - refinesM_eithers_cons_l f g elims eith P. - -Definition refinesM_eithers_cons_r_IntroArg - {A B C} (f:A -> CompM C) (g:B -> CompM C) elims eith P : - (FreshIntroArg Any _ (fun a => - FreshIntroArg Either (eith = SAWCorePrelude.Left _ _ a) (fun _ => P |= f a))) -> - (FreshIntroArg Any _ (fun eith' => - FreshIntroArg Either (eith = SAWCorePrelude.Right _ _ eith') - (fun _ => P |= SAWCorePrelude.eithers _ (SAWCorePrelude.FunsTo_Cons _ _ g elims) eith'))) -> - P |= - SAWCorePrelude.eithers - (CompM C) - (SAWCorePrelude.FunsTo_Cons _ _ f (SAWCorePrelude.FunsTo_Cons _ _ g elims)) - eith := - refinesM_eithers_cons_r f g elims eith P. - -Hint Extern 1 (SAWCorePrelude.eithers _ (SAWCorePrelude.FunsTo_Nil _) _ |= _) => - simple apply refinesM_eithers_nil_l : refinesM. -Hint Extern 1 (_ |= SAWCorePrelude.eithers _ (SAWCorePrelude.FunsTo_Nil _) _) => - simple apply refinesM_eithers_nil_r : refinesM. -Hint Extern 1 (SAWCorePrelude.eithers - _ (SAWCorePrelude.FunsTo_Cons - _ _ _ (SAWCorePrelude.FunsTo_Nil _)) _ |= _) => - simple apply refinesM_eithers_one_l : refinesM. -Hint Extern 1 (_ |= SAWCorePrelude.eithers - _ (SAWCorePrelude.FunsTo_Cons - _ _ _ (SAWCorePrelude.FunsTo_Nil _)) _) => - simple apply refinesM_eithers_one_r : refinesM. -Hint Extern 3 (SAWCorePrelude.eithers - _ (SAWCorePrelude.FunsTo_Cons - _ _ _ (SAWCorePrelude.FunsTo_Cons - _ _ _ (SAWCorePrelude.FunsTo_Nil _))) _ |= _) => - simple apply refinesM_eithers_cons_l_IntroArg : refinesM. -Hint Extern 3 (_ |= SAWCorePrelude.eithers - _ (SAWCorePrelude.FunsTo_Cons - _ _ _ (SAWCorePrelude.FunsTo_Cons - _ _ _ (SAWCorePrelude.FunsTo_Nil _))) _) => - simple apply refinesM_eithers_cons_r_IntroArg : refinesM. - - -Definition refinesM_maybe_l_IntroArg {A B} (x : CompM B) (f : A -> CompM B) mb P : - (FreshIntroArg Maybe (mb = SAWCorePrelude.Nothing _) (fun _ => x |= P)) -> - (FreshIntroArg Any _ (fun a => - FreshIntroArg Maybe (mb = SAWCorePrelude.Just _ a) (fun _ => f a |= P))) -> - SAWCorePrelude.maybe _ _ x f mb |= P := refinesM_maybe_l x f mb P. -Definition refinesM_maybe_r_IntroArg {A B} (x : CompM B) (f : A -> CompM B) mb P : - (FreshIntroArg Maybe (mb = SAWCorePrelude.Nothing _) (fun _ => P |= x)) -> - (FreshIntroArg Any _ (fun a => - FreshIntroArg Maybe (mb = SAWCorePrelude.Just _ a) (fun _ => P |= f a))) -> - P |= SAWCorePrelude.maybe _ _ x f mb := refinesM_maybe_r x f mb P. - -Hint Extern 2 (SAWCorePrelude.maybe _ _ _ _ _ |= _) => - simple apply refinesM_maybe_l_IntroArg : refinesM. -Hint Extern 2 (_ |= SAWCorePrelude.maybe _ _ _ _ _) => - simple apply refinesM_maybe_r_IntroArg : refinesM. - -Definition refinesM_sigT_rect_l_IntroArg {A1 A2 B} F P (s: {x:A1 & A2 x}) : - (FreshIntroArg Any _ (fun a1 => FreshIntroArg Any _ (fun a2 => - FreshIntroArg SigT (s = existT _ a1 a2) (fun _ => F a1 a2 |= P)))) -> - sigT_rect (fun _ => CompM B) F s |= P := refinesM_sigT_rect_l F P s. - -Definition refinesM_sigT_rect_r_IntroArg {A1 A2 B} F P (s: {x:A1 & A2 x}) : - (FreshIntroArg Any _ (fun a1 => FreshIntroArg Any _ (fun a2 => - FreshIntroArg SigT (s = existT _ a1 a2) (fun _ => P |= F a1 a2)))) -> - P |= sigT_rect (fun _ => CompM B) F s := refinesM_sigT_rect_r F P s. - -Hint Extern 2 (sigT_rect (fun _ => CompM _) _ _ |= _) => - simple apply refinesM_sigT_rect_l_IntroArg : refinesM. -Hint Extern 2 (_ |= sigT_rect (fun _ => CompM _) _ _) => - simple apply refinesM_sigT_rect_r_IntroArg : refinesM. - -Definition refinesM_if_l_IntroArg {A} (m1 m2:CompM A) b P : - (FreshIntroArg If (b = true) (fun _ => m1 |= P)) -> - (FreshIntroArg If (b = false) (fun _ => m2 |= P)) -> - (if b then m1 else m2) |= P := refinesM_if_l m1 m2 b P. -Definition refinesM_if_r_IntroArg {A} (m1 m2:CompM A) b P : - (FreshIntroArg If (b = true) (fun _ => P |= m1)) -> - (FreshIntroArg If (b = false) (fun _ => P |= m2)) -> - P |= (if b then m1 else m2) := refinesM_if_r m1 m2 b P. - -Hint Extern 2 ((if _ then _ else _) |= _) => - apply refinesM_if_l_IntroArg : refinesM. -Hint Extern 2 (_ |= (if _ then _ else _)) => - apply refinesM_if_r_IntroArg : refinesM. - -Hint Extern 1 (returnM (if _ then _ else _) |= _) => - simple apply refinesM_returnM_if_l : refinesM. -Hint Extern 1 (_ |= returnM (if _ then _ else _)) => - simple apply refinesM_returnM_if_r : refinesM. - -Definition refinesM_bindM_assertM_l_IntroArg {A} (P:Prop) (m1 m2: CompM A) : - (FreshIntroArg Assert P (fun _ => m1 |= m2)) -> assertM P >> m1 |= m2 := - refinesM_bindM_assertM_l P m1 m2. -Definition refinesM_assumingM_r_IntroArg {A} (P:Prop) (m1 m2: CompM A) : - (FreshIntroArg Assuming P (fun _ => m1 |= m2)) -> m1 |= assumingM P m2 := - refinesM_assumingM_r P m1 m2. - -Hint Extern 1 (assertM _ >> _ |= _) => - simple eapply refinesM_bindM_assertM_l_IntroArg : refinesM. -Hint Extern 1 (_ |= assumingM _ _) => - simple eapply refinesM_assumingM_r_IntroArg : refinesM. - -Hint Extern 3 (_ |= assertM _ >> _) => - simple eapply refinesM_bindM_assertM_r; shelve : refinesM. -Hint Extern 3 (assumingM _ _ |= _) => - simple eapply refinesM_assumingM_l; shelve : refinesM. - -Definition refinesM_existsM_l_IntroArg A B (P: A -> CompM B) Q : - (FreshIntroArg Exists _ (fun a => P a |= Q)) -> existsM P |= Q := - refinesM_existsM_l A B P Q. -Definition refinesM_forallM_r_IntroArg {A B} P (Q: A -> CompM B) : - (FreshIntroArg Forall _ (fun a => P |= (Q a))) -> P |= (forallM Q) := - refinesM_forallM_r P Q. - -Hint Extern 3 (existsM _ |= _) => - simple apply refinesM_existsM_l_IntroArg : refinesM. -Hint Extern 3 (_ |= forallM _) => - simple apply refinesM_forallM_r_IntroArg : refinesM. - -Hint Extern 4 (_ |= existsM _) => - simple eapply refinesM_existsM_r; shelve : refinesM. -Hint Extern 4 (forallM _ |= _) => - simple eapply refinesM_forallM_l; shelve : refinesM. - -Hint Extern 4 (returnM _ |= returnM _) => - apply refinesM_returnM; (reflexivity || shelve) : refinesM. - -Hint Extern 2 (orM _ _ |= _) => simple apply refinesM_orM_l : refinesM. -Hint Extern 2 (_ |= andM _ _) => simple apply refinesM_andM_r : refinesM. -(* Note: For the moment, we don't automatically apply refinesM_orM_r or - refinesM_andM_l - use continue_prove_refinement_left and - continue_prove_refinement_right. *) - -Lemma refinesM_returnM_bindM_l A B (a:A) (f:A -> CompM B) P : - f a |= P -> returnM a >>= f |= P. -Proof. rewrite returnM_bindM; eauto. Qed. -Lemma refinesM_returnM_bindM_r A B P (a:A) (f:A -> CompM B) : - P |= f a -> P |= returnM a >>= f. -Proof. rewrite returnM_bindM; eauto. Qed. - -Hint Extern 1 ((returnM _ >>= _) |= _) => simple apply refinesM_returnM_bindM_l : refinesM. -Hint Extern 1 (_ |= (returnM _ >>= _)) => simple apply refinesM_returnM_bindM_r : refinesM. - -Lemma refinesM_existsM_bindM_l A B C (P: A -> CompM B) (Q: B -> CompM C) R : - existsM (fun x => P x >>= Q) |= R -> (existsM P) >>= Q |= R. -Proof. rewrite existsM_bindM; eauto. Qed. -Lemma refinesM_existsM_bindM_r A B C P (Q: A -> CompM B) (R: B -> CompM C) : - P |= existsM (fun x => Q x >>= R) -> P |= (existsM Q) >>= R. -Proof. rewrite existsM_bindM; eauto. Qed. - -Hint Extern 1 ((existsM _ >>= _) |= _) => simple apply refinesM_existsM_bindM_l : refinesM. -Hint Extern 1 (_ |= (existsM _ >>= _)) => simple apply refinesM_existsM_bindM_r : refinesM. - -Lemma refinesM_orM_bindM_l A B (m1 m2 : CompM A) (P : A -> CompM B) Q : - orM (m1 >>= P) (m2 >>= P) |= Q -> (orM m1 m2) >>= P |= Q. -Proof. rewrite orM_bindM; eauto. Qed. -Lemma refinesM_orM_bindM_r A B P (m1 m2 : CompM A) (Q : A -> CompM B) : - P |= orM (m1 >>= Q) (m2 >>= Q) -> P |= (orM m1 m2) >>= Q. -Proof. rewrite orM_bindM; eauto. Qed. - -Hint Extern 1 ((orM _ _ >>= _) |= _) => simple apply refinesM_orM_bindM_l : refinesM. -Hint Extern 1 (_ |= (orM _ _ >>= _)) => simple apply refinesM_orM_bindM_r : refinesM. - -Lemma refinesM_errorM_bindM_l A B str (f:A -> CompM B) P : - errorM str |= P -> errorM str >>= f |= P. -Proof. rewrite errorM_bindM; eauto. Qed. -Lemma refinesM_errorM_bindM_r A B P str (f:A -> CompM B) : - P |= errorM str -> P |= errorM str >>= f. -Proof. rewrite errorM_bindM; eauto. Qed. - -Hint Extern 1 ((errorM _ >>= _) |= _) => simple apply refinesM_errorM_bindM_l : refinesM. -Hint Extern 1 (_ |= (errorM _ >>= _)) => simple apply refinesM_errorM_bindM_r : refinesM. - -Lemma refinesM_bindM_bindM_l A B C (m : CompM A) (f : A -> CompM B) (g : B -> CompM C) P : - m >>= (fun x : A => f x >>= g) |= P -> m >>= f >>= g |= P. -Proof. rewrite bindM_bindM; eauto. Qed. -Lemma refinesM_bindM_bindM_r A B C (m : CompM A) (f : A -> CompM B) (g : B -> CompM C) P : - P |= m >>= (fun x : A => f x >>= g) -> P |= m >>= f >>= g. -Proof. rewrite bindM_bindM; eauto. Qed. - -Hint Extern 1 (((_ >>= _) >>= _) |= _) => simple apply refinesM_bindM_bindM_l : refinesM. -Hint Extern 1 (_ |= ((_ >>= _) >>= _)) => simple apply refinesM_bindM_bindM_r : refinesM. - -Lemma refinesM_bindM_returnM_l A (m:CompM A) P : - m |= P -> m >>= (fun x => returnM x) |= P. -Proof. rewrite bindM_returnM; eauto. Qed. -Lemma refinesM_bindM_returnM_r A P (m:CompM A) : - P |= m -> P |= m >>= (fun x => returnM x). -Proof. rewrite bindM_returnM; eauto. Qed. - -Hint Extern 1 ((_ >>= (fun _ => returnM _)) |= _) => simple apply refinesM_bindM_returnM_l : refinesM. -Hint Extern 1 (_ |= (_ >>= (fun _ => returnM _))) => simple apply refinesM_bindM_returnM_r : refinesM. - -Lemma bindM_returnM_sigT_unit A (m:CompM {_:A & unit}) u : - m >>= (fun x => returnM (existT (fun _ => unit) (projT1 x) u)) ~= m. -Proof. - assert (forall x u, existT (fun _ => unit) (projT1 x : A) u = x). - { intros [] []; destruct u0; easy. } - setoid_rewrite H. - apply bindM_returnM. -Qed. - -Lemma refinesM_bindM_returnM_sigT_unit_l A (m:CompM {_:A & unit}) P : - m |= P -> m >>= (fun x => returnM (existT (fun _ => unit) (projT1 x) tt)) |= P. -Proof. rewrite bindM_returnM_sigT_unit; eauto. Qed. - -Lemma refinesM_bindM_returnM_sigT_unit_r A P (m:CompM {_:A & unit}) : - P |= m -> P |= m >>= (fun x => returnM (existT (fun _ => unit) (projT1 x) tt)). -Proof. rewrite bindM_returnM_sigT_unit; eauto. Qed. - -Hint Extern 1 ((_ >>= (fun _ => returnM (existT _ (projT1 _) _))) |= _) => - simple apply refinesM_bindM_returnM_sigT_unit_l : refinesM. -Hint Extern 1 (_ |= (_ >>= (fun _ => returnM (existT _ (projT1 _) _)))) => - simple apply refinesM_bindM_returnM_sigT_unit_r : refinesM. - -Lemma refinesM_forallM_bindM_l A B C (P: A -> CompM B) (Q: B -> CompM C) (R : CompM C) : - forallM (fun a => P a >>= Q) |= R -> (forallM P) >>= Q |= R. -Proof. rewrite forallM_bindM; eauto. Qed. -Lemma refinesM_assumingM_bindM_l A B P (m: CompM A) (Q: A -> CompM B) (R : CompM B) : - assumingM P (m >>= Q) |= R -> (assumingM P m) >>= Q |= R. -Proof. rewrite assumingM_bindM; eauto. Qed. - -Hint Extern 1 (((forallM _) >>= _) |= _) => simple apply refinesM_forallM_bindM_l : refinesM. -Hint Extern 1 (((assumingM _ _) >>= _) |= _) => simple apply refinesM_assumingM_bindM_l : refinesM. - -Create HintDb refinement_proofs. -Hint Extern 1 (_ _ >>= _ |= _) => - progress (try (rewrite_strat (outermost (hints refinement_proofs)))) : refinesM. - -Definition DidInduction {A} (a : A) : Type := unit. - -Lemma didInduction {A} (a : A) : DidInduction a. -Proof. exact tt. Qed. - -Tactic Notation "doInduction" tactic(ind) tactic(smp) ident(l) := - lazymatch goal with - | H: DidInduction l |- _ => assumption - | _ => let l' := fresh l in - ind l l'; try pose proof (didInduction l'); smp - end. - -Tactic Notation "doDestruction" tactic(dst) tactic(smp) ident(l) := - let l' := fresh l in dst l l'; smp. - -Ltac list_destruct l l' := destruct l as [| ? l']. -Ltac list_induction l l' := induction l as [| ? l']. -Ltac list_simpl := simpl SAWCorePrelude.unfoldList in *; simpl list_rect in *. - -Hint Extern 2 (IntroArg ?n (eq (SAWCorePrelude.unfoldList _ ?l) - (SAWCorePrelude.Left _ _ _)) _) => - doDestruction (list_destruct) (list_simpl) l : refinesFun. -Hint Extern 2 (IntroArg ?n (eq (SAWCorePrelude.unfoldList _ ?l) - (SAWCorePrelude.Right _ _ _)) _) => - doDestruction (list_destruct) (list_simpl) l : refinesFun. - -Hint Extern 9 (list_rect _ _ _ ?l |= _) => - doInduction (list_induction) (list_simpl) l : refinesM. -Hint Extern 9 (_ |= list_rect _ _ _ ?l) => - doInduction (list_induction) (list_simpl) l : refinesM. - -(*** - *** Rewriting rules - ***) - -Lemma existT_eta A (B:A -> Type) (s: {a:A & B a}) : - existT B (projT1 s) (projT2 s) = s. -Proof. - destruct s; reflexivity. -Qed. - -Lemma existT_eta_unit A (s: {_:A & unit}) : existT (fun _ => unit) (projT1 s) tt = s. -Proof. - destruct s; destruct u; reflexivity. -Qed. - -Hint Rewrite existT_eta existT_eta_unit : refinesM. - -(* -Lemma function_eta A B (f:A -> B) : pointwise_relation A eq (fun x => f x) f. -Proof. - intro; reflexivity. -Qed. - *) - -(* Specialized versions of monad laws for CompM to make rewriting faster, -probably because Coq doesn't have to search for the instances...? *) - -Definition returnM_bindM_CompM A B (a:A) (f:A -> CompM B) : returnM a >>= f ~= f a := - returnM_bindM (M:=CompM) A B a f. - -Definition bindM_returnM_CompM A (m:CompM A) : m >>= (fun x => returnM x) ~= m := - bindM_returnM (M:=CompM) A m. - -Definition bindM_bindM_CompM A B C (m : CompM A) (f : A -> CompM B) (g : B -> CompM C) : - m >>= f >>= g ~= m >>= (fun x : A => f x >>= g) := - bindM_bindM (M:=CompM) A B C m f g. - -Definition errorM_bindM_CompM A B str (f:A -> CompM B) : errorM str >>= f ~= errorM str := - errorM_bindM (M:=CompM) A B str f. - -Hint Rewrite returnM_bindM_CompM bindM_returnM_CompM bindM_bindM_CompM errorM_bindM_CompM : refinesM. - -(* -FIXME: do we need these rules? - -Lemma bvEq_sym n x y : bvEq n x y = bvEq n y x. - admit. -Admitted. - -From Coq Require Import Nat. - -Lemma bvEq_eqb n x y : bvEq n (bvNat n x) (bvNat n y) = eqb x y. - admit. -Admitted. - *) - - -(*** - *** Automation for proving function refinement - ***) - -Definition StartAutomation (goal : Prop) := goal. - -Lemma StartAutomation_fold goal : StartAutomation goal -> goal. -Proof. easy. Qed. - -Hint Extern 999 (StartAutomation ?A) => unfold StartAutomation : refinesFun. - -(* Create HintDb refinesFun. *) -Hint Extern 999 (_ |= _) => shelve : refinesFun. -Hint Extern 999 (refinesFun _ _) => shelve : refinesFun. - -(* Definition MaybeDestructArg A (a:A) (goal:Prop) : Prop := goal. *) -(* Definition noDestructArg A a (goal:Prop) : goal -> MaybeDestructArg A a goal := fun g => g. *) - -Definition refinesFun_multiFixM_fst' lrt (F:lrtPi (LRT_Cons lrt LRT_Nil) - (lrtTupleType (LRT_Cons lrt LRT_Nil))) f - (ref_f:refinesFun (fst (F f)) f) : - refinesFun (fst (multiFixM F)) f := refinesFun_multiFixM_fst lrt F f ref_f. - -Definition refinesFun_fst lrt B f1 (fs:B) f2 (r:@refinesFun lrt f1 f2) : - refinesFun (fst (f1, fs)) f2 := r. - -Hint Resolve refinesFun_fst | 1 : refinesFun. -Hint Resolve refinesFun_multiFixM_fst' | 1 : refinesFun. -(* Hint Resolve noDestructArg | 5 : refinesFun. *) - -(* (* If a goal contains W64List_rect applied to l, then destruct l *) *) -(* Ltac destructArg_W64List := *) -(* (lazymatch goal with *) -(* | |- MaybeDestructArg ?W64list ?l ?g => *) -(* match g with *) -(* | context [SAWCorePrelude.W64List_rect _ _ _ l] => *) -(* induction l; let IH := get_last_hyp tt in *) -(* try simpl in IH; try unfold MaybeDestructArg in IH; *) -(* simpl; apply noDestructArg *) -(* end *) -(* end). *) -(* Hint Extern 1 (MaybeDestructArg _ _ _) => destructArg_W64List :refinesFun. *) - -(* (* If a goal contains list_rect applied to l, then destruct l *) *) -(* Ltac destructArg_list := *) -(* (lazymatch goal with *) -(* | |- MaybeDestructArg (list _) ?l ?g => *) -(* match g with *) -(* | context [Datatypes.list_rect _ _ _ l] => *) -(* induction l; let IH := get_last_hyp tt in *) -(* try simpl in IH; try unfold MaybeDestructArg in IH; *) -(* simpl; apply noDestructArg *) -(* end *) -(* end). *) -(* Hint Extern 1 (MaybeDestructArg _ _ _) => destructArg_list :refinesFun. *) - -Definition refinesFunBase B m1 m2 (r: m1 |= m2) : @refinesFun (LRT_Ret B) m1 m2 := r. -Definition refinesFunStep A lrtF f1 f2 - (r: IntroArg Any _ (fun a => @refinesFun (lrtF a) (f1 a) (f2 a))) : - @refinesFun (LRT_Fun A lrtF) f1 f2 := r. - -Hint Extern 5 (@refinesFun (LRT_Ret _) _ _) => - simple apply refinesFunBase; unfold_projs : refinesFun. - -Hint Extern 5 (@refinesFun (LRT_Fun _ _) _ _) => - simple apply refinesFunStep : refinesFun. - - -(*** - *** Top-level tactics to put it all together - ***) - -Variant ProveRefOpts := Default | NoRewrite | NoDestructProds | NoRewriteNoDestructProds. - -Ltac prove_refinement_eauto := - unshelve (typeclasses eauto with refinesM refinesFun). -Ltac prove_refinement_destruct_prod_hyps := - split_prod_hyps; unfold_projs in *. -Ltac prove_refinement_rewrite := - try unshelve (rewrite_strat (bottomup (hints refinesM))). -Ltac prove_refinement_try_solve := - split_prod_goal; - try reflexivity || contradiction. - -Tactic Notation "prove_refinement_core" "with" constr(opts) := - prove_refinement_eauto; - match opts with - | Default => prove_refinement_destruct_prod_hyps; prove_refinement_rewrite - | NoRewrite => prove_refinement_destruct_prod_hyps - | NoDestructProds => prove_refinement_rewrite - | NoRewriteNoDestructProds => idtac - end; - prove_refinement_try_solve. - -Ltac prove_refinement_core := prove_refinement_core with Default. - -(* Automatically prove refinements of the form `refinesFun F G` or of the - form` P |= Q`, where P,Q may contain matching calls to `letRecM`. *) - -Tactic Notation "prove_refinement" "with" constr(opts) := - unfold_projs; - apply StartAutomation_fold; - prove_refinement_core with opts. - -Ltac prove_refinement := prove_refinement with Default. - -(* After a call to `prove_refinement`, give user input as to whether to continue - proof automation in the left or right branch of an `orM`/`andM`. *) - -Tactic Notation "continue_prove_refinement_lr" tactic(tac) "with" constr(opts) := - match goal with - | |- _ |= orM _ _ => apply refinesM_orM_r; tac; prove_refinement_core with opts - | |- andM _ _ |= _ => apply refinesM_andM_l; tac; prove_refinement_core with opts - end. - -Tactic Notation "continue_prove_refinement_left" "with" constr(opts) := - continue_prove_refinement_lr (left) with opts. -Tactic Notation "continue_prove_refinement_right" "with" constr(opts) := - continue_prove_refinement_lr (right) with opts. - -Ltac continue_prove_refinement_left := continue_prove_refinement_left with Default. -Ltac continue_prove_refinement_right := continue_prove_refinement_right with Default. - -(* For refinements of the form `refinesFun F G` or `P |= Q` where a subexpression - on the left has a call to `letRecM` which does not match one on the right, - this tactic tries to prove the refinement by transitivity, where the new - middle expression has a `letRecM` which matches the one on the left as per - `refinesM_letRecM_match_r`. After giving values for each of the needed - functions, call `prove_refinement` to continue automation. *) - -Ltac prove_refinement_match_letRecM_l := - prove_refinement_eauto; - unshelve (eapply refinesM_letRecM_match_r); - [ unfold lrtTupleType, lrtToType; repeat split | apply ProperLRTFun_any | ]. - -(* It's important for the tactic above that `letRecM` is opaque! Otherwise - `eauto` will unfold it too soon. *) -Hint Opaque letRecM : refinesM refinesFun. - -(* Ltac prove_refinesFun := unshelve (typeclasses eauto with refinesFun). *) - -(* -Ltac rewrite_refinesM := - try ((rewrite returnM_bindM || rewrite bindM_returnM || rewrite bindM_bindM || - rewrite errorM_bindM || rewrite existsM_bindM); rewrite_refinesM). - *) - - -(*** FIXME: old stuff below ***) - -Ltac old_prove_refinesM := - lazymatch goal with - (* Bind cases *) - | |- (returnM _ >>= _) |= _ => rewrite returnM_bindM; old_prove_refinesM - | |- _ |= (returnM _ >>= _) => rewrite returnM_bindM; old_prove_refinesM - | |- (existsM _ >>= _) |= _ => rewrite existsM_bindM; old_prove_refinesM - | |- _ |= (existsM _ >>= _) => rewrite existsM_bindM; old_prove_refinesM - | |- (errorM >>= _) |= _ => rewrite errorM_bindM; old_prove_refinesM - | |- _ |= (errorM >>= _) => rewrite errorM_bindM; old_prove_refinesM - | |- ((_ >>= _) >>= _) |= _ => rewrite bindM_bindM; old_prove_refinesM - | |- _ |= ((_ >>= _) >>= _) => rewrite bindM_bindM; old_prove_refinesM - - (* letRecM cases *) - | |- letRecM tt _ |= _ => apply refinesM_letRecM_Nil_l; old_prove_refinesM - - (* either *) - | |- SAWCorePrelude.either _ _ _ _ _ _ |= _ => - apply refinesM_either_l; intros; old_prove_refinesM - | |- _ |= SAWCorePrelude.either _ _ _ _ _ _ => - apply refinesM_either_r; intros; old_prove_refinesM - | |- sigT_rect _ _ _ |= _ => - - (* sigT_rect *) - apply refinesM_sigT_rect_l; intros; old_prove_refinesM - | |- _ |= sigT_rect _ _ _ => - apply refinesM_sigT_rect_r; intros; old_prove_refinesM - - (* if *) - | |- (if _ then _ else _) |= _ => - apply refinesM_if_l; intros; old_prove_refinesM - | |- _ |= (if _ then _ else _) => - apply refinesM_if_r; intros; old_prove_refinesM - - (* quantifiers *) - | |- existsM _ |= _ => apply refinesM_existsM_l; intros; old_prove_refinesM - | |- _ |= forallM _ => apply refinesM_forallM_r; intros; old_prove_refinesM - | |- _ |= existsM _ => eapply refinesM_existsM_r; old_prove_refinesM - | |- forallM _ |= _ => eapply refinesM_forallM_l; old_prove_refinesM - | |- returnM _ |= returnM _ => apply refinesM_returnM; intros; try reflexivity - - (* default: give up! *) - | _ => idtac (* try (progress (autorewrite with refinesM) ; old_prove_refinesM) *) - end. - -Ltac old_prove_refinesFun := - apply refinesFun_multiFixM_fst; simpl; intros; old_prove_refinesM. - - -Module CompMExtraNotation. - Declare Scope fun_syntax. - - - Infix "&&" := andb : fun_syntax. - Infix "<=" := (SAWCoreVectorsAsCoqVectors.bvsle _) : fun_syntax. - Notation " a

    f) m) (at level 100) : fun_syntax. - Notation "'If' m 'Then' f 'Else' default " := (SAWCorePrelude.maybe _ _ default (fun _ => f) m) (at level 99) : fun_syntax. - Notation "v [ ix <- elem ]" := (SAWCorePrelude.updBVVec _ _ _ v ix elem) (at level 100) : fun_syntax. - Infix "+" := (SAWCoreVectorsAsCoqVectors.bvAdd _) : fun_syntax. - Notation "'Forall' x : T , f" := (LRT_Fun T (fun x => f)) (at level 100, format " 'Forall' x : T , '/ ' f") : fun_syntax. - Notation "T ->> f" := (LRT_Fun T (fun _ => f)) (at level 99, right associativity, format "T '/' ->> '/' f") : fun_syntax. - Notation "x" := (LRT_Ret x) (at level 99, only printing) : fun_syntax. - Notation "'Vector' T len":= (SAWCorePrelude.BVVec _ len T) (at level 98) : fun_syntax. - Notation "[[ x1 ]]":= ((LRT_Cons x1 LRT_Nil )) (at level 7, format "[[ '[' x1 ']' ]]") : fun_syntax. - Notation "[[ x1 ; x2 ; .. ; xn ]]":= ((LRT_Cons x1 (LRT_Cons x2 .. (LRT_Cons xn LRT_Nil) .. ))) - (at level 7, format "[[ '[' x1 ; '/' x2 ; '/' .. ; '/' xn ']' ]]") : fun_syntax. - Notation "[ x1 ]__lrt":= (lrtTupleType (LRT_Cons x1 LRT_Nil )) (at level 7, format "[ '[' x1 ']' ]__lrt") : fun_syntax. - Notation "[ x1 ; x2 ; .. ; xn ]__lrt":= (lrtTupleType (LRT_Cons x1 (LRT_Cons x2 .. (LRT_Cons xn LRT_Nil) .. ))) - (at level 7, format "[ '[' x1 ; '/' x2 ; '/' .. ; '/' xn ']' ]__lrt") : fun_syntax. - Notation "'int64'" := (SAWCoreVectorsAsCoqVectors.bitvector 64) (at level 97) : fun_syntax. - Notation "'int32'" := (SAWCoreVectorsAsCoqVectors.bitvector 32) (at level 97) : fun_syntax. - Notation "'bool'" := (SAWCoreVectorsAsCoqVectors.bitvector 1) (at level 97) : fun_syntax. - Notation "[ x ]__ty" := (lrtToType x) (only printing) : fun_syntax. - Notation "'LetRec' x := f 'InBody' ( body )" := - (letRecM _ (fun x => f) (fun x => body)) - (at level 0, only printing, - format "'[ ' 'LetRec' x := '//' '[' f ']' '//' 'InBody' '/' ( '[' body ']' ) ']'") : fun_syntax. - (* Visualy simplifies trivial `letRecM`*) - Notation "x" := (letRecM LRT_Nil tt x) - (at level 99, only printing) : fun_syntax. - (* Notation "[Functions: f1 := f1_body ]" := - (multiFixM (fun f1 => (f1_body, tt))) - (at level 100, only printing, format "[Functions: '//' f1 := '[' f1_body ']' ]") : fun_syntax. - Notation "[Functions: f1 := f1_body f2 := f2_body ]" := - (multiFixM (fun f1 f2 => (f1_body, f2_body, tt))) - (at level 100, only printing, - format "[Functions: '//' f1 := '[' f1_body ']' '//' f2 := '[' f2_body ']' ]") : fun_syntax. - *) - Delimit Scope fun_syntax with sytx. - -End CompMExtraNotation. diff --git a/saw-core-coq/coq/handwritten/CryptolToCoq/CompM_ITrees.v b/saw-core-coq/coq/handwritten/CryptolToCoq/CompM_ITrees.v deleted file mode 100644 index 8ea1b4761d..0000000000 --- a/saw-core-coq/coq/handwritten/CryptolToCoq/CompM_ITrees.v +++ /dev/null @@ -1,834 +0,0 @@ -(*** - *** A version of the computation monad using the option-set monad - ***) - -From Coq Require Export Morphisms Setoid Program.Equality. -From ITree Require Export ITree ITreeFacts. -From Paco Require Import paco. - -Infix ">>=" := ITree.bind (at level 58, left associativity). -Notation "m1 >> m2" := (m1 >>= fun _ => m2) (at level 58, left associativity). - - -(** * `itree_spec` **) - -Variant SpecEvent (E:Type -> Type) (A:Type) : Type := -| Spec_vis : E A -> SpecEvent E A -| Spec_forall : SpecEvent E A -| Spec_exists : SpecEvent E A -. - -Arguments Spec_vis {E A}. -Arguments Spec_forall {E A}. -Arguments Spec_exists {E A}. - -(* An ITree that defines a set of ITrees *) -Notation itree_spec E := (itree (SpecEvent E)). - -(* The body of an itree_spec, inside the observe projection *) -Notation itree_spec' E A := (itree' (SpecEvent E) A). - - -(** * `satisfies` **) - -Inductive satisfiesF {E A} (satisfies : itree_spec E A -> itree E A -> Prop) - : itree_spec' E A -> itree' E A -> Prop := -| Satisfies_Ret a : satisfiesF satisfies (RetF a) (RetF a) -| Satisfies_Tau spec tree : - satisfies spec tree -> - satisfiesF satisfies (TauF spec) (TauF tree) -| Satisfies_TauL spec tree : - satisfiesF satisfies (observe spec) tree -> - satisfiesF satisfies (TauF spec) tree -| Satisfies_TauR spec tree : - satisfiesF satisfies spec (observe tree) -> - satisfiesF satisfies spec (TauF tree) -| Satisfies_Vis X (e:E X) spec tree : - (forall x, satisfies (spec x) (tree x)) -> - satisfiesF satisfies (VisF (Spec_vis e) spec) (VisF e tree) -| Satisfies_Forall X spec tree : - (forall x:X, satisfies (spec x) tree) -> - satisfiesF satisfies (VisF Spec_forall spec) (observe tree) -| Satisfies_Exists X spec tree : - (exists x:X, satisfies (spec x) tree) -> - satisfiesF satisfies (VisF Spec_exists spec) (observe tree) -. - -Hint Constructors satisfiesF : core. - -Instance Proper_satisfies_satisfiesF {E A} : - Proper (pointwise_relation _ (pointwise_relation _ Basics.impl) ==> - eq ==> eq ==> Basics.impl) (@satisfiesF E A). -Proof. - intros R1 R2 implR spec1 spec2 e_spec tree1 tree2 e_tree sats. - rewrite <- e_spec; rewrite <- e_tree. - clear e_spec spec2 e_tree tree2. - induction sats; constructor; intros; try (apply implR; apply H); try assumption. - destruct H as [ x H ]. exists x. apply implR; assumption. -Qed. - -Lemma satisfiesF_mono {E A} (sats1 sats2:itree_spec E A -> itree E A -> Prop) - (sub_sats:forall spec tree, sats1 spec tree -> sats2 spec tree) : - forall spec tree, - satisfiesF sats1 spec tree -> satisfiesF sats2 spec tree. -Proof. - intros. - apply (Proper_satisfies_satisfiesF sats1 sats2 sub_sats _ _ eq_refl _ _ eq_refl H). -Qed. - -Definition satisfies_ {E A} satisfies spec tree := - @satisfiesF E A satisfies (observe spec) (observe tree). - -Lemma satisfies__mono E A : monotone2 (@satisfies_ E A). -Proof. - intros spec tree r1 r2 sats sub12. unfold satisfies_. - induction sats; constructor; try assumption. - { apply sub12; assumption. } - { intros; apply sub12. apply H. } - { intros; apply sub12. apply H. } - { destruct H as [ x H ]. exists x. apply sub12. apply H. } -Qed. - -Hint Resolve satisfies__mono : paco. - -Definition satisfies {E A} spec tree := paco2 (@satisfies_ E A) bot2 spec tree. - -Instance Proper_observing_paco2_satisfies_impl E A r : - Proper (observing eq ==> observing eq ==> iff) (paco2 (@satisfies_ E A) r). -Proof. - intros spec1 spec2 [ Rspec ] tree1 tree2 [ Rtree ]. - split; intro; punfold H; pfold; unfold satisfies_; - [ rewrite <- Rtree; rewrite <- Rspec | rewrite Rtree; rewrite Rspec ]; - apply H. -Qed. - -Instance Proper_observing_satisfies E A : - Proper (observing eq ==> observing eq ==> iff) (@satisfies E A). -Proof. - apply Proper_observing_paco2_satisfies_impl. -Qed. - - -(** * `satisfies` is proper wrt `eutt` **) - -Ltac simpobs x := apply simpobs in x. - -Ltac weaken_bis Hb := match type of Hb with ?x ≅ ?y => assert (x ≈ y); try (rewrite Hb; reflexivity) end. - -Lemma satisfies_eutt_spec_tau_vis_aux: forall (E : Type -> Type) (A u : Type) (e : SpecEvent E u) - (k1 k2 : u -> itree (SpecEvent E) A), - (forall v : u, paco2 (eqit_ eq true true id) bot2 (k1 v) (k2 v)) -> - forall (r : itree_spec E A -> itree E A -> Prop) (tree0 : itree E A), - (forall (P1 P2 : itree_spec E A) (tree : itree E A), - satisfies P1 tree -> P1 ≈ P2 -> r P2 tree) -> - satisfiesF (upaco2 satisfies_ bot2) (VisF e k1) (observe tree0) -> - satisfiesF (upaco2 satisfies_ r) (VisF e k2) (observe tree0). -Proof. - intros E A u e k1 k2 REL r tree0 CIH H. - dependent induction H. - - rewrite <- x. constructor. eapply IHsatisfiesF; eauto. - - rewrite <- x. constructor. intros. right. - pclearbot. eapply CIH; eauto. apply H. - - rewrite <- x. constructor. right. pclearbot; eapply CIH; eauto. - apply H. - - rewrite <- x. constructor. destruct H as [x' Hx' ]. pclearbot. - exists x'. right. eapply CIH; eauto. -Qed. - -Lemma satisfiesF_TauL: forall (E : Type -> Type) (A : Type) (t1 : itree (SpecEvent E) A) - (tree0 : itree E A), - satisfiesF (upaco2 satisfies_ bot2) (TauF t1) (observe tree0) -> - satisfiesF (upaco2 satisfies_ bot2) (observe t1) (observe tree0). -Proof. - intros E A t1 tree0 H. - dependent induction H; auto. - - pclearbot. rewrite <- x. constructor. punfold H. - - rewrite <- x. constructor. eapply IHsatisfiesF; eauto. -Qed. - -(* Requires coinduction because the forall and exist states *) -Lemma satisfies_TauR: - forall (E : Type -> Type) (A : Type) (P : itree_spec E A) (t : itree E A), - satisfies P (Tau t) -> - satisfies P t. -Proof. - intros E A. pcofix CIH. intros P t HP. - pfold. red. - punfold HP. red in HP. dependent induction HP; pclearbot; auto. - - rewrite <- x. constructor. pstep_reverse. eapply paco2_mon; eauto. - intuition. - - rewrite <- x. constructor. eapply IHHP; eauto. - - pstep_reverse. clear IHHP. eapply paco2_mon with (r := bot2); intuition. - - rewrite <- x0. cbn in x. constructor. right. - eapply CIH; eauto. pfold. red. cbn. rewrite <- x. pstep_reverse. - - rewrite <- x0. constructor. destruct H as [x' Hx']. pclearbot. - exists x'. right. eapply CIH. pfold. red. rewrite <- x. pstep_reverse. -Qed. - -Lemma satisfies_eutt_spec_l E A (P1 P2:itree_spec E A) tree : - satisfies P1 tree -> eutt eq P1 P2 -> satisfies P2 tree. -Proof. - revert P1 P2 tree. pcofix CIH. intros P1 P2 tree HP HP12. - punfold HP. red in HP. pfold. red. punfold HP12. red in HP12. - dependent induction HP. - - rewrite <- x. rewrite <- x0 in HP12. dependent induction HP12; auto. - + rewrite <- x. constructor. - + rewrite <- x. constructor. eapply IHHP12; eauto. - - pclearbot. - remember (observe P2) as oP2. clear HeqoP2 P2. - assert ((exists P2', oP2 = TauF P2') \/ (forall P2', oP2 <> TauF P2') ). - { destruct oP2; eauto; right; repeat intro; discriminate. } - rewrite <- x. rewrite <- x0 in HP12. clear x0 x. - destruct H0 as [ [P2' HP2'] | HP2' ]. - + subst. constructor. right. eapply CIH; eauto. - rewrite <- tau_eutt. setoid_rewrite <- tau_eutt at 3. - pfold. auto. - + inversion HP12; try (exfalso; eapply HP2'; eauto; fail); subst. - clear HP12. punfold H. red in H. - dependent induction REL; intros; subst; - try (exfalso; eapply HP2'; eauto; fail). - * constructor. rewrite <- x in H. - clear CIH HP2' x. dependent induction H; try constructor. - ++ rewrite <- x. constructor. - ++ rewrite <- x. constructor. apply IHsatisfiesF; auto. - * rewrite <- x in H. constructor. pclearbot. - eapply satisfies_eutt_spec_tau_vis_aux; eauto. - * eapply IHREL; auto. rewrite <- x in H. - eapply satisfiesF_TauL; eauto. - - eapply IHHP; eauto. rewrite <- x in HP12. - assert (Tau spec ≈ P2); try (pfold; auto; fail). - rewrite tau_eutt in H. punfold H. - - rewrite <- x. constructor. eapply IHHP; eauto. - - rewrite <- x. rewrite <- x0 in HP12. dependent induction HP12. - + rewrite <- x. constructor. pclearbot. intros. right. eapply CIH; eauto. - apply H. - + rewrite <- x. constructor. eapply IHHP12; eauto. - - rewrite <- x0 in HP12. dependent induction HP12. - + rewrite <- x. constructor. pclearbot. intros. right. eapply CIH; eauto. - pfold. red. rewrite <- x1. - specialize (H x2). punfold H. - + rewrite <- x. constructor. eapply IHHP12; eauto. - - rewrite <- x0 in HP12. rewrite <- x. clear x tree. dependent induction HP12. - + rewrite <- x. constructor. destruct H as [x' Hx']. pclearbot. - exists x'. right. eapply CIH; eauto. - + rewrite <- x. constructor. eapply IHHP12; eauto. -Qed. - -Lemma satisfies_eutt_spec_r E A (P:itree_spec E A) (t1 t2 : itree E A) : - satisfies P t1 -> t1 ≈ t2 -> satisfies P t2. -Proof. - revert P t1 t2. pcofix CIH. intros P t1 t2 HP Ht12. - pfold. red. punfold Ht12. red in Ht12. punfold HP. red in HP. - dependent induction Ht12. - - rewrite <- x. rewrite <- x0 in HP. clear x x0. - dependent induction HP; auto; - try (rewrite <- x; auto). - + rewrite <- x0. pclearbot. constructor. - intros. right. eapply CIH; try apply H. reflexivity. - + rewrite <- x0. constructor. destruct H as [x' Hx']. pclearbot. - exists x'. right. eapply CIH; eauto. reflexivity. - (* Tau Tau case *) - - pclearbot. remember (observe P) as oP. clear HeqoP P. - assert ( (exists P, oP = TauF P) \/ (forall P, oP <> TauF P) ). - { destruct oP; eauto; right; repeat intro; discriminate. } - destruct H as [ [P HoP] | HoP]. - + subst. rewrite <- x. constructor. right. eapply CIH; eauto. - apply satisfies_TauR. pfold. red. apply satisfiesF_TauL. simpl. - rewrite x0. auto. - + rewrite <- x. rewrite <- x0 in HP. - inversion HP; try (exfalso; eapply HoP; eauto; fail). - * subst. clear HP. clear x x0. punfold REL. red in REL. constructor. - dependent induction H1; try (exfalso; eapply HoP; eauto; fail). - ++ rewrite <- x in REL. clear x. dependent induction REL; - try (rewrite <- x; auto). - ++ eapply IHsatisfiesF; auto. pstep_reverse. - assert (m1 ≈ m2); try (pfold; auto; fail). simpobs x. rewrite x in H. - rewrite tau_eutt in H. auto. - ++ rewrite <- x in REL. clear x. dependent induction REL. - ** rewrite <- x; auto. constructor. right. - pclearbot. eapply CIH; eauto. apply H. - ** rewrite <- x. constructor. eapply IHREL; eauto. - ++ pclearbot. constructor. right. eapply CIH; eauto. pfold. red. - rewrite <- x. pstep_reverse. - ++ constructor. destruct H as [x' Hx']. pclearbot. exists x'. right. - eapply CIH; eauto. simpobs x. rewrite <- itree_eta in x. rewrite <- x. - pfold. auto. - * constructor. constructor. right. pclearbot. eapply CIH; eauto. - apply satisfies_TauR. pfold. red. cbn. rewrite <- H. pstep_reverse. - * constructor. constructor. destruct H1 as [x' Hx' ]. pclearbot. - exists x'. right. eapply CIH; eauto. symmetry in H. simpobs H. - rewrite H. rewrite tau_eutt. auto. - - rewrite <- x. rewrite <- x0 in HP. clear x x0. dependent induction HP. - + rewrite <- x. constructor. eapply IHHP; eauto. - + rewrite <- x. constructor. intros. right. - pclearbot. eapply CIH; eauto. apply H. - + rewrite <- x0. pclearbot. - assert (VisF e k2 = observe (Vis e k2) ); auto. rewrite H0. - constructor. intros. right. eapply CIH; try apply H. - symmetry in x. simpobs x. rewrite x. - pfold. red. constructor. auto. - + rewrite <- x0. assert (VisF e k2 = observe (Vis e k2) ); auto. - rewrite H0. constructor. destruct H as [x' Hx']. pclearbot. - exists x'. right. eapply CIH; eauto. symmetry in x. simpobs x. - rewrite x. pfold. constructor. left. auto. - - eapply IHHt12; auto. rewrite <- x in HP. pstep_reverse. - apply satisfies_TauR. pfold. auto. - - rewrite <- x. constructor. - eapply IHHt12; eauto. -Qed. - -Instance proper_eutt_satisfies E R : Proper (@eutt (SpecEvent E) R R eq ==> eutt eq ==> iff) satisfies. -Proof. - intros P Q HPQ t1 t2 Ht12. split; intros. - - eapply satisfies_eutt_spec_r; eauto. eapply satisfies_eutt_spec_l; eauto. - - symmetry in HPQ. symmetry in Ht12. eapply satisfies_eutt_spec_r; eauto. eapply satisfies_eutt_spec_l; eauto. -Qed. - - -(** * `refines` and `refines_eq` **) - -Definition refines {E A} (s1 s2 : itree_spec E A) : Prop := - forall t, satisfies s1 t -> satisfies s2 t. - -Infix "|=" := refines (at level 70, no associativity). - -Instance PreOrder_refines E A : PreOrder (@refines E A). -Proof. - split; repeat intro; eauto. -Qed. - -Instance Proper_observing_refines E A : - Proper (observing eq ==> observing eq ==> iff) (@refines E A). -Proof. - split; repeat intro. - - rewrite <- H0. apply H1. rewrite H. eauto. - - rewrite H0. apply H1. rewrite <- H. eauto. -Qed. - -Instance Proper_eutt_refines E A : - Proper (eutt eq ==> eutt eq ==> iff) (@refines E A). -Proof. - split; repeat intro. - - rewrite <- H0. apply H1. rewrite H. eauto. - - rewrite H0. apply H1. rewrite <- H. eauto. -Qed. - -Definition refines_eq {E A} (s1 s2 : itree_spec E A) := s1 |= s2 /\ s2 |= s1. - -Infix "~=" := refines_eq (at level 70, no associativity). - -Instance Equivalence_refines_eq E A : Equivalence (@refines_eq E A). -Proof. - split; repeat intro. - - split; reflexivity. - - split; destruct H; eauto. - - split; destruct H, H0. - + rewrite H; exact H0. - + rewrite H2; exact H1. -Qed. - -Instance Proper_observing_refines_eq E A : - Proper (observing eq ==> observing eq ==> iff) (@refines_eq E A). -Proof. - split; repeat intro; unfold refines_eq. - - rewrite <- H, <- H0; eauto. - - rewrite H, H0; eauto. -Qed. - -Instance Proper_eutt_refines_eq E A : - Proper (eutt eq ==> eutt eq ==> iff) (@refines_eq E A). -Proof. - split; repeat intro; unfold refines_eq. - - rewrite <- H, <- H0; eauto. - - rewrite H, H0; eauto. -Qed. - -Instance Proper_refines_eq_refines E A : - Proper (refines_eq ==> refines_eq ==> iff) (@refines E A). -Proof. - split; destruct H, H0; intro. - - rewrite H1, <- H0; eauto. - - rewrite H, <- H2; eauto. -Qed. - - -(** * `refinesFun` and `refinesFun_eq` **) - -Definition refinesFun {E A B} := pointwise_relation A (@refines E B). -Hint Unfold refinesFun : core. - -Infix "|=1" := refinesFun (at level 70, no associativity). - -Instance PreOrder_refinesFun E A B : PreOrder (@refinesFun E A B). -Proof. - split; intro. - - intro; reflexivity. - - do 5 intro; transitivity (y a); eauto. -Qed. - -Definition refinesFun_eq {E A B} := pointwise_relation A (@refines_eq E B). -Hint Unfold refinesFun_eq : core. - -Infix "~=1" := refinesFun_eq (at level 70, no associativity). - -Instance Equivalence_refinesFun_eq E A B : Equivalence (@refinesFun_eq E A B). -Proof. - split; intro. - - intro; reflexivity. - - do 3 intro; symmetry; eauto. - - do 5 intro; transitivity (y a); eauto. -Qed. - - -(** * `bind` is proper w.r.t. `refines` **) - -(* The proposition that a is returned by an itree along some path *) -Inductive is_itree_retval' {E A} : itree' E A -> A -> Prop := -| iirv_ret a : is_itree_retval' (RetF a) a -| iirv_tau tree a : - is_itree_retval' (observe tree) a -> is_itree_retval' (TauF tree) a -| iirv_vis {X} (ev:E X) tree a x : - is_itree_retval' (observe (tree x)) a -> - is_itree_retval' (VisF ev tree) a -. - -Definition is_itree_retval {E A} tree a := @is_itree_retval' E A (observe tree) a. - -Instance Proper_observing_is_itree_retval E A : - Proper (observing eq ==> eq ==> iff) (@is_itree_retval E A). -Proof. - intros m1 m2 [ em ] a1 a2 ea. rewrite <- ea. unfold is_itree_retval. - rewrite em. reflexivity. -Qed. - -Lemma bind_satisfies_bind E A B (P:itree_spec E A) (Q:A -> itree_spec E B) - (m:itree E A) (f:A -> itree E B) : - satisfies P m -> - (forall a, is_itree_retval m a -> satisfies (Q a) (f a)) -> - satisfies (P >>= Q) (m >>= f). -Proof. - intro sats; revert P m sats. pcofix CIH. - intros P m sats satsQ; punfold sats. unfold satisfies_ at 1 in sats. - remember (observe P) as obsP eqn: e_obsP. - remember (observe m) as obsm eqn: e_obsm. - revert P m e_obsP e_obsm satsQ. induction sats; intros. - { rewrite <- (observing_intros _ (Ret a) _ e_obsP). - rewrite <- (observing_intros _ (Ret a) _ e_obsm). - repeat rewrite bind_ret_. - eapply paco2_mon_bot; [ apply satsQ | intros; eassumption ]. - rewrite <- (observing_intros _ (Ret a) _ e_obsm). constructor. } - { rewrite <- (observing_intros _ (Tau _) _ e_obsP). - rewrite <- (observing_intros _ (Tau _) _ e_obsm). - repeat rewrite bind_tau_. - pfold. apply Satisfies_Tau. right. pclearbot. apply CIH; [ assumption | ]. - intros a iirv. apply satsQ. - rewrite <- (observing_intros _ (Tau _) _ e_obsm). - constructor. assumption. } - { rewrite <- (observing_intros _ (Tau _) _ e_obsP). rewrite bind_tau_. - pfold. apply Satisfies_TauL. - set (IHapp := IHsats spec m eq_refl e_obsm satsQ). punfold IHapp. } - { rewrite <- (observing_intros _ (Tau _) _ e_obsm). rewrite bind_tau_. - pfold. apply Satisfies_TauR. - assert (paco2 satisfies_ r (P >>= Q) (tree >>= f)) as IHapp; - [ | punfold IHapp ]. - apply IHsats; [ assumption | reflexivity | ]. - intros. apply satsQ. rewrite <- (observing_intros _ (Tau _) _ e_obsm). - constructor. assumption. } - { rewrite <- (observing_intros _ (Vis _ _) _ e_obsP). - rewrite <- (observing_intros _ (Vis _ _) _ e_obsm). - repeat rewrite bind_vis_. pfold. - apply Satisfies_Vis. intro x. right. apply CIH. - - pclearbot. apply H. - - intros. apply satsQ. rewrite <- (observing_intros _ (Vis _ _) _ e_obsm). - econstructor. eassumption. } - { rewrite <- (observing_intros _ (Vis _ _) _ e_obsP). - rewrite <- (observing_intros _ _ _ e_obsm). - rewrite bind_vis_. pfold. apply Satisfies_Forall. intro x. right. apply CIH. - - pclearbot. apply H. - - intros. apply satsQ. - rewrite <- (observing_intros _ _ _ e_obsm). assumption. } - { rewrite <- (observing_intros _ (Vis _ _) _ e_obsP). - rewrite <- (observing_intros _ _ _ e_obsm). - rewrite bind_vis_. pfold. - destruct H as [ x H ]. apply Satisfies_Exists. exists x. right. apply CIH. - - pclearbot. apply H. - - intros. apply satsQ. - rewrite <- (observing_intros _ _ _ e_obsm). assumption. } -Qed. - -Instance Proper_refines_bind {E A B} : - Proper ((pointwise_relation A refines) ==> @refines E A ==> @refines E B) ITree.bind'. -Proof. - repeat intro; unfold pointwise_relation in H; unfold refines in *. - revert x y H y0 H0 t H1. pcofix CIH; intros. - case_eq (observe x0); intros; simpl. - - rewrite (observing_intros eq x0 (Ret r0) H) in H2. - rewrite unfold_bind in H2; simpl in H2. - specialize (H0 _ t H2). - replace t with (Ret r0 >> t) by admit. - (* eapply bind_satisfies_bind. *) - admit. - - admit. - - admit. -Admitted. - -Instance Proper_refines_eq_bind {E A B} : - Proper ((pointwise_relation A refines_eq) ==> @refines_eq E A ==> @refines_eq E B) ITree.bind'. -Proof. - split; apply Proper_refines_bind; eauto. - - intro; destruct (H a); eauto. - - destruct H0; eauto. - - intro; destruct (H a); eauto. - - destruct H0; eauto. -Qed. - - -(** * `mrec` and `refines` **) - -Lemma refines_mrec {D E} (ctx : D ~> itree (D +' SpecEvent E)) - (g : D ~> itree_spec E) : - (forall T d, interp (case_ g ITree.trigger) (ctx T d) |= g T d) -> - (forall T d, mrec ctx d |= g T d). -Proof. - (* Recall: mrec ctx d ≈ interp (case_ (mrec ctx) ITree.trigger) (ctx T d) *) - intros. pcofix CIH. intros. - unfold refines in H. - rewrite mrec_as_interp in H1; unfold mrecursive in H1. -Admitted. - - -(** * `forall` and `exists` specs **) - -Notation forall_spec k := (Vis Spec_forall k). - -Lemma forall_spec_is_forall {E A B} (k : A -> itree_spec E B) t : - satisfies (forall_spec k) t <-> forall a, satisfies (k a) t. -Proof. - split; intros. - - punfold H. red in H. pfold. red. cbn in H. dependent induction H. - + rewrite <- x. constructor. eauto. - + simpobs x. rewrite <- itree_eta in x. pclearbot. pstep_reverse. - rewrite x. auto. - - pfold. red. cbn. constructor. intros. specialize (H x). left. auto. -Qed. - -(* Hey, this now holds in both directions with itrees! *) -Lemma forall_spec_bind {E A B C} (k1 : A -> itree_spec E B) (k2 : B -> itree_spec E C) : - (forall_spec k1) >>= k2 ≈ forall_spec (fun a => (k1 a) >>= k2). -Proof. - rewrite bind_vis. pfold. constructor. - intros; left. apply Reflexive_eqit; eauto. -Qed. - -Lemma refines_forall_spec_r {E A B} P (Q : A -> itree_spec E B) : - (forall a, P |= Q a) -> P |= forall_spec Q. -Proof. - repeat intro. - apply forall_spec_is_forall. - intro; apply H; eauto. -Qed. - -Lemma refines_forall_spec_l {E A B} (P : A -> itree_spec E B) Q a : - P a |= Q -> forall_spec P |= Q. -Proof. - repeat intro. - eapply forall_spec_is_forall in H0. - apply H; eauto. -Qed. - -Notation exists_spec k := (Vis Spec_exists k). - -Lemma exists_spec_is_exists {E A B} (k : A -> itree_spec E B) t : - satisfies (exists_spec k) t <-> exists a, satisfies (k a) t. -Proof. - split; intros. - - punfold H. red in H. cbn in *. dependent induction H; [ simpobs x | idtac ]. - + setoid_rewrite x. setoid_rewrite tau_eutt. eapply IHsatisfiesF; eauto. - + simpobs x. rewrite <- itree_eta in x. setoid_rewrite x. - destruct H; pclearbot; eauto. - - pfold. red. cbn. constructor. - destruct H; exists x; auto. -Qed. - -Lemma exists_spec_bind {E A B C} (k1 : A -> itree_spec E B) (k2 : B -> itree_spec E C) : - (exists_spec k1) >>= k2 ≈ exists_spec (fun a => k1 a >>= k2). -Proof. - rewrite bind_vis. pfold. constructor. - intros; left. apply Reflexive_eqit; eauto. -Qed. - -Lemma refines_exists_spec_r {E A B} P (Q : A -> itree_spec E B) a : - P |= Q a -> P |= exists_spec Q. -Proof. - repeat intro. - apply exists_spec_is_exists. - exists a; auto. -Qed. - -Lemma refines_exists_spec_l {E A B} (P : A -> itree_spec E B) Q : - (forall a, P a |= Q) -> exists_spec P |= Q. -Proof. - repeat intro. - apply exists_spec_is_exists in H0; destruct H0. - apply (H x); auto. -Qed. - -Lemma refines_exists_spec_lr {E A B} (P Q : A -> itree_spec E B) : - (forall a, P a |= Q a) -> exists_spec P |= exists_spec Q. -Proof. - repeat intro. - apply exists_spec_is_exists. - apply exists_spec_is_exists in H0; destruct H0. - exists x; apply (H x); auto. -Qed. - - -(** * `top` and `bottom` specs **) - -CoFixpoint top_spec {E A} : itree_spec E A := - forall_spec (fun _ : unit => top_spec). - -Lemma top_spec_is_top {E A} (t : itree E A) : satisfies top_spec t. -Proof. - pcofix CIH. intros. pfold. red. cbn. constructor. intros. right. auto. -Qed. - -Lemma refines_top_spec_r {E A} (k : itree_spec E A) : k |= top_spec. -Proof. - repeat intro. apply top_spec_is_top. -Qed. - -Definition bottom_spec {E A} : itree_spec E A := - exists_spec (fun v : void => match v with end). - -Lemma bottom_spec_is_bottom {E A} (t : itree E A) : ~ satisfies bottom_spec t. -Proof. - intros Hcontra. punfold Hcontra. red in Hcontra. cbn in *. dependent induction Hcontra; eauto. - destruct H as [ [] _ ]. -Qed. - -Lemma refines_bottom_spec_l {E A} (k : itree_spec E A) : bottom_spec |= k. -Proof. - repeat intro. apply bottom_spec_is_bottom in H. inversion H. -Qed. - - -(** * `and` and `or` specs **) - -Definition and_spec {E A} (P Q : itree_spec E A) := - forall_spec (fun b : bool => if b then P else Q). - -Lemma and_spec_is_and {E A} (t : itree E A) (P Q : itree_spec E A) : - satisfies (and_spec P Q) t <-> (satisfies P t /\ satisfies Q t). -Proof. - split; intros; [split | destruct H]. - - apply (proj1 (forall_spec_is_forall _ _) H true). - - apply (proj1 (forall_spec_is_forall _ _) H false). - - apply forall_spec_is_forall; destruct a; eauto. -Qed. - -Lemma and_spec_bind {E A B} (P Q : itree_spec E A) (k : A -> itree_spec E B) : - (and_spec P Q) >>= k ≈ and_spec (P >>= k) (Q >>= k). -Proof. - unfold and_spec. - rewrite forall_spec_bind. - apply eqit_Vis. - destruct u; reflexivity. -Qed. - -Lemma refines_and_spec_r {E A} k (P Q : itree_spec E A) : - k |= P -> k |= Q -> k |= and_spec P Q. -Proof. - intros; apply refines_forall_spec_r. - destruct a; eauto. -Qed. - -Lemma refines_and_spec_l {E A} (P Q : itree_spec E A) k : - P |= k \/ Q |= k -> and_spec P Q |= k. -Proof. - destruct 1. - - apply (refines_forall_spec_l _ _ true); eauto. - - apply (refines_forall_spec_l _ _ false); eauto. -Qed. - -Definition or_spec {E A} (P Q : itree_spec E A) := - exists_spec (fun b : bool => if b then P else Q). - -Lemma or_spec_is_or {E A} (t : itree E A) (P Q : itree_spec E A) : - satisfies (or_spec P Q) t <-> (satisfies P t \/ satisfies Q t). -Proof. - split; intros; [|destruct H]. - - pose proof (proj1 (exists_spec_is_exists _ _) H). - destruct H0 as [[]]; eauto. - - apply exists_spec_is_exists; exists true; eauto. - - apply exists_spec_is_exists; exists false; eauto. -Qed. - -Lemma or_spec_bind {E A B} (P Q : itree_spec E A) (k : A -> itree_spec E B) : - (or_spec P Q) >>= k ≈ or_spec (P >>= k) (Q >>= k). -Proof. - unfold or_spec. - rewrite exists_spec_bind. - apply eqit_Vis. - destruct u; reflexivity. -Qed. - -Lemma refines_or_spec_r {E A} k (P Q : itree_spec E A) : - k |= P \/ k |= Q -> k |= or_spec P Q. -Proof. - destruct 1. - - apply (refines_exists_spec_r _ _ true); eauto. - - apply (refines_exists_spec_r _ _ false); eauto. -Qed. - -Lemma refines_or_spec_l {E A} (P Q : itree_spec E A) k : - P |= k -> Q |= k -> or_spec P Q |= k. -Proof. - intros; apply refines_exists_spec_l. - destruct a; eauto. -Qed. - - -(** * `assert` and `assuming` specs **) - -Definition assert_spec {E} (P : Prop) : itree_spec E unit := - exists_spec (fun pf : P => Ret tt). - -Lemma iwish {E A} (P : Prop) (k : itree_spec E A) : - exists_spec (fun pf : P => k) ~= assert_spec P >> k. -Proof. - split; unfold assert_spec; - rewrite bind_vis; - eapply refines_exists_spec_lr; intro; - rewrite bind_ret_l; reflexivity. -Qed. - -Definition assert_spec_refines_eq {E} (P : Prop) (pf : P) : - @assert_spec E P ~= Ret tt. -Proof. - split; repeat intro. - - apply exists_spec_is_exists in H; destruct H; eauto. - - apply exists_spec_is_exists; exists pf; eauto. -Qed. - -Lemma refines_bind_assert_spec_r {E A} (P : Prop) (k1 k2 : itree_spec E A) : - P -> k1 |= k2 -> k1 |= assert_spec P >> k2. -Proof. - intros pf ?. - rewrite <- iwish. - apply refines_exists_spec_r; eauto. -Qed. - -Lemma refinesM_bindM_assertM_l {A} (P:Prop) (m1 m2: CompM A) : - (P -> m1 |= m2) -> assertM P >> m1 |= m2. -Proof. - intro H. unfold assertM; rewrite existsM_bindM. - apply refinesM_existsM_l. - rewrite returnM_bindM; assumption. -Qed. - -Definition assumingM {A} (P:Prop) (m:CompM A) : CompM A := - forallM (fun pf:P => m). - -Lemma refinesM_assumingM_r {A} (P:Prop) (m1 m2: CompM A) : - (P -> m1 |= m2) -> m1 |= assumingM P m2. -Proof. - apply refinesM_forallM_r. -Qed. - -Lemma refinesM_assumingM_l {A} (P:Prop) (m1 m2 : CompM A) : - P -> m1 |= m2 -> assumingM P m1 |= m2. -Proof. - apply refinesM_forallM_l. -Qed. - - - - - -(** * misc. stuff below **) - -Notation " x : T <- m1 ;; m2" := (ITree.bind m1 (fun x : T=> m2) ) (at level 40). - -Section l_bind_satisfies_bind_counter. - Variant NonDet : Type -> Type := Choose : NonDet bool. - - Definition m_counter : itree NonDet unit := - x : bool <- ITree.trigger Choose ;; - if x then Ret tt else y : bool <- ITree.trigger Choose;; Ret tt. - - Definition P_counter : itree_spec NonDet unit := - x : bool <- ITree.trigger (Spec_vis Choose);; Ret tt. - - Definition Q_counter : unit -> itree_spec NonDet unit := - fun _ => or_spec (Ret tt) ( x : bool <- ITree.trigger (Spec_vis Choose);; Ret tt ). - - Lemma m_counter_sats_P_bind_Q_counter : satisfies (P_counter >>= Q_counter) m_counter. - Proof. - pfold. red. cbn. constructor. left. destruct x. - - pfold. red. cbn. - assert (RetF (E:= NonDet) tt = observe (Ret tt)); auto. - rewrite H. constructor. exists true. left. pfold; constructor. - - pfold. red. cbn. assert (VisF Choose (fun x : bool => _ : bool <- Ret x;; Ret tt) = - observe (Vis Choose (fun x : bool => _ : bool <- Ret x;; Ret tt) ) ); auto. - rewrite H. constructor. exists false. left. pfold. red. cbn. - rewrite H. constructor. intros [ | ]; left; pfold; red; cbn; auto. - Qed. - - Lemma satifies_P_counter : forall m, satisfies P_counter m -> - m ≈ (x : bool <- ITree.trigger Choose;; Ret tt). - Proof. - intros. unfold P_counter in *. punfold H. red in H. pfold. red. cbn in *. - dependent induction H. - - rewrite <- x. constructor; auto. - - rewrite <- x. constructor. left. pclearbot. specialize (H v). - assert (satisfies (_ : bool <- Ret v;; Ret tt) (tree v) ); auto. - enough (tree v ≈ ( _ : bool <- Ret v;; Ret tt) ); auto. rewrite bind_ret_l. - rewrite bind_ret_l in H0. symmetry. clear x H m. - pfold. red. punfold H0. red in H0. cbn in *. - remember (observe (tree v) ) as ot. clear Heqot tree v. dependent induction H0; auto. - Qed. - - Definition m0_counter : itree NonDet unit := x : bool <- ITree.trigger Choose;; Ret tt. - - Lemma m0_counter_no_continuation : forall k, - ~ m0_counter >>= k ≈ m_counter . - Proof. - unfold m0_counter, m_counter. - intros k Hcontra. repeat rewrite bind_trigger in Hcontra. - rewrite bind_vis in Hcontra. apply eqit_inv_vis in Hcontra as [_ Hcontra] . - specialize (Hcontra true) as Hktrue. specialize (Hcontra false) as Hkfalse. - cbn in *. rewrite bind_ret_l in Hktrue. rewrite bind_ret_l in Hkfalse. - rewrite Hktrue in Hkfalse. pinversion Hkfalse. - Qed. - - Lemma not_l_bind_satisfies_bind_aux : exists E R S - (m : itree E R) (P : itree_spec E S) (Q : S -> itree_spec E R), - satisfies (P >>= Q) m /\ (forall m0 k, satisfies P m0 -> ~ (m0 >>= k ≈ m) ). - Proof. - exists NonDet, unit, unit, m_counter, P_counter, Q_counter. - split; try apply m_counter_sats_P_bind_Q_counter. - intros. apply satifies_P_counter in H. rewrite H. fold m0_counter. - apply m0_counter_no_continuation. - Qed. - - -End l_bind_satisfies_bind_counter. - -Lemma not_l_bind_satisfies_bind : ~ forall E R S - (m : itree E R) (P : itree_spec E S) (Q : S -> itree_spec E R), - satisfies (P >>= Q) m -> exists m0 k, satisfies P m0 /\ (forall a, is_itree_retval m0 a -> satisfies (Q a) (k a) ) /\ (m0 >>= k ≈ m). -Proof. - destruct not_l_bind_satisfies_bind_aux as [ E [R [S [m [P [Q [H0 H1] ] ] ] ] ] ]. - intros Hcontra. specialize (Hcontra E R S m P Q H0). - destruct Hcontra as [m0 [k [Hsat [ _ Heutt] ] ] ]. eapply H1; eauto. -Qed. - -(* Our event type = errors *) -Inductive CompMEvent : Type -> Type := -| ErrorEvent : CompMEvent False -. - -(* Our computations are sets of ITrees. That is, they are really more like -specifications of computations *) -Definition CompM (A:Type) : Type := itree_spec CompMEvent A. diff --git a/saw-core-coq/coq/handwritten/CryptolToCoq/CryptolPrimitivesForSAWCoreExtra.v b/saw-core-coq/coq/handwritten/CryptolToCoq/CryptolPrimitivesForSAWCoreExtra.v index d78192a415..03aea40627 100644 --- a/saw-core-coq/coq/handwritten/CryptolToCoq/CryptolPrimitivesForSAWCoreExtra.v +++ b/saw-core-coq/coq/handwritten/CryptolToCoq/CryptolPrimitivesForSAWCoreExtra.v @@ -10,7 +10,6 @@ From CryptolToCoq Require Import SAWCorePrelude. Import SAWCorePrelude. From CryptolToCoq Require Import SAWCorePreludeExtra. From CryptolToCoq Require Import SAWCoreVectorsAsCoqVectors. -From CryptolToCoq Require Import SpecM. From CryptolToCoq Require Import CryptolPrimitivesForSAWCore. Import CryptolPrimitivesForSAWCore. diff --git a/saw-core-coq/coq/handwritten/CryptolToCoq/Everything.v b/saw-core-coq/coq/handwritten/CryptolToCoq/Everything.v index 516dce0398..4051457e17 100644 --- a/saw-core-coq/coq/handwritten/CryptolToCoq/Everything.v +++ b/saw-core-coq/coq/handwritten/CryptolToCoq/Everything.v @@ -13,4 +13,3 @@ From CryptolToCoq Require Import SAWCorePrelude_proofs. From CryptolToCoq Require Import SAWCorePreludeExtra. From CryptolToCoq Require Import SAWCoreScaffolding. From CryptolToCoq Require Import SAWCoreVectorsAsCoqVectors. -(* From CryptolToCoq Require Import SpecMExtra. *) diff --git a/saw-core-coq/coq/handwritten/CryptolToCoq/SpecM.v b/saw-core-coq/coq/handwritten/CryptolToCoq/SpecM.v deleted file mode 100644 index d3be33b3a8..0000000000 --- a/saw-core-coq/coq/handwritten/CryptolToCoq/SpecM.v +++ /dev/null @@ -1,140 +0,0 @@ - -From CryptolToCoq Require Import SAWCoreScaffolding. -From CryptolToCoq Require Import SAWCoreVectorsAsCoqVectors. -From CryptolToCoq Require Import CryptolPrimitivesForSAWCore. -Import CryptolPrimitivesForSAWCore. - -From EnTree Require Import EnTreeSpecs TpDesc. - - -(** - ** Defining the TpExprOps instance for SAW - **) - -Inductive TpExprUnOp : ExprKind -> ExprKind -> Type@{entree_u} := -| UnOp_BVToNat w : TpExprUnOp (Kind_bv w) Kind_nat -| UnOp_NatToBV w : TpExprUnOp Kind_nat (Kind_bv w) -| UnOp_NatToNum : TpExprUnOp Kind_nat Kind_num -. - -Inductive TpExprBinOp : ExprKind -> ExprKind -> ExprKind -> Type@{entree_u} := -| BinOp_AddNat : TpExprBinOp Kind_nat Kind_nat Kind_nat -| BinOp_MulNat : TpExprBinOp Kind_nat Kind_nat Kind_nat -| BinOp_AddBV w : TpExprBinOp (Kind_bv w) (Kind_bv w) (Kind_bv w) -| BinOp_MulBV w : TpExprBinOp (Kind_bv w) (Kind_bv w) (Kind_bv w) -| BinOp_AddNum : TpExprBinOp Kind_num Kind_num Kind_num -| BinOp_MulNum : TpExprBinOp Kind_num Kind_num Kind_num -. - -Lemma dec_eq_UnOp {EK1 EK2} (op1 op2 : TpExprUnOp EK1 EK2) : {op1=op2} + {~op1=op2}. -Admitted. - -Lemma dec_eq_BinOp {EK1 EK2 EK3} (op1 op2 : TpExprBinOp EK1 EK2 EK3) - : {op1=op2} + {~op1=op2}. -Admitted. - -Definition evalUnOp {EK1 EK2} (op: TpExprUnOp EK1 EK2) : - exprKindElem EK1 -> exprKindElem EK2 := - match op in TpExprUnOp EK1 EK2 return exprKindElem EK1 -> exprKindElem EK2 with - | UnOp_BVToNat w => bvToNat w - | UnOp_NatToBV w => bvNat w - | UnOp_NatToNum => TCNum - end. - -Definition evalBinOp {EK1 EK2 EK3} (op: TpExprBinOp EK1 EK2 EK3) : - exprKindElem EK1 -> exprKindElem EK2 -> exprKindElem EK3 := - match op in TpExprBinOp EK1 EK2 EK3 - return exprKindElem EK1 -> exprKindElem EK2 -> exprKindElem EK3 with - | BinOp_AddNat => addNat - | BinOp_MulNat => mulNat - | BinOp_AddBV w => bvAdd w - | BinOp_MulBV w => bvMul w - | BinOp_AddNum => tcAdd - | BinOp_MulNum => tcMul - end. - -Global Instance SAWTpExprOps : TpExprOps := - { - TpExprUnOp := TpExprUnOp; - TpExprBinOp := TpExprBinOp; - dec_eq_UnOp := @dec_eq_UnOp; - dec_eq_BinOp := @dec_eq_BinOp; - evalUnOp := @evalUnOp; - evalBinOp := @evalBinOp; - }. - - -(** - ** Now we re-export all of TpDesc using the above instance - **) - -(* EvType *) -Definition EvType := FixTree.EvType. -Definition Build_EvType := FixTree.Build_EvType. -Definition evTypeType := FixTree.evTypeType. -Definition evRetType := FixTree.evRetType. - -(* ExprKind *) -Definition ExprKind := ExprKind. -Definition ExprKind_rect := ExprKind_rect. -Definition Kind_unit := Kind_unit. -Definition Kind_bool := Kind_bool. -Definition Kind_nat := Kind_nat. -Definition Kind_num := Kind_num. -Definition Kind_bv := Kind_bv. - -(* KindDesc *) -Definition KindDesc := KindDesc. -Definition KindDesc_rect := KindDesc_rect. -Definition Kind_Expr := Kind_Expr. -Definition Kind_Tp := Kind_Tp. - -(* TpExpr *) -Definition TpExpr := TpExpr. -Definition TpExpr_rect := TpExpr_rect. -Definition TpExpr_Const := @TpExpr_Const SAWTpExprOps. -Definition TpExpr_Var := @TpExpr_Var SAWTpExprOps. -Definition TpExpr_UnOp := @TpExpr_UnOp SAWTpExprOps. -Definition TpExpr_BinOp := @TpExpr_BinOp SAWTpExprOps. - -(* TpDesc *) -Definition TpDesc := TpDesc. -Definition TpDesc_rect := TpDesc_rect. -Definition Tp_M := Tp_M. -Definition Tp_Pi := Tp_Pi. -Definition Tp_Arr := Tp_Arr. -Definition Tp_Kind := Tp_Kind. -Definition Tp_Pair := Tp_Pair. -Definition Tp_Sum := Tp_Sum. -Definition Tp_Sigma := Tp_Sigma. -Definition Tp_Seq := Tp_Seq. -Definition Tp_Void := Tp_Void. -Definition Tp_Ind := Tp_Ind. -Definition Tp_Var := Tp_Var. -Definition Tp_TpSubst := Tp_TpSubst. -Definition Tp_ExprSubst := Tp_ExprSubst. - -(* tpElem and friends *) -Definition FunFlag := FunFlag. -Definition IsData := IsData. -Definition IsFun := IsFun. -Definition tpSubst := tpSubst. -Definition elimTpEnvElem := elimTpEnvElem. -Definition tpElemEnv := tpElemEnv. -Definition indElem := indElem. -Definition foldTpElem := @foldTpElem. -Definition unfoldTpElem := @unfoldTpElem. - -(* SpecM and its operations *) -Definition SpecM := @SpecM.SpecM SAWTpExprOps. -Definition retS := @SpecM.RetS SAWTpExprOps. -Definition bindS := @SpecM.BindS SAWTpExprOps. -Definition triggerS := @SpecM.TriggerS SAWTpExprOps. -Definition errorS := @SpecM.ErrorS SAWTpExprOps. -Definition forallS := @SpecM.ForallS SAWTpExprOps. -Definition existsS := @SpecM.ExistsS SAWTpExprOps. -Definition assumeS := @SpecM.AssumeS SAWTpExprOps. -Definition assertS := @SpecM.AssertS SAWTpExprOps. -Definition FixS := @SpecM.FixS SAWTpExprOps. -Definition MultiFixS := @SpecM.MultiFixS SAWTpExprOps. -Definition LetRecS := @SpecM.LetRecS SAWTpExprOps. diff --git a/saw-core-coq/coq/handwritten/CryptolToCoq/SpecMExtra.v b/saw-core-coq/coq/handwritten/CryptolToCoq/SpecMExtra.v deleted file mode 100644 index 69f98036a2..0000000000 --- a/saw-core-coq/coq/handwritten/CryptolToCoq/SpecMExtra.v +++ /dev/null @@ -1,205 +0,0 @@ -(*** - *** Extra Proofs for SpecM that Rely on SAWCorePrelude - ***) - -From CryptolToCoq Require Import SAWCorePrelude. -From CryptolToCoq Require Import SAWCoreScaffolding. -From CryptolToCoq Require Import SAWCoreVectorsAsCoqVectors. -From CryptolToCoq Require Import SAWCoreBitvectors. -From EnTree Require Export - Basics.HeterogeneousRelations - Basics.QuantType - Ref.SpecM. - Automation. -Import SAWCorePrelude. - - - -(*** - *** Additional Automation - ***) - -(* QOL: nicer names for bitvector arguments *) -#[global] Hint Extern 901 (IntroArg Any (bitvector _) _) => - let e := fresh "x" in IntroArg_intro e : refines prepostcond. -#[global] Hint Extern 901 (IntroArg RetAny (bitvector _) _) => - let e := fresh "r_x" in IntroArg_intro e : refines prepostcond. - -(* Maybe automation *) - -Lemma spec_refines_maybe_l (E1 E2 : EvType) Γ1 Γ2 R1 R2 - (RPre : SpecPreRel E1 E2 Γ1 Γ2) (RPost : SpecPostRel E1 E2 Γ1 Γ2) - RR A t1 k1 mb (t2 : SpecM E2 Γ2 R2) : - (mb = Nothing _ -> spec_refines RPre RPost RR t1 t2) -> - (forall a, mb = Just _ a -> spec_refines RPre RPost RR (k1 a) t2) -> - spec_refines RPre RPost RR (maybe A (SpecM E1 Γ1 R1) t1 k1 mb) t2. -Proof. destruct mb; intros; eauto. Qed. - -Lemma spec_refines_maybe_r (E1 E2 : EvType) Γ1 Γ2 R1 R2 - (RPre : SpecPreRel E1 E2 Γ1 Γ2) (RPost : SpecPostRel E1 E2 Γ1 Γ2) - RR (t1 : SpecM E1 Γ1 R1) A t2 k2 mb : - (mb = Nothing _ -> spec_refines RPre RPost RR t1 t2) -> - (forall a, mb = Just _ a -> spec_refines RPre RPost RR t1 (k2 a)) -> - spec_refines RPre RPost RR t1 (maybe A (SpecM E2 Γ2 R2) t2 k2 mb). -Proof. destruct mb; intros; eauto. Qed. - -Definition spec_refines_maybe_l_IntroArg (E1 E2 : EvType) Γ1 Γ2 R1 R2 - (RPre : SpecPreRel E1 E2 Γ1 Γ2) (RPost : SpecPostRel E1 E2 Γ1 Γ2) - RR A t1 k1 mb (t2 : SpecM E2 Γ2 R2) : - (IntroArg Hyp (mb = Nothing _) (fun _ => spec_refines RPre RPost RR t1 t2)) -> - (IntroArg Any A (fun a => IntroArg Hyp (mb = Just _ a) (fun _ => - spec_refines RPre RPost RR (k1 a) t2))) -> - spec_refines RPre RPost RR (maybe A (SpecM E1 Γ1 R1) t1 k1 mb) t2 := - spec_refines_maybe_l E1 E2 Γ1 Γ2 R1 R2 RPre RPost RR A t1 k1 mb t2. - -Definition spec_refines_maybe_r_IntroArg (E1 E2 : EvType) Γ1 Γ2 R1 R2 - (RPre : SpecPreRel E1 E2 Γ1 Γ2) (RPost : SpecPostRel E1 E2 Γ1 Γ2) - RR (t1 : SpecM E1 Γ1 R1) A t2 k2 mb : - (IntroArg Hyp (mb = Nothing _) (fun _ => spec_refines RPre RPost RR t1 t2)) -> - (IntroArg Any A (fun a => IntroArg Hyp (mb = Just _ a) (fun _ => - spec_refines RPre RPost RR t1 (k2 a)))) -> - spec_refines RPre RPost RR t1 (maybe A (SpecM E2 Γ2 R2) t2 k2 mb) := - spec_refines_maybe_r E1 E2 Γ1 Γ2 R1 R2 RPre RPost RR t1 A t2 k2 mb. - -#[global] Hint Extern 101 (spec_refines _ _ _ (maybe _ _ _ _ _) _) => - simple apply spec_refines_maybe_l_IntroArg : refines. -#[global] Hint Extern 101 (spec_refines _ _ _ _ (maybe _ _ _ _ _)) => - simple apply spec_refines_maybe_r_IntroArg : refines. - -Lemma IntroArg_eq_Nothing_const n A (goal : Prop) - : goal -> IntroArg n (Nothing A = Nothing A) (fun _ => goal). -Proof. intros H eq; eauto. Qed. -Lemma IntroArg_eq_Just_const n A (x y : A) (goal : Prop) - : IntroArg n (x = y) (fun _ => goal) -> - IntroArg n (Just A x = Just A y) (fun _ => goal). -Proof. intros H eq; apply H; injection eq; eauto. Qed. -Lemma IntroArg_eq_Nothing_Just n A (x : A) goal - : IntroArg n (Nothing A = Just A x) goal. -Proof. intros eq; discriminate eq. Qed. -Lemma IntroArg_eq_Just_Nothing n A (x : A) goal - : IntroArg n (Just A x = Nothing A) goal. -Proof. intros eq; discriminate eq. Qed. - -#[global] Hint Extern 101 (IntroArg _ (Nothing _ = Nothing _) _) => - simple apply IntroArg_eq_Nothing_const : refines. -#[global] Hint Extern 101 (IntroArg _ (Just _ _ = Just _ _) _) => - simple apply IntroArg_eq_Just_const : refines. -#[global] Hint Extern 101 (IntroArg _ (Nothing _ = Just _ _) _) => - apply IntroArg_eq_Nothing_Just : refines. -#[global] Hint Extern 101 (IntroArg _ (Just _ _ = Nothing _) _) => - apply IntroArg_eq_Just_Nothing : refines. - - -(* sawLet automation *) - -Definition spec_refines_sawLet_const_l (E1 E2 : EvType) Γ1 Γ2 R1 R2 - (RPre : SpecPreRel E1 E2 Γ1 Γ2) (RPost : SpecPostRel E1 E2 Γ1 Γ2) - (RR : Rel R1 R2) A (x : A) t1 t2 : - spec_refines RPre RPost RR t1 t2 -> - spec_refines RPre RPost RR (sawLet_def _ _ x (fun _ => t1)) t2 := fun pf => pf. -Definition spec_refines_sawLet_const_r (E1 E2 : EvType) Γ1 Γ2 R1 R2 - (RPre : SpecPreRel E1 E2 Γ1 Γ2) (RPost : SpecPostRel E1 E2 Γ1 Γ2) - (RR : Rel R1 R2) A (x : A) t1 t2 : - spec_refines RPre RPost RR t1 t2 -> - spec_refines RPre RPost RR t1 (sawLet_def _ _ x (fun _ => t2)) := fun pf => pf. - -Definition spec_refines_sawLet_bv_l_IntroArg (E1 E2 : EvType) Γ1 Γ2 R1 R2 - (RPre : SpecPreRel E1 E2 Γ1 Γ2) (RPost : SpecPostRel E1 E2 Γ1 Γ2) - (RR : Rel R1 R2) w (x : bitvector w) k1 t2 : - IntroArg Any _ (fun a => IntroArg SAWLet (a = x) (fun _ => - spec_refines RPre RPost RR (k1 a) t2)) -> - spec_refines RPre RPost RR (sawLet_def _ _ x k1) t2. -Proof. intro H; eapply H; eauto. Qed. -Definition spec_refines_sawLet_bv_r_IntroArg (E1 E2 : EvType) Γ1 Γ2 R1 R2 - (RPre : SpecPreRel E1 E2 Γ1 Γ2) (RPost : SpecPostRel E1 E2 Γ1 Γ2) - (RR : Rel R1 R2) w (x : bitvector w) t1 k2 : - IntroArg Any _ (fun a => IntroArg SAWLet (a = x) (fun _ => - spec_refines RPre RPost RR t1 (k2 a))) -> - spec_refines RPre RPost RR t1 (sawLet_def _ _ x k2). -Proof. intro H; eapply H; eauto. Qed. - -Definition spec_refines_sawLet_unfold_l (E1 E2 : EvType) Γ1 Γ2 R1 R2 - (RPre : SpecPreRel E1 E2 Γ1 Γ2) (RPost : SpecPostRel E1 E2 Γ1 Γ2) - (RR : Rel R1 R2) A (x : A) k1 t2 : - spec_refines RPre RPost RR (k1 x) t2 -> - spec_refines RPre RPost RR (sawLet_def _ _ x k1) t2 := fun pf => pf. -Definition spec_refines_sawLet_unfold_r (E1 E2 : EvType) Γ1 Γ2 R1 R2 - (RPre : SpecPreRel E1 E2 Γ1 Γ2) (RPost : SpecPostRel E1 E2 Γ1 Γ2) - (RR : Rel R1 R2) A (x : A) t1 k2 : - spec_refines RPre RPost RR t1 (k2 x) -> - spec_refines RPre RPost RR t1 (sawLet_def _ _ x k2) := fun pf => pf. - -Ltac spec_refines_sawLet_l := - first [ simple apply spec_refines_sawLet_const_l - | simple apply spec_refines_sawLet_bv_l_IntroArg - | simple apply spec_refines_sawLet_unfold_l ]. -Ltac spec_refines_sawLet_r := - first [ simple apply spec_refines_sawLet_const_r - | simple apply spec_refines_sawLet_bv_r_IntroArg - | simple apply spec_refines_sawLet_unfold_r ]. - -#[global] Hint Extern 101 (spec_refines _ _ _ (sawLet_def _ _ _ _) _) => - spec_refines_sawLet_l : refines. -#[global] Hint Extern 101 (spec_refines _ _ _ _ (sawLet_def _ _ _ _ )) => - spec_refines_sawLet_r : refines. - - -(* Bitvector (In)Equality Automation *) - -Lemma simpl_llvm_bool_eq (b : bool) : - negb (bvEq 1 (if b then intToBv 1 (-1) else intToBv 1 0) (intToBv 1 0)) = b. -Proof. destruct b; eauto. Qed. - -Definition simpl_llvm_bool_eq_IntroArg n (b1 b2 : bool) (goal : Prop) : - IntroArg n (b1 = b2) (fun _ => goal) -> - IntroArg n (negb (bvEq 1 (if b1 then intToBv 1 (-1) else intToBv 1 0) (intToBv 1 0)) = b2) (fun _ => goal). -Proof. rewrite simpl_llvm_bool_eq; eauto. Defined. - -#[global] Hint Extern 101 (IntroArg _ (negb (bvEq 1 (if _ then intToBv 1 (-1) else intToBv 1 0) (intToBv 1 0)) = _) _) => - simple eapply simpl_llvm_bool_eq_IntroArg : refines. - -Polymorphic Lemma bvuleWithProof_not : - forall w a b, - bvuleWithProof w a b = Nothing _ <-> ~ (isBvule w a b). -Proof. - unfold bvuleWithProof, isBvule. - split. - - intros H0 H1. - rewrite H1 in H0. simpl. - discriminate. - - intros H. - destruct (bvule w a b). - + contradiction. - + reflexivity. -Qed. - -Polymorphic Lemma bvuleWithProof_not_IntroArg n w a b goal : - IntroArg n (~ (isBvule w a b)) (fun _ => goal) -> - IntroArg n (bvuleWithProof w a b = Nothing _) (fun _ => goal). -Proof. intros H eq; apply H; apply bvuleWithProof_not; eauto. Qed. - -#[global] Hint Extern 101 (IntroArg _ (bvuleWithProof _ _ _ = Nothing _) _) => - simple apply bvuleWithProof_not_IntroArg || shelve : refines. - -Polymorphic Lemma bvultWithProof_not : - forall w a b, - bvultWithProof w a b = Nothing _ <-> ~ (isBvult w a b). -Proof. - unfold bvultWithProof, isBvult. - split. - - intros H0 H1. - rewrite H1 in H0. simpl. - discriminate. - - intros H. - destruct (bvult w a b). - + contradiction. - + reflexivity. -Qed. - -Polymorphic Lemma bvultWithProof_not_IntroArg n w a b goal : - IntroArg n (~ (isBvult w a b)) (fun _ => goal) -> - IntroArg n (bvultWithProof w a b = Nothing _) (fun _ => goal). -Proof. intros H eq; apply H; apply bvultWithProof_not; eauto. Qed. - -#[global] Hint Extern 101 (IntroArg _ (bvultWithProof _ _ _ = Nothing _) _) => - apply bvultWithProof_not_IntroArg : refines. diff --git a/saw-core-coq/src/SAWCoreCoq/SpecialTreatment.hs b/saw-core-coq/src/SAWCoreCoq/SpecialTreatment.hs index c4693f2b7e..d16493766d 100644 --- a/saw-core-coq/src/SAWCoreCoq/SpecialTreatment.hs +++ b/saw-core-coq/src/SAWCoreCoq/SpecialTreatment.hs @@ -199,9 +199,6 @@ stringModule = sawDefinitionsModule :: ModuleName sawDefinitionsModule = mkModuleName ["SAWCoreScaffolding"] -specMModule :: ModuleName -specMModule = mkModuleName ["SpecM"] - tpDescModule :: ModuleName tpDescModule = mkModuleName ["TpDesc"] @@ -226,7 +223,6 @@ specialTreatmentMap configuration = Map.fromList $ over _1 (mkModuleName . (: [])) <$> [ ("Cryptol", cryptolPreludeSpecialTreatmentMap) , ("Prelude", sawCorePreludeSpecialTreatmentMap configuration) - , ("SpecM", specMSpecialTreatmentMap configuration) ] cryptolPreludeSpecialTreatmentMap :: Map.Map String IdentSpecialTreatment @@ -549,55 +545,6 @@ sawCorePreludeSpecialTreatmentMap configuration = ] -} -specMSpecialTreatmentMap :: TranslationConfiguration -> - Map.Map String IdentSpecialTreatment -specMSpecialTreatmentMap _configuration = - Map.fromList $ - - -- Type descriptions - map (\str -> (str, mapsTo specMModule (Coq.Ident str))) - [ "ExprKind", "Kind_unit", "Kind_bool", "Kind_nat", "Kind_bv" - , "TpExprUnOp", "UnOp_BVToNat", "UnOp_NatToBV" - , "TpExprBinOp", "BinOp_AddNat", "BinOp_MulNat", "BinOp_AddBV", "BinOp_MulBV" - , "KindDesc", "Kind_Expr", "Kind_Tp" - , "TpExpr", "TpExpr_Const", "TpExpr_Var", "TpExpr_UnOp", "TpExpr_BinOp" - , "TpDesc", "Tp_M", "Tp_Pi", "Tp_Arr", "Tp_Kind", "Tp_Pair", "Tp_Sum" - , "Tp_Sigma", "Tp_Seq", "Tp_Void", "Tp_Ind", "Tp_Var", "Tp_TpSubst" - , "Tp_ExprSubst" - , "tpSubst", "elimTpEnvElem", "tpElemEnv" - , "indElem", "indToTpElem", "tpToIndElem" - , "FunFlag", "IsFun", "IsData" - ] - - -- The specification monad - ++ - [ ("EvType", mapsTo specMModule "EvType") - , ("Build_EvType", mapsTo specMModule "Build_EvType") - , ("evTypeType", mapsTo specMModule "evTypeType") - , ("evRetType", mapsTo specMModule "evRetType") - , ("SpecM", mapsTo specMModule "SpecM") - , ("retS", mapsToExpl specMModule "retS") - , ("bindS", mapsToExpl specMModule "bindS") - , ("triggerS", mapsToExpl specMModule "triggerS") - , ("errorS", mapsToExpl specMModule "errorS") - , ("forallS", mapsToExplInferArg "SpecM.forallS" 2) - , ("existsS", mapsToExplInferArg "SpecM.existsS" 2) - , ("assumeS", mapsToExpl specMModule "assumeS") - , ("assertS", mapsToExpl specMModule "assertS") - , ("FixS", mapsToExpl specMModule "FixS") - , ("MultiFixS", mapsToExpl specMModule "MultiFixS") - , ("LetRecS", mapsToExpl specMModule "LetRecS") - {- - , ("SpecPreRel", mapsToExpl entreeSpecsModule "SpecPreRel") - , ("SpecPostRel", mapsToExpl entreeSpecsModule "SpecPostRel") - , ("eqPreRel", mapsToExpl entreeSpecsModule "eqPreRel") - , ("eqPostRel", mapsToExpl entreeSpecsModule "eqPostRel") -} - , ("refinesS", skip) - , ("refinesS_eq", skip) - ] - - - escapeIdent :: Coq.Ident -> Coq.Ident escapeIdent (Coq.Ident str) | all okChar str = Coq.Ident str diff --git a/saw-core-coq/src/SAWCoreCoq/Term.hs b/saw-core-coq/src/SAWCoreCoq/Term.hs index 07e489143b..11405fd332 100644 --- a/saw-core-coq/src/SAWCoreCoq/Term.hs +++ b/saw-core-coq/src/SAWCoreCoq/Term.hs @@ -400,23 +400,29 @@ translateIdentToIdent i = translateSort :: Sort -> Coq.Sort translateSort s = if s == propSort then Coq.Prop else Coq.Type +translateTuple :: [Coq.Term] -> Coq.Term +translateTuple [] = Coq.Var "tt" +translateTuple (x : xs) = Coq.App (Coq.Var "pair") [x, translateTuple xs] + +translateTupleType :: [Coq.Term] -> Coq.Term +translateTupleType [] = Coq.Ascription (Coq.Var "unit") (Coq.Sort Coq.Type) + -- We need to explicitly tell Coq that we want unit to be a Type, since + -- all SAW core sorts are translated to Types +translateTupleType (x : xs) = Coq.App (Coq.Var "prod") [x, translateTupleType xs] + +translateTupleSelector :: Int -> Coq.Term -> Coq.Term +translateTupleSelector i x + | i == 0 = Coq.App (Coq.Var "SAWCoreScaffolding.fst") [x] + | otherwise = translateTupleSelector (i - 1) (Coq.App (Coq.Var "SAWCoreScaffolding.snd") [x]) + flatTermFToExpr :: TermTranslationMonad m => FlatTermF Term -> m Coq.Term flatTermFToExpr tf = -- traceFTermF "flatTermFToExpr" tf $ case tf of - UnitValue -> pure (Coq.Var "tt") - UnitType -> - -- We need to explicitly tell Coq that we want unit to be a Type, since - -- all SAW core sorts are translated to Types - pure (Coq.Ascription (Coq.Var "unit") (Coq.Sort Coq.Type)) - PairValue x y -> Coq.App (Coq.Var "pair") <$> traverse translateTerm [x, y] - PairType x y -> Coq.App (Coq.Var "prod") <$> traverse translateTerm [x, y] - PairLeft t -> - Coq.App <$> pure (Coq.Var "fst") <*> traverse translateTerm [t] - PairRight t -> - Coq.App <$> pure (Coq.Var "snd") <*> traverse translateTerm [t] + TupleValue xs -> translateTuple <$> traverse translateTerm (Vector.toList xs) + TupleSelector x i -> translateTupleSelector i <$> translateTerm x RecursorType _d _params motive motiveTy -> -- type of the motive looks like @@ -826,10 +832,8 @@ defaultTermForType typ = do defaultT <- defaultTermForType typ' return $ Coq.App seqConst [ nT, typ'T, defaultT ] - (asPairType -> Just (x,y)) -> do - x' <- defaultTermForType x - y' <- defaultTermForType y - return $ Coq.App (Coq.Var "pair") [x',y'] + (asTupleType -> Just xs) -> + translateTuple <$> traverse defaultTermForType xs (asPiList -> (bs,body)) | not (null bs) diff --git a/saw-core-sbv/src/SAWCoreSBV/SBV.hs b/saw-core-sbv/src/SAWCoreSBV/SBV.hs index a8d4b036a9..f539ca2ffc 100644 --- a/saw-core-sbv/src/SAWCoreSBV/SBV.hs +++ b/saw-core-sbv/src/SAWCoreSBV/SBV.hs @@ -264,10 +264,8 @@ flattenSValue nm v = do Just w -> return ([w], "") Nothing -> case v of - VUnit -> return ([], "") - VPair x y -> do (xs, sx) <- flattenSValue nm =<< force x - (ys, sy) <- flattenSValue nm =<< force y - return (xs ++ ys, sx ++ sy) + VTuple (V.toList -> ts) -> do (xss, ss) <- unzip <$> traverse (force >=> flattenSValue nm) ts + pure (concat xss, concat ss) VRecordValue elems -> do (xss, sxs) <- unzip <$> mapM (flattenSValue nm <=< force . snd) elems @@ -666,13 +664,10 @@ parseUninterpreted cws nm ty = | i <- [0 .. n-1] ] return (VVector (V.fromList (map ready xs))) - VUnitType - -> return VUnit - - (VPairType ty1 ty2) - -> do x1 <- parseUninterpreted cws (nm ++ ".L") ty1 - x2 <- parseUninterpreted cws (nm ++ ".R") ty2 - return (VPair (ready x1) (ready x2)) + VTupleType tys + -> do let mkElem i ty' = parseUninterpreted cws (nm ++ "." ++ show i) ty' + xs <- V.imapM mkElem tys + pure (VTuple (fmap ready xs)) (VRecordType elem_tps) -> (VRecordValue <$> @@ -927,16 +922,11 @@ sbvSetOutput checkSz (FOTVec n t) (VVector xv) i = do Just ws -> do svCgOutputArr ("out_"++show i) ws return $! i+1 Nothing -> foldM (\i' x -> sbvSetOutput checkSz t x i') i xs -sbvSetOutput _checkSz (FOTTuple []) VUnit i = - return i -sbvSetOutput checkSz (FOTTuple [t]) v i = sbvSetOutput checkSz t v i -sbvSetOutput checkSz (FOTTuple (t:ts)) (VPair l r) i = do - l' <- liftIO $ force l - r' <- liftIO $ force r - sbvSetOutput checkSz t l' i >>= sbvSetOutput checkSz (FOTTuple ts) r' - -sbvSetOutput _checkSz (FOTRec fs) VUnit i | Map.null fs = do - return i +sbvSetOutput checkSz (FOTTuple ts) (VTuple xs) i = + do unless (length ts == V.length xs) $ + fail "sbvCodeGen: vector length mismatch when setting output values" + vs <- liftIO $ traverse force xs + foldM (\i' (t, v) -> sbvSetOutput checkSz t v i') i (zip ts (V.toList vs)) sbvSetOutput _checkSz (FOTRec fs) (VRecordValue []) i | Map.null fs = return i diff --git a/saw-core-what4/src/SAWCoreWhat4/What4.hs b/saw-core-what4/src/SAWCoreWhat4/What4.hs index 204d57042d..0900d6569c 100644 --- a/saw-core-what4/src/SAWCoreWhat4/What4.hs +++ b/saw-core-what4/src/SAWCoreWhat4/What4.hs @@ -76,7 +76,7 @@ import qualified Data.Vector as V import Data.Traversable as T import qualified Control.Exception as X -import Control.Monad ((<=<), foldM, unless) +import Control.Monad ((<=<), foldM, unless, zipWithM) import Control.Monad.State as ST (MonadState(..), StateT(..), evalStateT, modify) import Control.Monad.Trans.Class (MonadTrans(..)) import Numeric.Natural (Natural) @@ -982,13 +982,12 @@ parseUninterpreted sym ref app ty = -> (VArray . SArray) <$> mkUninterpreted sym ref app (BaseArrayRepr (Ctx.Empty Ctx.:> idx_repr) elm_repr) - VUnitType - -> return VUnit - - VPairType ty1 ty2 - -> do x1 <- parseUninterpreted sym ref (suffixUnintApp "_L" app) ty1 - x2 <- parseUninterpreted sym ref (suffixUnintApp "_R" app) ty2 - return (VPair (ready x1) (ready x2)) + VTupleType tys + -> do let mkElem i ty' = + do let app' = suffixUnintApp ("_" ++ show i) app + parseUninterpreted sym ref app' ty' + xs <- V.imapM mkElem tys + pure (VTuple (fmap ready xs)) VRecordType elem_tps -> (VRecordValue <$> @@ -1047,10 +1046,7 @@ applyUnintApp :: IO (UnintApp (SymExpr sym)) applyUnintApp sym app0 v = case v of - VUnit -> return app0 - VPair x y -> do app1 <- applyUnintApp sym app0 =<< force x - app2 <- applyUnintApp sym app1 =<< force y - return app2 + VTuple xv -> foldM (applyUnintApp sym) app0 =<< traverse force xv VRecordValue elems -> foldM (applyUnintApp sym) app0 =<< traverse (force . snd) elems VVector xv -> foldM (applyUnintApp sym) app0 =<< traverse force xv VBool sb -> return (extendUnintApp app0 sb BaseBoolRepr) @@ -1233,14 +1229,8 @@ vAsFirstOrderType v = -> FOTVec n <$> vAsFirstOrderType v2 VArrayType iv ev -> FOTArray <$> vAsFirstOrderType iv <*> vAsFirstOrderType ev - VUnitType - -> return (FOTTuple []) - VPairType v1 v2 - -> do t1 <- vAsFirstOrderType v1 - t2 <- vAsFirstOrderType v2 - case t2 of - FOTTuple ts -> return (FOTTuple (t1 : ts)) - _ -> return (FOTTuple [t1, t2]) + VTupleType tvs + -> FOTTuple <$> traverse vAsFirstOrderType (V.toList tvs) VRecordType tps -> (FOTRec <$> Map.fromList <$> mapM (\(f,tp) -> (f,) <$> vAsFirstOrderType tp) tps) @@ -1418,18 +1408,15 @@ rebuildTerm sym st sc tv sv = case sv of VFun _ _ -> chokeOn "lambdas (VFun)" - VUnit -> - scUnitValue sc - VPair x y -> + VTuple xs -> case tv of - VPairType tx ty -> - do vx <- force x - vy <- force y - x' <- rebuildTerm sym st sc tx vx - y' <- rebuildTerm sym st sc ty vy - scPairValue sc x' y' + VTupleType txs + | V.length xs == V.length txs -> + do vxs <- traverse force xs + xs' <- zipWithM (rebuildTerm sym st sc) (V.toList txs) (V.toList vxs) + scTuple sc xs' _ -> panic "rebuildTerm" [ - "Pair wasn't a pair: found " <> Text.pack (show tv) + "Tuple wasn't a tuple: found " <> Text.pack (show tv) ] VCtorApp _ _ _ -> chokeOn "constructors (VCtorApp)" @@ -1659,15 +1646,13 @@ parseUninterpretedSAW sym st sc ref trm app ty = -> (VArray . SArray) <$> mkUninterpretedSAW sym st sc ref trm app (BaseArrayRepr (Ctx.Empty Ctx.:> idx_repr) elm_repr) - VUnitType - -> return VUnit - - VPairType ty1 ty2 - -> do let trm1 = ArgTermPairLeft trm - let trm2 = ArgTermPairRight trm - x1 <- parseUninterpretedSAW sym st sc ref trm1 (suffixUnintApp "_L" app) ty1 - x2 <- parseUninterpretedSAW sym st sc ref trm2 (suffixUnintApp "_R" app) ty2 - return (VPair (ready x1) (ready x2)) + VTupleType tys + -> do let mkElem i ty' = + do let trm' = ArgTermTupleProj trm i + let app' = suffixUnintApp ("_" ++ show i) app + parseUninterpretedSAW sym st sc ref trm' app' ty' + xs <- V.imapM mkElem tys + pure (VTuple (fmap ready xs)) _ -> fail $ "could not create uninterpreted symbol of type " ++ show ty @@ -1697,15 +1682,13 @@ data ArgTerm | ArgTermToIntMod Natural ArgTerm -- ^ toIntMod n x | ArgTermFromIntMod Natural ArgTerm -- ^ fromIntMod n x | ArgTermVector Term [ArgTerm] -- ^ element type, elements - | ArgTermUnit - | ArgTermPair ArgTerm ArgTerm + | ArgTermTuple [ArgTerm] | ArgTermRecord [(FieldName, ArgTerm)] | ArgTermConst Term | ArgTermApply ArgTerm ArgTerm | ArgTermAt Natural Term ArgTerm Natural -- ^ length, element type, list, index - | ArgTermPairLeft ArgTerm - | ArgTermPairRight ArgTerm + | ArgTermTupleProj ArgTerm Int | ArgTermBVToNat Natural ArgTerm -- | Reassemble a saw-core term from an 'ArgTerm' and a list of parts. @@ -1742,14 +1725,10 @@ reconstructArgTerm atrm sc ts = do (xs, ts1) <- parseList ats ts0 x <- scVectorReduced sc ty xs return (x, ts1) - ArgTermUnit -> - do x <- scUnitValue sc - return (x, ts0) - ArgTermPair at1 at2 -> - do (x1, ts1) <- parse at1 ts0 - (x2, ts2) <- parse at2 ts1 - x <- scPairValue sc x1 x2 - return (x, ts2) + ArgTermTuple ats -> + do (xs, ts1) <- parseList ats ts0 + x <- scTupleReduced sc xs + pure (x, ts1) ArgTermRecord flds -> do let (tags, ats) = unzip flds (xs, ts1) <- parseList ats ts0 @@ -1768,14 +1747,10 @@ reconstructArgTerm atrm sc ts = i' <- scNat sc i x <- scAt sc n' ty x1 i' return (x, ts1) - ArgTermPairLeft at1 -> - do (x1, ts1) <- parse at1 ts0 - x <- scPairLeft sc x1 - return (x, ts1) - ArgTermPairRight at1 -> + ArgTermTupleProj at1 i -> do (x1, ts1) <- parse at1 ts0 - x <- scPairRight sc x1 - return (x, ts1) + x <- scTupleSelector sc x1 i + pure (x, ts1) ArgTermBVToNat w at1 -> do (x1, ts1) <- parse at1 ts0 x <- scBvToNat sc w x1 @@ -1800,7 +1775,6 @@ mkArgTerm sc ty val = (_, VWord ZBV) -> return ArgTermBVZero -- 0-width bitvector is a constant (_, VWord (DBV _)) -> return ArgTermVar (_, VArray{}) -> return ArgTermVar - (VUnitType, VUnit) -> return ArgTermUnit (VIntModType n, VIntMod _ _) -> pure (ArgTermToIntMod n ArgTermVar) (VVecType _ ety, VVector vv) -> @@ -1809,10 +1783,10 @@ mkArgTerm sc ty val = ety' <- termOfTValue sc ety return (ArgTermVector ety' xs) - (VPairType ty1 ty2, VPair v1 v2) -> - do x1 <- mkArgTerm sc ty1 =<< force v1 - x2 <- mkArgTerm sc ty2 =<< force v2 - return (ArgTermPair x1 x2) + (VTupleType tys, VTuple ts) | V.length tys == V.length ts -> + do vs <- traverse force ts + xs <- sequence (V.zipWith (mkArgTerm sc) tys vs) + pure (ArgTermTuple (V.toList xs)) (VRecordType tys, VRecordValue flds) | map fst tys == map fst flds -> do let tags = map fst tys @@ -1851,15 +1825,13 @@ termOfTValue sc val = case val of VBoolType -> scBoolType sc VIntType -> scIntegerType sc - VUnitType -> scUnitType sc VVecType n a -> do n' <- scNat sc n a' <- termOfTValue sc a scVecType sc n' a' - VPairType a b - -> do a' <- termOfTValue sc a - b' <- termOfTValue sc b - scPairType sc a' b' + VTupleType vs -> + do vs' <- traverse (termOfTValue sc) vs + scTupleType sc (V.toList vs') VRecordType flds -> do flds' <- traverse (traverse (termOfTValue sc)) flds scRecordType sc flds' @@ -1868,8 +1840,10 @@ termOfTValue sc val = termOfSValue :: SharedContext -> SValue sym -> IO Term termOfSValue sc val = case val of - VUnit -> scUnitValue sc - VNat n - -> scNat sc n + VNat n -> scNat sc n + VTuple ts -> + do vs <- traverse force ts + vs' <- traverse (termOfSValue sc) vs + scTuple sc (V.toList vs') TValue tv -> termOfTValue sc tv _ -> fail $ "termOfSValue: " ++ show val diff --git a/saw-core/prelude/Prelude.sawcore b/saw-core/prelude/Prelude.sawcore index 5f9c329b7c..0829d406fa 100644 --- a/saw-core/prelude/Prelude.sawcore +++ b/saw-core/prelude/Prelude.sawcore @@ -22,57 +22,43 @@ sawLet : (a b : sort 1) -> a -> (a -> b) -> b; sawLet _ _ x f = f x; --- FIXME: below are some defined data-types that could be used in place of --- the SAW primitive types - -------------------------------------------------------------------------------- --- The Unit type - -data UnitType : sort 0 where { - Unit : UnitType; - } +-- Tuple types --- The recursor for the Unit type at sort 0 --- UnitType__rec : (p : UnitType -> sort 0) -> p Unit -> (u : UnitType) -> p u; --- UnitType__rec p f1 u = UnitType#rec p f1 u; -UnitType__rec (p : UnitType -> sort 0) (f1 : p Unit) (u : UnitType) : p u - = UnitType#rec p f1 u; - --------------------------------------------------------------------------------- --- Pair types +-- TypeNil, TypeCons and Tuple are used to represent the #(a, b, c) +-- syntax for tuple types, so it is important that they be defined +-- before any uses of tuple types in this file. -data PairType (a b : sort 0) : sort 0 where { - PairValue : a -> b -> PairType a b; -} +data TypeList : sort 1 where { + TypeNil : TypeList; + TypeCons : sort 0 -> TypeList -> TypeList; + } -pair_example : (a b : sort 0) -> a -> b -> PairType a b; -pair_example a b x y = PairValue a b x y; +TypeList__rec + (p : TypeList -> sort 1) + (f1 : p TypeNil) + (f2 : (t : sort 0) -> (ts : TypeList) -> p ts -> p (TypeCons t ts)) + (ts : TypeList) + : p ts + = TypeList#rec p f1 f2 ts; --- The recursor for primitive pair types at sort 1 -Pair__rec - (a b : sort 0) - (p : PairType a b -> sort 0) - (f : (x:a) -> (y:b) -> p (PairValue a b x y)) - (pair : PairType a b) - : p pair - = PairType#rec a b p f pair; +primitive Tuple : TypeList -> sort 0; -Pair_fst : (a b : sort 0) -> PairType a b -> a; -Pair_fst a b = Pair__rec a b (\ (p:PairType a b) -> a) - (\ (x:a) -> \ (y: b) -> x); +primitive headTuple : (t : sort 0) -> (ts : TypeList) -> Tuple (TypeCons t ts) -> t; +primitive tailTuple : (t : sort 0) -> (ts : TypeList) -> Tuple (TypeCons t ts) -> Tuple ts; +primitive consTuple : (t : sort 0) -> (ts : TypeList) -> t -> Tuple ts -> Tuple (TypeCons t ts); -Pair_snd : (a b : sort 0) -> PairType a b -> b; -Pair_snd a b = Pair__rec a b (\ (p:PairType a b) -> b) - (\ (x:a) -> \ (y:b) -> y); +-------------------------------------------------------------------------------- +-- Pair types -fst : (a b : sort 0) -> a * b -> a; -fst a b tup = tup.(1); +fst : (a b : sort 0) -> #(a, b) -> a; +fst a b tup = tup.0; -snd : (a b : sort 0) -> a * b -> b; -snd a b tup = tup.(2); +snd : (a b : sort 0) -> #(a, b) -> b; +snd a b tup = tup.1; -uncurry (a b c : sort 0) (f : a -> b -> c) : a * b -> c - = (\ (x : a * b) -> f x.(1) x.(2)); +uncurry (a b c : sort 0) (f : a -> b -> c) : #(a, b) -> c + = (\ (x : #(a, b)) -> f x.0 x.1); -------------------------------------------------------------------------------- -- String values @@ -426,11 +412,19 @@ implies__eq a b = Refl Bool (implies a b); -unitEq : UnitType -> UnitType -> Bool; +unitEq : Tuple TypeNil -> Tuple TypeNil -> Bool; unitEq _ _ = True; -pairEq : (a b : sort 0) -> (a -> a -> Bool) -> (b -> b -> Bool) -> a * b -> a * b -> Bool; -pairEq a b f g x y = and ( f x.(1) y.(1) ) ( g x.(2) y.(2) ); +pairEq : + (t : sort 0) -> + (ts : TypeList) -> + (t -> t -> Bool) -> + (Tuple ts -> Tuple ts -> Bool) -> + Tuple (TypeCons t ts) -> Tuple (TypeCons t ts) -> Bool; +pairEq t ts f g x y = + and + (f (headTuple t ts x) (headTuple t ts y)) + (g (tailTuple t ts x) (tailTuple t ts y)); -- @@ -1029,13 +1023,13 @@ expNat b e = Nat_cases Nat 1 (\ (e':Nat) -> \ (exp_b_e:Nat) -> mulNat b exp_b_e) e; -- | Natural division and modulus -primitive divModNat : Nat -> Nat -> Nat * Nat; +primitive divModNat : Nat -> Nat -> #(Nat, Nat); divNat : Nat -> Nat -> Nat; -divNat x y = (divModNat x y).(1); +divNat x y = (divModNat x y).0; modNat : Nat -> Nat -> Nat; -modNat x y = (divModNat x y).(2); +modNat x y = (divModNat x y).1; -- There are implicit constructors from integer literals. @@ -1196,7 +1190,7 @@ single = replicate 1; axiom at_single : (a : sort 0) -> (x : a) -> (i : Nat) -> Eq a (at 1 a (single a x) i) x; -- Zip together two lists (truncating the longer of the two). -primitive zip : (a b : sort 0) -> (m n : Nat) -> Vec m a -> Vec n b -> Vec (minNat m n) (a * b); +primitive zip : (a b : sort 0) -> (m n : Nat) -> Vec m a -> Vec n b -> Vec (minNat m n) #(a, b); primitive foldr : (a b : sort 0) -> (n : Nat) -> (a -> b -> b) -> b -> Vec n a -> b; primitive foldl : (a b : sort 0) -> (n : Nat) -> (b -> a -> b) -> b -> Vec n a -> b; @@ -1405,7 +1399,7 @@ bvCarry n x y = bvult n (bvAdd n x y) x; bvSCarry : (n : Nat) -> Vec (Succ n) Bool -> Vec (Succ n) Bool -> Bool; bvSCarry n x y = and (boolEq (msb n x) (msb n y)) (xor (msb n x) (msb n (bvAdd (Succ n) x y))); -bvAddWithCarry : (n : Nat) -> Vec n Bool -> Vec n Bool -> Bool * Vec n Bool; +bvAddWithCarry : (n : Nat) -> Vec n Bool -> Vec n Bool -> #(Bool, Vec n Bool); bvAddWithCarry n x y = (bvCarry n x y, bvAdd n x y); axiom bvAddZeroL : (n : Nat) -> (x : Vec n Bool) -> Eq (Vec n Bool) (bvAdd n (bvNat n 0) x) x; @@ -1753,20 +1747,20 @@ List__rec : (l : List a) -> P l; List__rec a P f1 f2 l = List#rec a P f1 f2 l; -unfoldList : (a:sort 0) -> List a -> Either #() (a * List a); +unfoldList : (a:sort 0) -> List a -> Either #() #(a, List a); unfoldList a l = - List__rec a (\ (_:List a) -> Either #() (a * List a)) - (Left #() (a * List a) ()) - (\ (x:a) (l:List a) (_:Either #() (a * List a)) -> - Right #() (a * List a) (x, l)) + List__rec a (\ (_:List a) -> Either #() #(a, List a)) + (Left #() #(a, List a) ()) + (\ (x:a) (l:List a) (_:Either #() #(a, List a)) -> + Right #() #(a, List a) (x, l)) l; -foldList : (a:sort 0) -> Either #() (a * List a) -> List a; +foldList : (a:sort 0) -> Either #() #(a, List a) -> List a; foldList a = - either #() (a * List a) (List a) + either #() #(a, List a) (List a) (\ (_ : #()) -> Nil a) - (\ (tup : (a * List a)) -> - Cons a tup.(1) tup.(2)); + (\ (tup : #(a, List a)) -> + Cons a tup.0 tup.1); -- A list of types, i.e. `List (sort 0)` if `List` was universe polymorphic data ListSort : sort 1 @@ -1985,29 +1979,27 @@ data W64List : sort 0 where { unfoldedW64List : sort 0; unfoldedW64List = - Either #() - (Sigma (Vec 64 Bool) (\ (_:Vec 64 Bool) -> #()) * W64List * #()); + Either #() #(Sigma (Vec 64 Bool) (\ (_:Vec 64 Bool) -> #()), W64List); unfoldW64List : W64List -> unfoldedW64List; unfoldW64List l = W64List#rec (\ (_:W64List) -> unfoldedW64List) - (Left #() (Sigma (Vec 64 Bool) (\ (_:Vec 64 Bool) -> #()) * W64List * #()) ()) + (Left #() #(Sigma (Vec 64 Bool) (\ (_:Vec 64 Bool) -> #()), W64List) ()) (\ (bv:Vec 64 Bool) (l':W64List) (_:unfoldedW64List) -> - Right #() (Sigma (Vec 64 Bool) (\ (_:Vec 64 Bool) -> #()) * W64List * #()) + Right #() #(Sigma (Vec 64 Bool) (\ (_:Vec 64 Bool) -> #()), W64List) (exists (Vec 64 Bool) (\ (_:Vec 64 Bool) -> #()) bv (), - l', ())) + l')) l; foldW64List : unfoldedW64List -> W64List; foldW64List = - either #() (Sigma (Vec 64 Bool) (\ (_:Vec 64 Bool) -> #()) * W64List * #()) + either #() #(Sigma (Vec 64 Bool) (\ (_:Vec 64 Bool) -> #()), W64List) W64List (\ (_:#()) -> W64Nil) - (\ (bv_l:(Sigma (Vec 64 Bool) (\ (_:Vec 64 Bool) -> #()) - * W64List * #())) -> + (\ (bv_l : #(Sigma (Vec 64 Bool) (\ (_:Vec 64 Bool) -> #()), W64List)) -> W64Cons (Sigma_proj1 (Vec 64 Bool) - (\ (_:Vec 64 Bool) -> #()) bv_l.(1)) - bv_l.(2).(1)); + (\ (_:Vec 64 Bool) -> #()) bv_l.0) + bv_l.1); -------------------------------------------------------------------------------- diff --git a/saw-core/src/SAWCore/Conversion.hs b/saw-core/src/SAWCore/Conversion.hs index a8e73a05eb..7cf036c1bb 100644 --- a/saw-core/src/SAWCore/Conversion.hs +++ b/saw-core/src/SAWCore/Conversion.hs @@ -376,14 +376,13 @@ pureApp mx y = do mkTermF (App x y) mkTuple :: [TermBuilder Term] -> TermBuilder Term -mkTuple [] = mkTermF (FTermF UnitValue) -mkTuple (t : ts) = mkTermF . FTermF =<< (PairValue <$> t <*> mkTuple ts) +mkTuple ts = mkTermF . FTermF . TupleValue . V.fromList =<< sequence ts +-- | Zero-indexed tuple field selection. mkTupleSelector :: Int -> Term -> TermBuilder Term mkTupleSelector i t - | i == 1 = mkTermF (FTermF (PairLeft t)) - | i > 1 = mkTermF (FTermF (PairRight t)) >>= mkTupleSelector (i - 1) - | otherwise = panic "mkTupleSelector" ["non-positive index: " <> Text.pack (show i)] + | i < 0 = panic "Verifier.SAW.Conversion.mkTupleSelector" ["non-positive index: " <> Text.pack (show i)] + | otherwise = mkTermF (FTermF (TupleSelector t i)) mkCtor :: Name -> [TermBuilder Term] -> [TermBuilder Term] -> TermBuilder Term mkCtor i paramsB argsB = diff --git a/saw-core/src/SAWCore/ExternalFormat.hs b/saw-core/src/SAWCore/ExternalFormat.hs index 399491720b..f2a33cba3f 100644 --- a/saw-core/src/SAWCore/ExternalFormat.hs +++ b/saw-core/src/SAWCore/ExternalFormat.hs @@ -139,13 +139,8 @@ scWriteExternal t0 = pure $ unwords ["Variable", show (ecVarIndex ec), show (ecType ec)] FTermF ftf -> case ftf of - UnitValue -> pure $ unwords ["Unit"] - UnitType -> pure $ unwords ["UnitT"] - PairValue x y -> pure $ unwords ["Pair", show x, show y] - PairType x y -> pure $ unwords ["PairT", show x, show y] - PairLeft e -> pure $ unwords ["ProjL", show e] - PairRight e -> pure $ unwords ["ProjR", show e] - + TupleValue xs -> pure $ unwords ("Tuple" : map show (V.toList xs)) + TupleSelector x i -> pure $ unwords ["TupleSelector", show x, show i] RecursorType d ps motive motive_ty -> do stashName d pure $ unwords @@ -299,12 +294,9 @@ scReadExternal sc input = ["Var", i] -> pure $ LocalVar (read i) ["Constant",i] -> Constant <$> readName i ["ConstantOpaque",i] -> Constant <$> readName i - ["Unit"] -> pure $ FTermF UnitValue - ["UnitT"] -> pure $ FTermF UnitType - ["Pair", x, y] -> FTermF <$> (PairValue <$> readIdx x <*> readIdx y) - ["PairT", x, y] -> FTermF <$> (PairType <$> readIdx x <*> readIdx y) - ["ProjL", x] -> FTermF <$> (PairLeft <$> readIdx x) - ["ProjR", x] -> FTermF <$> (PairRight <$> readIdx x) + ("Tuple" : xs) -> FTermF <$> (TupleValue <$> (V.fromList <$> traverse readIdx xs)) + ["TupleSelector", x, i] + -> FTermF <$> (TupleSelector <$> readIdx x <*> pure (read i)) ("RecursorType" : i : (separateArgs -> diff --git a/saw-core/src/SAWCore/OpenTerm.hs b/saw-core/src/SAWCore/OpenTerm.hs index 306461b624..4dcf91cb7a 100644 --- a/saw-core/src/SAWCore/OpenTerm.hs +++ b/saw-core/src/SAWCore/OpenTerm.hs @@ -72,20 +72,6 @@ module SAWCore.OpenTerm ( bitvectorTypeOpenTerm, bvVecTypeOpenTerm, listOpenTerm, list1OpenTerm, eitherTypeOpenTerm, sigmaTypeOpenTerm, sigmaTypeOpenTermMulti, sigmaOpenTerm, sigmaOpenTermMulti, sigmaElimOpenTermMulti, - -- * Operations for building @SpecM@ computations - EventType (..), defaultSpecMEventType, unitKindDesc, bvExprKind, - tpDescTypeOpenTerm, kindToTpDesc, unitTpDesc, - boolExprKind, boolKindDesc, boolTpDesc, natExprKind, natKindDesc, - numExprKind, numKindDesc, bvKindDesc, bvTpDesc, tpKindDesc, - pairTpDesc, tupleTpDesc, sumTpDesc, bvVecTpDesc, - constTpExpr, bvConstTpExpr, binOpTpExpr, bvSumTpExprs, - bvMulTpExpr, sigmaTpDesc, sigmaTpDescMulti, seqTpDesc, arrowTpDesc, - arrowTpDescMulti, mTpDesc, funTpDesc, piTpDesc, piTpDescMulti, voidTpDesc, - varTpDesc, varTpExpr, varKindExpr, constKindExpr, indTpDesc, - substTpDesc, substTpDescMulti, substIdTpDescMulti, substIndIdTpDescMulti, - tpElemTypeOpenTerm, - substEnvTpDesc, tpEnvOpenTerm, specMTypeOpenTerm, retSOpenTerm, - bindSOpenTerm, errorSOpenTerm, letRecSOpenTerm, multiFixBodiesOpenTerm, -- * Monadic operations for building terms including 'IO' actions OpenTermM(..), completeOpenTermM, dedupOpenTermM, lambdaOpenTermM, piOpenTermM, @@ -214,11 +200,11 @@ natOpenTerm = flatOpenTerm . NatLit -- | The 'OpenTerm' for the unit value unitOpenTerm :: OpenTerm -unitOpenTerm = flatOpenTerm UnitValue +unitOpenTerm = tupleOpenTerm [] -- | The 'OpenTerm' for the unit type unitTypeOpenTerm :: OpenTerm -unitTypeOpenTerm = flatOpenTerm UnitType +unitTypeOpenTerm = tupleTypeOpenTerm [] -- | Build a SAW core string literal. stringLitOpenTerm :: Text -> OpenTerm @@ -267,55 +253,55 @@ bvTypeOpenTerm n = -- | Build an 'OpenTerm' for a pair pairOpenTerm :: OpenTerm -> OpenTerm -> OpenTerm -pairOpenTerm t1 t2 = flatOpenTerm $ PairValue t1 t2 +pairOpenTerm t1 t2 = tupleOpenTerm [t1, t2] -- | Build an 'OpenTerm' for a pair type pairTypeOpenTerm :: OpenTerm -> OpenTerm -> OpenTerm -pairTypeOpenTerm t1 t2 = flatOpenTerm $ PairType t1 t2 +pairTypeOpenTerm t1 t2 = tupleTypeOpenTerm [t1, t2] -- | Build an 'OpenTerm' for the left projection of a pair pairLeftOpenTerm :: OpenTerm -> OpenTerm -pairLeftOpenTerm t = flatOpenTerm $ PairLeft t +pairLeftOpenTerm t = projTupleOpenTerm 0 t -- | Build an 'OpenTerm' for the right projection of a pair pairRightOpenTerm :: OpenTerm -> OpenTerm -pairRightOpenTerm t = flatOpenTerm $ PairRight t +pairRightOpenTerm t = projTupleOpenTerm 1 t --- | Build a right-nested tuple as an 'OpenTerm' +-- | Build a tuple as an 'OpenTerm' tupleOpenTerm :: [OpenTerm] -> OpenTerm -tupleOpenTerm = foldr pairOpenTerm unitOpenTerm +tupleOpenTerm ts = flatOpenTerm $ TupleValue (V.fromList ts) --- | Build a right-nested tuple type as an 'OpenTerm' +-- | Build a tuple type as an 'OpenTerm' tupleTypeOpenTerm :: [OpenTerm] -> OpenTerm -tupleTypeOpenTerm = foldr pairTypeOpenTerm unitTypeOpenTerm +tupleTypeOpenTerm ts = applyGlobalOpenTerm "Prelude.Tuple" [typeListOpenTerm ts] --- | Project the @n@th element of a right-nested tuple type -projTupleOpenTerm :: Integer -> OpenTerm -> OpenTerm -projTupleOpenTerm 0 t = pairLeftOpenTerm t -projTupleOpenTerm i t = projTupleOpenTerm (i-1) (pairRightOpenTerm t) +typeListOpenTerm :: [OpenTerm] -> OpenTerm +typeListOpenTerm [] = + applyGlobalOpenTerm "Prelude.TypeNil" [] +typeListOpenTerm (t : ts) = + applyGlobalOpenTerm "Prelude.TypeCons" [t, typeListOpenTerm ts] + +-- | Project the @n@th element of a tuple type. +projTupleOpenTerm :: Natural -> OpenTerm -> OpenTerm +projTupleOpenTerm i t + | otherwise = flatOpenTerm $ TupleSelector t (fromIntegral i) -- FIXME: unchecked fromIntegral --- | Build a right-nested tuple as an 'OpenTerm' but without adding a final unit --- as the right-most element +-- | Build a tuple as an 'OpenTerm', while avoiding 1-tuples. tupleOpenTerm' :: [OpenTerm] -> OpenTerm -tupleOpenTerm' [] = unitOpenTerm -tupleOpenTerm' ts = foldr1 pairOpenTerm ts +tupleOpenTerm' [t] = t +tupleOpenTerm' ts = flatOpenTerm $ TupleValue (V.fromList ts) --- | Build a right-nested tuple type as an 'OpenTerm' but without adding a final --- unit type as the right-most element +-- | Build a tuple type as an 'OpenTerm', while avoiding 1-tuples. tupleTypeOpenTerm' :: [OpenTerm] -> OpenTerm -tupleTypeOpenTerm' [] = unitTypeOpenTerm -tupleTypeOpenTerm' ts = foldr1 pairTypeOpenTerm ts +tupleTypeOpenTerm' [t] = t +tupleTypeOpenTerm' ts = applyGlobalOpenTerm "Prelude.Tuple" [typeListOpenTerm ts] --- | Project the @i@th element from a term of a right-nested tuple term that --- does not have a final unit type as the right-most type. The first argument is --- the number of types used to make the tuple type and the second is the index. +-- | Project the @n@th element of a tuple type while avoiding 1-tuples. +-- The first argument is the number of types used to make the tuple type and the second is the index. projTupleOpenTerm' :: Natural -> Natural -> OpenTerm -> OpenTerm -projTupleOpenTerm' 0 _ _ = - panic "projTupleOpenTerm'" ["Projection of empty tuple!"] -projTupleOpenTerm' 1 0 tup = tup -projTupleOpenTerm' _ 0 tup = pairLeftOpenTerm tup -projTupleOpenTerm' len i tup = - projTupleOpenTerm' (len-1) (i-1) $ pairRightOpenTerm tup +projTupleOpenTerm' len i t + | len == 1 = t + | otherwise = flatOpenTerm $ TupleSelector t (fromIntegral i) -- FIXME: unchecked fromIntegral -- | Build a record value as an 'OpenTerm' recordOpenTerm :: [(FieldName, OpenTerm)] -> OpenTerm @@ -559,288 +545,6 @@ sigmaElimOpenTermMulti x (tp:tps) tp_f sig f_elim = sigmaElimOpenTermMulti x tps (tp_f . (proj1:)) proj2 (f_elim . (proj1:)) --------------------------------------------------------------------------------- --- Operations for building SpecM computations - --- | A SAW core term that indicates an event type for the @SpecM@ monad -newtype EventType = EventType { evTypeTerm :: OpenTerm } - --- | The default event type uses the @Void@ type for events -defaultSpecMEventType :: EventType -defaultSpecMEventType = EventType $ globalOpenTerm "SpecM.VoidEv" - --- | The kind description for the unit type -unitKindDesc :: OpenTerm -unitKindDesc = ctorOpenTerm "SpecM.Kind_Expr" [ctorOpenTerm - "SpecM.Kind_unit" []] - --- | The @ExprKind@ for the bitvector type with width @w@ -bvExprKind :: Natural -> OpenTerm -bvExprKind w = ctorOpenTerm "SpecM.Kind_bv" [natOpenTerm w] - --- | The type @TpDesc@ of type descriptions -tpDescTypeOpenTerm :: OpenTerm -tpDescTypeOpenTerm = dataTypeOpenTerm "SpecM.TpDesc" [] - --- | Convert a kind description to a type description with the @Tp_Kind@ --- constructor -kindToTpDesc :: OpenTerm -> OpenTerm -kindToTpDesc d = ctorOpenTerm "SpecM.Tp_Kind" [d] - --- | The type description for the unit type -unitTpDesc :: OpenTerm -unitTpDesc = ctorOpenTerm "SpecM.Tp_Kind" [unitKindDesc] - --- | The expression kind for the Boolean type -boolExprKind :: OpenTerm -boolExprKind = ctorOpenTerm "SpecM.Kind_bool" [] - --- | The kind description for the Boolean type -boolKindDesc :: OpenTerm -boolKindDesc = ctorOpenTerm "SpecM.Kind_Expr" [boolExprKind] - --- | The type description for the Boolean type -boolTpDesc :: OpenTerm -boolTpDesc = ctorOpenTerm "SpecM.Tp_Kind" [boolKindDesc] - --- | The expression kind for the @Nat@ type -natExprKind :: OpenTerm -natExprKind = ctorOpenTerm "SpecM.Kind_nat" [] - --- | The expression kind for the @Num@ type -numExprKind :: OpenTerm -numExprKind = ctorOpenTerm "SpecM.Kind_num" [] - --- | The kind description for the @Nat@ type -natKindDesc :: OpenTerm -natKindDesc = ctorOpenTerm "SpecM.Kind_Expr" [natExprKind] - --- | The kind description for the @Num@ type -numKindDesc :: OpenTerm -numKindDesc = ctorOpenTerm "SpecM.Kind_Expr" [numExprKind] - --- | The kind description for the type @bitvector w@ -bvKindDesc :: Natural -> OpenTerm -bvKindDesc w = ctorOpenTerm "SpecM.Kind_Expr" [bvExprKind w] - --- | The type description for thhe type @bitvector w@ -bvTpDesc :: Natural -> OpenTerm -bvTpDesc w = applyGlobalOpenTerm "SpecM.Tp_bitvector" [natOpenTerm w] - --- | The kind description for the type of type descriptions -tpKindDesc :: OpenTerm -tpKindDesc = ctorOpenTerm "SpecM.Kind_Tp" [] - --- | Build a pair type description from two type descriptions -pairTpDesc :: OpenTerm -> OpenTerm -> OpenTerm -pairTpDesc d1 d2 = ctorOpenTerm "SpecM.Tp_Pair" [d1,d2] - --- | Build a tuple type description from a list of type descriptions -tupleTpDesc :: [OpenTerm] -> OpenTerm -tupleTpDesc [] = unitTpDesc -tupleTpDesc [d] = d -tupleTpDesc (d : ds) = pairTpDesc d (tupleTpDesc ds) - --- | Build a sum type description from two type descriptions -sumTpDesc :: OpenTerm -> OpenTerm -> OpenTerm -sumTpDesc d1 d2 = ctorOpenTerm "SpecM.Tp_Sum" [d1,d2] - --- | Build a type description for the type @BVVec n len d@ from a SAW core term --- @n@ of type @Nat@, a type expression @len@ for the length, and a type --- description @d@ for the element type -bvVecTpDesc :: OpenTerm -> OpenTerm -> OpenTerm -> OpenTerm -bvVecTpDesc w_term len_term elem_d = - applyGlobalOpenTerm "SpecM.Tp_BVVec" [w_term, len_term, elem_d] - --- | Build a type expression of type @TpExpr EK@ of kind description @EK@ from a --- type-level value of type @exprKindElem EK@ -constTpExpr :: OpenTerm -> OpenTerm -> OpenTerm -constTpExpr k_d v = ctorOpenTerm "SpecM.TpExpr_Const" [k_d, v] - --- | Build a type description expression from a bitvector value of a given width -bvConstTpExpr :: Natural -> OpenTerm -> OpenTerm -bvConstTpExpr w bv = constTpExpr (bvExprKind w) bv - --- | Build a type expression from a binary operation, the given input kinds and --- output kind, and the given expression arguments -binOpTpExpr :: OpenTerm -> OpenTerm -> OpenTerm -> OpenTerm -> - OpenTerm -> OpenTerm -> OpenTerm -binOpTpExpr op k1 k2 k3 e1 e2 = - ctorOpenTerm "SpecM.TpExpr_BinOp" [k1, k2, k3, op, e1, e2] - --- | Build a type expression for the bitvector sum of a list of type --- expressions, all of the given width -bvSumTpExprs :: Natural -> [OpenTerm] -> OpenTerm -bvSumTpExprs w [] = bvConstTpExpr w (natOpenTerm 0) -bvSumTpExprs _ [bv] = bv -bvSumTpExprs w (bv:bvs) = - ctorOpenTerm "SpecM.TpExpr_BinOp" - [bvExprKind w, bvExprKind w, bvExprKind w, - ctorOpenTerm "SpecM.BinOp_AddBV" [natOpenTerm w], bv, bvSumTpExprs w bvs] - --- | Build a type expression for the bitvector product of two type expressions -bvMulTpExpr :: Natural -> OpenTerm -> OpenTerm -> OpenTerm -bvMulTpExpr w bv1 bv2 = - ctorOpenTerm "SpecM.TpExpr_BinOp" - [bvExprKind w, bvExprKind w, bvExprKind w, - ctorOpenTerm "SpecM.BinOp_MulBV" [natOpenTerm w], bv1, bv2] - --- | Build a type description for a sigma type from a kind description for the --- first element and a type description with an additional free variable for the --- second -sigmaTpDesc :: OpenTerm -> OpenTerm -> OpenTerm -sigmaTpDesc k d = ctorOpenTerm "SpecM.Tp_Sigma" [k,d] - --- | Build a type description for 0 or more nested sigma types over a list of --- kind descriptions -sigmaTpDescMulti :: [OpenTerm] -> OpenTerm -> OpenTerm -sigmaTpDescMulti [] d = d -sigmaTpDescMulti (k:ks) d = sigmaTpDesc k $ sigmaTpDescMulti ks d - --- | Build a type description for a sequence -seqTpDesc :: OpenTerm -> OpenTerm -> OpenTerm -seqTpDesc n d = ctorOpenTerm "SpecM.Tp_Seq" [n, d] - --- | Build an arrow type description for left- and right-hand type descriptions -arrowTpDesc :: OpenTerm -> OpenTerm -> OpenTerm -arrowTpDesc d_in d_out = ctorOpenTerm "SpecM.Tp_Arr" [d_in, d_out] - --- | Build a multi-arity nested arrow type description -arrowTpDescMulti :: [OpenTerm] -> OpenTerm -> OpenTerm -arrowTpDescMulti ds_in d_out = foldr arrowTpDesc d_out ds_in - --- | Build a monadic type description, i.e., a nullary monadic function -mTpDesc :: OpenTerm -> OpenTerm -mTpDesc d = ctorOpenTerm "SpecM.Tp_M" [d] - --- | Build the type description @Tp_Arr d1 (... (Tp_Arr dn (Tp_M d_ret)))@ for a --- monadic function that takes in the types described by @d1@ through @dn@ and --- returns the type described by @d_ret@ -funTpDesc :: [OpenTerm] -> OpenTerm -> OpenTerm -funTpDesc ds_in d_ret = arrowTpDescMulti ds_in (mTpDesc d_ret) - --- | Build the type description for a pi-abstraction over a kind description -piTpDesc :: OpenTerm -> OpenTerm -> OpenTerm -piTpDesc kd tpd = ctorOpenTerm "SpecM.Tp_Pi" [kd, tpd] - --- | Build the type description for a multi-arity pi-abstraction over a sequence --- of kind descriptions, i.e., SAW core terms of type @KindDesc@ -piTpDescMulti :: [OpenTerm] -> OpenTerm -> OpenTerm -piTpDescMulti ks tp = foldr piTpDesc tp ks - --- | The type description for the @Void@ type -voidTpDesc :: OpenTerm -voidTpDesc = ctorOpenTerm "SpecM.Tp_Void" [] - --- | Build a type description for a free deBruijn index -varTpDesc :: Natural -> OpenTerm -varTpDesc ix = ctorOpenTerm "SpecM.Tp_Var" [natOpenTerm ix] - --- | Build a type-level expression with a given @ExprKind@ for a free variable -varTpExpr :: OpenTerm -> Natural -> OpenTerm -varTpExpr ek ix = ctorOpenTerm "SpecM.TpExpr_Var" [ek, natOpenTerm ix] - --- | Build a kind expression of a given kind from a deBruijn index -varKindExpr :: OpenTerm -> Natural -> OpenTerm -varKindExpr d ix = applyGlobalOpenTerm "SpecM.varKindExpr" [d,natOpenTerm ix] - --- | Build a kind expression of a given kind from an element of that kind -constKindExpr :: OpenTerm -> OpenTerm -> OpenTerm -constKindExpr d e = applyGlobalOpenTerm "SpecM.constKindExpr" [d,e] - --- | Build the type description @Tp_Ind T@ that represents a recursively-defined --- inductive type that unfolds to @[Tp_Ind T/x]T@ -indTpDesc :: OpenTerm -> OpenTerm -indTpDesc d = ctorOpenTerm "SpecM.Tp_Ind" [d] - --- | Build the type description @Tp_Subst T K e@ that represents an explicit --- substitution of expression @e@ of kind @K@ into type description @T@ -substTpDesc :: OpenTerm -> OpenTerm -> OpenTerm -> OpenTerm -substTpDesc d k_d e = applyGlobalOpenTerm "SpecM.Tp_Subst" [d,k_d,e] - --- | Build the type description that performs 0 or more explicit substitutions -substTpDescMulti :: OpenTerm -> [OpenTerm] -> [OpenTerm] -> OpenTerm -substTpDescMulti d [] [] = d -substTpDescMulti d (k_d:k_ds) (e:es) = - substTpDescMulti (substTpDesc d k_d e) k_ds es -substTpDescMulti _ ks es = - panic "substTpDescMulti" [ - "Mismatched number of kinds versus expressions", - Text.pack (show $ length ks) <> " remaining kinds", - Text.pack (show $ length es) <> " remaining exprs", - "(sorry, the terms themselves are unresolved monadic computations)" - ] - --- | Build the type description that performs 0 or more explicit substitutions --- into a type description given by an identifier -substIdTpDescMulti :: Ident -> [OpenTerm] -> [OpenTerm] -> OpenTerm -substIdTpDescMulti i = substTpDescMulti (globalOpenTerm i) - --- | Build the type description that performs 0 or more explicit substitutions --- into an inductive type description @Tp_Ind T@ where the body @T@ is given by --- an identifier -substIndIdTpDescMulti :: Ident -> [OpenTerm] -> [OpenTerm] -> OpenTerm -substIndIdTpDescMulti i = substTpDescMulti (indTpDesc (globalOpenTerm i)) - --- | Map from type description @T@ to the type @T@ describes -tpElemTypeOpenTerm :: EventType -> OpenTerm -> OpenTerm -tpElemTypeOpenTerm ev d = - applyGlobalOpenTerm "SpecM.tpElem" [evTypeTerm ev, d] - --- | Apply the @tpSubst@ combinator to substitute a type-level environment --- (built by applying 'tpEnvOpenTerm' to the supplied list) at the supplied --- natural number lifting level to a type description -substEnvTpDesc :: Natural -> [(OpenTerm,OpenTerm)] -> OpenTerm -> OpenTerm -substEnvTpDesc n ks_elems d = - applyGlobalOpenTerm "SpecM.tpSubst" [natOpenTerm n, - tpEnvOpenTerm ks_elems, d] - --- | Build a SAW core term for a type-level environment, i.e., a term of type --- @TpEnv@, from a list of kind descriptions and elements of those kind --- descriptions -tpEnvOpenTerm :: [(OpenTerm,OpenTerm)] -> OpenTerm -tpEnvOpenTerm = - foldr (\(k,v) env -> applyGlobalOpenTerm "SpecM.envConsElem" [k,v,env]) - (ctorOpenTerm "Prelude.Nil" [globalOpenTerm "SpecM.TpEnvElem"]) - --- | Build the computation type @SpecM E A@ -specMTypeOpenTerm :: EventType -> OpenTerm -> OpenTerm -specMTypeOpenTerm ev tp = - applyGlobalOpenTerm "SpecM.SpecM" [evTypeTerm ev, tp] - --- | Build a @SpecM@ computation that returns a value -retSOpenTerm :: EventType -> OpenTerm -> OpenTerm -> OpenTerm -retSOpenTerm ev tp x = - applyGlobalOpenTerm "SpecM.retS" [evTypeTerm ev, tp, x] - --- | Build a @SpecM@ computation using a bind -bindSOpenTerm :: EventType -> OpenTerm -> OpenTerm -> OpenTerm -> OpenTerm -> - OpenTerm -bindSOpenTerm ev a b m f = - applyGlobalOpenTerm "SpecM.bindS" [evTypeTerm ev, a, b, m, f] - --- | Build a @SpecM@ error computation with the given error message -errorSOpenTerm :: EventType -> OpenTerm -> String -> OpenTerm -errorSOpenTerm ev ret_tp msg = - applyGlobalOpenTerm "SpecM.errorS" - [evTypeTerm ev, ret_tp, stringLitOpenTerm (Text.pack msg)] - --- | Build a @SpecM@ computation that uses @LetRecS@ to bind multiple --- corecursive functions in a body computation -letRecSOpenTerm :: EventType -> [OpenTerm] -> OpenTerm -> OpenTerm -> - OpenTerm -> OpenTerm -letRecSOpenTerm ev ds ret_tp bodies body = - applyGlobalOpenTerm "SpecM.LetRecS" - [evTypeTerm ev, listOpenTerm tpDescTypeOpenTerm ds, ret_tp, bodies, body] - --- | Build the type @MultiFixBodies E Ts@ from an event type and a list of type --- descriptions for @Ts@ -multiFixBodiesOpenTerm :: EventType -> [OpenTerm] -> OpenTerm -multiFixBodiesOpenTerm ev ds = - applyGlobalOpenTerm "SpecM.MultiFixBodies" - [evTypeTerm ev, listOpenTerm tpDescTypeOpenTerm ds] - - -------------------------------------------------------------------------------- -- Monadic operations for building terms including 'IO' actions @@ -1008,11 +712,11 @@ natTermLike = flatTermLike . NatLit -- | The term for the unit value unitTermLike :: OpenTermLike t => t -unitTermLike = flatTermLike UnitValue +unitTermLike = tupleTermLike [] -- | The term for the unit type unitTypeTermLike :: OpenTermLike t => t -unitTypeTermLike = flatTermLike UnitType +unitTypeTermLike = tupleTypeTermLike [] -- | Build a SAW core string literal. stringLitTermLike :: OpenTermLike t => Text -> t @@ -1061,23 +765,23 @@ bvTypeTermLike n = -- | Build a term for a pair pairTermLike :: OpenTermLike t => t -> t -> t -pairTermLike t1 t2 = flatTermLike $ PairValue t1 t2 +pairTermLike t1 t2 = tupleTermLike [t1, t2] -- | Build a term for a pair type pairTypeTermLike :: OpenTermLike t => t -> t -> t -pairTypeTermLike t1 t2 = flatTermLike $ PairType t1 t2 +pairTypeTermLike t1 t2 = tupleTypeTermLike [t1, t2] -- | Build a term for the left projection of a pair pairLeftTermLike :: OpenTermLike t => t -> t -pairLeftTermLike t = flatTermLike $ PairLeft t +pairLeftTermLike t = flatTermLike $ TupleSelector t 0 -- | Build a term for the right projection of a pair pairRightTermLike :: OpenTermLike t => t -> t -pairRightTermLike t = flatTermLike $ PairRight t +pairRightTermLike t = flatTermLike $ TupleSelector t 1 -- | Build a right-nested tuple as a term tupleTermLike :: OpenTermLike t => [t] -> t -tupleTermLike = foldr pairTermLike unitTermLike +tupleTermLike ts = flatTermLike $ TupleValue (V.fromList ts) -- | Build a right-nested tuple type as a term tupleTypeTermLike :: OpenTermLike t => [t] -> t diff --git a/saw-core/src/SAWCore/Parser/AST.hs b/saw-core/src/SAWCore/Parser/AST.hs index 519fc388d7..0ceea282a3 100644 --- a/saw-core/src/SAWCore/Parser/AST.hs +++ b/saw-core/src/SAWCore/Parser/AST.hs @@ -66,17 +66,14 @@ data UTerm | Lambda Pos UTermCtx UTerm | Pi Pos UTermCtx UTerm | Recursor (PosPair Text) - | UnitValue Pos - | UnitType Pos -- | New-style records | RecordValue Pos [(PosPair FieldName, UTerm)] | RecordType Pos [(PosPair FieldName, UTerm)] | RecordProj UTerm FieldName - -- | Simple pairs - | PairValue Pos UTerm UTerm - | PairType Pos UTerm UTerm - | PairLeft UTerm - | PairRight UTerm + -- | Tuples + | TupleValue Pos [UTerm] + | TupleType Pos [UTerm] + | TupleProj UTerm Int -- | Identifies a type constraint on the term, i.e., a type ascription | TypeConstraint UTerm Pos UTerm | NatLit Pos Natural @@ -116,15 +113,12 @@ instance Positioned UTerm where App x _ -> pos x Pi p _ _ -> p Recursor i -> pos i - UnitValue p -> p - UnitType p -> p RecordValue p _ -> p RecordType p _ -> p RecordProj x _ -> pos x - PairValue p _ _ -> p - PairType p _ _ -> p - PairLeft x -> pos x - PairRight x -> pos x + TupleValue p _ -> p + TupleType p _ -> p + TupleProj x _ -> pos x TypeConstraint _ p _ -> p NatLit p _ -> p StringLit p _ -> p @@ -239,21 +233,14 @@ asApp = go [] -- | Build a tuple value @(x1, .., xn)@. mkTupleValue :: Pos -> [UTerm] -> UTerm -mkTupleValue p [] = UnitValue p mkTupleValue _ [x] = x -mkTupleValue p (x:xs) = PairValue (pos x) x (mkTupleValue p xs) +mkTupleValue p xs = TupleValue p xs -- | Build a tuple type @#(x1, .., xn)@. mkTupleType :: Pos -> [UTerm] -> UTerm -mkTupleType p [] = UnitType p mkTupleType _ [x] = x -mkTupleType p (x:xs) = PairType (pos x) x (mkTupleType p xs) +mkTupleType p xs = TupleType p xs --- | Build a projection @t.i@ of a tuple. NOTE: This function does not --- work to access the last component in a tuple, since it always --- generates a @PairLeft@. +-- | Build a projection @t.i@ of a tuple. mkTupleSelector :: UTerm -> Natural -> UTerm -mkTupleSelector t i - | i == 1 = PairLeft t - | i > 1 = mkTupleSelector (PairRight t) (i - 1) - | otherwise = error "mkTupleSelector: non-positive index" +mkTupleSelector t i = TupleProj t (fromIntegral i) -- FIXME: unchecked fromIntegral diff --git a/saw-core/src/SAWCore/Parser/Grammar.y b/saw-core/src/SAWCore/Parser/Grammar.y index 4aa8d7ac0f..63bf5fa78c 100644 --- a/saw-core/src/SAWCore/Parser/Grammar.y +++ b/saw-core/src/SAWCore/Parser/Grammar.y @@ -171,14 +171,9 @@ Term :: { UTerm } : -- Term with uses of pi and lambda, but no type ascriptions LTerm :: { UTerm } : - ProdTerm { $1 } - | ProdTerm '->' LTerm { Pi (pos $2) (mkPiArg $1) $3 } - | '\\' VarCtx '->' LTerm { Lambda (pos $1) $2 $4 } - --- Term formed from infix product type operator (right-associative) -ProdTerm :: { UTerm } : AppTerm { $1 } - | AppTerm '*' ProdTerm { PairType (pos $1) $1 $3 } + | AppTerm '->' LTerm { Pi (pos $2) (mkPiArg $1) $3 } + | '\\' VarCtx '->' LTerm { Lambda (pos $1) $2 $4 } -- Term formed from applications of atomic expressions AppTerm :: { UTerm } : @@ -195,13 +190,12 @@ AtomTerm :: { UTerm } : | 'Prop' { Sort (pos $1) propSort noFlags } | Sort nat { Sort (pos $1) (mkSort (tokNat (val $2))) (val $1) } | AtomTerm '.' Ident { RecordProj $1 (val $3) } - | AtomTerm '.' nat {% parseTupleSelector $1 (fmap tokNat $3) } + | AtomTerm '.' nat { mkTupleSelector $1 (tokNat (val $3)) } | '(' sepBy(Term, ',') ')' { mkTupleValue (pos $1) $2 } | '#' '(' sepBy(Term, ',') ')' { mkTupleType (pos $1) $3 } | '[' sepBy(Term, ',') ']' { VecLit (pos $1) $2 } | '{' sepBy(FieldValue, ',') '}' { RecordValue (pos $1) $2 } | '#' '{' sepBy(FieldType, ',') '}' { RecordType (pos $1) $3 } - | AtomTerm '.' '(' nat ')' {% mkTupleProj $1 (tokNat (val $4)) } -- Identifier (wrapper to extract the text) Ident :: { PosPair Text } : @@ -339,17 +333,9 @@ mkPiArg (TypeConstraint (exprAsIdentList -> Just xs) _ t) = map (\x -> (x, t)) xs mkPiArg lhs = [(UnusedVar (pos lhs), lhs)] --- | Parse a tuple projection of the form @t.(1)@ or @t.(2)@ -mkTupleProj :: UTerm -> Natural -> Parser UTerm -mkTupleProj t 1 = return $ PairLeft t -mkTupleProj t 2 = return $ PairRight t -mkTupleProj t _ = - do addParseError (pos t) "Projections must be either .(1) or .(2)" - return (badTerm (pos t)) - parseTupleSelector :: UTerm -> PosPair Natural -> Parser UTerm parseTupleSelector t i = - if val i >= 1 then return (mkTupleSelector t (val i)) else + if val i >= 0 then return (mkTupleSelector t (val i)) else do addParseError (pos t) "non-positive tuple projection index" return (badTerm (pos t)) diff --git a/saw-core/src/SAWCore/Prelude.hs b/saw-core/src/SAWCore/Prelude.hs index f90da1a498..a81967275f 100644 --- a/saw-core/src/SAWCore/Prelude.hs +++ b/saw-core/src/SAWCore/Prelude.hs @@ -102,14 +102,12 @@ scDecEq sc fot args = case fot of Nothing -> scGlobalDef sc "Prelude.unitEq" Just _ -> scBool sc True - FOTTuple [t] -> scDecEq sc t args - FOTTuple (t:ts) -> do fnLeft <- scDecEq sc t Nothing fnRight <- scDecEq sc (FOTTuple ts) Nothing fn <- scGlobalDef sc "Prelude.pairEq" t' <- scFirstOrderType sc t - ts' <- scFirstOrderType sc (FOTTuple ts) + ts' <- scTypeList sc =<< traverse (scFirstOrderType sc) ts case args of Nothing -> scApplyAll sc fn [t',ts',fnLeft,fnRight] Just (x,y) -> scApplyAll sc fn [t',ts',fnLeft,fnRight,x,y] @@ -119,7 +117,7 @@ scDecEq sc fot args = case fot of Just (x,y) -> mkRecordEqBody (Map.toList fs) x y - Nothing -> + Nothing -> do x <- scLocalVar sc 1 y <- scLocalVar sc 0 tp <- scFirstOrderType sc fot diff --git a/saw-core/src/SAWCore/Prelude/Constants.hs b/saw-core/src/SAWCore/Prelude/Constants.hs index f36f4dbd35..f93cf45652 100644 --- a/saw-core/src/SAWCore/Prelude/Constants.hs +++ b/saw-core/src/SAWCore/Prelude/Constants.hs @@ -25,6 +25,12 @@ preludeZeroIdent = mkIdent preludeModuleName "Zero" preludeSuccIdent :: Ident preludeSuccIdent = mkIdent preludeModuleName "Succ" +preludeTypeNilIdent :: Ident +preludeTypeNilIdent = mkIdent preludeModuleName "TypeNil" + +preludeTypeConsIdent :: Ident +preludeTypeConsIdent = mkIdent preludeModuleName "TypeCons" + preludeIntegerIdent :: Ident preludeIntegerIdent = mkIdent preludeModuleName "Integer" diff --git a/saw-core/src/SAWCore/Recognizer.hs b/saw-core/src/SAWCore/Recognizer.hs index 82de5f8744..094abf118d 100644 --- a/saw-core/src/SAWCore/Recognizer.hs +++ b/saw-core/src/SAWCore/Recognizer.hs @@ -28,9 +28,6 @@ module SAWCore.Recognizer , (<@>), (@>), (<@) , asApplyAll , asGlobalApply - , asPairType - , asPairValue - , asPairSelector , asTupleType , asTupleValue , asTupleSelector @@ -172,63 +169,29 @@ asGlobalApply i t = isGlobalDef i f pure xs -asPairType :: Recognizer Term (Term, Term) -asPairType t = do - ftf <- asFTermF t - case ftf of - PairType x y -> return (x, y) - _ -> Nothing - -asPairValue :: Recognizer Term (Term, Term) -asPairValue t = do - ftf <- asFTermF t - case ftf of - PairValue x y -> return (x, y) - _ -> Nothing - -asPairSelector :: Recognizer Term (Term, Bool) -asPairSelector t = do - ftf <- asFTermF t - case ftf of - PairLeft x -> return (x, False) - PairRight x -> return (x, True) - _ -> Nothing - -destTupleType :: Term -> [Term] -destTupleType t = - case unwrapTermF t of - FTermF (PairType x y) -> x : destTupleType y - _ -> [t] - -destTupleValue :: Term -> [Term] -destTupleValue t = - case unwrapTermF t of - FTermF (PairValue x y) -> x : destTupleType y - _ -> [t] +asTypeList :: Recognizer Term [Term] +asTypeList (asGlobalApply preludeTypeNilIdent -> Just []) = + Just [] +asTypeList (asGlobalApply preludeTypeConsIdent -> Just [t, asTypeList -> Just ts]) = + Just (t : ts) +asTypeList _ = Nothing asTupleType :: Recognizer Term [Term] -asTupleType t = - do ftf <- asFTermF t - case ftf of - UnitType -> Just [] - PairType x y -> Just (x : destTupleType y) - _ -> Nothing +asTupleType = isGlobalDef "Prelude.Tuple" @> asTypeList asTupleValue :: Recognizer Term [Term] asTupleValue t = do ftf <- asFTermF t case ftf of - UnitValue -> Just [] - PairValue x y -> Just (x : destTupleValue y) + TupleValue xs -> Just (V.toList xs) _ -> Nothing asTupleSelector :: Recognizer Term (Term, Int) -asTupleSelector t = do - ftf <- asFTermF t - case ftf of - PairLeft x -> return (x, 1) - PairRight y -> do (x, i) <- asTupleSelector y; return (x, i+1) - _ -> Nothing +asTupleSelector t = + do ftf <- asFTermF t + case ftf of + TupleSelector x i -> Just (x, i) + _ -> Nothing asRecordType :: Recognizer Term (Map FieldName Term) asRecordType t = do diff --git a/saw-core/src/SAWCore/Rewriter.hs b/saw-core/src/SAWCore/Rewriter.hs index dbf79dc10a..adfa6f8545 100644 --- a/saw-core/src/SAWCore/Rewriter.hs +++ b/saw-core/src/SAWCore/Rewriter.hs @@ -73,6 +73,7 @@ import Data.List.Extra (nubOrd) import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set +import qualified Data.Vector as V import Control.Monad.Trans.Writer.Strict import Numeric.Natural @@ -623,9 +624,9 @@ asBetaRedex t = asPairRedex :: R.Recognizer Term Term asPairRedex t = - do (u, b) <- R.asPairSelector t - (x, y) <- R.asPairValue u - return (if b then y else x) + do (u, i) <- R.asTupleSelector t + ts <- R.asTupleValue u + return (ts !! i) asRecordRedex :: R.Recognizer Term Term asRecordRedex t = @@ -674,7 +675,7 @@ appCollectedArgs t = step0 (unshared t) [] step1 f args = foldl (++) [] (map (\ x -> step2 f $ unshared x) args) -- step2: analyse an arg. look inside tuples, sequences (TBD), more calls to f step2 :: TermF Term -> TermF Term -> [Term] - step2 f (FTermF (PairValue x y)) = (step2 f $ unshared x) ++ (step2 f $ unshared y) + step2 f (FTermF (TupleValue xs)) = concatMap (step2 f . unshared) (V.toList xs) step2 f (s@(App g a)) = possibly_curried_args s f (unshared g) (step2 f $ unshared a) step2 _ a = [Unshared a] -- @@ -823,12 +824,8 @@ rewriteSharedTermTypeSafe sc ss t0 = FlatTermF Term -> IO (FlatTermF Term) rewriteFTermF ftf = case ftf of - UnitValue -> return ftf - UnitType -> return ftf - PairValue{} -> traverse rewriteAll ftf - PairType{} -> return ftf -- doesn't matter - PairLeft{} -> traverse rewriteAll ftf - PairRight{} -> traverse rewriteAll ftf + TupleValue{} -> traverse rewriteAll ftf + TupleSelector{} -> traverse rewriteAll ftf -- NOTE: we don't rewrite arguments of constructors, datatypes, or -- recursors because of dependent types, as we could potentially cause diff --git a/saw-core/src/SAWCore/SCTypeCheck.hs b/saw-core/src/SAWCore/SCTypeCheck.hs index f1313694d3..1088fbe824 100644 --- a/saw-core/src/SAWCore/SCTypeCheck.hs +++ b/saw-core/src/SAWCore/SCTypeCheck.hs @@ -530,18 +530,10 @@ instance TypeInfer (TermF SCTypedTerm) where -- terms. Intuitively, this represents the case where each immediate subterm of -- a term has already been labeled with its (most general) type. instance TypeInfer (FlatTermF SCTypedTerm) where - typeInfer UnitValue = liftTCM scUnitType - typeInfer UnitType = liftTCM scSort (mkSort 0) - typeInfer (PairValue (SCTypedTerm _ tx) (SCTypedTerm _ ty)) = - liftTCM scPairType tx ty - typeInfer (PairType (SCTypedTerm _ tx) (SCTypedTerm _ ty)) = - do sx <- ensureSort tx - sy <- ensureSort ty - liftTCM scSort (max sx sy) - typeInfer (PairLeft (SCTypedTerm _ tp)) = - ensurePairType tp >>= \(t1,_) -> return t1 - typeInfer (PairRight (SCTypedTerm _ tp)) = - ensurePairType tp >>= \(_,t2) -> return t2 + typeInfer (TupleValue tts) = + liftTCM scTupleType (map typedType (V.toList tts)) + typeInfer (TupleSelector (SCTypedTerm _ tp) i) = + ensureTupleType tp >>= \ts -> pure (ts !! i) typeInfer (RecursorType d ps motive mty) = do s <- inferRecursorType d ps motive mty @@ -602,10 +594,10 @@ ensureRecognizer f err trm = ensureSort :: Term -> TCM Sort ensureSort tp = ensureRecognizer asSort (NotSort tp) tp --- | Ensure a 'Term' is a pair type, normalizing if necessary, and return the --- two components of that pair type -ensurePairType :: Term -> TCM (Term, Term) -ensurePairType tp = ensureRecognizer asPairType (NotTupleType tp) tp +-- | Ensure a 'Term' is a tuple type, normalizing if necessary, and return the +-- components of that tuple type +ensureTupleType :: Term -> TCM [Term] +ensureTupleType tp = ensureRecognizer asTupleType (NotTupleType tp) tp -- | Ensure a 'Term' is a record type, normalizing if necessary, and return the -- components of that record type diff --git a/saw-core/src/SAWCore/SharedTerm.hs b/saw-core/src/SAWCore/SharedTerm.hs index d36999d60f..c0d3d3d4db 100644 --- a/saw-core/src/SAWCore/SharedTerm.hs +++ b/saw-core/src/SAWCore/SharedTerm.hs @@ -120,18 +120,19 @@ module SAWCore.SharedTerm , scEqTrue , scBool , scBoolType - -- *** Unit, pairs, and tuples + -- *** Tuples , scUnitValue , scUnitType , scPairValue , scPairType - , scPairLeft - , scPairRight - , scPairValueReduced + , scTypeList , scTuple , scTupleType , scTupleSelector , scTupleReduced + , scTuple' + , scTupleType' + , scTupleSelector' -- *** Records , scRecord , scRecordSelect @@ -277,7 +278,7 @@ import Control.Applicative import Control.Concurrent.MVar import Control.Exception import Control.Lens -import Control.Monad (foldM, forM, forM_, join, unless, when) +import Control.Monad (foldM, forM, forM_, guard, join, unless, when) import Control.Monad.IO.Class (MonadIO(..)) import qualified Control.Monad.State.Strict as State import Control.Monad.Trans.Class (MonadTrans(..)) @@ -1170,7 +1171,7 @@ scReduceNatRecursor sc rec crec n data WHNFElim = ElimApp Term | ElimProj FieldName - | ElimPair Bool + | ElimTuple Int | ElimRecursor Term (CompiledRecursor Term) [Term] -- | Test if a term is a constructor application that should be converted to a @@ -1204,9 +1205,11 @@ scWhnf sc t0 = go xs (convertsToNat -> Just k) = scFlatTermF sc (NatLit k) >>= go xs go xs (asApp -> Just (t, x)) = go (ElimApp x : xs) t go xs (asRecordSelector -> Just (t, n)) = go (ElimProj n : xs) t - go xs (asPairSelector -> Just (t, i)) = go (ElimPair i : xs) t + go xs (asTupleSelector -> Just (t, i)) = go (ElimTuple i : xs) t go (ElimApp x : xs) (asLambda -> Just (_, _, body)) = betaReduce xs [x] body - go (ElimPair i : xs) (asPairValue -> Just (a, b)) = go xs (if i then b else a) + go (ElimTuple i : xs) (asTupleValue -> Just ts) = case V.fromList ts V.!? i of + Just t -> go xs t + Nothing -> error "scWhnf: invalid tuple index" go (ElimProj fld : xs) (asRecordValue -> Just elems) = case Map.lookup fld elems of Just t -> go xs t Nothing -> @@ -1215,13 +1218,6 @@ scWhnf sc t0 = (asNat -> Just n) = scReduceNatRecursor sc rec crec n >>= go xs go xs (asRecursorApp -> Just (r, crec, ixs, arg)) = go (ElimRecursor r crec ixs : xs) arg - go xs (asPairValue -> Just (a, b)) = do b' <- memo b - t' <- scPairValue sc a b' - foldM reapply t' xs - go xs (asPairType -> Just (a, b)) = do a' <- memo a - b' <- memo b - t' <- scPairType sc a' b' - foldM reapply t' xs go xs (asRecordType -> Just elems) = do elems' <- mapM (\(i,t) -> (i,) <$> memo t) (Map.assocs elems) t' <- scRecordType sc elems' @@ -1257,7 +1253,7 @@ scWhnf sc t0 = reapply :: Term -> WHNFElim -> IO Term reapply t (ElimApp x) = scApply sc t x reapply t (ElimProj i) = scRecordSelect sc t i - reapply t (ElimPair i) = scPairSelector sc t i + reapply t (ElimTuple i) = scTupleSelector sc t i reapply t (ElimRecursor r _crec ixs) = scFlatTermF sc (RecursorApp r ixs t) @@ -1425,26 +1421,17 @@ scTypeOf' sc env t0 = State.evalStateT (memo t0) Map.empty -> State.StateT (Map TermIndex Term) IO Term ftermf tf = case tf of - UnitValue -> lift $ scUnitType sc - UnitType -> lift $ scSort sc (mkSort 0) - PairValue x y -> do - tx <- memo x - ty <- memo y - lift $ scPairType sc tx ty - PairType x y -> do - sx <- sort x - sy <- sort y - lift $ scSort sc (max sx sy) - PairLeft t -> do - tp <- (liftIO . scWhnf sc) =<< memo t - case asPairType tp of - Just (t1, _) -> return t1 - Nothing -> fail "scTypeOf: type error: expected pair type" - PairRight t -> do - tp <- (liftIO . scWhnf sc) =<< memo t - case asPairType tp of - Just (_, t2) -> return t2 - Nothing -> fail "scTypeOf: type error: expected pair type" + TupleValue xs -> + liftIO . scTupleType sc =<< traverse memo (V.toList xs) + TupleSelector x i -> + do tp <- (liftIO . scWhnf sc) =<< memo x + case asTupleType tp of + Nothing -> fail "scTypeOf: type error: expected pair type" + Just ts -> + case V.fromList ts V.!? i of + Nothing -> + fail $ "scTypeOf: tuple selector out of range (" ++ show i ++ " > " ++ show (length ts) ++ ")" + Just t -> pure t RecursorType _d _ps _motive motive_ty -> do s <- sort motive_ty lift $ scSort sc s @@ -1750,18 +1737,18 @@ scRecordType sc elem_tps = scFlatTermF sc (RecordType elem_tps) -- | Create a unit-valued term. scUnitValue :: SharedContext -> IO Term -scUnitValue sc = scFlatTermF sc UnitValue +scUnitValue sc = scTuple sc [] -- | Create a term representing the unit type. scUnitType :: SharedContext -> IO Term -scUnitType sc = scFlatTermF sc UnitType +scUnitType sc = scTupleType sc [] -- | Create a pair term from two terms. scPairValue :: SharedContext -> Term -- ^ The left projection -> Term -- ^ The right projection -> IO Term -scPairValue sc x y = scFlatTermF sc (PairValue x y) +scPairValue sc x y = scTuple sc [x, y] -- | Create a term representing a pair type from two other terms, each -- representing a type. @@ -1769,50 +1756,64 @@ scPairType :: SharedContext -> Term -- ^ Left projection type -> Term -- ^ Right projection type -> IO Term -scPairType sc x y = scFlatTermF sc (PairType x y) +scPairType sc x y = scTupleType sc [x, y] -- | Create an n-place tuple from a list (of length n) of 'Term's. --- Note that tuples are nested pairs, associating to the right e.g. --- @(a, (b, (c, d)))@. +-- In particular, a length-1 list will yield a 1-element tuple. scTuple :: SharedContext -> [Term] -> IO Term -scTuple sc [] = scUnitValue sc -scTuple _ [t] = return t -scTuple sc (t : ts) = scPairValue sc t =<< scTuple sc ts +scTuple sc ts = scFlatTermF sc (TupleValue (V.fromList ts)) + +scTypeList :: SharedContext -> [Term] -> IO Term +scTypeList sc [] = scGlobalApply sc "Prelude.TypeNil" [] +scTypeList sc (t : ts) = + do ts' <- scTypeList sc ts + scGlobalApply sc "Prelude.TypeCons" [t, ts'] -- | Create a term representing the type of an n-place tuple, from a list -- (of length n) of 'Term's, each representing a type. +-- In particular, a length-1 list will yield a 1-element tuple type. scTupleType :: SharedContext -> [Term] -> IO Term -scTupleType sc [] = scUnitType sc -scTupleType _ [t] = return t -scTupleType sc (t : ts) = scPairType sc t =<< scTupleType sc ts - --- | Create a term giving the left projection of a 'Term' representing a pair. -scPairLeft :: SharedContext -> Term -> IO Term -scPairLeft sc t = scFlatTermF sc (PairLeft t) - --- | Create a term giving the right projection of a 'Term' representing a pair. -scPairRight :: SharedContext -> Term -> IO Term -scPairRight sc t = scFlatTermF sc (PairRight t) - --- | Create a term representing either the left or right projection of the --- given 'Term', depending on the given 'Bool': left if @False@, right if @True@. -scPairSelector :: SharedContext -> Term -> Bool -> IO Term -scPairSelector sc t False = scPairLeft sc t -scPairSelector sc t True = scPairRight sc t - --- | @scTupleSelector sc t i n@ returns a term selecting the @i@th component of --- an @n@-place tuple 'Term', @t@. +scTupleType sc ts = + do ts' <- scTypeList sc ts + scGlobalApply sc "Prelude.Tuple" [ts'] + +-- | @scTupleSelector sc t i@ returns a term selecting the @i@th component of +-- a tuple 'Term', @t@. scTupleSelector :: - SharedContext -> Term -> - Int {- ^ 1-based index -} -> + SharedContext -> + Term {- ^ tuple -} -> + Int {- ^ 0-based index -} -> + IO Term +scTupleSelector sc t i + | i < 0 = fail "scTupleSelector: negative index" + | otherwise = scFlatTermF sc (TupleSelector t i) + +-- | Create an n-element tuple from a list (of length n) of 'Term's, +-- while avoiding 1-tuples. +scTuple' :: SharedContext -> [Term] -> IO Term +scTuple' _ [t] = pure t +scTuple' sc ts = scTuple sc ts + +-- | Create an n-element tuple from a list (of length n) of 'Term's, +-- while avoiding 1-tuples. +scTupleType' :: SharedContext -> [Term] -> IO Term +scTupleType' _ [t] = pure t +scTupleType' sc ts = scTupleType sc ts + +-- | @scTupleSelector' sc t i n@ returns a term selecting the @i@th +-- component of an @n@-element tuple 'Term' @t@. We assume that a +-- 1-tuple was created with 'scTuple', so that a 1-tuple of type @t@ is +-- just type @t@; thus a projection from a size-1 tuple is a no-op. +scTupleSelector' :: + SharedContext -> + Term {- ^ tuple -} -> + Int {- ^ 0-based index -} -> Int {- ^ tuple size -} -> IO Term -scTupleSelector sc t i n - | n == 1 = return t - | i == 1 = scPairLeft sc t - | i > 1 = do t' <- scPairRight sc t - scTupleSelector sc t' (i - 1) (n - 1) - | otherwise = fail "scTupleSelector: non-positive index" +scTupleSelector' sc t i n + | i > n = fail $ "scTupleSelector: index too large (" ++ show i ++ " > " ++ show n ++ ")" + | n == 1 = pure t + | otherwise = scTupleSelector sc t i -- | Create a term representing the type of a non-dependent function, given a -- parameter and result type (as 'Term's). @@ -1952,20 +1953,25 @@ scGlobalApply sc i ts = do c <- scGlobalDef sc i scApplyAll sc c ts --- | An optimized variant of 'scPairValue' that will reduce pairs of --- the form @(x.L, x.R)@ to @x@. -scPairValueReduced :: SharedContext -> Term -> Term -> IO Term -scPairValueReduced sc x y = - case (unwrapTermF x, unwrapTermF y) of - (FTermF (PairLeft a), FTermF (PairRight b)) | a == b -> return a - _ -> scPairValue sc x y - --- | An optimized variant of 'scPairTuple' that will reduce tuples of --- the form @(x.1, x.2, x.3)@ to @x@. +-- | An optimized variant of 'scTuple' that will reduce tuples of +-- the form @(x.0, x.1, x.2)@ to @x@. scTupleReduced :: SharedContext -> [Term] -> IO Term -scTupleReduced sc [] = scUnitValue sc -scTupleReduced _ [t] = return t -scTupleReduced sc (t : ts) = scPairValueReduced sc t =<< scTupleReduced sc ts +scTupleReduced sc ts = + case asTupleRedex ts of + Just t -> pure t + Nothing -> scTuple sc ts + +asTupleRedex :: [Term] -> Maybe Term +asTupleRedex [] = Nothing +asTupleRedex (t0 : ts0) = + do (x, i) <- asTupleSelector t0 + go x i ts0 + where + go x _ [] = Just x + go x i (t : ts) = + do (y, j) <- asTupleSelector t + guard (j == i + 1 && x == y) + go x j ts -- | An optimized variant of 'scVector' that will reduce vectors of -- the form @[at x 0, at x 1, at x 2, at x 3]@ to just @x@. diff --git a/saw-core/src/SAWCore/Simulator.hs b/saw-core/src/SAWCore/Simulator.hs index 5899ee89c5..68797e2b71 100644 --- a/saw-core/src/SAWCore/Simulator.hs +++ b/saw-core/src/SAWCore/Simulator.hs @@ -48,6 +48,7 @@ import qualified Data.IntMap as IntMap import qualified Data.IntMap as IMap import Data.Text (Text) import qualified Data.Text as Text +import qualified Data.Vector as V import Data.Traversable import GHC.Stack @@ -160,8 +161,8 @@ evalTermF cfg lam recEval tf env = pure (VDependentPi (\x -> toTValue <$> lam t2 ((x,v) : env))) else do -- put dummy values in the environment; the term should never reference them - let val = ready VUnit - let tp = VUnitType + let val = ready (VTuple mempty) + let tp = VTupleType mempty VNondependentPi . toTValue <$> lam t2 ((val,tp):env) return $ TValue $ VPiType nm v body @@ -191,25 +192,11 @@ evalTermF cfg lam recEval tf env = simExtCns cfg tf ec' FTermF ftf -> case ftf of - UnitValue -> return VUnit + TupleValue xs -> VTuple <$> traverse recEvalDelay xs - UnitType -> return $ TValue VUnitType - - PairValue x y -> do tx <- recEvalDelay x - ty <- recEvalDelay y - return $ VPair tx ty - - PairType x y -> do vx <- evalType x - vy <- evalType y - return $ TValue $ VPairType vx vy - - PairLeft x -> recEval x >>= \case - VPair l _r -> force l - _ -> simNeutral cfg env (NeutralPairLeft (NeutralBox x)) - - PairRight x -> recEval x >>= \case - VPair _l r -> force r - _ -> simNeutral cfg env (NeutralPairRight (NeutralBox x)) + TupleSelector x i -> recEval x >>= \case + VTuple ys -> force (ys V.! i) + _ -> simNeutral cfg env (NeutralTupleProj (NeutralBox x) i) RecursorType d ps m mtp -> do dty <- evalType (resolvedNameType (requireNameInMap d (simModMap cfg))) diff --git a/saw-core/src/SAWCore/Simulator/Prims.hs b/saw-core/src/SAWCore/Simulator/Prims.hs index 05ae76a19d..bc93a17649 100644 --- a/saw-core/src/SAWCore/Simulator/Prims.hs +++ b/saw-core/src/SAWCore/Simulator/Prims.hs @@ -163,6 +163,12 @@ vectorFun unpack = PrimFilterFun "expected vector" r r (VWord w) = fmap (ready . VBool) <$> lift (unpack w) r _ = mzero +-- | A primitive that requires a tuple argument +tupleFun :: VMonad l => (Vector (Thunk l) -> Prim l) -> Prim l +tupleFun = PrimFilterFun "expected Tuple" r + where r (VTuple b) = pure b + r _ = mzero + ------------------------------------------------------------ -- @@ -280,6 +286,11 @@ constMap bp = Map.fromList , ("Prelude.or" , boolBinOp (bpOr bp)) , ("Prelude.xor" , boolBinOp (bpXor bp)) , ("Prelude.boolEq", boolBinOp (bpBoolEq bp)) + -- Tuples + , ("Prelude.Tuple" , tupleOp) + , ("Prelude.headTuple", headTupleOp) + , ("Prelude.tailTuple", tailTupleOp) + , ("Prelude.consTuple", consTupleOp) -- Bitwise , ("Prelude.bvAnd" , wordBinOp (bpPack bp) (bpBvAnd bp)) , ("Prelude.bvOr" , wordBinOp (bpPack bp) (bpBvOr bp)) @@ -497,6 +508,56 @@ selectV mux maxValue valueFn v = impl len 0 impl 0 x = valueFn x impl i x = mux (vecIdx err v (len - i)) (impl j (x `setBit` j)) (impl j x) where j = i - 1 +------------------------------------------------------------ +-- Tuple primitives + +-- | Deconstruct a value of type @TypeList@ as a list of 'TValue's. +vAsTypeList :: (VMonad l, Show (Extra l)) => Value l -> EvalM l [TValue l] +vAsTypeList val = + case val of + VCtorApp _ec [] [] -> pure [] + VCtorApp _ec [] [x1, x2] -> + do v1 <- force x1 + t <- + case v1 of + TValue tv -> pure tv + _ -> panic "vAsTypeList" ["Expected type"] + v2 <- force x2 + ts <- vAsTypeList v2 + pure (t : ts) + _ -> panic "vAsTypeList" ["Expected type list, got: " <> Text.pack (show val)] + +-- Tuple : TypeList -> sort 0; +tupleOp :: (VMonad l, Show (Extra l)) => Prim l +tupleOp = + strictFun $ \v -> + Prim (TValue . VTupleType . V.fromList <$> vAsTypeList v) + +-- headTuple : (t : sort 0) -> (ts : TypeList) -> Tuple (TypeCons t ts) -> t; +headTupleOp :: (VMonad l) => Prim l +headTupleOp = + constFun $ + constFun $ + tupleFun $ \xs -> + Prim (force (V.head xs)) + +-- tailTuple : (t : sort 0) -> (ts : TypeList) -> Tuple (TypeCons t ts) -> Tuple ts; +tailTupleOp :: (VMonad l) => Prim l +tailTupleOp = + constFun $ + constFun $ + tupleFun $ \xs -> + PrimValue (VTuple (V.tail xs)) + +-- consTuple : (t : sort 0) -> (ts : TypeList) -> t -> Tuple ts -> Tuple (TypeCons t ts); +consTupleOp :: (VMonad l) => Prim l +consTupleOp = + constFun $ + constFun $ + primFun $ \x -> + tupleFun $ \xs -> + PrimValue (VTuple (V.cons x xs)) + ------------------------------------------------------------ -- Values for common primitives @@ -1337,9 +1398,9 @@ muxValue bp tp0 b = value tp0 y <- g a value tp' x y - value VUnitType VUnit VUnit = return VUnit - value (VPairType t1 t2) (VPair x1 x2) (VPair y1 y2) = - VPair <$> thunk t1 x1 y1 <*> thunk t2 x2 y2 + value (VTupleType ts) (VTuple xs) (VTuple ys) + | V.length ts == V.length xs && V.length ts == V.length ys + = VTuple <$> V.sequence (V.zipWith3 thunk ts xs ys) value (VRecordType fs) (VRecordValue elems1) (VRecordValue elems2) = do let em1 = Map.fromList elems1 diff --git a/saw-core/src/SAWCore/Simulator/TermModel.hs b/saw-core/src/SAWCore/Simulator/TermModel.hs index 09dde662c9..c343341d7a 100644 --- a/saw-core/src/SAWCore/Simulator/TermModel.hs +++ b/saw-core/src/SAWCore/Simulator/TermModel.hs @@ -243,7 +243,6 @@ readBackTValue sc cfg = loop where loop tv = case tv of - VUnitType -> scUnitType sc VBoolType -> scBoolType sc VStringType -> scStringType sc VIntType -> scIntegerType sc @@ -259,10 +258,9 @@ readBackTValue sc cfg = loop do n' <- scNat sc n t' <- loop t scVecType sc n' t' - VPairType t1 t2 -> - do t1' <- loop t1 - t2' <- loop t2 - scPairType sc t1' t2' + VTupleType ts -> + do ts' <- traverse loop (V.toList ts) + scTupleType sc ts' VRecordType fs -> do fs' <- traverse (traverse loop) fs scRecordType sc fs' @@ -325,7 +323,6 @@ reflectTerm :: reflectTerm sc cfg = loop where loop tv tm = case tv of - VUnitType -> pure VUnit VBoolType -> return (VBool (Left tm)) VIntType -> return (VInt (Left tm)) VIntModType m -> return (VIntMod m (Left tm)) @@ -361,7 +358,7 @@ reflectTerm sc cfg = loop VStringType{} -> return (VExtra (VExtraTerm tv tm)) VRecordType{} -> return (VExtra (VExtraTerm tv tm)) - VPairType{} -> return (VExtra (VExtraTerm tv tm)) + VTupleType{} -> return (VExtra (VExtraTerm tv tm)) VDataType{} -> return (VExtra (VExtraTerm tv tm)) VRecursorType{} -> return (VExtra (VExtraTerm tv tm)) VTyTerm{} -> return (VExtra (VExtraTerm tv tm)) @@ -377,8 +374,6 @@ readBackValue :: IO Term readBackValue sc cfg = loop where - loop _ VUnit = scUnitValue sc - loop _ (VNat n) = scNat sc n loop _ (VBVToNat w n) = @@ -417,10 +412,9 @@ readBackValue sc cfg = loop do (ecs, tm) <- readBackFuns tv v scAbstractExtsEtaCollapse sc ecs tm - loop (VPairType t1 t2) (VPair v1 v2) = - do tm1 <- loop t1 =<< force v1 - tm2 <- loop t2 =<< force v2 - scPairValueReduced sc tm1 tm2 + loop (VTupleType ts) (VTuple vs) | V.length ts == V.length vs = + do tms <- V.sequence $ V.zipWith (\t v -> loop t =<< force v) ts vs + scTupleReduced sc (V.toList tms) loop (VVecType _n tp) (VVector vs) = do tp' <- readBackTValue sc cfg tp diff --git a/saw-core/src/SAWCore/Simulator/Value.hs b/saw-core/src/SAWCore/Simulator/Value.hs index a6bd1fddba..e0c2a5da86 100644 --- a/saw-core/src/SAWCore/Simulator/Value.hs +++ b/saw-core/src/SAWCore/Simulator/Value.hs @@ -55,8 +55,7 @@ The concrete parameters to use are computed from the name using a collection of type families (e.g., 'EvalM', 'VBool', etc.). -} data Value l = VFun !LocalName !(Thunk l -> MValue l) - | VUnit - | VPair (Thunk l) (Thunk l) -- TODO: should second component be strict? + | VTuple !(Vector (Thunk l)) | VCtorApp !(ExtCns (TValue l)) ![Thunk l] ![Thunk l] | VCtorMux ![Thunk l] !(IntMap (VBool l, ExtCns (TValue l), [Thunk l])) -- ^ A mux tree of possible constructor values of a data type. @@ -93,9 +92,8 @@ data TValue l | VArrayType !(TValue l) !(TValue l) | VPiType LocalName !(TValue l) !(PiBody l) | VStringType - | VUnitType - | VPairType !(TValue l) !(TValue l) | VDataType !(ExtCns (TValue l)) ![Value l] ![Value l] + | VTupleType !(Vector (TValue l)) | VRecordType ![(FieldName, TValue l)] | VSort !Sort | VRecursorType @@ -115,8 +113,7 @@ data PiBody l -- is being hidden, etc.) data NeutralTerm = NeutralBox Term -- the thing blocking evaluation - | NeutralPairLeft NeutralTerm -- left pair projection - | NeutralPairRight NeutralTerm -- right pair projection + | NeutralTupleProj NeutralTerm Int -- tuple projection | NeutralRecordProj NeutralTerm FieldName -- record projection | NeutralApp NeutralTerm Term -- function application | NeutralRecursor @@ -184,8 +181,7 @@ instance Show (Extra l) => Show (Value l) where showsPrec p v = case v of VFun {} -> showString "<>" - VUnit -> showString "()" - VPair{} -> showString "<>" + VTuple xv -> showString "<<" . shows (V.length xv) . showString "-tuple>>" VCtorApp s _ps _xv -> shows (toAbsoluteName (ecNameInfo s)) VCtorMux {} -> showString "<>" VVector xv -> showList (toList xv) @@ -218,8 +214,7 @@ instance Show (Extra l) => Show (TValue l) where VArrayType{} -> showString "Array" VPiType _ t _ -> showParen True (shows t . showString " -> ...") - VUnitType -> showString "#()" - VPairType x y -> showParen True (shows x . showString " * " . shows y) + VTupleType ts -> showString "#" . showParen True (showCommas (map shows (V.toList ts))) VDataType s ps vs | null (ps++vs) -> shows s | otherwise -> shows s . showList (ps++vs) @@ -232,6 +227,10 @@ instance Show (Extra l) => Show (TValue l) where VRecursorType{} -> showString "RecursorType" VTyTerm _ tm -> showString "TyTerm (" . (\x -> showTerm tm ++ x) . showString ")" + where + showCommas [] = id + showCommas [x] = x + showCommas (x : xs) = x . showString "," . showCommas xs data Nil = Nil @@ -242,23 +241,10 @@ instance Show Nil where -- Basic operations on values vTuple :: VMonad l => [Thunk l] -> Value l -vTuple [] = VUnit -vTuple [_] = error "vTuple: unsupported 1-tuple" -vTuple [x, y] = VPair x y -vTuple (x : xs) = VPair x (ready (vTuple xs)) +vTuple xs = VTuple (V.fromList xs) vTupleType :: VMonad l => [TValue l] -> TValue l -vTupleType [] = VUnitType -vTupleType [t] = t -vTupleType (t : ts) = VPairType t (vTupleType ts) - -valPairLeft :: (HasCallStack, VMonad l, Show (Extra l)) => Value l -> MValue l -valPairLeft (VPair t1 _) = force t1 -valPairLeft v = panic "valPairLeft" ["Not a pair value: " <> Text.pack (show v)] - -valPairRight :: (HasCallStack, VMonad l, Show (Extra l)) => Value l -> MValue l -valPairRight (VPair _ t2) = force t2 -valPairRight v = panic "valPairRight" ["Not a pair value: " <> Text.pack (show v)] +vTupleType ts = VTupleType (V.fromList ts) vRecord :: Map FieldName (Thunk l) -> Value l vRecord m = VRecordValue (Map.assocs m) @@ -301,13 +287,8 @@ asFiniteTypeTValue v = VVecType n v1 -> do t1 <- asFiniteTypeTValue v1 return (FTVec n t1) - VUnitType -> return (FTTuple []) - VPairType v1 v2 -> do - t1 <- asFiniteTypeTValue v1 - t2 <- asFiniteTypeTValue v2 - case t2 of - FTTuple ts -> return (FTTuple (t1 : ts)) - _ -> return (FTTuple [t1, t2]) + VTupleType vs -> + FTTuple <$> traverse asFiniteTypeTValue (V.toList vs) VRecordType elem_tps -> FTRec <$> Map.fromList <$> mapM (\(fld,tp) -> (fld,) <$> asFiniteTypeTValue tp) elem_tps @@ -328,13 +309,8 @@ asFirstOrderTypeTValue v = VIntModType m -> return (FOTIntMod m) VArrayType a b -> FOTArray <$> asFirstOrderTypeTValue a <*> asFirstOrderTypeTValue b - VUnitType -> return (FOTTuple []) - VPairType v1 v2 -> do - t1 <- asFirstOrderTypeTValue v1 - t2 <- asFirstOrderTypeTValue v2 - case t2 of - FOTTuple ts -> return (FOTTuple (t1 : ts)) - _ -> return (FOTTuple [t1, t2]) + VTupleType vs -> + FOTTuple <$> traverse asFirstOrderTypeTValue (V.toList vs) VRecordType elem_tps -> FOTRec . Map.fromList <$> mapM (traverse asFirstOrderTypeTValue) elem_tps @@ -363,11 +339,9 @@ suffixTValue tv = b' <- suffixTValue b Just ("_Array" ++ a' ++ b') VPiType _ _ _ -> Nothing - VUnitType -> Just "_Unit" - VPairType a b -> - do a' <- suffixTValue a - b' <- suffixTValue b - Just ("_Pair" ++ a' ++ b') + VTupleType vs -> + do vs' <- traverse suffixTValue (V.toList vs) + Just ("_Tuple" ++ show (V.length vs) ++ concat vs') VStringType -> Nothing VDataType {} -> Nothing @@ -381,10 +355,8 @@ neutralToTerm :: NeutralTerm -> Term neutralToTerm = loop where loop (NeutralBox tm) = tm - loop (NeutralPairLeft nt) = - Unshared (FTermF (PairLeft (loop nt))) - loop (NeutralPairRight nt) = - Unshared (FTermF (PairRight (loop nt))) + loop (NeutralTupleProj nt i) = + Unshared (FTermF (TupleSelector (loop nt) i)) loop (NeutralRecordProj nt f) = Unshared (FTermF (RecordProj (loop nt) f)) loop (NeutralApp nt arg) = @@ -400,10 +372,9 @@ neutralToSharedTerm :: SharedContext -> NeutralTerm -> IO Term neutralToSharedTerm sc = loop where loop (NeutralBox tm) = pure tm - loop (NeutralPairLeft nt) = - scFlatTermF sc . PairLeft =<< loop nt - loop (NeutralPairRight nt) = - scFlatTermF sc . PairRight =<< loop nt + loop (NeutralTupleProj nt i) = + do tm <- loop nt + scFlatTermF sc (TupleSelector tm i) loop (NeutralRecordProj nt f) = do tm <- loop nt scFlatTermF sc (RecordProj tm f) diff --git a/saw-core/src/SAWCore/Term/Functor.hs b/saw-core/src/SAWCore/Term/Functor.hs index 813bdf8789..068b8d8419 100644 --- a/saw-core/src/SAWCore/Term/Functor.hs +++ b/saw-core/src/SAWCore/Term/Functor.hs @@ -184,14 +184,9 @@ sortFlagsFromList bs = SortFlags (isSet 0) (isSet 1) -- NB: If you add constructors to FlatTermF, make sure you update -- zipWithFlatTermF! data FlatTermF e - -- Tuples are represented as nested pairs, grouped to the right, - -- terminated with unit at the end. - = UnitValue - | UnitType - | PairValue e e - | PairType e e - | PairLeft e - | PairRight e + = TupleValue (Vector e) + -- | A zero-indexed tuple field selection. + | TupleSelector e Int -- | The type of a recursor, which is specified by the datatype name, -- the parameters to the data type, the motive function, and the @@ -295,17 +290,15 @@ zipRec f (CompiledRecursor d1 ps1 m1 mty1 es1 ord1) (CompiledRecursor d2 ps2 m2 -- | Zip a binary function @f@ over a pair of 'FlatTermF's by applying @f@ -- pointwise to immediate subterms, if the two 'FlatTermF's are the same --- constructor; otherwise, return 'Nothing' if they use different constructors +-- constructor; otherwise, return 'Nothing' if they use different constructors. zipWithFlatTermF :: (x -> y -> z) -> FlatTermF x -> FlatTermF y -> Maybe (FlatTermF z) zipWithFlatTermF f = go where - go UnitValue UnitValue = Just UnitValue - go UnitType UnitType = Just UnitType - go (PairValue x1 x2) (PairValue y1 y2) = Just (PairValue (f x1 y1) (f x2 y2)) - go (PairType x1 x2) (PairType y1 y2) = Just (PairType (f x1 y1) (f x2 y2)) - go (PairLeft x) (PairLeft y) = Just (PairLeft (f x y)) - go (PairRight x) (PairRight y) = Just (PairLeft (f x y)) + go (TupleValue xs) (TupleValue ys) + | V.length xs == V.length ys = Just $ TupleValue (V.zipWith f xs ys) + go (TupleSelector x i) (TupleSelector y j) + | i == j = Just (TupleSelector (f x y) i) go (RecursorType d1 ps1 m1 mty1) (RecursorType d2 ps2 m2 mty2) = do d <- zipName d1 d2 @@ -337,12 +330,8 @@ zipWithFlatTermF f = go | V.length vx == V.length vy = Just $ ArrayValue (f tx ty) (V.zipWith f vx vy) - go UnitValue _ = Nothing - go UnitType _ = Nothing - go PairValue{} _ = Nothing - go PairType{} _ = Nothing - go PairLeft{} _ = Nothing - go PairRight{} _ = Nothing + go TupleValue{} _ = Nothing + go TupleSelector{}_ = Nothing go RecursorType{} _ = Nothing go Recursor{} _ = Nothing go RecursorApp{} _ = Nothing diff --git a/saw-core/src/SAWCore/Term/Pretty.hs b/saw-core/src/SAWCore/Term/Pretty.hs index d07385d575..8ba60fa75e 100644 --- a/saw-core/src/SAWCore/Term/Pretty.hs +++ b/saw-core/src/SAWCore/Term/Pretty.hs @@ -70,7 +70,6 @@ data Prec = PrecCommas -- ^ Nonterminal @sepBy(Term, \',\')@ | PrecTerm -- ^ Nonterminal @Term@ | PrecLambda -- ^ Nonterminal @LTerm@ - | PrecProd -- ^ Nonterminal @ProdTerm@ | PrecApp -- ^ Nonterminal @AppTerm@ | PrecArg -- ^ Nonterminal @AtomTerm@ deriving (Eq, Ord) @@ -336,13 +335,14 @@ ppLetBlock defs body = pure $ mv <+> pretty '=' <+> d --- | Pretty-print pairs as "(x, y)" -ppPair :: Prec -> PPS.Doc -> PPS.Doc -> PPS.Doc -ppPair prec x y = ppParensPrec prec PrecCommas (group (vcat [x <> pretty ',', y])) +ppCommaSep :: [PPS.Doc] -> PPS.Doc +ppCommaSep [] = emptyDoc +ppCommaSep [x] = x +ppCommaSep (x : xs) = group (vcat [x <> pretty ',', ppCommaSep xs]) --- | Pretty-print pair types as "x * y" -ppPairType :: Prec -> PPS.Doc -> PPS.Doc -> PPS.Doc -ppPairType prec x y = ppParensPrec prec PrecProd (x <+> pretty '*' <+> y) +-- | Pretty-print tuples as "(x, y, z)" +ppTuple :: [PPS.Doc] -> PPS.Doc +ppTuple xs = parens (align (ppCommaSep xs)) -- | Pretty-print records (if the flag is 'False') or record types (if the flag -- is 'True'), where the latter are preceded by the string @#@, either as: @@ -390,12 +390,8 @@ ppPi tp (name, body) = vsep [lhs, "->" <+> body] ppFlatTermF :: Prec -> FlatTermF Term -> PPM PPS.Doc ppFlatTermF prec tf = case tf of - UnitValue -> return "(-empty-)" - UnitType -> return "#(-empty-)" - PairValue x y -> ppPair prec <$> ppTerm' PrecTerm x <*> ppTerm' PrecCommas y - PairType x y -> ppPairType prec <$> ppTerm' PrecApp x <*> ppTerm' PrecProd y - PairLeft t -> ppProj "1" <$> ppTerm' PrecArg t - PairRight t -> ppProj "2" <$> ppTerm' PrecArg t + TupleValue xs -> ppTuple <$> traverse (ppTerm' PrecCommas) (V.toList xs) + TupleSelector t i -> ppProj (Text.pack (show i)) <$> ppTerm' PrecArg t RecursorType d params motive _motiveTy -> do params_pp <- mapM (ppTerm' PrecArg) params @@ -562,8 +558,7 @@ scTermCountAux doBinders = go shouldMemoizeTerm :: Term -> Bool shouldMemoizeTerm t = case unwrapTermF t of - FTermF UnitValue -> False - FTermF UnitType -> False + FTermF (TupleValue xs) -> not (V.null xs) FTermF Sort{} -> False FTermF NatLit{} -> False FTermF (ArrayValue _ v) | V.length v == 0 -> False diff --git a/saw-core/src/SAWCore/Typechecker.hs b/saw-core/src/SAWCore/Typechecker.hs index dc3f93630b..9513a32acd 100644 --- a/saw-core/src/SAWCore/Typechecker.hs +++ b/saw-core/src/SAWCore/Typechecker.hs @@ -248,23 +248,19 @@ typeInferCompleteTerm (Un.RecordType _ elems) = typeInferCompleteTerm (Un.RecordProj t prj) = (RecordProj <$> typeInferComplete t <*> return prj) >>= typeInferComplete --- Unit -typeInferCompleteTerm (Un.UnitValue _) = - typeInferComplete (UnitValue :: FlatTermF SCTypedTerm) -typeInferCompleteTerm (Un.UnitType _) = - typeInferComplete (UnitType :: FlatTermF SCTypedTerm) - --- Simple pairs -typeInferCompleteTerm (Un.PairValue _ t1 t2) = - (PairValue <$> typeInferComplete t1 <*> typeInferComplete t2) +-- Tuples +typeInferCompleteTerm (Un.TupleValue _ ts) = + (TupleValue <$> traverse typeInferComplete (V.fromList ts)) >>= typeInferComplete -typeInferCompleteTerm (Un.PairType _ t1 t2) = - (PairType <$> typeInferComplete t1 <*> typeInferComplete t2) - >>= typeInferComplete -typeInferCompleteTerm (Un.PairLeft t) = - (PairLeft <$> typeInferComplete t) >>= typeInferComplete -typeInferCompleteTerm (Un.PairRight t) = - (PairRight <$> typeInferComplete t) >>= typeInferComplete +typeInferCompleteTerm (Un.TupleType _ ts) = + do tts <- traverse typeInferComplete ts + v <- liftTCM scTupleType (map typedVal tts) + -- Ensure all arguments have type 'sort 0' + s0 <- liftTCM scSort (mkSort 0) + mapM_ (\tt -> checkSubtype tt s0) tts + pure (SCTypedTerm v s0) +typeInferCompleteTerm (Un.TupleProj t i) = + (TupleSelector <$> typeInferComplete t <*> pure i) >>= typeInferComplete -- Type ascriptions typeInferCompleteTerm (Un.TypeConstraint t _ tp) = diff --git a/saw-script/src/SAWScript/HeapsterBuiltins.hs b/saw-script/src/SAWScript/HeapsterBuiltins.hs deleted file mode 100644 index a15e9434b5..0000000000 --- a/saw-script/src/SAWScript/HeapsterBuiltins.hs +++ /dev/null @@ -1,1309 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE ViewPatterns #-} - -module SAWScript.HeapsterBuiltins - ( heapster_init_env - , heapster_init_env_debug - , heapster_init_env_from_file - , heapster_init_env_from_file_debug - , heapster_init_env_for_files - , heapster_init_env_for_files_debug - , load_sawcore_from_file - , heapster_get_cfg - , heapster_typecheck_fun - , heapster_typecheck_mut_funs - , heapster_typecheck_fun_rename - , heapster_typecheck_mut_funs_rename - -- , heapster_typecheck_fun_rs - -- , heapster_typecheck_fun_rename_rs - , heapster_define_opaque_perm - , heapster_define_recursive_perm - , heapster_define_reachability_perm - , heapster_define_recursive_shape - , heapster_define_perm - , heapster_define_llvmshape - , heapster_define_opaque_llvmshape - , heapster_define_rust_type - , heapster_define_rust_type_qual - , heapster_block_entry_hint - , heapster_gen_block_perms_hint - , heapster_join_point_hint - , heapster_find_symbol - , heapster_find_symbols - , heapster_find_symbol_with_type - , heapster_find_symbols_with_type - , heapster_find_symbol_commands - , heapster_find_trait_method_symbol - , heapster_assume_fun - , heapster_assume_fun_rename - , heapster_translate_rust_type - , heapster_assume_fun_rename_prim - , heapster_assume_fun_multi - , heapster_set_event_type - , heapster_print_fun_trans - , heapster_export_coq - , heapster_parse_test - , heapster_dump_ide_info - , heapster_set_debug_level - , heapster_set_translation_checks - ) where - -import Data.Maybe -import Data.String -import Data.List (find, intersperse, isInfixOf) -import Data.IORef -import Data.Functor.Product -import Data.Functor.Constant (getConstant) -import Control.Applicative ( (<|>) ) -import Control.Lens -import Control.Monad -import Control.Monad.Reader -import qualified Control.Monad.Fail as Fail -import System.Directory -import Data.Text (Text) -import qualified Data.Text as Text -import qualified Data.Text as T -- XXX remove uses of this (too many for just now) -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.IO as TLIO - -import Data.Binding.Hobbits hiding (sym) - -import Data.Parameterized.BoolRepr -import qualified Data.Parameterized.Context as Ctx -import Data.Parameterized.TraversableF -import Data.Parameterized.TraversableFC - -import qualified SAWSupport.Pretty as PPS (defaultOpts) - -import SAWCore.Term.Functor -import SAWCore.Name -import SAWCore.Module (Def(..), DefQualifier(..), Module(..), emptyModule, insImport) -import SAWCore.Module as Mod (resolveName) -import CryptolSAWCore.Monadify -import SAWCore.SharedTerm -import SAWCore.Recognizer -import SAWCore.OpenTerm -import SAWCore.Typechecker -import SAWCore.SCTypeCheck -import qualified SAWCore.Term.Pretty as Pretty (scPrettyTerm, scPrettyTermInCtx) -import qualified SAWCore.Parser.AST as Un -import qualified SAWCore.Parser.Grammar as Un - -import Lang.Crucible.Types -import Lang.Crucible.FunctionHandle -import Lang.Crucible.CFG.Core -import Lang.Crucible.LLVM.Extension -import Lang.Crucible.LLVM.MemModel -import qualified Lang.Crucible.LLVM.PrettyPrint as Crucible.LLVM -import Lang.Crucible.LLVM.Translation --- import Lang.Crucible.LLVM.Translation.Types -import Lang.Crucible.LLVM.TypeContext -import Lang.Crucible.LLVM.DataLayout - -import qualified Text.LLVM.AST as L -import qualified Text.LLVM.Parser as L -import qualified Text.PrettyPrint.HughesPJ as L (render) - -import SAWCentral.TopLevel -import SAWCentral.Value -import SAWCentral.Options -import SAWCentral.LLVMBuiltins -import SAWCentral.Builtins -import SAWCentral.Crucible.LLVM.Builtins -import SAWCentral.Crucible.LLVM.MethodSpecIR - -import Heapster.CruUtil -import Heapster.HintExtract -import Heapster.Permissions -import Heapster.SAWTranslation -import Heapster.PermParser -import Heapster.RustTypes (parseSome3FunPermFromRust, Some3FunPerm(..)) -import Heapster.ParsedCtx -import qualified Heapster.IDESupport as HIDE -import Heapster.LLVMGlobalConst - -import SAWCentral.Prover.Exporter -import SAWCoreCoq.Coq -import Prettyprinter - -import SAWScript.Panic - - --- | Build the SAW core term for the type @TpDesc@ -tpDescTypeM :: MonadIO m => SharedContext -> m Term -tpDescTypeM sc = liftIO $ completeOpenTerm sc tpDescTypeOpenTerm - --- | Pretty-print a SAW core term with a 'String' prefix to 'stderr' if the --- current debug level in the supplied 'HeapsterEnv' is above the supplied one -debugPrettyTermWithPrefix :: HeapsterEnv -> DebugLevel -> String -> Term -> - TopLevel () -debugPrettyTermWithPrefix henv req_dlevel prefix trm = - do dlevel <- liftIO $ readIORef $ heapsterEnvDebugLevel henv - pp_opts <- getTopLevelPPOpts - debugTrace req_dlevel dlevel (prefix ++ - Pretty.scPrettyTerm pp_opts trm) (return ()) - --- | Check that a type equals the type described by a type description in a ctx -checkTypeAgreesWithDesc :: SharedContext -> PermEnv -> Text -> Ident -> - CruCtx args -> Ident -> IO () -checkTypeAgreesWithDesc sc env nm tp_ident ctx d_ident = - do d_tp <- translateDescTypeFun sc env ctx $ identOpenTerm d_ident - tp <- scGlobalDef sc tp_ident - ok <- scConvertibleEval sc scTypeCheckWHNF True tp d_tp - if ok then return () else - do tp_norm <- scTypeCheckWHNF sc tp - d_tp_norm <- scTypeCheckWHNF sc d_tp - fail $ Text.unpack $ - "Type description for " <> nm <> - " does not match user-supplied type\n" <> - "Type for description:\n" <> - Text.pack (Pretty.scPrettyTermInCtx PPS.defaultOpts [] d_tp_norm) <> - "\n" <> - "User-supplied type:\n" <> - Text.pack (Pretty.scPrettyTermInCtx PPS.defaultOpts [] tp_norm) - --- | Extract out the contents of the 'Right' of an 'Either', calling 'fail' if --- the 'Either' is a 'Left'. The supplied 'String' describes the action (in --- "ing" form, as in, "parsing") that was performed to create this 'Either'. --- failOnLeft :: (MonadFail m, Show err) => String -> Either err a -> m a --- failOnLeft action (Left err) = Fail.fail ("Error" ++ action ++ ": " ++ show err) --- failOnLeft _ (Right a) = return a - --- | Extract out the contents of the 'Just' of a 'Maybe' wrapped in a --- `MonadFail`, calling 'fail' on the given string if the `Maybe` is a --- `Nothing`. -failOnNothing :: Fail.MonadFail m => Text -> Maybe a -> m a -failOnNothing err_str Nothing = Fail.fail $ Text.unpack err_str -failOnNothing _ (Just a) = return a - --- | Extract the bit width of an architecture -archReprWidth :: ArchRepr arch -> NatRepr (ArchWidth arch) -archReprWidth (X86Repr w) = w - --- | Get the architecture of an LLVM module -llvmModuleArchRepr :: LLVMModule arch -> ArchRepr arch -llvmModuleArchRepr lm = llvmArch $ view transContext $ modTrans lm - --- | Get the bit width of the architecture of an LLVM module -llvmModuleArchReprWidth :: LLVMModule arch -> NatRepr (ArchWidth arch) -llvmModuleArchReprWidth = archReprWidth . llvmModuleArchRepr - --- | Get the 'TypeContext' of an LLVM module -llvmModuleTypeContext :: LLVMModule arch -> TypeContext -llvmModuleTypeContext lm = modTrans lm ^. transContext . llvmTypeCtx - --- | Look up the 'L.Declare' for an external symbol in an 'LLVMModule' -lookupFunctionDecl :: LLVMModule arch -> Text -> Maybe L.Declare -lookupFunctionDecl lm nm = - find (((fromString $ Text.unpack nm) ==) . L.decName) $ L.modDeclares $ modAST lm - --- | Look up the 'L.Define' for a symbol defined in an 'LLVMModule' -lookupFunctionDef :: LLVMModule arch -> Text -> Maybe L.Define -lookupFunctionDef lm nm = - find (((fromString $ Text.unpack nm) ==) . L.defName) $ L.modDefines $ modAST lm - --- | Lookup a the singnature for a symbol in an 'LLVMModule'. This --- will find a signaure for either an external symbol, or for --- a defined symbol -lookupFunctionDeclOrDef :: LLVMModule arch -> Text -> Maybe L.Declare -lookupFunctionDeclOrDef lm nm = - lookupFunctionDecl lm nm <|> (declareFromDefine <$> lookupFunctionDef lm nm) - --- | Look up the Crucible CFG for a defined symbol in an 'LLVMModule' -lookupFunctionCFG :: LLVMModule arch -> Text -> IO (Maybe (AnyCFG Lang.Crucible.LLVM.Extension.LLVM)) -lookupFunctionCFG lm nm = - getTranslatedCFG (modTrans lm) (fromString $ Text.unpack nm) >>= \case - Nothing -> return Nothing - Just (_,cfg,_warns) -> return (Just cfg) - --- | Look up the argument and return types of a named function -lookupFunctionType :: LLVMModule arch -> Text -> - TopLevel (Some CtxRepr, Some TypeRepr) -lookupFunctionType (lm :: LLVMModule arch) nm = - case lookupFunctionDeclOrDef lm nm of - Just decl -> - do let w = llvmModuleArchReprWidth lm - leq1_proof <- case decideLeq (knownNat @1) w of - Left pf -> return pf - Right _ -> fail "LLVM arch width is 0!" - leq16_proof <- case decideLeq (knownNat @16) w of - Left pf -> return pf - Right _ -> fail "LLVM arch width is too small!" - let ?ptrWidth = w - let ?lc = llvmModuleTypeContext lm - withLeqProof leq1_proof $ withLeqProof leq16_proof $ - llvmDeclToFunHandleRepr' @(ArchWidth arch) decl $ \args ret -> - return (Some args, Some ret) - Nothing -> - fail $ Text.unpack $ "Could not find symbol: " <> nm - --- | Look for the LLVM module in a 'HeapsterEnv' where a symbol is defined -lookupModDefiningSym :: HeapsterEnv -> Text -> Maybe (Some LLVMModule) -lookupModDefiningSym env nm = - find (\(Some lm) -> isJust (lookupFunctionDef lm nm)) $ - heapsterEnvLLVMModules env - --- | Look for any LLVM module in a 'HeapsterEnv' containing a symbol -lookupModContainingSym :: HeapsterEnv -> Text -> Maybe (Some LLVMModule) -lookupModContainingSym env nm = - find (\(Some lm) -> isJust (lookupFunctionDeclOrDef lm nm)) $ - heapsterEnvLLVMModules env - --- | An LLVM module plus a CFG for a specific function in that module -data ModuleAndCFG arch = - ModuleAndCFG (LLVMModule arch) (AnyCFG Lang.Crucible.LLVM.Extension.LLVM) - --- | Look up the LLVM module and associated CFG for a symobl -lookupLLVMSymbolModAndCFG :: HeapsterEnv -> Text -> IO (Maybe (Some ModuleAndCFG)) -lookupLLVMSymbolModAndCFG henv nm = - case lookupModDefiningSym henv nm of - Just (Some lm) -> - do res <- lookupFunctionCFG lm nm - return ((Some . ModuleAndCFG lm) <$> res) - Nothing -> return Nothing - -heapster_default_env :: PermEnv -heapster_default_env = emptyPermEnv - --- | Based on the function of the same name in SAWCore.ParserUtils. --- Unlike that function, this calls 'fail' instead of 'error'. --- --- XXX: we only need one; unify these once the error handling gets fixed. -readModuleFromFile :: FilePath -> TopLevel (Un.Module, ModuleName) -readModuleFromFile path = do - base <- liftIO getCurrentDirectory - txt <- liftIO $ TLIO.readFile path - case Un.parseSAW base path txt of - Right m@(Un.Module (Un.PosPair _ mnm) _ _) -> pure (m, mnm) - Left err -> fail $ "Module parsing failed:\n" ++ show err - --- | Parse the second given string as a term, the first given string being --- used as the path for error reporting --- --- XXX: this should be moved to saw-core once we have unified error --- handling that'll allow it to not need to explicitly live in --- TopLevel. -parseTermFromString :: String -> String -> TopLevel Un.UTerm -parseTermFromString nm term_string = do - let base = "" - path = "<" ++ nm ++ ">" - case Un.parseSAWTerm base path (TL.pack term_string) of - Right term -> pure term - Left err -> fail $ "Term parsing failed:\n" ++ show err - --- | Find an unused identifier in a 'Module' by starting with a particular --- 'String' and appending a number if necessary -findUnusedIdent :: Module -> String -> Ident -findUnusedIdent m str = - fromJust $ find (isNothing . Mod.resolveName m . identBaseName) $ - map (mkSafeIdent (moduleName m)) $ - (str : map ((str ++) . show) [(0::Int) ..]) - --- | Insert a SAW core definition into the SAW core module associated with a --- 'HeapsterEnv', printing out the definition if the debug level is at least 2 -heapsterInsertDef :: HeapsterEnv -> Ident -> Term -> Term -> TopLevel () -heapsterInsertDef henv trm_ident trm_tp trm = - do debugPrettyTermWithPrefix henv verboseDebugLevel - ("Inserting def " ++ show trm_ident ++ " =\n") trm - sc <- getSharedContext - liftIO $ scInsertDef sc trm_ident trm_tp trm - --- | Parse the second given string as a term, check that it has the given type, --- and, if the parsed term is not already an identifier, add it as a definition --- in the current module using the first given string. If that first string is --- already used, find another name for the definition. Return either the --- identifer of the new definition or the identifier that was parsed. -parseAndInsDef :: HeapsterEnv -> String -> Term -> String -> TopLevel Ident -parseAndInsDef henv nm term_tp term_string = - do sc <- getSharedContext - un_term <- parseTermFromString nm term_string - let mnm = heapsterEnvSAWModule henv - typed_term <- liftIO $ scTypeCheckCompleteError sc (Just mnm) un_term - liftIO $ scCheckSubtype sc (Just mnm) typed_term term_tp - case typedVal typed_term of - STApp {stAppTermF = Constant (Name _ (ModuleIdentifier term_ident))} -> - return term_ident - term -> do - m <- liftIO $ scFindModule sc mnm - let term_ident = findUnusedIdent m nm - heapsterInsertDef henv term_ident term_tp term - return term_ident - --- | Build a 'HeapsterEnv' associated with the given SAW core module and the --- given 'LLVMModule's. Add any globals in the 'LLVMModule's to the returned --- 'HeapsterEnv'. -mkHeapsterEnv :: DebugLevel -> ModuleName -> [Some LLVMModule] -> - TopLevel HeapsterEnv -mkHeapsterEnv dlevel saw_mod_name llvm_mods@(Some first_mod:_) = - do sc <- getSharedContext - let w = llvmModuleArchReprWidth first_mod - let endianness = - llvmDataLayout (modTrans first_mod ^. transContext ^. llvmTypeCtx) - ^. intLayout - leq_proof <- case decideLeq (knownNat @1) w of - Left pf -> return pf - Right _ -> fail "LLVM arch width is 0!" - let globals = concatMap (\(Some lm) -> L.modGlobals $ modAST lm) llvm_mods - env <- - liftIO $ withKnownNat w $ withLeqProof leq_proof $ - foldM (permEnvAddGlobalConst sc saw_mod_name dlevel endianness w) - heapster_default_env globals - env_ref <- liftIO $ newIORef env - dlevel_ref <- liftIO $ newIORef dlevel - checks_ref <- liftIO $ newIORef doChecks - tcfg_ref <- liftIO $ newIORef [] - return $ HeapsterEnv { - heapsterEnvSAWModule = saw_mod_name, - heapsterEnvPermEnvRef = env_ref, - heapsterEnvLLVMModules = llvm_mods, - heapsterEnvDebugLevel = dlevel_ref, - heapsterEnvChecksFlag = checks_ref, - heapsterEnvTCFGs = tcfg_ref - } -mkHeapsterEnv _ _ [] = fail "mkHeapsterEnv: empty list of LLVM modules!" - - -heapster_init_env :: Text -> FilePath -> TopLevel HeapsterEnv -heapster_init_env mod_str llvm_filename = - heapster_init_env_gen noDebugLevel mod_str llvm_filename - -heapster_init_env_debug :: Text -> FilePath -> TopLevel HeapsterEnv -heapster_init_env_debug mod_str llvm_filename = - heapster_init_env_gen traceDebugLevel mod_str llvm_filename - -heapster_init_env_gen :: DebugLevel -> Text -> FilePath -> TopLevel HeapsterEnv -heapster_init_env_gen dlevel mod_str llvm_filename = - do llvm_mod <- llvm_load_module llvm_filename - sc <- getSharedContext - liftIO $ ensureCryptolMLoaded sc - let saw_mod_name = mkModuleName [mod_str] - mod_loaded <- liftIO $ scModuleIsLoaded sc saw_mod_name - if mod_loaded then - fail ("SAW module with name " ++ show mod_str ++ " already defined!") - else return () - -- import SpecM by default - let specMModuleName = mkModuleName ["SpecM"] - preludeMod <- liftIO $ scFindModule sc specMModuleName - liftIO $ scLoadModule sc (insImport (const True) preludeMod $ - emptyModule saw_mod_name) - mkHeapsterEnv dlevel saw_mod_name [llvm_mod] - -load_sawcore_from_file :: FilePath -> TopLevel () -load_sawcore_from_file mod_filename = - do sc <- getSharedContext - liftIO $ ensureCryptolMLoaded sc - (saw_mod, _) <- readModuleFromFile mod_filename - liftIO $ tcInsertModule sc saw_mod - -heapster_init_env_from_file :: FilePath -> FilePath -> TopLevel HeapsterEnv -heapster_init_env_from_file mod_filename llvm_filename = - heapster_init_env_for_files_gen noDebugLevel mod_filename [llvm_filename] - -heapster_init_env_from_file_debug :: FilePath -> FilePath -> TopLevel HeapsterEnv -heapster_init_env_from_file_debug mod_filename llvm_filename = - heapster_init_env_for_files_gen traceDebugLevel mod_filename [llvm_filename] - -heapster_init_env_for_files_gen :: DebugLevel -> - FilePath -> [FilePath] -> - TopLevel HeapsterEnv -heapster_init_env_for_files_gen dlevel mod_filename llvm_filenames = - do llvm_mods <- mapM llvm_load_module llvm_filenames - sc <- getSharedContext - liftIO $ ensureCryptolMLoaded sc - (saw_mod, saw_mod_name) <- readModuleFromFile mod_filename - liftIO $ tcInsertModule sc saw_mod - mkHeapsterEnv dlevel saw_mod_name llvm_mods - -heapster_init_env_for_files :: FilePath -> [FilePath] -> TopLevel HeapsterEnv -heapster_init_env_for_files mod_filename llvm_filenames = - heapster_init_env_for_files_gen noDebugLevel mod_filename llvm_filenames - -heapster_init_env_for_files_debug :: FilePath -> [FilePath] -> TopLevel HeapsterEnv -heapster_init_env_for_files_debug mod_filename llvm_filenames = - heapster_init_env_for_files_gen traceDebugLevel mod_filename llvm_filenames - --- | Look up the CFG associated with a symbol name in a Heapster environment --- XXX why does this take the BuiltinContext and Options if it doesn't use them? -heapster_get_cfg :: BuiltinContext -> Options -> HeapsterEnv -> - Text -> TopLevel SAW_CFG -heapster_get_cfg _ _ henv nm = - case lookupModDefiningSym henv nm of - Just (Some lm) -> llvm_cfg (Some lm) nm - Nothing -> fail $ Text.unpack $ "Could not find CFG for symbol: " <> nm - - --- | Define a new opaque named permission with the given name, arguments, and --- Crucible type that translates to the given SAW core type with the supplied --- type description --- XXX why does this take the BuiltinContext and Options if it doesn't use them? -heapster_define_opaque_perm :: BuiltinContext -> Options -> HeapsterEnv -> - Text -> Text -> Text -> Text -> - Text -> TopLevel () -heapster_define_opaque_perm _bic _opts henv nm args_str tp_str term_str d_str = - do env <- liftIO $ readIORef $ heapsterEnvPermEnvRef henv - Some args <- parseCtxString "argument types" env (Text.unpack args_str) - Some tp_perm <- parseTypeString "permission type" env (Text.unpack tp_str) - sc <- getSharedContext - term_tp <- liftIO $ translateExprTypeFunType sc env args - term_ident <- parseAndInsDef henv (Text.unpack nm) term_tp (Text.unpack term_str) - d_tp <- tpDescTypeM sc - d_ident <- parseAndInsDef henv (Text.unpack nm ++ "__desc") d_tp (Text.unpack d_str) - liftIO $ checkTypeAgreesWithDesc sc env nm term_ident args d_ident - let env' = permEnvAddOpaquePerm env (Text.unpack nm) args tp_perm term_ident d_ident - liftIO $ writeIORef (heapsterEnvPermEnvRef henv) env' - - --- | Define a new recursive named permission with the given name, arguments, --- type, and permission that it unfolds to --- XXX why does this take the BuiltinContext and Options if it doesn't use them? -heapster_define_recursive_perm :: BuiltinContext -> Options -> HeapsterEnv -> - Text -> Text -> Text -> Text -> - TopLevel () -heapster_define_recursive_perm _bic _opts henv nm args_str tp_str p_str = - do env <- liftIO $ readIORef $ heapsterEnvPermEnvRef henv - let mnm = heapsterEnvSAWModule henv - sc <- getSharedContext - - -- Parse the arguments, the type, and the body - Some args_ctx <- parseParsedCtxString "argument types" env (Text.unpack args_str) - Some tp <- parseTypeString "permission type" env (Text.unpack tp_str) - let args = parsedCtxCtx args_ctx - args_p = CruCtxCons args (ValuePermRepr tp) - mb_p <- parsePermInCtxString "permission" env - (consParsedCtx (Text.unpack nm) (ValuePermRepr tp) args_ctx) tp (Text.unpack p_str) - - -- Generate the type description for the body of the recursive perm - d_tp <- tpDescTypeM sc - let d_ident = mkSafeIdent mnm (Text.unpack nm ++ "__desc") - d_trm <- liftIO $ translateCompleteDescInCtx sc env args_p mb_p - heapsterInsertDef henv d_ident d_tp d_trm - - -- Generate the function \args -> tpElemEnv args (Ind d) from the - -- arguments to the type of the translation of the permission as the term - let transf_ident = mkSafeIdent mnm (Text.unpack nm) - transf_tp <- liftIO $ translateExprTypeFunType sc env args - transf_trm <- - liftIO $ translateIndTypeFun sc env args (globalOpenTerm d_ident) - heapsterInsertDef henv transf_ident transf_tp transf_trm - - -- Add the recursive perm to the environment and update henv - env' <- - permEnvAddRecPermM env (Text.unpack nm) args tp transf_ident d_ident mb_p - NameNonReachConstr - (\_ _ -> return NoReachMethods) - liftIO $ writeIORef (heapsterEnvPermEnvRef henv) env' - - --- | Define a new recursive named permission with the given name, arguments, --- type, and permission that it unfolds to, that forms a reachability --- permission, meaning it has the form --- --- > P := eq(x) or q --- --- where the name @P@ occurs exactly once and @x@ occurs not at all in --- permission @q@. The last input should define a transitivity method as --- described in the documentation for the 'ReachMethods' type. --- XXX why does this take the BuiltinContext and Options if it doesn't use them? -heapster_define_reachability_perm :: BuiltinContext -> Options -> HeapsterEnv -> - Text -> Text -> Text -> Text -> - Text -> TopLevel () -heapster_define_reachability_perm _bic _opts henv nm args_str tp_str p_str trans_fun_str = - do env <- liftIO $ readIORef $ heapsterEnvPermEnvRef henv - let mnm = heapsterEnvSAWModule henv - sc <- getSharedContext - - -- Parse the arguments, the type, and the translation type - Some (tp :: TypeRepr tp) <- parseTypeString "permission type" env (Text.unpack tp_str) - (Some pre_args_ctx, - last_args_ctx :: ParsedCtx (RNil :> tp)) <- - do some_args_ctx <- parseParsedCtxString "argument types" env (Text.unpack args_str) - case some_args_ctx of - Some args_ctx - | CruCtxCons _ tp' <- parsedCtxCtx args_ctx - , Just Refl <- testEquality tp tp' -> - return (Some (parsedCtxUncons args_ctx), parsedCtxLast args_ctx) - _ -> Fail.fail "Incorrect type for last argument of reachability perm" - let args_ctx = appendParsedCtx pre_args_ctx last_args_ctx - let args = parsedCtxCtx args_ctx - args_p = CruCtxCons args (ValuePermRepr tp) - mb_p <- parsePermInCtxString "permission" env - (consParsedCtx (Text.unpack nm) (ValuePermRepr tp) args_ctx) tp (Text.unpack p_str) - - -- Generate the type description for the body of the recursive perm - d_tp <- tpDescTypeM sc - let d_ident = mkSafeIdent mnm (Text.unpack nm ++ "__desc") - d_trm <- liftIO $ translateCompleteDescInCtx sc env args_p mb_p - heapsterInsertDef henv d_ident d_tp d_trm - - -- Generate the function \args -> tpElemEnv args (Ind d) from the - -- arguments to the type of the translation of the permission as the term - let transf_ident = mkSafeIdent mnm (Text.unpack nm) - transf_tp <- liftIO $ translateExprTypeFunType sc env args - transf_trm <- - liftIO $ translateIndTypeFun sc env args (globalOpenTerm d_ident) - heapsterInsertDef henv transf_ident transf_tp transf_trm - - -- Add the recursive perm to the environment and update henv - env' <- - permEnvAddRecPermM env (Text.unpack nm) args tp transf_ident d_ident mb_p - NameReachConstr - (\npn tmp_env -> - -- Return the ReachMethods structure, which contains trans_ident. - -- Typecheck trans_ident with x:P, y:P -o x:P - do trans_fun_tp <- - liftIO $ - translateCompletePureFunType sc tmp_env (CruCtxCons args tp) - (nus (cruCtxProxies args :>: Proxy) $ \(ns :>: y :>: z) -> - MNil :>: - ValPerm_Named npn (namesToExprs (ns :>: y)) NoPermOffset :>: - ValPerm_Named npn (namesToExprs (ns :>: z)) NoPermOffset) - (nus (cruCtxProxies args :>: Proxy) $ \(ns :>: _ :>: z) -> - ValPerm_Named npn (namesToExprs (ns :>: z)) NoPermOffset) - trans_ident <- - parseAndInsDef henv ("trans_" ++ Text.unpack nm) trans_fun_tp (Text.unpack trans_fun_str) - return (ReachMethods trans_ident)) - liftIO $ writeIORef (heapsterEnvPermEnvRef henv) env' - - --- | Helper function to add a recursive named shape to a 'PermEnv', adding all --- the required identifiers to the given SAW core module -addRecNamedShape :: 1 <= w => HeapsterEnv -> String -> - CruCtx args -> NatRepr w -> - Mb (args :> LLVMShapeType w) (PermExpr (LLVMShapeType w)) -> - TopLevel PermEnv -addRecNamedShape henv nm args w mb_sh = - -- Generate the type description for the body of the recursive shape - do sc <- getSharedContext - env <- liftIO $ readIORef $ heapsterEnvPermEnvRef henv - let mnm = heapsterEnvSAWModule henv - d_tp <- tpDescTypeM sc - let d_ident = mkSafeIdent mnm (nm ++ "__desc") - args_p = CruCtxCons args (LLVMShapeRepr w) - d_trm <- liftIO $ translateCompleteDescInCtx sc env args_p mb_sh - heapsterInsertDef henv d_ident d_tp d_trm - - -- Generate the function \args -> tpElemEnv args (Ind d) from the - -- arguments to the type of the translation of the permission as the term - let transf_ident = mkSafeIdent mnm nm - transf_tp <- liftIO $ translateExprTypeFunType sc env args - transf_trm <- - liftIO $ translateIndTypeFun sc env args (globalOpenTerm d_ident) - heapsterInsertDef henv transf_ident transf_tp transf_trm - - -- Add the recursive shape to the environment and update henv - let nmsh = NamedShape nm args $ RecShapeBody mb_sh transf_ident d_ident - return $ withKnownNat w $ permEnvAddNamedShape env nmsh - - --- | Define a new recursive named permission with the given name, arguments, --- type, and memory shape that it unfolds to --- XXX why does this take the BuiltinContext and Options if it doesn't use them? -heapster_define_recursive_shape :: BuiltinContext -> Options -> HeapsterEnv -> - Text -> Int -> Text -> Text -> - TopLevel () -heapster_define_recursive_shape _bic _opts henv nm w_int args_str body_str = - do env <- liftIO $ readIORef $ heapsterEnvPermEnvRef henv - - -- Parse the bit width, arguments, and the body - SomeKnownNatGeq1 w <- - failOnNothing "Shape width must be positive" $ someKnownNatGeq1 w_int - Some args_ctx <- parseParsedCtxString "argument types" env (Text.unpack args_str) - let args = parsedCtxCtx args_ctx - mb_sh <- parseExprInCtxString env (LLVMShapeRepr w) - (consParsedCtx (Text.unpack nm) (LLVMShapeRepr w) args_ctx) (Text.unpack body_str) - - -- Add the shape to the current environment - env' <- addRecNamedShape henv (Text.unpack nm) args w mb_sh - liftIO $ writeIORef (heapsterEnvPermEnvRef henv) env' - - --- | Define a new named permission with the given name, arguments, and type --- that is equivalent to the given permission. --- XXX why does this take the BuiltinContext and Options if it doesn't use them? -heapster_define_perm :: BuiltinContext -> Options -> HeapsterEnv -> - Text -> Text -> Text -> Text -> - TopLevel () -heapster_define_perm _bic _opts henv nm args_str tp_str perm_string = - do env <- liftIO $ readIORef $ heapsterEnvPermEnvRef henv - Some args_ctx <- parseParsedCtxString "argument types" env (Text.unpack args_str) - let args = parsedCtxCtx args_ctx - Some tp_perm <- parseTypeString "permission type" env (Text.unpack tp_str) - perm <- parsePermInCtxString "permission body" env - args_ctx tp_perm (Text.unpack perm_string) - let env' = permEnvAddDefinedPerm env (Text.unpack nm) args tp_perm perm - liftIO $ writeIORef (heapsterEnvPermEnvRef henv) env' - - --- | Define a new named llvm shape with the given name, pointer width, --- arguments, and definition as a shape --- XXX why does this take the BuiltinContext and Options if it doesn't use them? -heapster_define_llvmshape :: BuiltinContext -> Options -> HeapsterEnv -> - Text -> Int -> Text -> Text -> - TopLevel () -heapster_define_llvmshape _bic _opts henv nm w_int args_str sh_str = - do env <- liftIO $ readIORef $ heapsterEnvPermEnvRef henv - (Some (Pair w LeqProof)) <- - failOnNothing "Shape width must be positive" $ someNatGeq1 w_int - Some args_ctx <- parseParsedCtxString "argument types" env (Text.unpack args_str) - let args = parsedCtxCtx args_ctx - mb_sh <- parseExprInCtxString env (LLVMShapeRepr w) args_ctx (Text.unpack sh_str) - let env' = withKnownNat w $ permEnvAddDefinedShape env (Text.unpack nm) args mb_sh - liftIO $ writeIORef (heapsterEnvPermEnvRef henv) env' - - --- | Define a new opaque llvm shape with the given name, pointer width, --- arguments, expression for the length in bytes, SAW core expression for a --- type-level function from the Heapster translations of the argument types to a --- SAW core type, and SAW core expression for a type description of that type --- XXX why does this take the BuiltinContext and Options if it doesn't use them? -heapster_define_opaque_llvmshape :: BuiltinContext -> Options -> HeapsterEnv -> - Text -> Int -> Text -> Text -> - Text -> Text -> TopLevel () -heapster_define_opaque_llvmshape _bic _opts henv nm w_int args_str len_str tp_str d_str = - do env <- liftIO $ readIORef $ heapsterEnvPermEnvRef henv - (Some (Pair w LeqProof)) <- - failOnNothing "Shape width must be positive" $ someNatGeq1 w_int - Some args_ctx <- parseParsedCtxString "argument types" env (Text.unpack args_str) - let args = parsedCtxCtx args_ctx - mb_len <- parseExprInCtxString env (BVRepr w) args_ctx (Text.unpack len_str) - sc <- getSharedContext - d_tp <- tpDescTypeM sc - d_id <- parseAndInsDef henv (Text.unpack nm ++ "__desc") d_tp (Text.unpack d_str) - tp_tp <- liftIO $ translateExprTypeFunType sc env args - tp_id <- parseAndInsDef henv (Text.unpack nm) tp_tp (Text.unpack tp_str) - liftIO $ checkTypeAgreesWithDesc sc env nm tp_id args d_id - let env' = - withKnownNat w $ permEnvAddOpaqueShape env (Text.unpack nm) args mb_len tp_id d_id - liftIO $ writeIORef (heapsterEnvPermEnvRef henv) env' - - --- | Define a new named LLVM shape from a Rust type declaration and an optional --- crate name that qualifies the type name --- XXX why does this take the BuiltinContext and Options if it doesn't use them? -heapster_define_rust_type_qual_opt :: BuiltinContext -> Options -> HeapsterEnv -> - Maybe Text -> Text -> TopLevel () -heapster_define_rust_type_qual_opt _bic _opts henv maybe_crate str = - -- NOTE: Looking at first LLVM module to determine pointer width. Need to - -- think more to determine if this is always a safe thing to do (e.g. are - -- there ever circumstances where different modules have different pointer - -- widths?) - do Some lm <- failOnNothing ("No LLVM modules found") - (listToMaybe $ heapsterEnvLLVMModules henv) - let w = llvmModuleArchReprWidth lm - leq_proof <- case decideLeq (knownNat @1) w of - Left pf -> return pf - Right _ -> fail "LLVM arch width is 0!" - env <- liftIO $ readIORef (heapsterEnvPermEnvRef henv) - let crated_nm nm = maybe nm (\crate -> crate <> "::" <> nm) maybe_crate - withKnownNat w $ withLeqProof leq_proof $ - do partialShape <- parseRustTypeString env w (Text.unpack str) - case partialShape of - NonRecShape nm ctx sh -> - do let nsh = NamedShape { namedShapeName = Text.unpack $ crated_nm (Text.pack nm) - , namedShapeArgs = ctx - , namedShapeBody = DefinedShapeBody sh - } - env' = permEnvAddNamedShape env nsh - liftIO $ writeIORef (heapsterEnvPermEnvRef henv) env' - RecShape nm ctx mb_sh -> - do let nm' = crated_nm (Text.pack nm) - env' <- addRecNamedShape henv (Text.unpack nm') ctx w mb_sh - liftIO $ writeIORef (heapsterEnvPermEnvRef henv) env' - - --- | Define a new named LLVM shape from a Rust type declaration -heapster_define_rust_type :: BuiltinContext -> Options -> HeapsterEnv -> - Text -> TopLevel () -heapster_define_rust_type bic opts henv str = - heapster_define_rust_type_qual_opt bic opts henv Nothing str - --- | Define a new named LLVM shape from a Rust type declaration and a crate name --- that qualifies the Rust type by being prefixed to the name of the LLVM shape -heapster_define_rust_type_qual :: BuiltinContext -> Options -> HeapsterEnv -> - Text -> Text -> TopLevel () -heapster_define_rust_type_qual bic opts henv crate str = - heapster_define_rust_type_qual_opt bic opts henv (Just crate) str - --- | Add Heapster type-checking hint for some blocks in a function given by --- name. The blocks to receive the hint are those specified in the list, or all --- blocks if the list is empty. -heapster_add_block_hints :: HeapsterEnv -> Text -> [Int] -> - (forall ext blocks init ret args. - CFG ext blocks init ret -> BlockID blocks args -> - TopLevel (BlockHintSort args)) -> - TopLevel () -heapster_add_block_hints henv nm blks hintF = - do env <- liftIO $ readIORef $ heapsterEnvPermEnvRef henv - Some (ModuleAndCFG _ (AnyCFG cfg)) <- - failOnNothing ("Could not find symbol definition: " <> nm) =<< - io (lookupLLVMSymbolModAndCFG henv nm) - let h = cfgHandle cfg - blocks = fmapFC blockInputs $ cfgBlockMap cfg - block_idxs = fmapFC (blockIDIndex . blockID) $ cfgBlockMap cfg - blkIDs <- case blks of - -- If an empty list is given, add a hint to every block - [] -> pure $ toListFC (Some . BlockID) block_idxs - _ -> forM blks $ \blk -> - failOnNothing ("Block ID " <> Text.pack (show blk) <> - " not found in function " <> nm) - (fmapF BlockID <$> Ctx.intIndex blk (Ctx.size blocks)) - env' <- foldM (\env' (Some blkID) -> - permEnvAddHint env' <$> Hint_Block <$> - BlockHint h blocks blkID <$> - hintF cfg blkID) - env blkIDs - liftIO $ writeIORef (heapsterEnvPermEnvRef henv) env' - --- | Add a hint to the Heapster type-checker that Crucible block number @block@ in --- function @fun@ should have permissions @perms@ on its inputs --- XXX why does this take the BuiltinContext and Options if it doesn't use them? -heapster_block_entry_hint :: BuiltinContext -> Options -> HeapsterEnv -> - Text -> Int -> Text -> Text -> Text -> - TopLevel () -heapster_block_entry_hint _bic _opts henv nm blk top_args_str ghosts_str perms_str = - do env <- liftIO $ readIORef $ heapsterEnvPermEnvRef henv - Some top_args_p <- - parseParsedCtxString "top-level argument context" env (Text.unpack top_args_str) - Some ghosts_p <- - parseParsedCtxString "ghost argument context" env (Text.unpack ghosts_str) - let top_args = parsedCtxCtx top_args_p - ghosts = parsedCtxCtx ghosts_p - heapster_add_block_hints henv nm [blk] $ \cfg blkID -> - let block_args = - mkCruCtx $ blockInputs $ - (cfgBlockMap cfg) Ctx.! (blockIDIndex blkID) in - BlockEntryHintSort top_args ghosts <$> - parsePermsString "block entry permissions" env - (appendParsedCtx (appendParsedCtx - top_args_p (mkArgsParsedCtx block_args)) ghosts_p) - (Text.unpack perms_str) - - --- | Add a hint to the Heapster type-checker to *generalize* (recursively --- replace all instances of @eq(const)@ with @exists x. eq(x)@) all permissions --- on the inputs of the given Crucible blocks numbers. If the given list is --- empty, do so for every block in the CFG. --- XXX why does this take the BuiltinContext and Options if it doesn't use them? -heapster_gen_block_perms_hint :: BuiltinContext -> Options -> HeapsterEnv -> - Text -> [Int] -> TopLevel () -heapster_gen_block_perms_hint _bic _opts henv nm blks = - heapster_add_block_hints henv nm blks $ \_ _ -> return GenPermsHintSort - --- | Add a hint to the Heapster type-checker to make a join point at each of the --- given block numbers, meaning that all entries to the given blocks are merged --- into a single entrypoint, whose permissions are given by the first call to --- the block --- XXX why does this take the BuiltinContext and Options if it doesn't use them? -heapster_join_point_hint :: BuiltinContext -> Options -> HeapsterEnv -> - Text -> [Int] -> TopLevel () -heapster_join_point_hint _bic _opts henv nm blks = - heapster_add_block_hints henv nm blks $ \_ _ -> return JoinPointHintSort - --- | Search for all symbol names in any LLVM module in a 'HeapsterEnv' that --- contain the supplied string as a substring --- XXX why does this take the BuiltinContext and Options if it doesn't use them? -heapster_find_symbols :: BuiltinContext -> Options -> HeapsterEnv -> Text -> - TopLevel [Text] -heapster_find_symbols _bic _opts henv txt = do - let str = T.unpack txt - results = - concatMap (\(Some lm) -> - mapMaybe (\(L.Symbol nm) -> - if isInfixOf str nm then Just nm else Nothing) $ - map L.decName (L.modDeclares $ modAST lm) ++ - map L.defName (L.modDefines $ modAST lm)) $ - heapsterEnvLLVMModules henv - return $ map T.pack results - --- | Search for a symbol name in any LLVM module in a 'HeapsterEnv' that --- contains the supplied string as a substring, failing if there is not exactly --- one such symbol -heapster_find_symbol :: BuiltinContext -> Options -> HeapsterEnv -> Text -> - TopLevel Text -heapster_find_symbol bic opts henv txt = - heapster_find_symbols bic opts henv txt >>= \syms -> - case syms of - [sym] -> return sym - [] -> fail ("No symbol found matching string: " ++ T.unpack txt) - _ -> fail ("Found multiple symbols matching string " ++ T.unpack txt ++ ": " ++ - concat (intersperse ", " $ map show syms)) - --- | Extract the 'String' name of an LLVM symbol -symString :: L.Symbol -> String -symString (L.Symbol str) = str - --- | Extract the function type of an LLVM definition -defFunType :: L.Define -> L.Type -defFunType defn = - L.FunTy (L.defRetType defn) (map L.typedType - (L.defArgs defn)) (L.defVarArgs defn) - --- | Extract the function type of an LLVM declaration -decFunType :: L.Declare -> L.Type -decFunType decl = - L.FunTy (L.decRetType decl) (L.decArgs decl) (L.decVarArgs decl) - --- | Search for all symbols with the supplied string as a substring that have --- the supplied LLVM type --- XXX why does this take the BuiltinContext and Options if it doesn't use them? -heapster_find_symbols_with_type :: BuiltinContext -> Options -> HeapsterEnv -> - Text -> Text -> TopLevel [Text] -heapster_find_symbols_with_type _bic _opts henv str tp_str = - let str' = T.unpack str - tp_str' = T.unpack tp_str - in - case L.parseType tp_str' of - Left err -> - fail ("Error parsing LLVM type: " ++ tp_str' ++ "\n" ++ show err) - Right tp@(L.FunTy _ _ _) -> - return $ - concatMap (\(Some lm) -> - mapMaybe (\decl -> - if isInfixOf str' (symString $ L.decName decl) && - decFunType decl == tp - then Just (T.pack $ symString $ L.decName decl) else Nothing) - (L.modDeclares $ modAST lm) - ++ - mapMaybe (\defn -> - if isInfixOf str' (symString $ L.defName defn) && - defFunType defn == tp - then Just (T.pack $ symString $ L.defName defn) else Nothing) - (L.modDefines $ modAST lm)) $ - heapsterEnvLLVMModules henv - Right tp -> - fail ("Expected an LLVM function type, but found: " ++ show tp) - --- | Search for a symbol by name and Crucible type in any LLVM module in a --- 'HeapsterEnv' that contains the supplied string as a substring -heapster_find_symbol_with_type :: BuiltinContext -> Options -> HeapsterEnv -> - Text -> Text -> TopLevel Text -heapster_find_symbol_with_type bic opts henv str tp_str = - let str' = T.unpack str - tp_str' = T.unpack tp_str - in - heapster_find_symbols_with_type bic opts henv str tp_str >>= \syms -> - case syms of - [sym] -> return sym - [] -> fail ("No symbol found matching string: " ++ str' ++ - " and type: " ++ tp_str') - _ -> fail ("Found multiple symbols matching string " ++ str' ++ - " and type: " ++ tp_str' ++ ": " ++ - concat (intersperse ", " $ map show syms)) - --- | Print a 'String' as a SAW-script string literal, escaping any double quotes --- or newlines -print_as_saw_script_string :: String -> String -print_as_saw_script_string str = - "\"" ++ concatMap (\c -> case c of - '\"' -> "\\\"" - '\n' -> "\\\n\\" - _ -> [c]) str ++ "\""; - --- | Map a search string @str@ to a newline-separated sequence of SAW-script --- commands @"heapster_find_symbol_with_type str tp"@, one for each LLVM type --- @tp@ associated with a symbol whose name contains @str@ --- XXX why does this take the BuiltinContext and Options if it doesn't use them? -heapster_find_symbol_commands :: BuiltinContext -> Options -> HeapsterEnv -> - Text -> TopLevel Text -heapster_find_symbol_commands _bic _opts henv str = - let str' = T.unpack str - result = - concatMap (\tp -> - "heapster_find_symbol_with_type env\n \"" ++ str' ++ "\"\n " ++ - print_as_saw_script_string (L.render $ Crucible.LLVM.ppType tp) ++ ";\n") $ - concatMap (\(Some lm) -> - mapMaybe (\decl -> - if isInfixOf str' (symString $ L.decName decl) - then Just (decFunType decl) - else Nothing) - (L.modDeclares $ modAST lm) - ++ - mapMaybe (\defn -> - if isInfixOf str' (symString $ L.defName defn) - then Just (defFunType defn) else Nothing) - (L.modDefines $ modAST lm)) $ - heapsterEnvLLVMModules henv - in - return $ T.pack result - - --- | Search for a symbol name in any LLVM module in a 'HeapsterEnv' that --- corresponds to the supplied string, which should be of the form: --- @"trait::method"@. Fails if there is not exactly one such symbol. -heapster_find_trait_method_symbol :: BuiltinContext -> Options -> - HeapsterEnv -> Text -> TopLevel Text -heapster_find_trait_method_symbol bic opts henv str = do - -- Divide into "trait::method" and "" at the left angle bracket, if any - let (traitMethod, instType) = T.span (/= '<') str - -- Check for the <> on the type - if not (T.isPrefixOf "<" instType && T.isSuffixOf ">" instType) then - fail $ T.unpack $ "Ill-formed query string: " <> str - else do - -- pop off the brackets - let unbracketedType :: Text = T.drop 1 $ T.dropEnd 1 instType - -- split the method off the "trait::method" (may be more than one "::") - -- and replace each "::" with ".." - let (colonTrait, method) = - let (revMethod, revTrait) = T.span (/= ':') (T.reverse traitMethod) - in (T.reverse (T.drop 2 revTrait), T.reverse revMethod) - trait = T.intercalate ".." $ T.splitOn "::" colonTrait - -- assemble the lower-level query string - let queryStr = unbracketedType - <> "$u20$as$u20$" - <> trait - <> "$GT$" - <> (T.pack $ show $ T.length method) - <> method - heapster_find_symbol bic opts henv queryStr - - --- | Assume that the given named function has the supplied type and translates --- to a SAW core definition given by the second name --- XXX why does this take the BuiltinContext and Options if it doesn't use them? -heapster_assume_fun_rename :: BuiltinContext -> Options -> HeapsterEnv -> - Text -> Text -> Text -> Text -> - TopLevel () -heapster_assume_fun_rename _bic _opts henv nm nm_to perms_string term_string = - do let nm_to' = T.unpack nm_to - perms_string' = T.unpack perms_string - term_string' = T.unpack term_string - Some lm <- failOnNothing ("Could not find symbol: " <> nm) - (lookupModContainingSym henv nm) - sc <- getSharedContext - let w = llvmModuleArchReprWidth lm - leq_proof <- case decideLeq (knownNat @1) w of - Left pf -> return pf - Right _ -> fail "LLVM arch width is 0!" - env <- liftIO $ readIORef $ heapsterEnvPermEnvRef henv - (Some cargs, Some ret) <- lookupFunctionType lm nm - let args = mkCruCtx cargs - withKnownNat w $ withLeqProof leq_proof $ do - SomeFunPerm fun_perm <- - parseFunPermStringMaybeRust "permissions" w env args ret perms_string' - env' <- liftIO $ readIORef (heapsterEnvPermEnvRef henv) - fun_typ <- liftIO $ translateCompleteFunPerm sc env fun_perm - term_ident <- parseAndInsDef henv nm_to' fun_typ term_string' - let env'' = permEnvAddGlobalSymFun env' - (GlobalSymbol $ fromString $ T.unpack nm) - w - fun_perm - (globalOpenTerm term_ident) - liftIO $ writeIORef (heapsterEnvPermEnvRef henv) env'' - --- | Create a new SAW core primitive named @nm@ with type @tp@ in the module --- associated with the supplied Heapster environment, and return its identifier -insPrimitive :: HeapsterEnv -> Text -> Term -> TopLevel Ident -insPrimitive henv nm tp = - do sc <- getSharedContext - let mnm = heapsterEnvSAWModule henv - let ident = mkSafeIdent mnm (Text.unpack nm) - liftIO $ scDeclarePrim sc ident PrimQualifier tp - return ident - --- | Assume that the given named function has the supplied type and translates --- to a SAW core definition given by the second name --- XXX why does this take the BuiltinContext and Options if it doesn't use them? -heapster_assume_fun_rename_prim :: BuiltinContext -> Options -> HeapsterEnv -> - Text -> Text -> Text -> TopLevel () -heapster_assume_fun_rename_prim _bic _opts henv nm nm_to perms_string = - do Some lm <- failOnNothing ("Could not find symbol: " <> nm) - (lookupModContainingSym henv nm) - sc <- getSharedContext - let w = llvmModuleArchReprWidth lm - leq_proof <- case decideLeq (knownNat @1) w of - Left pf -> return pf - Right _ -> fail "LLVM arch width is 0!" - env <- liftIO $ readIORef $ heapsterEnvPermEnvRef henv - (Some cargs, Some ret) <- lookupFunctionType lm nm - let args = mkCruCtx cargs - withKnownNat w $ withLeqProof leq_proof $ do - SomeFunPerm fun_perm <- - parseFunPermStringMaybeRust "permissions" w env args ret (Text.unpack perms_string) - env' <- liftIO $ readIORef (heapsterEnvPermEnvRef henv) - fun_typ <- liftIO $ translateCompleteFunPerm sc env fun_perm - term_ident <- insPrimitive henv nm_to fun_typ - let env'' = permEnvAddGlobalSymFun env' - (GlobalSymbol $ fromString $ Text.unpack nm) - w - fun_perm - (globalOpenTerm term_ident) - liftIO $ writeIORef (heapsterEnvPermEnvRef henv) env'' - --- | Assume that the given named function has the supplied type and translates --- to a SAW core definition given by name --- XXX why does this take the BuiltinContext and Options if it doesn't use them? -heapster_assume_fun :: BuiltinContext -> Options -> HeapsterEnv -> - Text -> Text -> Text -> TopLevel () -heapster_assume_fun _bic _opts henv nm perms_string term_string = - heapster_assume_fun_rename _bic _opts henv nm nm perms_string term_string - --- | Assume that the given named function has one or more permissions and --- associated translations, each of which is as given in 'heapster_assume_fun' --- XXX why does this take the BuiltinContext and Options if it doesn't use them? -heapster_assume_fun_multi :: BuiltinContext -> Options -> HeapsterEnv -> - Text -> [(Text, Text)] -> TopLevel () -heapster_assume_fun_multi _bic _opts henv nm perms_terms_strings = - do Some lm <- failOnNothing ("Could not find symbol: " <> nm) - (lookupModContainingSym henv nm) - sc <- getSharedContext - let w = llvmModuleArchReprWidth lm - leq_proof <- case decideLeq (knownNat @1) w of - Left pf -> return pf - Right _ -> fail "LLVM arch width is 0!" - (Some (cargs :: CtxRepr cargs), - Some (ret :: TypeRepr ret)) <- lookupFunctionType lm nm - let args = mkCruCtx cargs - env <- liftIO $ readIORef (heapsterEnvPermEnvRef henv) - perms_terms :: [(SomeFunPerm (CtxToRList cargs) ret, OpenTerm)] <- - forM (zip perms_terms_strings [0::Int ..]) $ \((perms_string, - term_string), i) -> - withKnownNat w $ withLeqProof leq_proof $ - do some_fun_perm <- - parseFunPermStringMaybeRust "permissions" w env args ret (Text.unpack perms_string) - fun_typ <- - case some_fun_perm of - SomeFunPerm fun_perm -> - liftIO $ translateCompleteFunPerm sc env fun_perm - term_ident <- - parseAndInsDef henv (Text.unpack nm ++ "__" ++ show i) fun_typ (Text.unpack term_string) - return (some_fun_perm, globalOpenTerm term_ident) - let env' = - withKnownNat w $ withLeqProof leq_proof $ - permEnvAddGlobalSymFunMulti env (GlobalSymbol $ - fromString $ Text.unpack nm) w perms_terms - liftIO $ writeIORef (heapsterEnvPermEnvRef henv) env' - - --- | Type-check a list of potentially mutually recursive functions, each against --- its own function permission, specified as a list of pairs of a function --- name and a 'Text' representation of its permission -heapster_typecheck_mut_funs :: BuiltinContext -> Options -> HeapsterEnv -> - [(Text, Text)] -> TopLevel () -heapster_typecheck_mut_funs bic opts henv = - heapster_typecheck_mut_funs_rename bic opts henv . - map (\(nm, perms_string) -> (nm, nm, perms_string)) - --- | Type-check a list of potentially mutually recursive functions, each against --- its own function permission, potentially renaming the functions in the --- generated SAW core specifications. The functions are specified as a list of --- triples @(nm,nm_to,perms)@ of the function symbol @nm@ in the binary, the --- desired name @mn_to@ for the SAW core specification, and the permissions --- @perms@ given as a 'Text' -heapster_typecheck_mut_funs_rename :: - BuiltinContext -> Options -> HeapsterEnv -> - [(Text, Text, Text)] -> TopLevel () -heapster_typecheck_mut_funs_rename _bic opts henv fn_names_and_perms = - do let fst_nm = - case fn_names_and_perms of - (nm, _, _):_ -> nm - -- TODO: Give a proper error message here instead of panicking, - -- and document the non-empty list requirement. See #2096. - [] -> panic "heapster_typecheck_mut_funs_rename" - [ "Unexpected empty list of mutually recursive functions" - , "See https://github.com/GaloisInc/saw-script/issues/2096" - ] - Some lm <- failOnNothing ("Could not find symbol definition: " <> fst_nm) - (lookupModDefiningSym henv fst_nm) - let w = llvmModuleArchReprWidth lm - let endianness = - llvmDataLayout (modTrans lm ^. transContext ^. llvmTypeCtx) - ^. intLayout - dlevel <- liftIO $ readIORef $ heapsterEnvDebugLevel henv - checks <- liftIO $ readIORef $ heapsterEnvChecksFlag henv - LeqProof <- case decideLeq (knownNat @16) w of - Left pf -> return pf - Right _ -> fail "LLVM arch width is < 16!" - LeqProof <- case decideLeq (knownNat @1) w of - Left pf -> return pf - Right _ -> panic "heapster_typecheck_mut_funs_rename" ["1 > 16!"] - some_cfgs_and_perms <- forM fn_names_and_perms $ \(nm, nm_to, perms_string) -> - do let nm' = Text.unpack nm - nm_to' = Text.unpack nm_to - AnyCFG cfg <- - failOnNothing ("Could not find symbol definition: " <> nm) =<< - io (lookupFunctionCFG lm nm) - env <- liftIO $ readIORef $ heapsterEnvPermEnvRef henv - let args = mkCruCtx $ handleArgTypes $ cfgHandle cfg - let ret = handleReturnType $ cfgHandle cfg - SomeFunPerm fun_perm <- - withKnownNat w $ - parseFunPermStringMaybeRust "permissions" w env args ret (Text.unpack perms_string) - let mods = [ modAST m | Some m <- heapsterEnvLLVMModules henv ] - hints <- case extractHints env mods fun_perm cfg of - Left err -> fail ("Error parsing LLVM-level hints: " ++ err) - Right hints -> return hints - let env' = foldlFC (\e h -> maybe e (permEnvAddHint e) (getConstant h)) - env - hints - liftIO $ writeIORef (heapsterEnvPermEnvRef henv) env' - return (SomeCFGAndPerm (GlobalSymbol $ - fromString nm') nm_to' cfg fun_perm) - env <- liftIO $ readIORef $ heapsterEnvPermEnvRef henv - sc <- getSharedContext - let saw_modname = heapsterEnvSAWModule henv - (env', tcfgs) <- liftIO $ - let ?ptrWidth = w in - tcTranslateAddCFGs sc saw_modname env checks endianness dlevel - some_cfgs_and_perms - liftIO $ writeIORef (heapsterEnvPermEnvRef henv) env' - liftIO $ modifyIORef (heapsterEnvTCFGs henv) (\old -> map Some tcfgs ++ old) - forM_ fn_names_and_perms $ \(_, nm_to, _) -> - warnErrs nm_to =<< heapsterFunTrans henv nm_to - where warnErrs :: Text -> Term -> TopLevel () - warnErrs nm (asApplyAll -> (asGlobalDef -> Just "SpecM.errorS", - [_ev, _a, asStringLit -> Just msg])) - | Just msg_body <- Text.stripPrefix (Text.pack implicationFailurePrefix) msg - = let pref = "WARNING: Heapster implication failure while typechecking " - in io $ printOutLn opts Warn $ Text.unpack $ pref <> nm <> ":\n" <> msg_body <> "\n" - warnErrs nm (asLambda -> Just (_, _, t)) = warnErrs nm t - warnErrs nm (asApp -> Just (f, arg)) = warnErrs nm arg >> warnErrs nm f - warnErrs nm (asRecursorApp -> Just (_, _, ixs, arg)) = mapM_ (warnErrs nm) (arg:ixs) - warnErrs nm (asTupleValue -> Just ts) = mapM_ (warnErrs nm) ts - warnErrs nm (asTupleSelector -> Just (t, _)) = warnErrs nm t - warnErrs nm (asRecordValue -> Just ts) = mapM_ (warnErrs nm) ts - warnErrs nm (asRecordSelector -> Just (t, _)) = warnErrs nm t - warnErrs nm (asArrayValue -> Just (_, ts)) = mapM_ (warnErrs nm) ts - warnErrs _ _ = return () - - --- | Type-check a single function against a function permission -heapster_typecheck_fun :: BuiltinContext -> Options -> HeapsterEnv -> - Text -> Text -> TopLevel () -heapster_typecheck_fun bic opts henv fn_name perms_string = - heapster_typecheck_mut_funs bic opts henv [(fn_name, perms_string)] - --- | Type-check a single function against a function permission and generate a --- SAW core specification with a potentially different name -heapster_typecheck_fun_rename :: BuiltinContext -> Options -> HeapsterEnv -> - Text -> Text -> Text -> TopLevel () -heapster_typecheck_fun_rename bic opts henv fn_name fn_name_to perms_string = - heapster_typecheck_mut_funs_rename bic opts henv [(fn_name, fn_name_to, - perms_string)] - -{- -heapster_typecheck_fun_rs :: BuiltinContext -> Options -> HeapsterEnv -> - String -> String -> TopLevel () -heapster_typecheck_fun_rs bic opts henv fn_name perms_string = - heapster_typecheck_fun bic opts henv - -heapster_typecheck_fun_rename_rs :: BuiltinContext -> Options -> HeapsterEnv -> - String -> String -> String -> TopLevel () -heapster_typecheck_fun_rename_rs bic opts henv fn_name fn_name_to perms_string = - heapster_typecheck_mut_funs_rename bic opts henv [(fn_name, fn_name_to, - perms_string)] --} - --- | Set the event type for the remaining Heapster translations --- XXX why does this take the BuiltinContext and Options if it doesn't use them? -heapster_set_event_type :: BuiltinContext -> Options -> HeapsterEnv -> - Text -> TopLevel () -heapster_set_event_type _bic _opts henv term_string = - do sc <- getSharedContext - ev_tp <- - liftIO $ completeOpenTerm sc $ dataTypeOpenTerm "SpecM.EvType" [] - ev_id <- parseAndInsDef henv "HeapsterEv" ev_tp (Text.unpack term_string) - liftIO $ modifyIORef' (heapsterEnvPermEnvRef henv) $ \env -> - env { permEnvEventType = EventType (globalOpenTerm ev_id) } - --- | Fetch the SAW core definition associated with a name -heapsterFunTrans :: HeapsterEnv -> Text -> TopLevel Term -heapsterFunTrans henv fn_name = - do sc <- getSharedContext - let saw_modname = heapsterEnvSAWModule henv - fun_term <- - fmap (fromJust . defBody) $ - liftIO $ scRequireDef sc $ mkSafeIdent saw_modname (Text.unpack fn_name) - bodies <- - liftIO $ scResolveName sc $ fn_name <> "__bodies" - liftIO $ scUnfoldConstants sc bodies fun_term >>= - sawLetMinimize sc >>= betaNormalize sc - --- | Fetch the SAW core definition associated with a name and print it --- XXX why does this take the BuiltinContext and Options if it doesn't use them? -heapster_print_fun_trans :: BuiltinContext -> Options -> HeapsterEnv -> - Text -> TopLevel () -heapster_print_fun_trans _bic _opts henv fn_name = - do pp_opts <- getTopLevelPPOpts - fun_term <- heapsterFunTrans henv fn_name - liftIO $ putStrLn $ Pretty.scPrettyTerm pp_opts fun_term - --- | Export all definitions in the SAW core module associated with a Heapster --- environment to a Coq file with the given name -heapster_export_coq :: HeapsterEnv -> FilePath -> TopLevel () -heapster_export_coq henv filename = - do let coq_trans_conf = coqTranslationConfiguration [] [] - sc <- getSharedContext - mm <- liftIO $ scGetModuleMap sc - saw_mod <- liftIO $ scFindModule sc $ heapsterEnvSAWModule henv - let coq_doc = - vcat [preamble coq_trans_conf { - postPreamble = - "From CryptolToCoq Require Import " ++ - "SAWCorePrelude SpecMPrimitivesForSAWCore SAWCoreBitvectors.\n" }, - translateSAWModule coq_trans_conf mm saw_mod] - liftIO $ writeFile filename (show coq_doc) - --- | Set the Hepaster debug level -heapster_set_debug_level :: BuiltinContext -> Options -> HeapsterEnv -> - Int -> TopLevel () -heapster_set_debug_level _ _ env l = - liftIO $ writeIORef (heapsterEnvDebugLevel env) (DebugLevel l) - --- | Turn on or off the translation checks in the Heapster-to-SAW translation -heapster_set_translation_checks :: BuiltinContext -> Options -> HeapsterEnv -> - Bool -> TopLevel () -heapster_set_translation_checks _ _ env f = - liftIO $ writeIORef (heapsterEnvChecksFlag env) (ChecksFlag f) - --- | Parse a Rust type from an input string, translate it to a Heapster function --- permission, and print out that Heapster permission on stdout --- XXX why does this take the BuiltinContext and Options if it doesn't use them? -heapster_translate_rust_type :: BuiltinContext -> Options -> HeapsterEnv -> - Text -> TopLevel () -heapster_translate_rust_type _bic _opts henv perms_string = - do env <- liftIO $ readIORef $ heapsterEnvPermEnvRef henv - let w64 = (knownNat @64::NatRepr 64) - leq_proof <- case decideLeq (knownNat @1) w64 of - Left pf -> return pf - Right _ -> fail "LLVM arch width is 0!" - withKnownNat w64 $ withLeqProof leq_proof $ do - Some3FunPerm fun_perm <- - parseSome3FunPermFromRust env w64 (Text.unpack perms_string) - liftIO $ putStrLn $ permPrettyString emptyPPInfo fun_perm - --- | Parse a Heapster function permission from a 'String' and print it to --- stdout, using a particular symbol in an LLVM module as the type of the --- function that the permission applies to --- XXX why does this take the BuiltinContext and Options if it doesn't use them? -heapster_parse_test :: BuiltinContext -> Options -> Some LLVMModule -> - Text -> Text -> TopLevel () -heapster_parse_test _bic _opts _some_lm@(Some lm) fn_name perms_string = - do let env = heapster_default_env -- FIXME: env should be an argument - let _arch = llvmModuleArchRepr lm - AnyCFG cfg <- - failOnNothing ("Could not find symbol: " <> fn_name) =<< - io (lookupFunctionCFG lm fn_name) - let args = mkCruCtx $ handleArgTypes $ cfgHandle cfg - let ret = handleReturnType $ cfgHandle cfg - SomeFunPerm fun_perm <- parseFunPermString "permissions" env args - ret (Text.unpack perms_string) - liftIO $ putStrLn $ permPrettyString emptyPPInfo fun_perm - --- | Dump the IDE information contained in a Heapster environment to a JSON file -heapster_dump_ide_info :: HeapsterEnv -> FilePath -> TopLevel () -heapster_dump_ide_info henv filename = do - -- heapster_typecheck_mut_funs bic opts henv [(fnName, perms)] - penv <- io $ readIORef (heapsterEnvPermEnvRef henv) - tcfgs <- io $ readIORef (heapsterEnvTCFGs henv) - io $ HIDE.printIDEInfo penv tcfgs filename emptyPPInfo diff --git a/saw-script/src/SAWScript/Interpreter.hs b/saw-script/src/SAWScript/Interpreter.hs index 6c5b6dc83f..6e2085be09 100644 --- a/saw-script/src/SAWScript/Interpreter.hs +++ b/saw-script/src/SAWScript/Interpreter.hs @@ -81,7 +81,6 @@ import SAWCentral.Bisimulation import SAWCentral.Builtins import SAWCentral.Exceptions (failTypecheck) import qualified SAWScript.Import -import SAWScript.HeapsterBuiltins import SAWCentral.JavaExpr import SAWCentral.LLVMBuiltins import SAWCentral.Options @@ -98,7 +97,6 @@ import SAWCentral.SolverVersions import SAWCentral.Proof (ProofResult(..), Theorem, emptyTheoremDB) import SAWCentral.Prover.Rewrite(basic_ss) import SAWCentral.Prover.Exporter -import SAWCentral.Prover.MRSolver (emptyMREnv, emptyRefnset) import SAWCentral.Yosys -- XXX remove in favor of the following later import qualified SAWCentral.Yosys as Yo (YosysIR) import qualified SAWCentral.Yosys.State as Yo (YosysSequential) @@ -111,7 +109,6 @@ import SAWCore.Prim (rethrowEvalError) import SAWCore.Rewriter (emptySimpset, rewritingSharedContext, scSimpset) import SAWCore.SharedTerm import qualified CryptolSAWCore.CryptolEnv as CEnv -import qualified CryptolSAWCore.Monadify as Monadify import qualified CryptolSAWCore.Prelude as CryptolSAW @@ -1061,7 +1058,6 @@ buildTopLevelEnv proxy opts scriptArgv = jvmTrans <- CJ.mkInitialJVMContext halloc - mm <- scGetModuleMap sc let rw0 = TopLevelRW { rwValueInfo = primValueEnv opts bic , rwTypeInfo = primNamedTypeEnv @@ -1070,8 +1066,6 @@ buildTopLevelEnv proxy opts scriptArgv = , rwPosition = SS.Unknown , rwStackTrace = Trace.empty , rwLocalEnv = [] - , rwMonadify = let ?mm = mm in Monadify.defaultMonEnv - , rwMRSolverEnv = emptyMREnv , rwProofs = [] , rwPPOpts = PPS.defaultOpts , rwSharedContext = sc @@ -1550,13 +1544,6 @@ instance FromValue SAWSimpset where fromValue _ (VSimpset ss) = ss fromValue _ _ = error "fromValue Simpset" -instance IsValue SAWRefnset where - toValue _name rs = VRefnset rs - -instance FromValue SAWRefnset where - fromValue _ (VRefnset rs) = rs - fromValue _ _ = error "fromValue Refnset" - instance IsValue Theorem where toValue _name t = VTheorem t @@ -1637,13 +1624,6 @@ instance FromValue MIR.Adt where fromValue _ (VMIRAdt adt) = adt fromValue _ _ = error "fromValue Adt" -instance IsValue HeapsterEnv where - toValue _name m = VHeapsterEnv m - -instance FromValue HeapsterEnv where - fromValue _ (VHeapsterEnv m) = m - fromValue _ _ = error "fromValue HeapsterEnv" - instance IsValue ProofResult where toValue _name r = VProofResult r @@ -1769,7 +1749,10 @@ caseProofResultPrim pr vValid vInvalid = do ValidProof _ thm -> applyValue pos infoValid vValid (VTheorem thm) InvalidProof _ pairs _pst -> do - let fov = FOVTuple (map snd pairs) + let fov = + case map snd pairs of + [x] -> x + xs -> FOVTuple xs tt <- io $ typedTermOfFirstOrderValue sc fov applyValue pos infoInvalid vInvalid (VTerm tt) UnfinishedProof _ -> do @@ -1789,7 +1772,10 @@ caseSatResultPrim sr vUnsat vSat = do case sr of Unsat _ -> return vUnsat Sat _ pairs -> do - let fov = FOVTuple (map snd pairs) + let fov = + case map snd pairs of + [x] -> x + xs -> FOVTuple xs tt <- io $ typedTermOfFirstOrderValue sc fov applyValue pos info vSat (VTerm tt) SatUnknown -> do @@ -2178,21 +2164,19 @@ do_write_coq_term :: Text -> [(Text, Text)] -> [Text] -> Text -> Term -> TopLeve do_write_coq_term name notations skips path t = writeCoqTerm name notations skips (Text.unpack path) t -do_write_coq_cryptol_module :: Bool -> Text -> Text -> [(Text, Text)] -> [Text] -> TopLevel () -do_write_coq_cryptol_module monadic infile outfile notations skips = - writeCoqCryptolModule monadic (Text.unpack infile) (Text.unpack outfile) notations skips +do_write_coq_cryptol_module :: Text -> Text -> [(Text, Text)] -> [Text] -> TopLevel () +do_write_coq_cryptol_module infile outfile notations skips = + writeCoqCryptolModule (Text.unpack infile) (Text.unpack outfile) notations skips do_write_coq_sawcore_prelude :: Text -> [(Text, Text)] -> [Text] -> IO () do_write_coq_sawcore_prelude outfile notations skips = writeCoqSAWCorePrelude (Text.unpack outfile) notations skips -do_write_coq_cryptol_primitives_for_sawcore :: Text -> Text -> Text -> [(Text, Text)] -> [Text] -> IO () -do_write_coq_cryptol_primitives_for_sawcore cryfile specfile crymfile notations skips = +do_write_coq_cryptol_primitives_for_sawcore :: Text -> [(Text, Text)] -> [Text] -> IO () +do_write_coq_cryptol_primitives_for_sawcore cryfile notations skips = let cryfile' = Text.unpack cryfile - specfile' = Text.unpack specfile - crymfile' = Text.unpack crymfile in - writeCoqCryptolPrimitivesForSAWCore cryfile' specfile' crymfile' notations skips + writeCoqCryptolPrimitivesForSAWCore cryfile' notations skips do_offline_coq :: Text -> ProofScript () do_offline_coq f = @@ -2311,43 +2295,6 @@ do_yosys_verify_sequential_sally :: Yo.YosysSequential -> Text -> TypedTerm -> [ do_yosys_verify_sequential_sally s path q fixed = yosys_verify_sequential_sally s (Text.unpack path) q fixed --- XXX why are these being passed bic and opts if they don't use them? --- (they were that way in HeapsterBuiltins, I took the opportunity to --- drop the extra args there; and note that a bunch of other heapster --- builtins are also using bicVal for apparently no reason) - -do_heapster_init_env :: BuiltinContext -> Options -> Text -> Text -> TopLevel HeapsterEnv -do_heapster_init_env _bic _opts mod_str llvm_filename = - heapster_init_env mod_str (Text.unpack llvm_filename) - -do_heapster_init_env_debug :: BuiltinContext -> Options -> Text -> Text -> TopLevel HeapsterEnv -do_heapster_init_env_debug _bic _opts mod_str llvm_filename = - heapster_init_env_debug mod_str (Text.unpack llvm_filename) - -do_heapster_init_env_from_file :: BuiltinContext -> Options -> Text -> Text -> TopLevel HeapsterEnv -do_heapster_init_env_from_file _bic _opts mod_filename llvm_filename = - heapster_init_env_from_file (Text.unpack mod_filename) (Text.unpack llvm_filename) - -do_heapster_init_env_from_file_debug :: BuiltinContext -> Options -> Text -> Text -> TopLevel HeapsterEnv -do_heapster_init_env_from_file_debug _bic _opts mod_filename llvm_filename = - heapster_init_env_from_file_debug (Text.unpack mod_filename) (Text.unpack llvm_filename) - -do_heapster_init_env_for_files :: BuiltinContext -> Options -> Text -> [Text] -> TopLevel HeapsterEnv -do_heapster_init_env_for_files _bic _opts mod_filename llvm_filenames = - heapster_init_env_for_files (Text.unpack mod_filename) (map Text.unpack llvm_filenames) - -do_heapster_init_env_for_files_debug :: BuiltinContext -> Options -> Text -> [Text] -> TopLevel HeapsterEnv -do_heapster_init_env_for_files_debug _bic _opts mod_filename llvm_filenames = - heapster_init_env_for_files_debug (Text.unpack mod_filename) (map Text.unpack llvm_filenames) - -do_heapster_export_coq :: BuiltinContext -> Options -> HeapsterEnv -> Text -> TopLevel () -do_heapster_export_coq _bic _opts henv filename = - heapster_export_coq henv (Text.unpack filename) - -do_heapster_dump_ide_info :: BuiltinContext -> Options -> HeapsterEnv -> Text -> TopLevel () -do_heapster_dump_ide_info _bic _opts henv filename = - heapster_dump_ide_info henv (Text.unpack filename) - do_load_sawcore_from_file :: BuiltinContext -> Options -> Text -> TopLevel () do_load_sawcore_from_file _ _ mod_filename = load_sawcore_from_file (Text.unpack mod_filename) @@ -2431,7 +2378,6 @@ primTypes = Map.fromList , abstype "MIRValue" Experimental , abstype "ModuleSkeleton" Experimental , abstype "ProofResult" Current - , abstype "Refnset" Experimental , abstype "SatResult" Current , abstype "SetupValue" Current , abstype "Simpset" Current @@ -3263,7 +3209,7 @@ primitives = Map.fromList ] , prim "write_coq_cryptol_module" "String -> String -> [(String, String)] -> [String] -> TopLevel ()" - (pureVal (do_write_coq_cryptol_module False)) + (pureVal do_write_coq_cryptol_module) Experimental [ "Write out a representation of a Cryptol module in Gallina syntax for" , "Coq." @@ -3276,20 +3222,6 @@ primitives = Map.fromList , "The fourth argument is a list of identifiers to skip translating." ] - , prim "write_coq_cryptol_module_monadic" "String -> String -> [(String, String)] -> [String] -> TopLevel ()" - (pureVal (do_write_coq_cryptol_module True)) - Experimental - [ "Write out a representation of a Cryptol module in Gallina syntax for" - , "Coq, using the monadified version of the given module." - , "The first argument is the file containing the module to export." - , "The second argument is the name of the file to output into," - , "use an empty string to output to standard output." - , "The third argument is a list of pairs of notation substitutions:" - , "the operator on the left will be replaced with the identifier on" - , "the right, as we do not support notations on the Coq side." - , "The fourth argument is a list of identifiers to skip translating." - ] - , prim "write_coq_sawcore_prelude" "String -> [(String, String)] -> [String] -> TopLevel ()" (pureVal do_write_coq_sawcore_prelude) Experimental @@ -3304,13 +3236,13 @@ primitives = Map.fromList ] , prim "write_coq_cryptol_primitives_for_sawcore" - "String -> String -> String -> [(String, String)] -> [String] -> TopLevel ()" + "String -> [(String, String)] -> [String] -> TopLevel ()" (pureVal do_write_coq_cryptol_primitives_for_sawcore) Experimental - [ "Write out a representation of cryptol-saw-core's Cryptol.sawcore and " - , "CryptolM.sawcore in Gallina syntax for Coq." - , "The first three arguments are the names of the output files for translating " - , "Cryptol.sawcore, SpecM.sawcore, and CryptolM.sawcore, respectively." + [ "Write out a representation of cryptol-saw-core's Cryptol.sawcore" + , "in Gallina syntax for Coq." + , "The first argument is the name of the output file for translating" + , "Cryptol.sawcore." , "Use an empty string to output to standard output." , "The fourth argument is a list of pairs of notation substitutions:" , "the operator on the left will be replaced with the identifier on" @@ -6319,107 +6251,7 @@ primitives = Map.fromList ] ---------------------------------------- - -- Mr. Solver commands - - , prim "mrsolver_set_debug_level" "Int -> TopLevel ()" - (pureVal mrSolverSetDebug) - Experimental - [ "Set the debug level for Mr. Solver; 0 = no debug output," - , " 1 = basic debug output, 2 = verbose debug output," - , " 3 = all debug output" ] - - , prim "mrsolver_set_debug_printing_depth" "Int -> TopLevel ()" - (pureVal mrSolverSetDebugDepth) - Experimental - [ "Limit the printing of terms in all subsequent Mr. Solver error messages" - , "and debug output to a maximum depth" ] - - , prim "mrsolver" "ProofScript ()" - (pureVal (mrSolver emptyRefnset)) - Experimental - [ "Use MRSolver to prove a current refinement goal, i.e. a goal of" - , " the form `(a1:A1) -> ... -> (an:An) -> refinesS_eq ...`" ] - - , prim "empty_rs" "Refnset" - (pureVal (emptyRefnset :: SAWRefnset)) - Experimental - [ "The empty refinement set, containing no refinements." ] - - , prim "addrefn" "Theorem -> Refnset -> Refnset" - (funVal2 addrefn) - Experimental - [ "Add a proved refinement theorem to a given refinement set." ] - - , prim "addrefns" "[Theorem] -> Refnset -> Refnset" - (funVal2 addrefns) - Experimental - [ "Add proved refinement theorems to a given refinement set." ] - - , prim "mrsolver_with" "Refnset -> ProofScript ()" - (pureVal mrSolver) - Experimental - [ "Use MRSolver to prove a current refinement goal, i.e. a goal of" - , " the form `(a1:A1) -> ... -> (an:An) -> refinesS_eq ...`, with" - , " the given set of refinements taken as assumptions" ] - - , prim "refines" "[Term] -> Term -> Term -> Term" - (funVal3 refinesTerm) - Experimental - [ "Given a list of 'fresh_symbolic' variables over which to quantify" - , " as as well as two terms containing those variables, which may be" - , " either terms or functions in the SpecM monad, construct the" - , " SAWCore term which is the refinement (`SpecM.refinesS`) of the" - , " given terms, with the given variables generalized with a Pi type." ] - - ---------------------------------------- - -- Heapster commands - - , prim "monadify_term" "Term -> TopLevel Term" - (scVal monadifyTypedTerm) - Experimental - [ "Monadify a Cryptol term, converting it to a form where all recursion" - , " and errors are represented as monadic operators"] - - , prim "set_monadification" "String -> String -> Bool -> TopLevel ()" - (scVal setMonadification) - Experimental - [ "Set the monadification of a specific Cryptol identifer to a SAW core " - , "identifier of monadic type. The supplied Boolean flag indicates if the " - , "SAW core term is polymorphic in the event type and function stack of the" - , "SpecM monad."] - - , prim "heapster_init_env" - "String -> String -> TopLevel HeapsterEnv" - (bicVal do_heapster_init_env) - Experimental - [ "Create a new Heapster environment with the given SAW module name" - , " from the named LLVM bitcode file." - ] - - , prim "heapster_init_env_debug" - "String -> String -> TopLevel HeapsterEnv" - (bicVal do_heapster_init_env_debug) - Experimental - [ "Create a new Heapster environment with the given SAW module name" - , " from the named LLVM bitcode file with debug tracing turned on" - ] - - , prim "heapster_init_env_from_file" - "String -> String -> TopLevel HeapsterEnv" - (bicVal do_heapster_init_env_from_file) - Experimental - [ "Create a new Heapster environment from the named LLVM bitcode file," - , " initialized with the module in the given SAW core file." - ] - - , prim "heapster_init_env_from_file_debug" - "String -> String -> TopLevel HeapsterEnv" - (bicVal do_heapster_init_env_from_file_debug) - Experimental - [ "Create a new Heapster environment from the named LLVM bitcode file," - , " initialized with the module in the given SAW core file, with debug" - , " tracing turned on" - ] + -- SAWCore loading command , prim "load_sawcore_from_file" "String -> TopLevel ()" @@ -6428,332 +6260,6 @@ primitives = Map.fromList [ "Load a SAW core module from a file" ] - , prim "heapster_init_env_for_files" - "String -> [String] -> TopLevel HeapsterEnv" - (bicVal do_heapster_init_env_for_files) - Experimental - [ "Create a new Heapster environment from the named LLVM bitcode files," - , " initialized with the module in the given SAW core file." - ] - - , prim "heapster_init_env_for_files_debug" - "String -> [String] -> TopLevel HeapsterEnv" - (bicVal do_heapster_init_env_for_files_debug) - Experimental - [ "Create a new Heapster environment from the named LLVM bitcode files," - , " initialized with the module in the given SAW core file, with debug" - , " tracing turned on" - ] - - , prim "heapster_get_cfg" - "HeapsterEnv -> String -> TopLevel CFG" - (bicVal heapster_get_cfg) - Experimental - [ "Extract out the Crucible CFG associated with a symbol in a" - , " Heapster environemnt" - ] - - , prim "heapster_define_opaque_perm" - "HeapsterEnv -> String -> String -> String -> String -> String -> TopLevel ()" - (bicVal heapster_define_opaque_perm) - Experimental - [ "heapster_define_opaque_perm nm args tp trans d defines an opaque named" - , " Heapster permission named nm with arguments parsed from args and type" - , " tp that translates to the SAW core type trans with type description d" - ] - - , prim "heapster_define_recursive_perm" - "HeapsterEnv -> String -> String -> String -> String -> TopLevel ()" - (bicVal heapster_define_recursive_perm) - Experimental - [ "heapster_define_recursive_perm env nm arg_ctx tp p defines a recursive" - , " Heapster permission named nm with arguments parsed from args_ctx and" - , " type parsed from tp that translates to permissions p, which can" - , " resurively use nm (with no arguments) in those permissions" - ] - - , prim "heapster_define_reachability_perm" - "HeapsterEnv -> String -> String -> String -> String -> String -> TopLevel ()" - (bicVal heapster_define_reachability_perm) - Experimental - [ "heapster_define_recursive_perm env nm arg_ctx value_type p trans_fun" - , " defines a recursive named Heapster permission named nm with arguments" - , " parsed from args_ctx and type parsed from value_type that unfolds to p," - , " which should form a reachability permission, meaning that it should" - , " have the form eq(x) or q for some permission q, where x is the last" - , " argument argument in arg_ctx and q can contain nm with no arguments to" - , " refer to the entire permission recursively." - ] - - , prim "heapster_define_recursive_shape" - "HeapsterEnv -> String -> Int -> String -> String -> TopLevel ()" - (bicVal heapster_define_recursive_shape) - Experimental - [ "heapster_define_irt_recursive_shape env name w arg_ctx body_sh" - , " defines a recursive named Heapser shape named nm with arguments" - , " parsed from args_ctx and width w that unfolds to the shape body_sh," - , " whichx can contain name for recursive occurrences of the shape" - ] - - , prim "heapster_define_perm" - "HeapsterEnv -> String -> String -> String -> String -> TopLevel ()" - (bicVal heapster_define_perm) - Experimental - [ "heapster_define_perm nm args tp p defines a Heapster permission named" - , " nm with arguments x1,...,xn parsed from args and type parsed from tp" - , " such that nm is equivalent to the permission p." - ] - - , prim "heapster_define_llvmshape" - "HeapsterEnv -> String -> Int -> String -> String -> TopLevel ()" - (bicVal heapster_define_llvmshape) - Experimental - [ "heapster_define_llvmshape nm w args sh defines a Heapster LLVM shape" - , " nm with type llvmshape w and arguments x1,...,xn parsed from args" - , " such that nm is equivalent to the permission p." - ] - - , prim "heapster_define_opaque_llvmshape" - "HeapsterEnv -> String -> Int -> String -> String -> String -> String -> TopLevel ()" - (bicVal heapster_define_opaque_llvmshape) - Experimental - [ "heapster_define_opaque_llvmshape henv nm w args len tp d defines a Heapster" - , " LLVM shape that is opaque, meaning it acts as a sort of shape axiom, where" - , " Heapster does not know or care about the contents of memory of this shape" - , " but instead treats that memory as an opaque object, defined only by its" - , " length and its translation to a SAW core type." - , "" - , " The henv argument is the Heapster environment this new shape is added to," - , " nm is its name, args is a context of argument variables for this shape," - , " len is an expression for the length of the shape in terms of the arguments," - , " tp gives the translation of the shape as a SAW core type over the" - , " translation of the arguments to SAW core variables, and d is a SAW core" - , " term of type TpDesc that describes the SAW core type." - ] - - , prim "heapster_define_rust_type" - "HeapsterEnv -> String -> TopLevel ()" - (bicVal heapster_define_rust_type) - Experimental - [ "heapster_define_rust_type env tp defines a Heapster LLVM shape from tp," - , "a string representing a top-level struct or enum definition." - ] - - , prim "heapster_define_rust_type_qual" - "HeapsterEnv -> String -> String -> TopLevel ()" - (bicVal heapster_define_rust_type_qual) - Experimental - [ "heapster_define_rust_type_qual env crate tp defines a Heapster LLVM" - , " shape from tp, a string representing a top-level Rust struct or enum" - , " definition. The type is qualified by crate, meaning that \"crate::\"" - , " is prepended to its name." - ] - - , prim "heapster_block_entry_hint" - "HeapsterEnv -> String -> Int -> String -> String -> String -> TopLevel ()" - (bicVal heapster_block_entry_hint) - Experimental - [ "heapster_block_entry_hint env nm block top_args ghosts perms adds a hint" - , " to the Heapster type-checker that Crucible block number block in nm" - , " should have permissions perms on its inputs, assuming that top_args" - , " lists the top-level ghost and normal arguments to function nm and" - , " ghosts gives the ghost arguments to block" - ] - - , prim "heapster_gen_block_perms_hint" - "HeapsterEnv -> String -> [Int] -> TopLevel ()" - (bicVal heapster_gen_block_perms_hint) - Experimental - [ "heapster_gen_block_perms_hint env nm blocks adds a hint to the Heapster" - , " type-checker to *generalize* (recursively replace all instances of" - , " eq(const) with (exists x. eq(x))) all permissions on the inputs of the" - , " given Crucible blocks numbers. If the given list is empty, do so for" - , " every block in the CFG." - ] - - , prim "heapster_join_point_hint" - "HeapsterEnv -> String -> [Int] -> TopLevel ()" - (bicVal heapster_join_point_hint) - Experimental - [ "heapster_join_point_hint env nm blocks adds a hint to the Heapster" - , " type-checker to make a join point at each of the given block numbers," - , " meaning that all entries to the given blocks are merged into a single" - , " entrypoint, whose permissions are given by the first call to the block." - , " If the given list is empty, do so for every block in the CFG." - ] - - , prim "heapster_find_symbol" - "HeapsterEnv -> String -> TopLevel String" - (bicVal heapster_find_symbol) - Experimental - [ "Search for a symbol in any module contained in a HeapsterEnv that" - , " contains the supplied string as a substring. Raise an error if there" - , " is not exactly one such symbol" - ] - - , prim "heapster_find_symbols" - "HeapsterEnv -> String -> TopLevel [String]" - (bicVal heapster_find_symbols) - Experimental - [ "Search for all symbols in any module contained in a HeapsterEnv that" - , " contain the supplied string as a substring" - ] - - , prim "heapster_find_symbol_with_type" - "HeapsterEnv -> String -> String -> TopLevel String" - (bicVal heapster_find_symbol_with_type) - Experimental - [ "Search for a symbol in any module contained in a HeapsterEnv that" - , " contains the supplied string as a substring and that has the specified" - , " LLVM type. Raise an error if there is not exactly one such symbol." - ] - - , prim "heapster_find_symbols_with_type" - "HeapsterEnv -> String -> String -> TopLevel [String]" - (bicVal heapster_find_symbols_with_type) - Experimental - [ "Search for all symbols in any module contained in a HeapsterEnv that" - , " contain the supplied string as a substring and that have the specified" - , " LLVM type" - ] - - , prim "heapster_find_symbol_commands" - "HeapsterEnv -> String -> TopLevel String" - (bicVal heapster_find_symbol_commands) - Experimental - [ "Map a search string str to a newline-separated sequence of SAW-script " - , " commands \"heapster_find_symbol_with_type str tp\", one for each LLVM " - , " type tp associated with a symbol whose name contains str" ] - - , prim "heapster_find_trait_method_symbol" - "HeapsterEnv -> String -> TopLevel String" - (bicVal heapster_find_trait_method_symbol) - Experimental - [ "Search for a symbol in any module contained in a HeapsterEnv that" - , "corresponds to the given trait method implementation. The search" - , "string should be of the form: trait::method, e.g." - , "core::fmt::Debug::fmt" - ] - - , prim "heapster_assume_fun" - "HeapsterEnv -> String -> String -> String -> TopLevel ()" - (bicVal heapster_assume_fun) - Experimental - [ "heapster_assume_fun env nm perms trans assumes that function nm has" - , " permissions perms and translates to the SAW core term trans" - ] - - , prim "heapster_assume_fun_rename" - "HeapsterEnv -> String -> String -> String -> String -> TopLevel ()" - (bicVal heapster_assume_fun_rename) - Experimental - [ "heapster_assume_fun_rename env nm nm_to perms trans assumes that function nm" - , " has permissions perms and translates to the SAW core term trans. If" - , " trans is not an identifier then it is bound to the defined name nm_to." - ] - - , prim "heapster_assume_fun_rename_prim" - "HeapsterEnv -> String -> String -> String -> TopLevel ()" - (bicVal heapster_assume_fun_rename_prim) - Experimental - [ - "heapster_assume_fun_rename_prim env nm nm_to perms assumes that function nm" - , " has permissions perms as a primitive." - ] - - , prim "heapster_assume_fun_multi" - "HeapsterEnv -> String -> [(String, String)] -> TopLevel ()" - (bicVal heapster_assume_fun_multi) - Experimental - [ "heapster_assume_fun_multi env nm [(perm1, trans1), ...] assumes that function" - , " nm can be typed with 0 or more permissions, each with the corresponding" - , " translation to SAW core" - ] - - , prim "heapster_typecheck_fun" - "HeapsterEnv -> String -> String -> TopLevel ()" - (bicVal heapster_typecheck_fun) - Experimental - [ "Translate an LLVM function to a SAW core term using Heapster" - , " type-checking, and store the result in the current Heapster SAW module." - ] - - , prim "heapster_typecheck_fun_rename" - "HeapsterEnv -> String -> String -> String -> TopLevel ()" - (bicVal heapster_typecheck_fun_rename) - Experimental - [ "Translate the LLVM function named by the first String to a SAW core term" - , " using Heapster type-checking, and store the result in the current" - , " Heapster SAW module as a definition named with the second string." - ] - - , prim "heapster_typecheck_mut_funs" - "HeapsterEnv -> [(String, String)] -> TopLevel ()" - (bicVal heapster_typecheck_mut_funs) - Experimental - [ "Translate a set of mutually recursive LLVM function to a set of SAW " - , "core terms using Heapster type-checking. Store the results in the " - , "current Heapster SAW module." - ] - - , prim "heapster_set_event_type" - "HeapsterEnv -> String -> TopLevel ()" - (bicVal heapster_set_event_type) - Experimental - [ "Set the event type for the remaining Heapster translations to a SAW " - , "core term of type EvType. It is recommended that this is done at most " - , "once in a SAW script, at the beginning, because changing the event type " - , "yields incompatible specifications." - ] - - , prim "heapster_print_fun_trans" - "HeapsterEnv -> String -> TopLevel ()" - (bicVal heapster_print_fun_trans) - Experimental - [ "Print the translation to SAW of a function that has been type-checked." - ] - - , prim "heapster_export_coq" - "HeapsterEnv -> String -> TopLevel ()" - (bicVal do_heapster_export_coq) - Experimental - [ "Export a Heapster environment to a Coq file" ] - - , prim "heapster_set_debug_level" - "HeapsterEnv -> Int -> TopLevel ()" - (bicVal heapster_set_debug_level) - Experimental - [ "Set the debug level for Heapster; 0 = no debug output, 1 = debug output" ] - - , prim "heapster_set_translation_checks" - "HeapsterEnv -> Bool -> TopLevel ()" - (bicVal heapster_set_translation_checks) - Experimental - [ "Tell Heapster whether to perform its translation-time checks of the " - , "well-formedness of type-checking proofs" ] - - , prim "heapster_trans_rust_type" - "HeapsterEnv -> String -> TopLevel ()" - (bicVal heapster_translate_rust_type) - Experimental - [ "Parse a Rust function type and print the equivalent Heapser type. " - , "Ideal for learning how Rust types are translated into Heapster. " - ] - - , prim "heapster_parse_test" - "LLVMModule -> String -> String -> TopLevel ()" - (bicVal heapster_parse_test) - Experimental - [ "Parse and print back a set of Heapster permissions for a function" - ] - - , prim "heapster_dump_ide_info" - "HeapsterEnv -> String -> TopLevel ()" - (bicVal do_heapster_dump_ide_info) - Experimental - [ "Dump environment info to a JSON file for IDE integration." - ] - ---------------------------------------- -- A few more misc commands diff --git a/saw-server/src/SAWServer/SAWServer.hs b/saw-server/src/SAWServer/SAWServer.hs index 1a85ee618a..8550b2baeb 100644 --- a/saw-server/src/SAWServer/SAWServer.hs +++ b/saw-server/src/SAWServer/SAWServer.hs @@ -50,7 +50,7 @@ import qualified SAWCentral.Trace as Trace (empty) --import qualified CryptolSAWCore.CryptolEnv as CryptolEnv import SAWCore.Module (emptyModule) -import SAWCore.SharedTerm (mkSharedContext, scLoadModule, scGetModuleMap) +import SAWCore.SharedTerm (mkSharedContext, scLoadModule) import SAWCore.Term.Functor (mkModuleName) import CryptolSAWCore.TypedTerm (TypedTerm, CryptolModule) @@ -69,8 +69,6 @@ import SAWCentral.Yosys.Theorem (YosysImport, YosysTheorem) import qualified CryptolSAWCore.Prelude as CryptolSAW import CryptolSAWCore.CryptolEnv (initCryptolEnv, bindTypedTerm) import qualified Cryptol.Utils.Ident as Cryptol -import CryptolSAWCore.Monadify (defaultMonEnv) -import SAWCentral.Prover.MRSolver (emptyMREnv) import SAWCentral.SolverCache (lazyOpenSolverCache) import qualified Argo @@ -218,7 +216,6 @@ initialState readFileFn = CryptolSAW.scLoadPreludeModule sc CryptolSAW.scLoadCryptolModule sc let mn = mkModuleName ["SAWScript"] - mm <- scGetModuleMap sc scLoadModule sc (emptyModule mn) ss <- basic_ss sc let bic = BuiltinContext { biSharedContext = sc @@ -253,8 +250,6 @@ initialState readFileFn = , rwPosition = PosInternal "SAWServer" , rwStackTrace = Trace.empty , rwLocalEnv = [] - , rwMonadify = let ?mm = mm in defaultMonEnv - , rwMRSolverEnv = emptyMREnv , rwPPOpts = PPS.defaultOpts , rwSolverCache = mb_cache , rwTheoremDB = emptyTheoremDB diff --git a/saw.cabal b/saw.cabal index 3d4bc54cce..64392a44b8 100644 --- a/saw.cabal +++ b/saw.cabal @@ -22,13 +22,6 @@ extra-source-files: -- extra files for cryptol-saw-core extra-source-files: cryptol-saw-core/saw/Cryptol.sawcore - cryptol-saw-core/saw/SpecM.sawcore - cryptol-saw-core/saw/CryptolM.sawcore - --- extra files for heapster -extra-source-files: - heapster/src/Heapster/Lexer.x - heapster/src/Heapster/Parser.y -- extra files for saw-script extra-source-files: @@ -243,9 +236,7 @@ library cryptol-saw-core exposed-modules: CryptolSAWCore.Cryptol CryptolSAWCore.CryptolEnv - CryptolSAWCore.Monadify CryptolSAWCore.Prelude - CryptolSAWCore.PreludeM CryptolSAWCore.Simpset CryptolSAWCore.TypedTerm other-modules: @@ -413,88 +404,6 @@ library saw-core-what4 SAWCoreWhat4.Panic ------------------------------------------------------------- --- heapster - --- Program verification in SAW using Heapster --- --- A type system for binaries based on separation logic, along with a --- translation from well-typed programs into pure monadic SAW core --- programs -library heapster - import: ghc-options - default-language: Haskell2010 - visibility: private - - build-tool-depends: - alex:alex, - happy:happy - build-depends: - -- upstream packages from hackage - base == 4.*, - aeson >= 1.5 && < 2.3, - array ^>= 0.5.3, - bytestring, - containers, - extra, - filepath, - lens, - mtl, - pretty, - prettyprinter >= 1.7.0, - reflection, - text, - template-haskell, - th-abstraction, - transformers, - vector, - - -- galois packages from hackage - bv-sized, - - -- packages in git submodules - -- (hobbits is for now actually a source-repository-package) - crucible, - crucible-llvm, - hobbits ^>= 1.4, - language-rust, - llvm-pretty >= 0.8, - parameterized-utils, - what4, - - -- internal sublibraries in the saw tree - saw:saw-support, - saw:saw-core - - hs-source-dirs: heapster/src - exposed-modules: - Heapster.CruUtil - Heapster.GenMonad - Heapster.IDESupport - Heapster.HintExtract - Heapster.Implication - Heapster.Lexer - Heapster.LLVMGlobalConst - Heapster.Located - Heapster.NamedMb - Heapster.JSONExport - Heapster.ParsedCtx - Heapster.Parser - Heapster.Permissions - Heapster.PermParser - Heapster.NamePropagation - Heapster.RustTypes - Heapster.SAWTranslation - Heapster.Token - Heapster.TypeChecker - Heapster.TypedCrucible - Heapster.UntypedAST - Heapster.Widening - other-modules: - Heapster.Panic - Heapster.PatternMatchUtil - - ------------------------------------------------------------ -- saw-central @@ -556,7 +465,6 @@ library saw-central bv-sized >= 1.0 && < 1.1, -- packages in git submodules - -- (hobbits is for now actually a source-repository-package) aig, crucible >= 0.4, crucible-jvm, @@ -565,7 +473,6 @@ library saw-central cryptol, elf-edit, galois-dwarf >= 0.2.2, - hobbits >= 1.3.1, jvm-parser, language-sally, llvm-pretty >= 0.8, @@ -590,7 +497,6 @@ library saw-central saw:saw-core-sbv, saw:saw-core-what4, saw:cryptol-saw-core, - saw:heapster, saw:saw-version, hs-source-dirs: saw-central/src @@ -618,17 +524,10 @@ library saw-central SAWCentral.Yosys.TransitionSystem SAWCentral.Yosys - SAWCentral.MRSolver.Monad - SAWCentral.MRSolver.SMT - SAWCentral.MRSolver.Solver - SAWCentral.MRSolver.Evidence - SAWCentral.MRSolver.Term - SAWCentral.Prover.Rewrite SAWCentral.Prover.SolverStats SAWCentral.Prover.Util SAWCentral.Prover.SBV - SAWCentral.Prover.MRSolver SAWCentral.Prover.RME SAWCentral.Prover.ABC SAWCentral.Prover.What4 @@ -734,14 +633,12 @@ library saw-script transformers, -- packages in git submodules - -- (hobbits is for now actually a source-repository-package) aig, crucible >= 0.4, crucible-jvm, crucible-llvm >= 0.2, crucible-mir, cryptol, - hobbits >= 1.3.1, jvm-parser, llvm-pretty >= 0.8, parameterized-utils, @@ -752,7 +649,6 @@ library saw-script saw:saw-core, saw:cryptol-saw-core, saw:saw-core-coq, - saw:heapster, saw:saw-central, hs-source-dirs: saw-script/src @@ -774,8 +670,6 @@ library saw-script SAWScript.Typechecker SAWScript.ValueOps - SAWScript.HeapsterBuiltins - SAWScript.REPL SAWScript.REPL.Command SAWScript.REPL.Haskeline @@ -1147,34 +1041,3 @@ test-suite saw-core-coq-tests type: exitcode-stdio-1.0 hs-source-dirs: otherTests/saw-core-coq main-is: Test.hs - - --- heapster has a test suite. -test-suite heapster-prover-tests - import: ghc-options - import: ghc-options-executable - default-language: Haskell2010 - - build-depends: - -- upstream packages from hackage - base, - directory, - filemanip, - filepath, - process, - tasty, - tasty-hunit, - tasty-expected-failure, - - -- packages in git submodules - -- (hobbits is for now actually a source-repository-package) - crucible, - crucible-llvm, - hobbits ^>= 1.4, - - -- the heapster library in the saw tree - saw:heapster - - type: exitcode-stdio-1.0 - hs-source-dirs: heapster/proverTests - main-is: Main.hs