diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index f90191b578..b0b00d50cf 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -333,7 +333,7 @@ jobs: # 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#52c4868f1f65c7ce74e90000214de27e23ba98fb + - run: opam pin -y entree-specs https://github.com/GaloisInc/entree-specs.git#5cf91e69c08376bcb17a95a8d2bf2daf406ae8cd # 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 diff --git a/cryptol-saw-core/cryptol-saw-core.cabal b/cryptol-saw-core/cryptol-saw-core.cabal index c1170a4028..44a8401341 100644 --- a/cryptol-saw-core/cryptol-saw-core.cabal +++ b/cryptol-saw-core/cryptol-saw-core.cabal @@ -15,6 +15,7 @@ Description: extra-source-files: saw/Cryptol.sawcore + saw/SpecM.sawcore saw/CryptolM.sawcore library @@ -39,6 +40,7 @@ library sbv, vector, text, + template-haskell, executable-path, filepath hs-source-dirs: src diff --git a/cryptol-saw-core/saw/CryptolM.sawcore b/cryptol-saw-core/saw/CryptolM.sawcore index 7c458c6b86..8a1c8ea252 100644 --- a/cryptol-saw-core/saw/CryptolM.sawcore +++ b/cryptol-saw-core/saw/CryptolM.sawcore @@ -4,43 +4,8 @@ module CryptolM where -- import Prelude; -import Cryptol; - --- Alternate versions of gen and at to get around the behavior of the default prims -genCryM : (n : Nat) -> (a : sort 0) -> (Nat -> a) -> Vec n a; -genCryM = gen; -atCryM : (n : Nat) -> (a : isort 0) -> Vec n a -> Nat -> a; -atCryM = at; - --- Alternate versions of Prelude functions, changed to use genCryM and atCryM - -joinCryM : (m n : Nat) -> (a : isort 0) -> - Vec m (Vec n a) -> Vec (mulNat m n) a; -joinCryM m n a v = - genCryM (mulNat m n) a (\ (i : Nat) -> - atCryM n a (at m (Vec n a) v (divNat i n)) (modNat i n)); - -zipCryM : (a b : isort 0) -> (m n : Nat) -> Vec m a -> Vec n b -> Vec (minNat m n) (a * b); -zipCryM a b m n xs ys = - genCryM (minNat m n) (a * b) (\ (i:Nat) -> (atCryM m a xs i, atCryM n b ys i)); - -splitCryM : (m n : Nat) -> (a : isort 0) -> Vec (mulNat m n) a -> Vec m (Vec n a); -splitCryM m n a v = - genCryM m (Vec n a) (\ (i : Nat) -> - genCryM n a (\ (j : Nat) -> - atCryM (mulNat m n) a v (addNat (mulNat i n) j))); - -zipSameCryM : (a b : isort 0) -> (n : Nat) -> Vec n a -> Vec n b -> Vec n (a * b); -zipSameCryM a b n x y = genCryM n (a*b) (\ (i : Nat) -> (atCryM n a x i, atCryM n b y i)); - -reverseCryM : (n : Nat) -> (a : isort 0) -> Vec n a -> Vec n a; -reverseCryM n a xs = genCryM n a (\ (i : Nat) -> atCryM n a xs (subNat (subNat n 1) i)); - -transposeCryM : (m n : Nat) -> (a : isort 0) -> Vec m (Vec n a) -> Vec n (Vec m a); -transposeCryM m n a xss = - genCryM n (Vec m a) (\ (j : Nat) -> - genCryM m a (\ (i : Nat) -> atCryM n a (atCryM m (Vec n a) xss i) j)); - +-- import Cryptol; +import SpecM; -------------------------------------------------------------------------------- @@ -49,12 +14,11 @@ transposeCryM m n a xss = primitive proveEqNum : (n m:Num) -> Maybe (Eq Num n m); -- A version of unsafeAssert specialized to the Num type -numAssertEqS : (E:EvType) -> (stack:FunStack) -> (n m:Num) -> - SpecM E stack (Eq Num n m); -numAssertEqS E stack n m = - maybe (Eq Num n m) (SpecM E stack (Eq Num n m)) - (errorS E stack (Eq Num n m) "numAssertEqS: assertion failed") - (retS E stack (Eq Num n m)) +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 @@ -69,12 +33,11 @@ checkFinite = (Nothing (isFinite TCInf)); -- Assert that a Num is finite, or fail -assertFiniteS : (E:EvType) -> (stack:FunStack) -> (n:Num) -> - SpecM E stack (isFinite n); -assertFiniteS E stack n = - maybe (isFinite n) (SpecM E stack (isFinite n)) - (errorS E stack (isFinite n) "assertFiniteM: Num not finite") - (retS E stack (isFinite n)) +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 @@ -89,12 +52,61 @@ Num_rec_fin p f = -------------------------------------------------------------------------------- -- Monadic Sequences --- The type of monadified sequences, which are just vectors for finite length --- but are sequences of computations for streams -mseq : (E:EvType) -> (stack:FunStack) -> Num -> sort 0 -> sort 0; -mseq E stack num a = - Num_rec (\ (_:Num) -> sort 0) (\ (n:Nat) -> Vec n a) - (Stream (SpecM E stack a)) num; +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) -> @@ -124,19 +136,19 @@ bvVecMapInvarBindM E stack a b c n len f xs invar cont = LRT_Fun (BVVec n len b) (\ (_:BVVec n len b) -> LRT_Ret c)))) stack) c) (and (bvule n i len) invar) - (maybe (is_bvult n i len) - (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) - (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))) - (bvultWithProof n i len))) + (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) -> @@ -154,317 +166,220 @@ bvVecMapM : (E:EvType) -> (stack:FunStack) -> bvVecMapM E stack a b n len f xs = bvVecMapInvarM E stack a b n len f xs True; -} -vecMapInvarBindM : (E:EvType) -> (stack:FunStack) -> - (a : sort 0) -> (b : qsort 0) -> (c : sort 0) -> - (n : Nat) -> (Nat -> a -> SpecM E stack b) -> - Vec n a -> Bool -> (Vec n b -> SpecM E stack c) -> - SpecM E stack c; -vecMapInvarBindM E stack a b c n f xs invar cont = - bindS E stack (Vec n b) c - (existsS E stack (Vec n b)) (\ (ys0:Vec n b) -> - multiArgFixS E stack - (LRT_Fun Nat (\ (_:Nat) -> LRT_Fun (Vec n b) (\ (_:Vec n b) -> LRT_Ret c))) - (\ (rec : Nat -> Vec n b -> SpecM E (pushFunStack (singletonFrame (LRT_Fun Nat (\ (_:Nat) -> LRT_Fun (Vec n b) (\ (_:Vec n b) -> LRT_Ret c)))) stack) c) - (i:Nat) (ys:Vec n b) -> - invariantHint (SpecM E (pushFunStack (singletonFrame (LRT_Fun Nat (\ (_:Nat) -> LRT_Fun (Vec n b) (\ (_:Vec n b) -> LRT_Ret c)))) stack) c) (and (ltNat i (Succ n)) invar) - (maybe (IsLtNat i n) (SpecM E (pushFunStack (singletonFrame (LRT_Fun Nat (\ (_:Nat) -> LRT_Fun (Vec n b) (\ (_:Vec n b) -> LRT_Ret c)))) stack) c) - (pushStackS E (singletonFrame (LRT_Fun Nat (\ (_:Nat) -> LRT_Fun (Vec n b) (\ (_:Vec n b) -> LRT_Ret c)))) stack c - (cont ys)) - (\ (pf:IsLtNat i n) -> - bindS E (pushFunStack (singletonFrame (LRT_Fun Nat (\ (_:Nat) -> LRT_Fun (Vec n b) (\ (_:Vec n b) -> LRT_Ret c)))) stack) b c - (pushStackS E (singletonFrame (LRT_Fun Nat (\ (_:Nat) -> LRT_Fun (Vec n b) (\ (_:Vec n b) -> LRT_Ret c)))) stack b - (f i (atWithProof n a xs i pf))) - (\ (y:b) -> rec (Succ i) - (updWithProof n b ys i y pf))) - (proveLtNat i n))) - 0 ys0); - -vecMapInvarM : (E:EvType) -> (stack:FunStack) -> - (a : sort 0) -> (b : qsort 0) -> - (n : Nat) -> (Nat -> a -> SpecM E stack b) -> - Vec n a -> Bool -> SpecM E stack (Vec n b); -vecMapInvarM E stack a b n f xs invar = - vecMapInvarBindM E stack a b (Vec n b) n f xs invar (retS E stack (Vec n b)); - -vecMapBindM : (E:EvType) -> (stack:FunStack) -> - (a : sort 0) -> (b : qsort 0) -> (c : sort 0) -> - (n : Nat) -> (Nat -> a -> SpecM E stack b) -> - Vec n a -> (Vec n b -> SpecM E stack c) -> - SpecM E stack c; -vecMapBindM E stack a b c n f xs = vecMapInvarBindM E stack a b c n f xs True; - -vecMapM : (E:EvType) -> (stack:FunStack) -> - (a : sort 0) -> (b : qsort 0) -> - (n : Nat) -> (Nat -> a -> SpecM E stack b) -> - Vec n a -> SpecM E stack (Vec n b); -vecMapM E stack a b n f xs = vecMapInvarM E stack a b n 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) -> (stack:FunStack) -> - (a : sort 0) -> (b : qsort 0) -> (n : Num) -> (a -> SpecM E stack b) -> - mseq E stack n a -> SpecM E stack (mseq E stack n b); -seqMapM E stack a b n_top f = - Num_rec (\ (n:Num) -> mseq E stack n a -> SpecM E stack (mseq E stack n b)) - (\ (n:Nat) -> vecMapM E stack a b n (\(i:Nat) -> f)) - (\ (s:Stream (SpecM E stack a)) -> - retS E stack (Stream (SpecM E stack b)) - (streamMap (SpecM E stack a) (SpecM E stack b) - (\ (m:SpecM E stack a) -> bindS E stack a b m f) s)) +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) -> (stack:FunStack) -> - (m : Num) -> (n : Num) -> (a : sort 0) -> - Eq Num m n -> Eq (sort 0) (mseq E stack m a) (mseq E stack n a); -mseq_cong1 E stack m n a eq_mn = - eq_cong Num m n eq_mn (sort 0) (\ (x:Num) -> mseq E stack x a); +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) -> (stack:FunStack) -> - (n:Num) -> (a:sort 0) -> seq n a -> mseq E stack n a; -seqToMseq E stack n_top a = - Num_rec (\ (n:Num) -> seq n a -> mseq E stack n a) +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 stack a) (retS E stack a)) + (streamMap a (SpecM E a) (retS E a)) n_top; -vecSequenceM : (E:EvType) -> (stack:FunStack) -> - (a : qsort 0) -> (n : Nat) -> - Vec n (SpecM E stack a) -> SpecM E stack (Vec n a); -vecSequenceM E stack a n = - vecMapM E stack (SpecM E stack a) a n (\(i:Nat) (x:SpecM E stack a) -> x); - - --------------------------------------------------------------------------------- --- Auxiliary functions - -bvVecAtM : (E:EvType) -> (stack:FunStack) -> - (n : Nat) -> (len : Vec n Bool) -> (a : sort 0) -> - BVVec n len a -> Vec n Bool -> SpecM E stack a; -bvVecAtM E stack n len a xs i = - maybe (is_bvult n i len) (SpecM E stack a) - (errorS E stack a "bvVecAtM: invalid sequence index") - (\ (pf:is_bvult n i len) -> retS E stack a (atBVVec n len a xs i pf)) - (bvultWithProof n i len); - -atM : (E:EvType) -> (stack:FunStack) -> - (n : Nat) -> (a : sort 0) -> Vec n a -> Nat -> SpecM E stack a; -atM E stack n a xs i = - maybe (IsLtNat i n) (SpecM E stack a) - (errorS E stack a "atM: invalid sequence index") - (\ (pf:IsLtNat i n) -> retS E stack a (atWithProof n a xs i pf)) - (proveLtNat i n); - -bvVecUpdateM : (E:EvType) -> (stack:FunStack) -> - (n : Nat) -> (len : Vec n Bool) -> (a : sort 0) -> - BVVec n len a -> Vec n Bool -> a -> - SpecM E stack (BVVec n len a); -bvVecUpdateM E stack n len a xs i x = - maybe (is_bvult n i len) (SpecM E stack (BVVec n len a)) - (errorS E stack (BVVec n len a) "bvVecUpdateM: invalid sequence index") - (\ (_:is_bvult n i len) -> retS E stack (BVVec n len a) - (updBVVec n len a xs i x)) - (bvultWithProof n i len); - -fromBVVecUpdateM : (E:EvType) -> (stack:FunStack) -> - (n : Nat) -> (len : Vec n Bool) -> (a : sort 0) -> - BVVec n len a -> Vec n Bool -> a -> - a -> (m : Nat) -> SpecM E stack (Vec m a); -fromBVVecUpdateM E stack n len a xs i x def m = - maybe (is_bvult n i len) (SpecM E stack (Vec m a)) - (errorS E stack (Vec m a) "bvVecUpdateM: invalid sequence index") - (\ (_:is_bvult n i len) -> retS E stack (Vec m a) - (genFromBVVec n len a - (updBVVec n len a xs i x) def m)) - (bvultWithProof n i len); - -updateM : (E:EvType) -> (stack:FunStack) -> - (n : Nat) -> (a : sort 0) -> Vec n a -> Nat -> a -> - SpecM E stack (Vec n a); -updateM E stack n a xs i x = - maybe (IsLtNat i n) (SpecM E stack (Vec n a)) - (errorS E stack (Vec n a) "updateM: invalid sequence index") - (\ (pf:IsLtNat i n) -> retS E stack (Vec n a) (updWithProof n a xs i x pf)) - (proveLtNat i n); - -eListSelM : (E:EvType) -> (stack:FunStack) -> - (a : sort 0) -> (n : Num) -> mseq E stack n a -> Nat -> - SpecM E stack a; -eListSelM E stack a = - Num_rec (\ (n:Num) -> mseq E stack n a -> Nat -> SpecM E stack a) - (\ (n:Nat) -> atM E stack n a) - (streamGet (SpecM E stack a)); - -streamJoinM : (E:EvType) -> (stack:FunStack) -> - (a : isort 0) -> (n : Nat) -> - Stream (SpecM E stack (Vec (Succ n) a)) -> - Stream (SpecM E stack a); -streamJoinM E stack a n s = - MkStream (SpecM E stack a) (\ (i:Nat) -> - fmapS E stack (Vec (Succ n) a) a - (\ (xs:Vec (Succ n) a) -> at (Succ n) a xs (modNat i (Succ n))) - (streamGet (SpecM E stack (Vec (Succ n) a)) s - (divNat i (Succ n))) ); +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) -> (stack:FunStack) -> - (a b : qisort 0) -> (m n : Num) -> mseq E stack m a -> - (a -> SpecM E stack (mseq E stack n b)) -> - SpecM E stack (mseq E stack (tcMul m n) (a * b)); -fromM E stack a b m n = +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 stack m a -> - (a -> SpecM E stack (mseq E stack n b)) -> - SpecM E stack (mseq E stack (tcMul m n) (a * b))) + (\ (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 stack (mseq E stack n b)) -> - SpecM E stack (mseq E stack (tcMul (TCNum m) n) (a * b))) + (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 stack (Vec n b)) -> - vecMapBindM E stack a (Vec n (a * b)) + \ (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 stack (Vec n b) (Vec n (a * b)) + 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 stack (Vec (mulNat m n) (a * b)) - (joinCryM m n (a * b) kxs))) + 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 stack (Stream (SpecM E stack b))) -> - SpecM E stack (mseq E stack (if0Nat Num m' (TCNum 0) TCInf) (a * b))) + (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 stack (Stream (SpecM E stack b))) -> - retS E stack (Vec 0 (a * b)) (EmptyVec (a * b))) + \ (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 stack (Stream (SpecM E stack b))) -> + \ (k : a -> SpecM E (Stream (SpecM E b))) -> (\ (x:a) -> - fmapS E stack (Stream (SpecM E stack b)) (Stream (SpecM E stack (a * b))) - (streamMap (SpecM E stack b) (SpecM E stack (a * b)) - (fmapS E stack b (a * b) (\ (y:b) -> (x, y)))) + 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 stack a) -> - (a -> SpecM E stack (mseq E stack n b)) -> - SpecM E stack (mseq E stack (tcMul TCInf n) (a * b))) + (\ (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 stack a) -> - (a -> SpecM E stack (Vec n' b)) -> - SpecM E stack (mseq E stack (if0Nat Num n' (TCNum 0) TCInf) (a * b))) - (\ (xs : Stream (SpecM E stack a)) -> - \ (k : a -> SpecM E stack (Vec 0 b)) -> - retS E stack (Vec 0 (a * b)) (EmptyVec (a * b))) + (\ (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 stack a)) -> - \ (k : a -> SpecM E stack (Vec (Succ n') b)) -> - retS E stack (Stream (SpecM E stack (a * b))) - (streamJoinM E stack (a * b) n' - (streamMap (SpecM E stack a) - (SpecM E stack (Vec (Succ n') (a * b))) - (\ (m:SpecM E stack a) -> - bindS E stack a (Vec (Succ n') (a * b)) m + \ (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 stack (Vec (Succ n') b) (Vec (Succ n') (a * b)) + 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 stack a)) -> - \ (k : a -> SpecM E stack (Stream (SpecM E stack b))) -> - bindS E stack a (Stream (SpecM E stack (a * b))) - (streamGet (SpecM E stack a) xs 0) + (\ (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 stack (Stream (SpecM E stack b)) (Stream (SpecM E stack (a * b))) - (streamMap (SpecM E stack b) (SpecM E stack (a * b)) - (fmapS E stack b (a * b) (\ (y:b) -> (x, y)))) + 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) -> (stack:FunStack) -> - (a : sort 0) -> (b : isort 0) -> (n : Num) -> a -> - (a -> SpecM E stack (mseq E stack n b)) -> - SpecM E stack (mseq E stack n (a * b)); -mletM E stack a b n = +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 stack (mseq E stack n b)) -> - SpecM E stack (mseq E stack n (a * b))) - (\ (n:Nat) -> \ (x:a) -> \ (f:a -> SpecM E stack (Vec n b)) -> - fmapS E stack (Vec n b) (Vec n (a * b)) + (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 stack (Stream (SpecM E stack b))) -> - fmapS E stack (Stream (SpecM E stack b)) (Stream (SpecM E stack (a * b))) - (streamMap (SpecM E stack b) (SpecM E stack (a * b)) - (fmapS E stack b (a * b) (\ (y:b) -> (x, y)))) + (\ (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) -> (stack:FunStack) -> - (a b : qisort 0) -> (m n : Num) -> - mseq E stack m a -> mseq E stack n b -> - SpecM E stack (mseq E stack (tcMin m n) (a * b)); -seqZipM E stack a b m 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 stack m a -> mseq E stack n b - -> SpecM E stack (mseq E stack (tcMin m n) (a * b))) + (\ (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 stack n b - -> SpecM E stack (mseq E stack (tcMin (TCNum m) n) (a * b))) + (\ (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 stack (Vec (minNat m n) (a * b)) (zipCryM a b m n xs ys)) - (\ (xs:Vec m a) -> \ (ys:Stream (SpecM E stack b)) -> - vecMapM E stack a (a * b) m + 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 stack b (a * b) (\ (y : b) -> (x,y)) - (streamGet (SpecM E stack b) ys i)) + fmapS E b (a * b) (\ (y : b) -> (x,y)) + (streamGet (SpecM E b) ys i)) xs) n) (Num_rec - (\ (n:Num) -> Stream (SpecM E stack a) -> mseq E stack n b - -> SpecM E stack (mseq E stack (tcMin TCInf n) (a * b))) + (\ (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 stack a)) -> \ (ys:Vec n b) -> - vecMapM E stack b (a * b) n + \ (xs:Stream (SpecM E a)) -> \ (ys:Vec n b) -> + vecMapM E b (a * b) n (\ (i : Nat) (y : b) -> - fmapS E stack a (a * b) (\ (x : a) -> (x,y)) - (streamGet (SpecM E stack a) xs i)) + fmapS E a (a * b) (\ (x : a) -> (x,y)) + (streamGet (SpecM E a) xs i)) ys) - (\ (xs:Stream (SpecM E stack a)) -> \ (ys:Stream (SpecM E stack b)) -> - retS E stack (Stream (SpecM E stack (a * b))) - (streamMap2 (SpecM E stack a) (SpecM E stack b) (SpecM E stack (a * b)) - (fmapS2 E stack a b (a * b) (\ (x:a) -> \ (y:b) -> (x, y))) + (\ (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) -> (stack:FunStack) -> - (a b : isort 0) -> (n : Num) -> - mseq E stack n a -> mseq E stack n b -> - mseq E stack n (a * b); -seqZipSameM E stack a b n = +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 stack n a -> mseq E stack n b -> mseq E stack n (a * b)) - (\ (n : Nat) -> zipSameCryM a b n) - (streamMap2 (SpecM E stack a) (SpecM E stack b) (SpecM E stack (a * b)) - (fmapS2 E stack a b (a * b) (\ (x:a) -> \ (y:b) -> (x,y)))) + (\ (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; @@ -472,120 +387,116 @@ seqZipSameM E stack a b n = -- Monadic versions of the Cryptol typeclass instances -- PEq -PEqMSeq : (E:EvType) -> (stack:FunStack) -> - (n:Num) -> isFinite n -> (a:isort 0) -> PEq a -> - PEq (mseq E stack n a); -PEqMSeq E stack = - Num_rec_fin (\ (n:Num) -> (a:isort 0) -> PEq a -> PEq (mseq E stack n a)) +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) -> (stack:FunStack) -> - (n : Num) -> isFinite n -> PEq (mseq E stack n Bool); -PEqMSeqBool E stack = - Num_rec_fin (\ (n:Num) -> PEq (mseq E stack n Bool)) PEqWord; +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) -> (stack:FunStack) -> - (n:Num) -> isFinite n -> (a:isort 0) -> PCmp a -> - PCmp (mseq E stack n a); -PCmpMSeq E stack = - Num_rec_fin (\ (n:Num) -> (a:isort 0) -> PCmp a -> PCmp (mseq E stack n a)) +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) -> (stack:FunStack) -> - (n : Num) -> isFinite n -> PCmp (mseq E stack n Bool); -PCmpMSeqBool E stack = - Num_rec_fin (\ (n:Num) -> PCmp (mseq E stack n Bool)) PCmpWord; +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) -> (stack:FunStack) -> - (n:Num) -> isFinite n -> (a:isort 0) -> PSignedCmp a -> - PSignedCmp (mseq E stack n a); -PSignedCmpMSeq E stack = +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 stack n a)) + PSignedCmp (mseq E n a)) (\ (n:Nat) -> PSignedCmpVec n); -PSignedCmpMSeqBool : (E:EvType) -> (stack:FunStack) -> - (n : Num) -> isFinite n -> PSignedCmp (mseq E stack n Bool); -PSignedCmpMSeqBool E stack = - Num_rec_fin (\ (n:Num) -> PSignedCmp (mseq E stack n Bool)) PSignedCmpWord; +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) -> (stack:FunStack) -> - (a : sort 0) -> PZero a -> PZero (SpecM E stack a); -PZeroSpecM E stack = retS E stack; - -PZeroMSeq : (E:EvType) -> (stack:FunStack) -> - (n : Num) -> (a : sort 0) -> PZero a -> PZero (mseq E stack n a); -PZeroMSeq E stack n_top a pa = - Num_rec (\ (n:Num) -> PZero (mseq E stack n a)) +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 stack a) (retS E stack 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) -> (stack:FunStack) -> - (a : sort 0) -> PLogic a -> PLogic (SpecM E stack a); -PLogicSpecM E stack a pa = - { logicZero = retS E stack a (pa.logicZero) - , and = fmapS2 E stack a a a (pa.and) - , or = fmapS2 E stack a a a (pa.or) - , xor = fmapS2 E stack a a a (pa.xor) - , not = fmapS E stack a a (pa.not) +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) -> (stack:FunStack) -> - (n : Num) -> (a : isort 0) -> PLogic a -> - PLogic (mseq E stack n a); -PLogicMSeq E stack n_top a pa = - Num_rec (\ (n:Num) -> PLogic (mseq E stack n a)) +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 stack a) (PLogicSpecM E stack a pa)) + (PLogicStream (SpecM E a) (PLogicSpecM E a pa)) n_top; -PLogicMSeqBool : (E:EvType) -> (stack:FunStack) -> - (n : Num) -> isFinite n -> PLogic (mseq E stack n Bool); -PLogicMSeqBool E stack = - Num_rec_fin (\ (n:Num) -> PLogic (mseq E stack n Bool)) PLogicWord; +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) -> (stack:FunStack) -> - (a : sort 0) -> PRing a -> PRing (SpecM E stack a); -PRingSpecM E stack a pa = - { ringZero = retS E stack a (pa.ringZero) - , add = fmapS2 E stack a a a (pa.add) - , sub = fmapS2 E stack a a a (pa.sub) - , mul = fmapS2 E stack a a a (pa.mul) - , neg = fmapS E stack a a (pa.neg) - , int = \ (i : Integer) -> retS E stack a (pa.int i) +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) -> (stack:FunStack) -> - (n : Num) -> (a : isort 0) -> PRing a -> PRing (mseq E stack n a); -PRingMSeq E stack n_top a pa = - Num_rec (\ (n:Num) -> PRing (mseq E stack n a)) +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 stack a) (PRingSpecM E stack a pa)) + (PRingStream (SpecM E a) (PRingSpecM E a pa)) n_top; -PRingMSeqBool : (E:EvType) -> (stack:FunStack) -> - (n : Num) -> isFinite n -> PRing (mseq E stack n Bool); -PRingMSeqBool E stack = - Num_rec_fin (\ (n:Num) -> PRing (mseq E stack n Bool)) PRingWord; +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) -> (stack:FunStack) -> - (n : Num) -> isFinite n -> PIntegral (mseq E stack n Bool); -PIntegralMSeqBool E stack = - Num_rec_fin (\ (n:Num) -> PIntegral (mseq E stack n Bool)) PIntegralWord; +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) -> (stack:FunStack) -> - (n : Num) -> isFinite n -> PLiteral (mseq E stack n Bool); -PLiteralSeqBoolM E stack = - Num_rec_fin (\ (n:Num) -> PLiteral (mseq E stack n Bool)) bvNat; +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; -------------------------------------------------------------------------------- @@ -594,339 +505,319 @@ PLiteralSeqBoolM E stack = -- Sequences -ecShiftLM : (E:EvType) -> (stack:FunStack) -> - (m : Num) -> (ix a : sort 0) -> PIntegral ix -> PZero a -> - mseq E stack m a -> ix -> mseq E stack m a; -ecShiftLM E stack = +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 stack m a -> ix -> mseq E stack m 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 stack a) pix (PZeroSpecM E stack a pa)); + ecShiftL TCInf ix (SpecM E a) pix (PZeroSpecM E a pa)); -ecShiftRM : (E:EvType) -> (stack:FunStack) -> - (m : Num) -> (ix a : sort 0) -> PIntegral ix -> PZero a -> - mseq E stack m a -> ix -> mseq E stack m a; -ecShiftRM E stack = +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 stack m a -> ix -> mseq E stack m 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 stack a) pix (PZeroSpecM E stack a pa)); + ecShiftR TCInf ix (SpecM E a) pix (PZeroSpecM E a pa)); -ecSShiftRM : (E:EvType) -> (stack:FunStack) -> - (n : Num) -> isFinite n -> (ix : sort 0) -> PIntegral ix -> - mseq E stack n Bool -> ix -> mseq E stack n Bool; -ecSShiftRM E stack = +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 stack n Bool -> ix -> - mseq E stack n Bool) + (\ (n:Num) -> (ix : sort 0) -> PIntegral ix -> mseq E n Bool -> ix -> + mseq E n Bool) (\ (n:Nat) -> ecSShiftR (TCNum n)); -ecRotLM : (E:EvType) -> (stack:FunStack) -> - (m : Num) -> isFinite m -> (ix a : sort 0) -> PIntegral ix -> - mseq E stack m a -> ix -> mseq E stack m a; -ecRotLM E stack = +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 stack m a -> ix -> - mseq E stack m a) + (\ (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) -> (stack:FunStack) -> - (m : Num) -> isFinite m -> (ix a : sort 0) -> PIntegral ix -> - mseq E stack m a -> ix -> mseq E stack m a; -ecRotRM E stack = +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 stack m a -> ix -> - mseq E stack m a) + (\ (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) -> (stack:FunStack) -> - (m : Num) -> isFinite m -> (n : Num) -> (a : isort 0) -> - mseq E stack m a -> mseq E stack n a -> mseq E stack (tcAdd m n) a; -ecCatM E stack = +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 stack m a -> mseq E stack n a -> - mseq E stack (tcAdd m n) a) + (\ (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 stack n a -> - mseq E stack (tcAdd (TCNum m) n) a) + (\ (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 stack a) m - (map a (SpecM E stack a) (retS E stack a) m v))); + streamAppend (SpecM E a) m + (map a (SpecM E a) (retS E a) m v))); -ecTakeM : (E:EvType) -> (stack:FunStack) -> - (m n : Num) -> (a : qisort 0) -> mseq E stack (tcAdd m n) a -> - SpecM E stack (mseq E stack m a); -ecTakeM E stack = +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 stack (tcAdd m n) a -> - SpecM E stack (mseq E stack m a)) + (\ (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 stack (tcAdd (TCNum m) n) a -> - SpecM E stack (Vec m a)) + (\ (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 stack (Vec m a) (take a m n xs)) + retS E (Vec m a) (take a m n xs)) -- The case (TCNum m, infinity) - (\ (a:qisort 0) -> \ (xs: Stream (SpecM E stack a)) -> - vecSequenceM E stack a m (streamTake (SpecM E stack a) m xs))) + (\ (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 stack (tcAdd TCInf n) a -> - SpecM E stack (Stream (SpecM E stack a))) + (\ (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 stack a)) -> - retS E stack (Stream (SpecM E stack a)) xs) + (\ (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 stack a)) -> - retS E stack (Stream (SpecM E stack a)) xs)); + (\ (a:qisort 0) -> \ (xs:Stream (SpecM E a)) -> + retS E (Stream (SpecM E a)) xs)); -ecDropM : (E:EvType) -> (stack:FunStack) -> - (m : Num) -> isFinite m -> (n : Num) -> (a : isort 0) -> - mseq E stack (tcAdd m n) a -> mseq E stack n a; -ecDropM E stack = +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 stack (tcAdd m n) a -> mseq E stack n a) + (\ (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 stack (tcAdd (TCNum m) n) a -> mseq E stack n a) + (\ (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 stack a) m)); + (\ (a:isort 0) -> streamDrop (SpecM E a) m)); -ecJoinM : (E:EvType) -> (stack:FunStack) -> - (m n : Num) -> isFinite n -> (a : isort 0) -> - mseq E stack m (mseq E stack n a) -> mseq E stack (tcMul m n) a; -ecJoinM E stack = +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 stack m (mseq E stack n a) -> mseq E stack (tcMul m n) a) + 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 stack n a) -> - mseq E stack (tcMul (TCNum m) n) a) + (\ (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) -> joinCryM m n a)) + (\ (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 stack (mseq E stack n a)) -> - mseq E stack (tcMul TCInf n) a) + (\ (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 stack (Vec n' a)) -> - mseq E stack (if0Nat Num n' (TCNum 0) TCInf) a) - (\ (s:Stream (SpecM E stack (Vec 0 a))) -> EmptyVec a) - (\ (n':Nat) -> \ (s:Stream (SpecM E stack (Vec (Succ n') a))) -> - streamJoinM E stack a n' s) + (\ (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) -> (stack:FunStack) -> - (m n : Num) -> isFinite n -> (a : qisort 0) -> - mseq E stack (tcMul m n) a -> mseq E stack m (mseq E stack n a); -ecSplitM E stack = +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 stack (tcMul m n) a -> mseq E stack m (mseq E stack n a)) + 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 stack (tcMul (TCNum m) n) a -> - Vec m (mseq E stack n a)) + (\ (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) -> splitCryM m n a)) + (\ (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 stack (tcMul TCInf n) a -> - Stream (SpecM E stack (mseq E stack n a))) + (\ (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 stack (if0Nat Num n' (TCNum 0) TCInf) a -> - Stream (SpecM E stack (Vec n' a))) - (\ (xs : Vec 0 a) -> streamConst (SpecM E stack (Vec 0 a)) - (retS E stack (Vec 0 a) xs)) - (\ (n':Nat) (xs : Stream (SpecM E stack a)) -> - streamMap (Vec (Succ n') (SpecM E stack a)) - (SpecM E stack (Vec (Succ n') a)) - (vecSequenceM E stack a (Succ n')) - (streamSplit (SpecM E stack a) (Succ n') xs)) + 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) -> (stack:FunStack) -> - (n : Num) -> isFinite n -> (a : isort 0) -> mseq E stack n a -> - mseq E stack n a; -ecReverseM E stack = - Num_rec_fin (\ (n:Num) -> (a : isort 0) -> mseq E stack n a -> mseq E stack n a) - (\ (n:Nat) -> reverseCryM n); - -ecTransposeM : (E:EvType) -> (stack:FunStack) -> - (m n : Num) -> (a : qisort 0) -> mseq E stack m (mseq E stack n a) -> - mseq E stack n (mseq E stack m a); -ecTransposeM E stack m n a = +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 stack m (mseq E stack n a) -> - mseq E stack n (mseq E stack m a)) + (\ (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 stack n a) -> - mseq E stack n (Vec m a)) - (\ (n : Nat) -> transposeCryM m n a) - (\ (xss : Vec m (Stream (SpecM E stack a))) -> - MkStream (SpecM E stack (Vec m a)) (\ (i : Nat) -> - vecMapM E stack (Stream (SpecM E stack a)) a m - (\ (j:Nat) -> \ (xs:Stream (SpecM E stack a)) -> - streamGet (SpecM E stack a) xs i) + (\ (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 stack (mseq E stack n a)) -> - mseq E stack n (Stream (SpecM E stack a))) - (\ (n : Nat) -> \ (xss : Stream (SpecM E stack (Vec n a))) -> - genCryM n (Stream (SpecM E stack a)) (\ (i : Nat) -> - MkStream (SpecM E stack a) (\ (j : Nat) -> - fmapS E stack (Vec n a) a - (\ (xs:Vec n a) -> atCryM n a xs i) - (streamGet (SpecM E stack (Vec n a)) xss j)))) - (\ (xss : Stream (SpecM E stack (Stream (SpecM E stack a)))) -> - MkStream (SpecM E stack (Stream (SpecM E stack a))) (\ (i : Nat) -> - retS E stack (Stream (SpecM E stack a)) - (MkStream (SpecM E stack a) (\ (j : Nat) -> - bindS E stack (Stream (SpecM E stack a)) a - (streamGet (SpecM E stack (Stream (SpecM E stack a))) xss j) - (\ (xs:Stream (SpecM E stack a)) -> streamGet (SpecM E stack a) xs i))))) + (\ (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) -> (stack:FunStack) -> - (n : Num) -> (a : sort 0) -> (ix : sort 0) -> PIntegral ix -> - mseq E stack n a -> ix -> SpecM E stack a; -ecAtM E stack n_top a ix pix = +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 stack n a -> ix -> SpecM E stack a) + (\ (n:Num) -> mseq E n a -> ix -> SpecM E a) (\ (n:Nat) (v:Vec n a) -> - pix.posNegCases (SpecM E stack a) (atM E stack n a v) + pix.posNegCases (SpecM E a) (atM E n a v) (\ (_:Nat) -> - errorS E stack a "ecAtM: invalid sequence index")) - (\ (s:Stream (SpecM E stack a)) -> - pix.posNegCases (SpecM E stack a) (streamGet (SpecM E stack a) s) + 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 stack a "ecAtM: invalid sequence index")) + errorS E a "ecAtM: invalid sequence index")) n_top; -ecUpdateM : (E:EvType) -> (stack:FunStack) -> - (n : Num) -> (a : sort 0) -> (ix : sort 0) -> PIntegral ix -> - mseq E stack n a -> ix -> a -> SpecM E stack (mseq E stack n a); -ecUpdateM E stack n_top a ix pix = +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 stack n a -> ix -> a -> - SpecM E stack (mseq E stack n a)) + (\ (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 stack (Vec n a)) - (\ (i:Nat) -> updateM E stack n a v i x) - (\ (_:Nat) -> errorS E stack (Vec n 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 stack a)) (i:ix) (x:a) -> - pix.posNegCases (SpecM E stack (Stream (SpecM E stack a))) + (\ (s:Stream (SpecM E a)) (i:ix) (x:a) -> + pix.posNegCases (SpecM E (Stream (SpecM E a))) (\ (i:Nat) -> - retS E stack (Stream (SpecM E stack a)) - (streamUpd (SpecM E stack a) s i - (retS E stack a x))) - (\ (_:Nat) -> errorS E stack (Stream (SpecM E stack a)) + 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) -> (stack:FunStack) -> - (n : Num) -> isFinite n -> (a : isort 0) -> +ecAtBackM : (E:EvType) -> (n : Num) -> isFinite n -> (a : isort 0) -> (ix : sort 0) -> PIntegral ix -> - mseq E stack n a -> ix -> SpecM E stack a; -ecAtBackM E stack n pf a ix pix xs = - ecAtM E stack n a ix pix (ecReverseM E stack n pf a xs); - -ecFromToM : (E:EvType) -> (stack:FunStack) -> - (first : Num) -> isFinite first -> (last : Num) -> isFinite last -> - (a : sort 0) -> PLiteral a -> - mseq E stack (tcAdd (TCNum 1) (tcSub last first)) a; -ecFromToM E stack = + 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 stack (tcAdd (TCNum 1) (tcSub last first)) a) + mseq E (tcAdd (TCNum 1) (tcSub last first)) a) (\ (first:Nat) -> Num_rec_fin (\ (last:Num) -> (a : sort 0) -> PLiteral a -> - mseq E stack (tcAdd (TCNum 1) (tcSub last (TCNum first))) a) + mseq E (tcAdd (TCNum 1) (tcSub last (TCNum first))) a) (\ (last:Nat) -> \ (a : sort 0) -> \ (pa : PLiteral a) -> - genCryM (addNat 1 (subNat last first)) a + gen (addNat 1 (subNat last first)) a (\ (i : Nat) -> pa (addNat i first)))); -ecFromToLessThanM : (E:EvType) -> (stack:FunStack) -> - (first : Num) -> isFinite first -> (bound : Num) -> - (a : sort 0) -> PLiteralLessThan a -> - mseq E stack (tcSub bound first) a; -ecFromToLessThanM E stack first pf bound a = +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 stack (tcSub bound first) a) + mseq E (tcSub bound first) a) (\ (first:Nat) -> Num_rec (\ (bound:Num) -> PLiteralLessThan a -> - mseq E stack (tcSub bound (TCNum first)) a) + mseq E (tcSub bound (TCNum first)) a) (\ (bound:Nat) -> \ (pa : PLiteralLessThan a) -> - genCryM (subNat bound first) a + gen (subNat bound first) a (\ (i : Nat) -> pa (addNat i first))) (\ (pa : PLiteralLessThan a) -> - MkStream (SpecM E stack a) - (\ (i : Nat) -> retS E stack a (pa (addNat i first)))) + MkStream (SpecM E a) + (\ (i : Nat) -> retS E a (pa (addNat i first)))) bound) first pf; ecFromThenToM : - (E:EvType) -> (stack:FunStack) -> - (first next last : Num) -> (a : sort 0) -> (len : Num) -> isFinite len -> - PLiteral a -> PLiteral a -> PLiteral a -> mseq E stack len a; -ecFromThenToM E stack first next _ a = + (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 stack len a) + (\ (len:Num) -> PLiteral a -> PLiteral a -> PLiteral a -> mseq E len a) (\ (len:Nat) -> \ (pa : PLiteral a) -> \ (_ : PLiteral a) -> \ (_ : PLiteral a) -> - genCryM len a + gen len a (\ (i : Nat) -> pa (subNat (addNat (getFinNat first) (mulNat i (getFinNat next))) (mulNat i (getFinNat first))))); -ecInfFromM : (E:EvType) -> (stack:FunStack) -> - (a : sort 0) -> PIntegral a -> a -> mseq E stack TCInf a; -ecInfFromM E stack a pa x = - MkStream (SpecM E stack a) +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 stack a (pa.integralRing.add + retS E a (pa.integralRing.add x (pa.integralRing.int (natToInt i)))); -ecInfFromThenM : (E:EvType) -> (stack:FunStack) -> - (a : sort 0) -> PIntegral a -> a -> a -> mseq E stack TCInf a; -ecInfFromThenM E stack a pa x y = - MkStream (SpecM E stack a) +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 stack a (pa.integralRing.add x + retS E a (pa.integralRing.add x (pa.integralRing.mul (pa.integralRing.sub y x) (pa.integralRing.int (natToInt i))))); -ecErrorM : (E:EvType) -> (stack:FunStack) -> - (a : sort 0) -> (len : Num) -> mseq E stack len (Vec 8 Bool) -> - SpecM E stack a; -ecErrorM E stack a len msg = - errorS E stack a "encountered call to the Cryptol 'error' function"; +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 new file mode 100644 index 0000000000..39772495d0 --- /dev/null +++ b/cryptol-saw-core/saw/SpecM.sawcore @@ -0,0 +1,944 @@ +------------------------------------------------------------------------------- +-- 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/Verifier/SAW/Cryptol.hs b/cryptol-saw-core/src/Verifier/SAW/Cryptol.hs index efe6dc0dee..476478193e 100644 --- a/cryptol-saw-core/src/Verifier/SAW/Cryptol.hs +++ b/cryptol-saw-core/src/Verifier/SAW/Cryptol.hs @@ -6,6 +6,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TemplateHaskell #-} {- | Module : Verifier.SAW.Cryptol @@ -91,6 +92,17 @@ import Verifier.SAW.TypedAST (mkSort, FieldName, LocalName) import GHC.Stack + +-- Type-check the Prelude, Cryptol, SpecM, and CryptolM modules at compile time +import Language.Haskell.TH +import Verifier.SAW.Cryptol.Prelude +import Verifier.SAW.Cryptol.PreludeM + +$(runIO (mkSharedContext >>= \sc -> + scLoadPreludeModule sc >> scLoadCryptolModule sc >> + scLoadSpecMModule sc >> scLoadCryptolMModule sc >> return [])) + + -------------------------------------------------------------------------------- -- Type Environments diff --git a/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs b/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs index 3246bfaa58..e9e6fbfa8a 100644 --- a/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs +++ b/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs @@ -10,6 +10,10 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE KindSignatures #-} {- | Module : Verifier.SAW.Cryptol.Monadify @@ -29,26 +33,51 @@ 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. -FIXME: explain this better - - -Type-level translation: - -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) -- NOTE: f must be a pure function! -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) - +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: @@ -72,12 +101,12 @@ Mon(cnst) = cnst otherwise module Verifier.SAW.Cryptol.Monadify where -import Data.Maybe +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 Control.Monad ((>=>), foldM, forM_, zipWithM) +import Control.Monad (forM_) import Control.Monad.Cont (Cont, cont, runCont) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Reader (MonadReader(..), ReaderT(..)) @@ -87,33 +116,67 @@ import qualified Control.Monad.Fail as Fail -- import Control.Monad.IO.Class (MonadIO, liftIO) import qualified Data.Text as T import qualified Text.URI as URI -import GHC.Generics (Generic) +import Data.Type.Equality +import Verifier.SAW.Utils import Verifier.SAW.Name import Verifier.SAW.Term.Functor import Verifier.SAW.SharedTerm import Verifier.SAW.OpenTerm import Verifier.SAW.TypedTerm import Verifier.SAW.Cryptol (Env) -import Verifier.SAW.SCTypeCheck import Verifier.SAW.Recognizer -- import Verifier.SAW.Position import Verifier.SAW.Cryptol.PreludeM import GHC.Stack -import Debug.Trace +-- import Debug.Trace --- Type-check the Prelude, Cryptol, and CryptolM modules at compile time -{- -import Language.Haskell.TH -import Verifier.SAW.Cryptol.Prelude +-- FIXME: move to OpenTerm.hs -$(runIO (mkSharedContext >>= \sc -> - scLoadPreludeModule sc >> scLoadCryptolModule sc >> - scLoadCryptolMModule sc >> return [])) --} +-- | A global definition, which is either a primitive or a constant. As +-- described in the documentation for 'ExtCns', the names need not be unique, +-- but the 'VarIndex' is, and this is what is used to index 'GlobalDef's. +data GlobalDef = GlobalDef { globalDefName :: NameInfo, + globalDefIndex :: VarIndex, + globalDefType :: Term, + globalDefTerm :: Term, + globalDefBody :: Maybe Term } + +instance Eq GlobalDef where + gd1 == gd2 = globalDefIndex gd1 == globalDefIndex gd2 +instance Ord GlobalDef where + compare gd1 gd2 = compare (globalDefIndex gd1) (globalDefIndex gd2) + +instance Show GlobalDef where + show = show . globalDefName + +-- | Get the 'String' name of a 'GlobalDef' +globalDefString :: GlobalDef -> String +globalDefString = T.unpack . toAbsoluteName . globalDefName + +-- | Build an 'OpenTerm' from a 'GlobalDef' +globalDefOpenTerm :: GlobalDef -> OpenTerm +globalDefOpenTerm = closedOpenTerm . globalDefTerm + +-- | Recognize a named global definition, including its type +asTypedGlobalDef :: Recognizer Term GlobalDef +asTypedGlobalDef t = + case unwrapTermF t of + FTermF (Primitive pn) -> + Just $ GlobalDef (ModuleIdentifier $ + primName pn) (primVarIndex pn) (primType pn) t Nothing + Constant ec body -> + Just $ GlobalDef (ecName ec) (ecVarIndex ec) (ecType ec) t body + FTermF (ExtCns ec) -> + Just $ GlobalDef (ecName ec) (ecVarIndex ec) (ecType ec) t Nothing + _ -> Nothing + + +-- FIXME HERE NOW: remove these if no longer needed +{- ---------------------------------------------------------------------- -- * Typing All Subterms @@ -165,6 +228,7 @@ instance ToTerm TypedSubsTerm where unsharedApply :: Term -> Term -> Term unsharedApply f arg = Unshared $ App f arg +-} ---------------------------------------------------------------------- @@ -177,220 +241,221 @@ isFirstOrderType (asPi -> Just (_, asPi -> Just _, _)) = False isFirstOrderType (asPi -> Just (_, _, tp_out)) = isFirstOrderType tp_out isFirstOrderType _ = True --- | A global definition, which is either a primitive or a constant. As --- described in the documentation for 'ExtCns', the names need not be unique, --- but the 'VarIndex' is, and this is what is used to index 'GlobalDef's. -data GlobalDef = GlobalDef { globalDefName :: NameInfo, - globalDefIndex :: VarIndex, - globalDefType :: Term, - globalDefTerm :: Term, - globalDefBody :: Maybe Term } - -instance Eq GlobalDef where - gd1 == gd2 = globalDefIndex gd1 == globalDefIndex gd2 - -instance Ord GlobalDef where - compare gd1 gd2 = compare (globalDefIndex gd1) (globalDefIndex gd2) - -instance Show GlobalDef where - show = show . globalDefName - --- | Get the 'String' name of a 'GlobalDef' -globalDefString :: GlobalDef -> String -globalDefString = T.unpack . toAbsoluteName . globalDefName - --- | Build an 'OpenTerm' from a 'GlobalDef' -globalDefOpenTerm :: GlobalDef -> OpenTerm -globalDefOpenTerm = closedOpenTerm . globalDefTerm - --- | Recognize a named global definition, including its type -asTypedGlobalDef :: Recognizer Term GlobalDef -asTypedGlobalDef t = - case unwrapTermF t of - FTermF (Primitive pn) -> - Just $ GlobalDef (ModuleIdentifier $ - primName pn) (primVarIndex pn) (primType pn) t Nothing - Constant ec body -> - Just $ GlobalDef (ecName ec) (ecVarIndex ec) (ecType ec) t body - FTermF (ExtCns ec) -> - Just $ GlobalDef (ecName ec) (ecVarIndex ec) (ecType ec) t Nothing - _ -> Nothing - --- | The event type and function stack arguments to the @SpecM@ type, using type --- @tm@ for terms -data SpecMParams tm = SpecMParams { specMEvType :: tm, specMStack :: tm } - deriving (Generic, Show) - --- | Convert a 'SpecMParams' to a list of terms -paramsToTerms :: SpecMParams tm -> [tm] -paramsToTerms SpecMParams { specMEvType = ev, specMStack = stack } = [ev,stack] - --- | The implicit argument version of 'SpecMParams' -type HasSpecMParams = (?specMParams :: SpecMParams OpenTerm) - --- | Build a @LetRecType@ for a nested pi type -lrtFromMonType :: HasSpecMParams => MonType -> OpenTerm -lrtFromMonType (MTyForall x k body_f) = - ctorOpenTerm "Prelude.LRT_Fun" - [monKindOpenTerm k, - lambdaOpenTerm x (monKindOpenTerm k) (\tp -> lrtFromMonType $ - body_f $ MTyBase k tp)] -lrtFromMonType (MTyArrow mtp1 mtp2) = - ctorOpenTerm "Prelude.LRT_Fun" - [toArgType mtp1, - lambdaOpenTerm "_" (toArgType mtp1) (\_ -> lrtFromMonType mtp2)] -lrtFromMonType mtp = - ctorOpenTerm "Prelude.LRT_Ret" [toArgType mtp] - --- | Push a frame of recursive functions with the given 'MonType's onto a --- @FunStack@ --- --- FIXME HERE: This will give the incorrect type if any of the 'MonType's are --- higher-order, meaning they themselves take in or return types containing --- @SpecM@. In order to fix this, we will need a more general @LetRecType@. -pushSpecMFrame :: HasSpecMParams => [MonType] -> OpenTerm -> OpenTerm -pushSpecMFrame tps stack = - let frame = - list1OpenTerm (dataTypeOpenTerm "Prelude.LetRecType" []) $ - map lrtFromMonType tps in - applyGlobalOpenTerm "Prelude.pushFunStack" [frame, stack] - --- | The empty function stack -emptyStackOpenTerm :: OpenTerm -emptyStackOpenTerm = globalOpenTerm "Prelude.emptyFunStack" - --- | Build a 'SpecMParams' with the empty stack from an 'EvType' -paramsOfEvType :: OpenTerm -> SpecMParams OpenTerm -paramsOfEvType ev = SpecMParams ev emptyStackOpenTerm - -data MonKind = MKType Sort | MKNum | MKFun MonKind MonKind deriving Eq - --- | Convert a kind to a SAW core sort, if possible -monKindToSort :: MonKind -> Maybe Sort -monKindToSort (MKType s) = Just s -monKindToSort _ = Nothing - --- | Convert a 'MonKind' to the term it represents -monKindOpenTerm :: MonKind -> OpenTerm -monKindOpenTerm (MKType s) = sortOpenTerm s -monKindOpenTerm MKNum = dataTypeOpenTerm "Cryptol.Num" [] -monKindOpenTerm (MKFun k1 k2) = - arrowOpenTerm "_" (monKindOpenTerm k1) (monKindOpenTerm k2) - +-- | 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 - = MTyForall LocalName MonKind (MonType -> MonType) + = forall k. MTyForall LocalName (KindRepr k) (TpExpr k -> MonType) | MTyArrow MonType MonType - | MTySeq OpenTerm MonType + | MTySeq NumTpExpr MonType + | MTyUnit + | MTyBool + | MTyBV Natural | MTyPair MonType MonType - | MTyRecord [(FieldName, MonType)] - | MTyBase MonKind OpenTerm -- A "base type" or type var of a given kind - | MTyNum OpenTerm - --- | Make a base type of sort 0 from an 'OpenTerm' -mkMonType0 :: OpenTerm -> MonType -mkMonType0 = MTyBase (MKType $ mkSort 0) - --- | Make a 'MonType' for the Boolean type -boolMonType :: MonType -boolMonType = mkMonType0 $ globalOpenTerm "Prelude.Bool" - --- | Test that a monadification type is monomorphic, i.e., has no foralls -monTypeIsMono :: MonType -> Bool -monTypeIsMono (MTyForall _ _ _) = False -monTypeIsMono (MTyArrow tp1 tp2) = monTypeIsMono tp1 && monTypeIsMono tp2 -monTypeIsMono (MTyPair tp1 tp2) = monTypeIsMono tp1 && monTypeIsMono tp2 -monTypeIsMono (MTyRecord tps) = all (monTypeIsMono . snd) tps -monTypeIsMono (MTySeq _ tp) = monTypeIsMono tp -monTypeIsMono (MTyBase _ _) = True -monTypeIsMono (MTyNum _) = True + | 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 (MTySeq _ _) = True -isBaseType (MTyPair _ _) = True -isBaseType (MTyRecord _) = True -isBaseType (MTyBase (MKType _) _) = True -isBaseType (MTyBase _ _) = True -isBaseType (MTyNum _) = False - --- | If a 'MonType' is a type-level number, return its 'OpenTerm', otherwise --- return 'Nothing' -monTypeNum :: MonType -> Maybe OpenTerm -monTypeNum (MTyNum t) = Just t -monTypeNum (MTyBase MKNum t) = Just t -monTypeNum _ = Nothing - --- | Get the kind of a 'MonType', assuming it has one -monTypeKind :: MonType -> Maybe MonKind -monTypeKind (MTyForall _ _ _) = Nothing -monTypeKind (MTyArrow t1 t2) = - do s1 <- monTypeKind t1 >>= monKindToSort - s2 <- monTypeKind t2 >>= monKindToSort - return $ MKType $ maxSort [s1, s2] -monTypeKind (MTyPair tp1 tp2) = - do sort1 <- monTypeKind tp1 >>= monKindToSort - sort2 <- monTypeKind tp2 >>= monKindToSort - return $ MKType $ maxSort [sort1, sort2] -monTypeKind (MTyRecord tps) = - do sorts <- mapM (monTypeKind . snd >=> monKindToSort) tps - return $ MKType $ maxSort sorts -monTypeKind (MTySeq _ tp) = - do sort <- monTypeKind tp >>= monKindToSort - return $ MKType sort -monTypeKind (MTyBase k _) = Just k -monTypeKind (MTyNum _) = Just MKNum - --- | Get the 'Sort' @s@ of a 'MonType' if it has kind @'MKType' s@ -monTypeSort :: MonType -> Maybe Sort -monTypeSort = monTypeKind >=> monKindToSort +isBaseType _ = True -- | Convert a SAW core 'Term' to a monadification kind, if possible -monadifyKind :: Term -> Maybe MonKind +monadifyKind :: Term -> Maybe SomeKindRepr monadifyKind (asDataType -> Just (num, [])) - | primName num == "Cryptol.Num" = return MKNum -monadifyKind (asSort -> Just s) = return $ MKType s -monadifyKind (asPi -> Just (_, tp_in, tp_out)) = - MKFun <$> monadifyKind tp_in <*> monadifyKind tp_out + | primName num == "Cryptol.Num" = Just $ SomeKindRepr MKNumRepr +monadifyKind (asSort -> Just s) | s == mkSort 0 = Just $ SomeKindRepr MKTypeRepr monadifyKind _ = Nothing --- | Get the kind of a type constructor with kind @k@ applied to type @t@, or --- return 'Nothing' if the kinds do not line up -applyKind :: MonKind -> MonType -> Maybe MonKind -applyKind (MKFun k1 k2) t - | Just kt <- monTypeKind t - , kt == k1 = Just k2 -applyKind _ _ = Nothing - --- | Perform 'applyKind' for 0 or more argument types -applyKinds :: MonKind -> [MonType] -> Maybe MonKind -applyKinds = foldM applyKind - --- | Convert a 'MonType' to the argument type @MT(tp)@ it represents -toArgType :: HasSpecMParams => MonType -> OpenTerm +-- | 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 (monKindOpenTerm k) (\tp -> toCompType (body $ MTyBase k tp)) + 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 "CryptolM.mseq") - [specMEvType ?specMParams, specMStack ?specMParams, n, toArgType 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 (MTyRecord tps) = - recordTypeOpenTerm $ map (\(f,tp) -> (f, toArgType tp)) tps -toArgType (MTyBase _ t) = t -toArgType (MTyNum n) = n +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 :: HasSpecMParams => MonType -> OpenTerm +toCompType :: HasSpecMEvType => MonType -> OpenTerm toCompType mtp@(MTyForall _ _ _) = toArgType mtp toCompType mtp@(MTyArrow _ _) = toArgType mtp -toCompType mtp = - let SpecMParams { specMEvType = ev, specMStack = stack } = ?specMParams in - applyOpenTermMulti (globalOpenTerm "Prelude.SpecM") [ev, stack, 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 @@ -405,21 +470,25 @@ typeclassMonMap = ("Cryptol.PIntegral", "Cryptol.PIntegral"), ("Cryptol.PLiteral", "Cryptol.PLiteral")] --- | The list of functions that are monadified as themselves in types -typeLevelOpMonList :: [Ident] -typeLevelOpMonList = ["Cryptol.tcAdd", "Cryptol.tcSub", "Cryptol.tcMul", - "Cryptol.tcDiv", "Cryptol.tcMod", "Cryptol.tcExp", - "Cryptol.tcMin", "Cryptol.tcMax"] +-- | 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, if their --- types corespond to 'MonKind's, a local 'MonType' that quantifies over them. +-- 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 MonType)] +type MonadifyTypeCtx = [(LocalName, Term, Maybe SomeTpExpr)] -- | Pretty-print a 'Term' relative to a 'MonadifyTypeCtx' ppTermInTypeCtx :: MonadifyTypeCtx -> Term -> String @@ -430,69 +499,83 @@ ppTermInTypeCtx ctx t = typeCtxPureCtx :: MonadifyTypeCtx -> [(LocalName,Term)] typeCtxPureCtx = map (\(x,tp,_) -> (x,tp)) + -- | Monadify a type and convert it to its corresponding argument type -monadifyTypeArgType :: (HasCallStack, HasSpecMParams) => MonadifyTypeCtx -> +monadifyTypeArgType :: (HasCallStack, HasSpecMEvType) => MonadifyTypeCtx -> Term -> OpenTerm monadifyTypeArgType ctx t = toArgType $ monadifyType ctx t --- | 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 -> Either MonType ArgMonTerm -> MonType -applyMonType (MTyArrow _ tp_ret) (Right _) = tp_ret -applyMonType (MTyForall _ _ f) (Left mtp) = f mtp -applyMonType _ _ = error "applyMonType: application at incorrect type" +-- | 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 monadification type -monadifyType :: (HasCallStack, HasSpecMParams) => MonadifyTypeCtx -> Term -> - MonType + +-- | 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 {- -monadifyType ctx t - | trace ("\nmonadifyType:\n" ++ ppTermInTypeCtx ctx t) False = undefined +monadifyTpExpr ctx t + | trace ("\nmonadifyTpExpr:\n" ++ ppTermInTypeCtx ctx t) False = undefined -} -monadifyType ctx (asPi -> Just (x, tp_in, tp_out)) - | Just k <- monadifyKind tp_in = - MTyForall x k (\tp' -> monadifyType ((x,tp_in,Just tp'):ctx) tp_out) -monadifyType ctx tp@(asPi -> Just (_, _, tp_out)) + +-- 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) -monadifyType ctx tp@(asPi -> Just (x, tp_in, tp_out)) = - MTyArrow (monadifyType ctx tp_in) - (monadifyType ((x,tp,Nothing):ctx) tp_out) -monadifyType _ (asTupleType -> Just []) = mkMonType0 unitTypeOpenTerm -monadifyType ctx (asPairType -> Just (tp1, tp2)) = +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 +-} +{- FIXME: do we ever need this? monadifyType ctx (asDataType -> Just (eq_pn, [k_trm, tp1, tp2])) - | primName eq_pn == "Prelude.Eq" + | primName eq_pn == "Prelude.Eq" = , isJust (monadifyKind k_trm) = -- NOTE: technically this is a Prop and not a sort 0, but it doesn't matter - mkMonType0 $ dataTypeOpenTerm "Prelude.Eq" [monadifyTypeArgType ctx tp1, - monadifyTypeArgType ctx tp2] -monadifyType ctx (asDataType -> Just (pn, args)) - | Just pn_k <- monadifyKind (primType pn) - , margs <- map (monadifyType ctx) args - , Just k_out <- applyKinds pn_k margs = - -- NOTE: this case only recognizes data types whose arguments are all types - -- and/or Nums - MTyBase k_out $ dataTypeOpenTerm (primName pn) (map toArgType margs) -monadifyType ctx (asVectorType -> Just (len, tp)) = - let lenOT = monadifyTypeNat ctx len in - MTySeq (ctorOpenTerm "Cryptol.TCNum" [lenOT]) $ monadifyType ctx tp -monadifyType ctx (asApplyAll -> ((asGlobalDef -> Just seq_id), [n, a])) + MTyIndesc $ dataTypeOpenTerm "Prelude.Eq" [monadifyTypeArgType ctx tp1, + monadifyTypeArgType ctx tp2] +-} +monadifyTpExpr ctx (asDataType -> Just (pn, args)) = + -- NOTE: this case only recognizes data types whose arguments are all types + -- and/or Nums + SomeTpExpr MKTypeRepr $ + MTyIndesc $ dataTypeOpenTerm (primName pn) (map (someTpExprVal . + monadifyTpExpr ctx) args) +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" = - let nOT = monadifyTypeArgType ctx n in - MTySeq nOT $ monadifyType ctx a -monadifyType ctx (asApp -> Just ((asGlobalDef -> Just f), arg)) + SomeTpExpr MKTypeRepr $ MTySeq (monadifyNum ctx n) (monadifyType ctx a) +monadifyTpExpr ctx (asApp -> Just ((asGlobalDef -> Just f), arg)) | Just f_trans <- lookup f typeclassMonMap = - MTyBase (MKType $ mkSort 1) $ + SomeTpExpr MKTypeRepr $ MTyIndesc $ applyOpenTerm (globalOpenTerm f_trans) $ monadifyTypeArgType ctx arg -monadifyType _ (asGlobalDef -> Just bool_id) - | bool_id == "Prelude.Bool" = - mkMonType0 (globalOpenTerm "Prelude.Bool") +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 @@ -502,33 +585,42 @@ monadifyType ctx (asApplyAll -> (f, args)) MTyBase k_out (applyOpenTermMulti (globalDefOpenTerm glob) $ map toArgType margs) -} -monadifyType _ (asCtor -> Just (pn, [])) + +-- Num cases +monadifyTpExpr _ (asCtor -> Just (pn, [])) | primName pn == "Cryptol.TCInf" - = MTyNum $ ctorOpenTerm "Cryptol.TCInf" [] -monadifyType ctx (asCtor -> Just (pn, [n])) + = SomeTpExpr MKNumRepr $ NExpr_Const $ ctorOpenTerm "Cryptol.TCInf" [] +monadifyTpExpr _ (asCtor -> Just (pn, [asNat -> Just n])) | primName pn == "Cryptol.TCNum" - = MTyNum $ ctorOpenTerm "Cryptol.TCNum" [monadifyTypeNat ctx n] -monadifyType ctx (asApplyAll -> ((asGlobalDef -> Just f), args)) - | f `elem` typeLevelOpMonList = - MTyNum $ - applyOpenTermMulti (globalOpenTerm f) $ map (monadifyTypeArgType ctx) args -monadifyType ctx (asLocalVar -> Just i) + = 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 tp) <- ctx!!i = tp -monadifyType ctx tp = - error ("monadifyType: not a valid type for monadification: " - ++ ppTermInTypeCtx ctx tp) - --- | Monadify a type-level natural number -monadifyTypeNat :: (HasCallStack, HasSpecMParams) => MonadifyTypeCtx -> Term -> - OpenTerm -monadifyTypeNat _ (asNat -> Just n) = natOpenTerm n -monadifyTypeNat ctx (asLocalVar -> Just i) - | i < length ctx - , (_,_,Just tp) <- ctx!!i = toArgType tp -monadifyTypeNat ctx tp = - error ("monadifyTypeNat: not a valid natural number for monadification: " - ++ ppTermInTypeCtx ctx tp) + , (_,_,Just (SomeTpExpr k e)) <- ctx!!i = SomeTpExpr k e +monadifyTpExpr ctx tp = + panic "monadifyTpExpr" + ["not a valid type or numeric expression for monadification: " + ++ 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: " ++ 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: " ++ ppTermInTypeCtx ctx t] ---------------------------------------------------------------------- @@ -543,7 +635,7 @@ data ArgMonTerm -- | A monadification term of non-depedent function type | FunMonTerm LocalName MonType MonType (ArgMonTerm -> MonTerm) -- | A monadification term of polymorphic type - | ForallMonTerm LocalName MonKind (MonType -> MonTerm) + | forall k. ForallMonTerm LocalName (KindRepr k) (TpExpr k -> MonTerm) -- | A representation of a term that has been translated to computational type -- @CompMT(tp)@ @@ -551,6 +643,21 @@ 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 @@ -567,16 +674,15 @@ instance GetMonType MonTerm where -- | Convert a monadification term to a SAW core term of type @CompMT(tp)@ class ToCompTerm a where - toCompTerm :: HasSpecMParams => a -> OpenTerm + toCompTerm :: HasSpecMEvType => a -> OpenTerm instance ToCompTerm ArgMonTerm where toCompTerm (BaseMonTerm mtp t) = - applyOpenTermMulti (globalOpenTerm "Prelude.retS") - [specMEvType ?specMParams, specMStack ?specMParams, toArgType 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 (monKindOpenTerm k) (toCompTerm . body . MTyBase k) + lambdaOpenTerm x (kindReprOpenTerm k) (toCompTerm . body . kindOfVal k) instance ToCompTerm MonTerm where toCompTerm (ArgMonTerm amtrm) = toCompTerm amtrm @@ -584,19 +690,19 @@ instance ToCompTerm MonTerm where -- | Convert an 'ArgMonTerm' to a SAW core term of type @MT(tp)@ -toArgTerm :: HasSpecMParams => ArgMonTerm -> OpenTerm +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 :: HasSpecMParams => MonType -> OpenTerm -> a + fromArgTerm :: HasSpecMEvType => MonType -> OpenTerm -> a instance FromArgTerm ArgMonTerm where fromArgTerm (MTyForall x k body) t = ForallMonTerm x k (\tp -> fromCompTerm (body tp) (applyOpenTerm t $ - toArgType tp)) + tpExprVal k tp)) fromArgTerm (MTyArrow t1 t2) t = FunMonTerm "_" t1 t2 (\x -> fromCompTerm t2 (applyOpenTerm t $ toArgTerm x)) fromArgTerm tp t = BaseMonTerm tp t @@ -605,67 +711,47 @@ instance FromArgTerm MonTerm where fromArgTerm mtp t = ArgMonTerm $ fromArgTerm mtp t -- | Build a monadification term from a computational term of type @CompMT(tp)@ -fromCompTerm :: HasSpecMParams => MonType -> OpenTerm -> MonTerm +fromCompTerm :: HasSpecMEvType => MonType -> OpenTerm -> MonTerm fromCompTerm mtp t | isBaseType mtp = CompMonTerm mtp t fromCompTerm mtp t = ArgMonTerm $ fromArgTerm mtp t --- | Take a function of type @A1 -> ... -> An -> SpecM E emptyFunStack B@ and --- lift the stack of the output type to an arbitrary @stack@ parameter using --- @liftStackS@. Note that @liftStackS@ is only added if the stack of the --- output type is non-empty, i.e. not @emptyFunStack@. Otherwise, this operation --- leaves the function unchanged. -class LiftCompStack a where - liftCompStack :: HasSpecMParams => a -> a - -instance LiftCompStack ArgMonTerm where - liftCompStack t@(BaseMonTerm _ _) = - -- A pure term need not be lifted, because it is not computational - t - liftCompStack (FunMonTerm nm tp_in tp_out body) = - FunMonTerm nm tp_in tp_out $ \x -> liftCompStack $ body x - liftCompStack (ForallMonTerm nm k body) = - ForallMonTerm nm k $ \x -> liftCompStack $ body x - -instance LiftCompStack MonTerm where - liftCompStack (ArgMonTerm amtrm) = ArgMonTerm $ liftCompStack amtrm - liftCompStack (CompMonTerm mtp trm) = CompMonTerm mtp $ OpenTerm $ do - -- Only add @liftStackS@ when the stack is not @emptyFunStack@ - empty_stk <- typedVal <$> unOpenTerm emptyStackOpenTerm - curr_stk <- typedVal <$> unOpenTerm (specMStack ?specMParams) - curr_stk_empty <- liftTCM scConvertible False empty_stk curr_stk - unOpenTerm $ if curr_stk_empty then trm else - applyGlobalOpenTerm "Prelude.liftStackS" - [specMEvType ?specMParams, specMStack ?specMParams, toArgType mtp, trm] - -- | Test if a monadification type @tp@ is pure, meaning @MT(tp)=tp@ monTypeIsPure :: MonType -> Bool -monTypeIsPure (MTyForall _ _ _) = False -- NOTE: this could potentially be true +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 (MTyRecord fld_mtps) = all (monTypeIsPure . snd) fld_mtps -monTypeIsPure (MTyBase _ _) = True -monTypeIsPure (MTyNum _) = True +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 $ MTyBase k $ + 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 (MTyRecord fld_mtps) = - -- Same as pairs, record types are only semi-pure if they are pure - all (monTypeIsPure . snd) fld_mtps -monTypeIsSemiPure (MTyBase _ _) = True -monTypeIsSemiPure (MTyNum _) = True +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 @@ -676,67 +762,74 @@ monTypeIsSemiPure (MTyNum _) = True -- > SemiP(Pi x Num b) = Pi x Num SemiP(b) -- > SemiP(Pi _ a b) = MT(a) -> SemiP(b) -- > SemiP(a) = MT(a) -fromSemiPureTermFun :: HasSpecMParams => MonType -> ([OpenTerm] -> OpenTerm) -> +fromSemiPureTermFun :: HasSpecMEvType => MonType -> ([OpenTerm] -> OpenTerm) -> ArgMonTerm fromSemiPureTermFun (MTyForall x k body) f = - ForallMonTerm x k $ \tp -> - ArgMonTerm $ fromSemiPureTermFun (body tp) (f . (toArgType tp:)) + 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 :: HasSpecMParams => MonType -> OpenTerm -> ArgMonTerm +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 :: HasSpecMParams => MonType -> String -> MonTerm -failMonTerm mtp str = fromArgTerm mtp (failOpenTerm str) +failMonTerm :: HasSpecMEvType => MonType -> String -> MonTerm +failMonTerm tp str = ArgMonTerm $ failArgMonTerm tp str --- | Build an 'ArgMonTerm' that 'fail's when converted to a term -failArgMonTerm :: HasSpecMParams => MonType -> String -> ArgMonTerm -failArgMonTerm tp str = fromArgTerm tp (failOpenTerm 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 -> Either MonType ArgMonTerm -> MonTerm -applyMonTerm (ArgMonTerm (FunMonTerm _ _ _ f)) (Right arg) = f arg -applyMonTerm (ArgMonTerm (ForallMonTerm _ _ f)) (Left mtp) = f mtp -applyMonTerm (ArgMonTerm (FunMonTerm _ _ _ _)) (Left _) = - error "applyMonTerm: application of term-level function to type-level argument" -applyMonTerm (ArgMonTerm (ForallMonTerm _ _ _)) (Right _) = - error "applyMonTerm: application of type-level function to term-level 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 _ _)) _ = - error "applyMonTerm: application of non-function base term" + panic "applyMonTerm" ["Application of non-functional pure term"] applyMonTerm (CompMonTerm _ _) _ = - error "applyMonTerm: application of computational term" + panic "applyMonTerm" ["Application of non-functional computational term"] -- | Apply a monadified term to 0 or more arguments -applyMonTermMulti :: HasCallStack => MonTerm -> [Either MonType ArgMonTerm] -> - MonTerm +applyMonTermMulti :: HasCallStack => MonTerm -> [MonArg] -> MonTerm applyMonTermMulti = foldl applyMonTerm -- | Build a 'MonTerm' from a global of a given argument type, applying it to --- the current 'SpecMParams' if the 'Bool' flag is 'True' or lifting it using --- @liftStackS@ if it is 'False' and the stack is non-empty -mkGlobalArgMonTerm :: HasSpecMParams => MonType -> Ident -> Bool -> ArgMonTerm +-- the current 'EventType' if the 'Bool' flag is 'True' +mkGlobalArgMonTerm :: HasSpecMEvType => MonType -> Ident -> Bool -> ArgMonTerm mkGlobalArgMonTerm tp ident params_p = - (if params_p then id else liftCompStack) $ fromArgTerm tp (if params_p - then applyGlobalOpenTerm ident (paramsToTerms ?specMParams) + then applyGlobalOpenTerm ident [evTypeTerm ?specMEvType] else globalOpenTerm ident) --- | Build a 'MonTerm' from a 'GlobalDef' of semi-pure type, applying it to --- the current 'SpecMParams' if the 'Bool' flag is 'True' -mkSemiPureGlobalDefTerm :: HasSpecMParams => GlobalDef -> Bool -> ArgMonTerm +-- | 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) (paramsToTerms ?specMParams) + then applyOpenTermMulti (globalDefOpenTerm glob) [evTypeTerm ?specMEvType] else globalDefOpenTerm glob) -- | Build a 'MonTerm' from a constructor with the given 'PrimName' -mkCtorArgMonTerm :: HasSpecMParams => PrimName Term -> ArgMonTerm +mkCtorArgMonTerm :: HasSpecMEvType => PrimName Term -> ArgMonTerm mkCtorArgMonTerm pn | not (isFirstOrderType (primType pn)) = failArgMonTerm (monadifyType [] $ primType pn) @@ -756,24 +849,22 @@ data MonMacro = MonMacro { macroNumArgs :: Int, macroApply :: GlobalDef -> [Term] -> MonadifyM MonTerm } --- | Make a simple 'MonMacro' that inspects 0 arguments and just returns a term, --- lifted with @liftStackS@ if the outer stack is non-empty +-- | Make a simple 'MonMacro' that inspects 0 arguments and just returns a term monMacro0 :: MonTerm -> MonMacro -monMacro0 mtrm = MonMacro 0 $ \_ _ -> usingSpecMParams $ - return $ liftCompStack mtrm +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 'SpecMParams' should also --- be passed as the first two arguments to the "to" global. +-- 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 -> usingSpecMParams $ + MonMacro 0 $ \glob args -> usingEvType $ if globalDefName glob == ModuleIdentifier from && args == [] then return $ ArgMonTerm $ fromSemiPureTerm (monadifyType [] $ globalDefType glob) - (if params_p then applyGlobalOpenTerm to (paramsToTerms ?specMParams) + (if params_p then applyGlobalOpenTerm to [evTypeTerm ?specMEvType] else globalOpenTerm to) else error ("Monadification macro for " ++ show from ++ " applied incorrectly") @@ -781,13 +872,11 @@ semiPureGlobalMacro from to params_p = -- | 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 and --- function stack; if so, the current 'SpecMParams' are passed as its first two --- arguments, and otherwise the returned computation is lifted with --- @liftStackS@ if the outer stack is non-empty. +-- 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 -> usingSpecMParams $ + MonMacro 0 $ \glob args -> usingEvType $ if globalDefName glob == from && args == [] then return $ ArgMonTerm $ mkGlobalArgMonTerm (monadifyType [] $ globalDefType glob) to params_p @@ -799,13 +888,9 @@ data MonadifyEnv = MonadifyEnv { -- | How to monadify named functions monEnvMonTable :: Map NameInfo MonMacro, -- | The @EvType@ used for monadification - monEnvEvType :: OpenTerm + monEnvEvType :: EventType } --- | Build a 'SpecMParams' with the empty funciton stack from a 'MonadifyEnv' -monEnvParams :: MonadifyEnv -> SpecMParams OpenTerm -monEnvParams env = paramsOfEvType (monEnvEvType env) - -- | Look up the monadification of a name in a 'MonadifyEnv' monEnvLookup :: NameInfo -> MonadifyEnv -> Maybe MonMacro monEnvLookup nmi env = Map.lookup nmi (monEnvMonTable env) @@ -819,14 +904,14 @@ monEnvAdd nmi macro env = -- 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,Either MonType MonTerm)] +type MonadifyCtx = [(LocalName,Term,MonArg)] -- | Convert a 'MonadifyCtx' to a 'MonadifyTypeCtx' ctxToTypeCtx :: MonadifyCtx -> MonadifyTypeCtx ctxToTypeCtx = map (\(x,tp,arg) -> (x,tp,case arg of - Left mtp -> Just mtp - Right _ -> Nothing)) + TpArg k mtp -> Just (SomeTpExpr k mtp) + TrmArg _ -> Nothing)) -- | Pretty-print a 'Term' relative to a 'MonadifyCtx' ppTermInMonCtx :: MonadifyCtx -> Term -> String @@ -854,10 +939,10 @@ data MonadifyROState = MonadifyROState { monStEnv :: MonadifyEnv, -- | The monadification context monStCtx :: MonadifyCtx, - -- | The current @SpecM@ function stack - monStStack :: OpenTerm, - -- | The monadified return type of the top-level term being monadified - monStTopRetType :: OpenTerm + -- | 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' @@ -872,31 +957,21 @@ newtype MonadifyM a = deriving (Functor, Applicative, Monad, MonadReader MonadifyROState, MonadState MonadifyMemoTable) --- | Get the current 'SpecMParams' in a 'MonadifyM' computation -askSpecMParams :: MonadifyM (SpecMParams OpenTerm) -askSpecMParams = - do st <- ask - let ev = monEnvEvType $ monStEnv st - let stack = monStStack st - return (SpecMParams { specMEvType = ev, specMStack = stack }) - --- | Run a 'MonadifyM' computation with the current 'SpecMParams' -usingSpecMParams :: (HasSpecMParams => MonadifyM a) -> MonadifyM a -usingSpecMParams m = - do params <- askSpecMParams - let ?specMParams = params in m - --- | Push a frame of recursive functions onto the current 'SpecMParams' -pushingSpecMParamsM :: [MonType] -> MonadifyM a -> MonadifyM a -pushingSpecMParamsM tps m = - usingSpecMParams $ - local (\rost -> rost { monStStack = pushSpecMFrame tps (monStStack rost) }) m +-- | 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 = - usingSpecMParams $ + usingEvType $ do ret_tp <- topRetType - shiftMonadifyM $ \_ -> failMonTerm (mkMonType0 ret_tp) str + 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 @@ -907,23 +982,22 @@ 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 :: OpenTerm -> MonadifyM MonTerm -> MonadifyM MonTerm +resetMonadifyM :: MonType -> MonadifyM MonTerm -> MonadifyM MonTerm resetMonadifyM ret_tp m = do ro_st <- ask - return $ - runMonadifyM (monStEnv ro_st) (monStCtx ro_st) (monStStack ro_st) ret_tp m + 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 OpenTerm +topRetType :: MonadifyM MonType topRetType = monStTopRetType <$> ask -- | Run a monadification computation -- -- FIXME: document the arguments -runMonadifyM :: MonadifyEnv -> MonadifyCtx -> OpenTerm -> - OpenTerm -> MonadifyM MonTerm -> MonTerm -runMonadifyM env ctx stack top_ret_tp m = - let ro_st = MonadifyROState env ctx stack top_ret_tp in +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 @@ -932,9 +1006,9 @@ runCompleteMonadifyM :: MonadIO m => SharedContext -> MonadifyEnv -> Term -> MonadifyM MonTerm -> m Term runCompleteMonadifyM sc env top_ret_tp m = - let ?specMParams = monEnvParams env in + let ?specMEvType = monEnvEvType env in liftIO $ completeOpenTerm sc $ toCompTerm $ - runMonadifyM env [] emptyStackOpenTerm (toArgType $ monadifyType [] top_ret_tp) m + runMonadifyM env [] (monadifyType [] top_ret_tp) m -- | Memoize a computation of the monadified term associated with a 'TermIndex' memoMonTerm :: TermIndex -> MonadifyM MonTerm -> MonadifyM MonTerm @@ -971,38 +1045,50 @@ memoArgMonTerm i m = argifyMonTerm :: MonTerm -> MonadifyM ArgMonTerm argifyMonTerm (ArgMonTerm mtrm) = return mtrm argifyMonTerm (CompMonTerm mtp trm) = - usingSpecMParams $ + usingEvType $ do let tp = toArgType mtp top_ret_tp <- topRetType shiftMonadifyM $ \k -> - CompMonTerm (mkMonType0 top_ret_tp) $ - applyOpenTermMulti (globalOpenTerm "Prelude.bindS") - [specMEvType ?specMParams, specMStack ?specMParams, tp, top_ret_tp, trm, - lambdaOpenTerm "x" tp (toCompTerm . k . fromArgTerm mtp)] + 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 :: HasSpecMParams => MonType -> MonadifyM ArgMonTerm -assertIsFinite (MTyNum n) = +assertIsFinite :: HasSpecMEvType => NumTpExpr -> MonadifyM ArgMonTerm +assertIsFinite e = + let n = numExprVal e in argifyMonTerm (CompMonTerm - (mkMonType0 (applyOpenTerm - (globalOpenTerm "CryptolM.isFinite") n)) + (MTyIndesc (applyOpenTerm + (globalOpenTerm "CryptolM.isFinite") n)) (applyGlobalOpenTerm "CryptolM.assertFiniteS" - [specMEvType ?specMParams, specMStack ?specMParams, n])) -assertIsFinite _ = - fail ("assertIsFinite applied to non-Num argument") + [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 tp = - usingSpecMParams $ - do ctx <- monStCtx <$> ask - return $ monadifyType (ctxToTypeCtx ctx) tp +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 => Maybe MonType -> Term -> MonadifyM ArgMonTerm @@ -1012,13 +1098,13 @@ monadifyArg _ t = undefined -} monadifyArg mtp t@(STApp { stAppIndex = ix }) = - memoArgMonTerm ix $ usingSpecMParams $ monadifyTerm' mtp t + memoArgMonTerm ix $ usingEvType $ monadifyTerm' mtp t monadifyArg mtp t = - usingSpecMParams (monadifyTerm' mtp t) >>= argifyMonTerm + usingEvType (monadifyTerm' mtp t) >>= argifyMonTerm -- | Monadify a term to argument type and convert back to a term monadifyArgTerm :: HasCallStack => Maybe MonType -> Term -> MonadifyM OpenTerm -monadifyArgTerm mtp t = usingSpecMParams (toArgTerm <$> monadifyArg mtp t) +monadifyArgTerm mtp t = usingEvType (toArgTerm <$> monadifyArg mtp t) -- | Monadify a term monadifyTerm :: Maybe MonType -> Term -> MonadifyM MonTerm @@ -1028,21 +1114,20 @@ monadifyTerm _ t = undefined -} monadifyTerm mtp t@(STApp { stAppIndex = ix }) = - memoMonTerm ix $ usingSpecMParams $ monadifyTerm' mtp t + memoMonTerm ix $ usingEvType $ monadifyTerm' mtp t monadifyTerm mtp t = - usingSpecMParams $ 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 => HasSpecMParams => +monadifyTerm' :: HasCallStack => HasSpecMEvType => Maybe MonType -> Term -> MonadifyM MonTerm monadifyTerm' (Just mtp) t@(asLambda -> Just _) = - ask >>= \(MonadifyROState { monStEnv = env, - monStCtx = ctx, monStStack = stack }) -> - return $ monadifyLambdas env ctx stack mtp t + ask >>= \(MonadifyROState { monStEnv = env, monStCtx = ctx }) -> + return $ monadifyLambdas env ctx mtp t {- monadifyTerm' (Just mtp@(MTyForall _ _ _)) t = ask >>= \ro_st -> @@ -1058,12 +1143,14 @@ monadifyTerm' (Just mtp@(MTyPair mtp1 mtp2)) (asPairValue -> 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 @@ -1076,8 +1163,7 @@ monadifyTerm' (Just mtp@(MTySeq n mtp_elem)) (asFTermF -> do trms' <- traverse (monadifyArgTerm $ Just mtp_elem) trms return $ fromArgTerm mtp $ applyOpenTermMulti (globalOpenTerm "CryptolM.seqToMseq") - [specMEvType ?specMParams, specMStack ?specMParams, - n, toArgType mtp_elem, + [evTypeTerm ?specMEvType, numExprVal n, toArgType mtp_elem, flatOpenTerm $ ArrayValue (toArgType mtp_elem) trms'] monadifyTerm' _ (asPairSelector -> Just (trm, True)) = do mtrm <- monadifyArg Nothing trm @@ -1086,6 +1172,7 @@ monadifyTerm' _ (asPairSelector -> Just (trm, True)) = _ -> 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 @@ -1093,14 +1180,14 @@ monadifyTerm' _ (asRecordSelector -> Just (trm, fld)) = _ -> 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 | (_,_,Right mtrm) <- ctx !! ix -> return mtrm + ctx | (_,_,TrmArg mtrm) <- ctx !! ix -> return $ ArgMonTerm mtrm _ -> fail "Monadification failed: type variable used in term position!" monadifyTerm' _ (asTupleValue -> Just []) = - return $ ArgMonTerm $ - fromSemiPureTerm (mkMonType0 unitTypeOpenTerm) unitOpenTerm + return $ ArgMonTerm $ fromSemiPureTerm MTyUnit unitOpenTerm monadifyTerm' _ (asCtor -> Just (pn, args)) = monadifyApply (ArgMonTerm $ mkCtorArgMonTerm pn) args monadifyTerm' _ (asApplyAll -> (asTypedGlobalDef -> Just glob, args)) = @@ -1130,47 +1217,54 @@ monadifyApply :: HasCallStack => MonTerm -> [Term] -> MonadifyM MonTerm monadifyApply f (t : ts) | MTyArrow tp_in _ <- getMonType f = do mtrm <- monadifyArg (Just tp_in) t - monadifyApply (applyMonTerm f (Right mtrm)) ts + monadifyApply (applyMonTerm f (TrmArg mtrm)) ts monadifyApply f (t : ts) | MTyForall _ _ _ <- getMonType f = - do mtp <- monadifyTypeM t - monadifyApply (applyMonTerm f (Left mtp)) ts + do arg <- tpExprToArg <$> monadifyTpExprM t + monadifyApply (applyMonTerm f arg) ts monadifyApply _ (_:_) = fail "monadifyApply: application at incorrect type" monadifyApply f [] = return f --- | FIXME: documentation; get our type down to a base type before going into --- the MonadifyM monad -monadifyLambdas :: HasCallStack => MonadifyEnv -> MonadifyCtx -> OpenTerm -> +-- | 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 => MonadifyEnv -> MonadifyCtx -> MonType -> Term -> MonTerm -monadifyLambdas env ctx stack (MTyForall _ k tp_f) (asLambda -> - Just (x, x_tp, body)) = +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,Left mtp) : ctx) stack (tp_f mtp) body -monadifyLambdas env ctx stack (MTyArrow tp_in tp_out) (asLambda -> - Just (x, x_tp, body)) = + 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,Right (ArgMonTerm arg)) : ctx) stack tp_out body -monadifyLambdas env ctx stack tp t = - monadifyEtaExpand env ctx stack tp tp t [] - --- | FIXME: documentation -monadifyEtaExpand :: HasCallStack => MonadifyEnv -> MonadifyCtx -> OpenTerm -> - MonType -> MonType -> Term -> - [Either MonType ArgMonTerm] -> MonTerm -monadifyEtaExpand env ctx stack top_mtp (MTyForall x k tp_f) t args = + 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 => 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 stack top_mtp (tp_f mtp) t (args ++ [Left mtp]) -monadifyEtaExpand env ctx stack top_mtp (MTyArrow tp_in tp_out) t args = + 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 stack top_mtp tp_out t (args ++ [Right arg]) -monadifyEtaExpand env ctx stack top_mtp mtp t args = - let ?specMParams = (monEnvParams env) { specMStack = stack } in - applyMonTermMulti - (runMonadifyM env ctx stack (toArgType mtp) (monadifyTerm (Just top_mtp) t)) - args + 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 ---------------------------------------------------------------------- @@ -1181,14 +1275,13 @@ monadifyEtaExpand env ctx stack top_mtp mtp t args = -- compared and dispatches to the proper comparison function unsafeAssertMacro :: MonMacro unsafeAssertMacro = MonMacro 1 $ \_ ts -> - usingSpecMParams $ + usingEvType $ let numFunType = - MTyForall "n" (MKType $ mkSort 0) $ \n -> - MTyForall "m" (MKType $ mkSort 0) $ \m -> - MTyBase (MKType $ mkSort 0) $ + MTyForall "n" MKNumRepr $ \n -> MTyForall "m" MKNumRepr $ \m -> + MTyIndesc $ dataTypeOpenTerm "Prelude.Eq" [dataTypeOpenTerm "Cryptol.Num" [], - toArgType n, toArgType m] in + numExprVal n, numExprVal m] in case ts of [(asDataType -> Just (num, []))] | primName num == "Cryptol.Num" -> @@ -1200,15 +1293,15 @@ unsafeAssertMacro = MonMacro 1 $ \_ ts -> -- | The macro for if-then-else, which contains any binds in a branch to that -- branch iteMacro :: MonMacro -iteMacro = MonMacro 4 $ \_ args -> usingSpecMParams $ +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 boolMonType) cond + atrm_cond <- monadifyArg (Just MTyBool) cond mtp <- monadifyTypeM tp - mtrm1 <- resetMonadifyM (toArgType mtp) $ monadifyTerm (Just mtp) branch1 - mtrm2 <- resetMonadifyM (toArgType mtp) $ monadifyTerm (Just mtp) branch2 + 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 $ @@ -1224,7 +1317,7 @@ iteMacro = MonMacro 4 $ \_ args -> usingSpecMParams $ -- application @either a b c@ to @either a b (CompM c)@ eitherMacro :: MonMacro eitherMacro = MonMacro 3 $ \_ args -> - usingSpecMParams $ + usingEvType $ do let (tp_a, tp_b, tp_c) = case args of [t1, t2, t3] -> (t1, t2, t3) @@ -1235,17 +1328,15 @@ eitherMacro = MonMacro 3 $ \_ args -> let eith_app = applyGlobalOpenTerm "Prelude.either" [toArgType mtp_a, toArgType mtp_b, toCompType mtp_c] - let tp_eith = dataTypeOpenTerm "Prelude.Either" [toArgType mtp_a, - toArgType mtp_b] return $ fromCompTerm (MTyArrow (MTyArrow mtp_a mtp_c) (MTyArrow (MTyArrow mtp_b mtp_c) - (MTyArrow (mkMonType0 tp_eith) mtp_c))) eith_app + (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 -> - usingSpecMParams $ + usingEvType $ do let (tp_a, tp_b, tp_c) = case args of [t1, t2, t3] -> (t1, t2, t3) @@ -1256,24 +1347,23 @@ uncurryMacro = MonMacro 3 $ \_ args -> let unc_app = applyGlobalOpenTerm "Prelude.uncurry" [toArgType mtp_a, toArgType mtp_b, toCompType mtp_c] - let tp_tup = pairTypeOpenTerm (toArgType mtp_a) (toArgType mtp_b) return $ fromCompTerm (MTyArrow (MTyArrow mtp_a (MTyArrow mtp_b mtp_c)) - (MTyArrow (mkMonType0 tp_tup) mtp_c)) unc_app + (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 :: MonMacro -invariantHintMacro = MonMacro 3 $ \_ args -> usingSpecMParams $ +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 boolMonType) cond + atrm_cond <- monadifyArg (Just MTyBool) cond mtp <- monadifyTypeM tp - mtrm <- resetMonadifyM (toArgType mtp) $ monadifyTerm (Just mtp) m + mtrm <- resetMonadifyM mtp $ monadifyTerm (Just mtp) m return $ fromCompTerm mtp $ - applyOpenTermMulti (globalOpenTerm "Prelude.invariantHint") + applyOpenTermMulti (globalOpenTerm "SpecM.invariantHint") [toCompType mtp, toArgTerm atrm_cond, toCompTerm mtrm] -- | The macro for @asserting@ or @assuming@, which converts @asserting@ to @@ -1282,56 +1372,59 @@ invariantHintMacro = MonMacro 3 $ \_ args -> usingSpecMParams $ -- body to the body assertingOrAssumingMacro :: Bool -> MonMacro assertingOrAssumingMacro doAsserting = MonMacro 3 $ \_ args -> - usingSpecMParams $ + 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 boolMonType) cond + atrm_cond <- monadifyArg (Just MTyBool) cond mtp <- monadifyTypeM tp - mtrm <- resetMonadifyM (toArgType mtp) $ monadifyTerm (Just mtp) m - params <- askSpecMParams - let ident = if doAsserting then "Prelude.assertingS" - else "Prelude.assumingS" + 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) - [specMEvType params, specMStack params, - toArgType mtp, toArgTerm atrm_cond, toCompTerm mtrm] + [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 'SpecMParams' should be passed as the first two arguments to @to@. +-- 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 -> usingSpecMParams $ + MonMacro (i+j) $ \glob args -> usingEvType $ do if globalDefName glob == ModuleIdentifier from && length args == i+j then return () else error ("Monadification macro for " ++ show from ++ " applied incorrectly") - let (init_args, fin_args) = splitAt i args + let (init_args_tms, fin_args_tms) = splitAt i args -- Monadify the first @i@ args - init_args_mtps <- mapM monadifyTypeM init_args - let init_args_m = map toArgType init_args_mtps + 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_mtps <- mapM monadifyTypeM fin_args - let fin_args_m = map toArgType fin_args_mtps - fin_pfs <- mapM assertIsFinite fin_args_mtps + 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_tp_app = foldl applyMonType glob_tp (map Left (init_args_mtps ++ fin_args_mtps)) + 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 (paramsToTerms ?specMParams ++) else id) - init_args_m ++ concatMap (\(n,pf) -> [n, toArgTerm pf]) (zip fin_args_m fin_pfs)) + ((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 $ (if params_p then id else liftCompStack) - $ fromArgTerm 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 -- @@ -1339,14 +1432,13 @@ finMacro isSemiPure i j from to params_p = fixMacro :: MonMacro fixMacro = MonMacro 2 $ \_ args -> case args of [tp@(asPi -> Just _), f] -> - do orig_params <- askSpecMParams + do ev <- askEvType mtp <- monadifyTypeM tp - pushingSpecMParamsM [mtp] $ usingSpecMParams $ do + usingEvType $ do amtrm_f <- monadifyArg (Just $ MTyArrow mtp mtp) f return $ fromCompTerm mtp $ - applyOpenTermMulti (globalOpenTerm "Prelude.multiArgFixS") - [specMEvType orig_params, specMStack orig_params, - lrtFromMonType mtp, toCompTerm amtrm_f] + 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!" @@ -1394,7 +1486,7 @@ mmCustom from_id macro = (ModuleIdentifier from_id, macro) -- | The default monadification environment defaultMonEnv :: MonadifyEnv defaultMonEnv = MonadifyEnv { monEnvMonTable = defaultMonTable, - monEnvEvType = globalOpenTerm "Prelude.VoidEv" } + monEnvEvType = defaultSpecMEventType } -- | The default primitive monadification table defaultMonTable :: Map NameInfo MonMacro @@ -1407,9 +1499,9 @@ defaultMonTable = , mmCustom "Prelude.fix" fixMacro , mmCustom "Prelude.either" eitherMacro , mmCustom "Prelude.uncurry" uncurryMacro - , mmCustom "Prelude.invariantHint" invariantHintMacro - , mmCustom "Prelude.asserting" (assertingOrAssumingMacro True) - , mmCustom "Prelude.assuming" (assertingOrAssumingMacro False) + , mmCustom "SpecM.invariantHint" invariantHintMacro + , mmCustom "SpecM.asserting" (assertingOrAssumingMacro True) + , mmCustom "SpecM.assuming" (assertingOrAssumingMacro False) -- Top-level sequence functions , mmArg "Cryptol.seqMap" "CryptolM.seqMapM" True @@ -1435,7 +1527,8 @@ defaultMonTable = , mmSemiPureFin 0 1 "Cryptol.PSignedCmpSeqBool" "CryptolM.PSignedCmpMSeqBool" True -- PZero constraints - , mmSemiPureFin 0 1 "Cryptol.PZeroSeq" "CryptolM.PZeroMSeq" True + , mmSemiPure "Cryptol.PZeroSeq" "CryptolM.PZeroMSeq" True + , mmSemiPureFin 0 1 "Cryptol.PZeroSeqBool" "CryptolM.PZeroMSeqBool" True -- PLogic constraints , mmSemiPure "Cryptol.PLogicSeq" "CryptolM.PLogicMSeq" True @@ -1505,7 +1598,7 @@ ensureCryptolMLoaded :: SharedContext -> IO () ensureCryptolMLoaded sc = scModuleIsLoaded sc (mkModuleName ["CryptolM"]) >>= \is_loaded -> if is_loaded then return () else - scLoadCryptolMModule sc + 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 @@ -1513,24 +1606,25 @@ ensureCryptolMLoaded sc = 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 and stack - (piOpenTerm "E" (dataTypeOpenTerm "Prelude.EvType" []) $ \e -> - piOpenTerm "stack" (globalOpenTerm "Prelude.FunStack") $ \st -> - let ?specMParams = SpecMParams { specMEvType = e, specMStack = st } in - -- NOTE: even though E and stack are free variables here, they are not - -- free in tp, which is a closed term, so we do not list them in the - -- MonadifyTypeCtx argument of monadifyTypeArgType + -- 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 ?specMParams = monEnvParams env in monadifyTypeArgType [] tp + 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 = - runCompleteMonadifyM sc env tp $ usingSpecMParams $ + (ensureCryptolMLoaded sc >>) $ + runCompleteMonadifyM sc env tp $ usingEvType $ monadifyTerm (Just $ monadifyType [] tp) trm -- | Convert a name of a definition to the name of its monadified version @@ -1547,8 +1641,8 @@ monadifyName (ImportedName uri aliases) = 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 ?specMParams = monEnvParams env in + -- 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 @@ -1570,6 +1664,7 @@ 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 diff --git a/cryptol-saw-core/src/Verifier/SAW/Cryptol/PreludeM.hs b/cryptol-saw-core/src/Verifier/SAW/Cryptol/PreludeM.hs index e984c25310..27b581f7fc 100644 --- a/cryptol-saw-core/src/Verifier/SAW/Cryptol/PreludeM.hs +++ b/cryptol-saw-core/src/Verifier/SAW/Cryptol/PreludeM.hs @@ -18,5 +18,8 @@ module Verifier.SAW.Cryptol.PreludeM import Verifier.SAW.Prelude import Verifier.SAW.ParserUtils +$(defineModuleFromFileWithFns + "specMModule" "scLoadSpecMModule" "saw/SpecM.sawcore") + $(defineModuleFromFileWithFns "cryptolMModule" "scLoadCryptolMModule" "saw/CryptolM.sawcore") diff --git a/examples/mr_solver/monadify.saw b/examples/mr_solver/monadify.saw index 0ef484fd5f..20a382d7d1 100644 --- a/examples/mr_solver/monadify.saw +++ b/examples/mr_solver/monadify.saw @@ -2,11 +2,11 @@ enable_experimental; import "SpecPrims.cry" as SpecPrims; import "monadify.cry"; -load_sawcore_from_file "../../cryptol-saw-core/saw/CryptolM.sawcore"; +// load_sawcore_from_file "../../cryptol-saw-core/saw/CryptolM.sawcore"; // Set the monadification of the Cryptol exists and forall functions -set_monadification "SpecPrims::exists" "Prelude.existsS" true; -set_monadification "SpecPrims::forall" "Prelude.forallS" true; +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); @@ -23,48 +23,48 @@ let run_test name cry_term mon_term_expected = my_abs <- unfold_term ["my_abs"] {{ my_abs }}; my_abs_M <- parse_core_mod "CryptolM" "\ -\ \\(x : (mseq VoidEv emptyFunStack (TCNum 64) Bool)) -> \ -\ bindS VoidEv emptyFunStack (isFinite (TCNum 64)) \ -\ (mseq VoidEv emptyFunStack (TCNum 64) Bool) \ -\ (assertFiniteS VoidEv emptyFunStack (TCNum 64)) \ +\ \\(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 emptyFunStack (isFinite (TCNum 64)) \ -\ (mseq VoidEv emptyFunStack (TCNum 64) Bool) \ -\ (assertFiniteS VoidEv emptyFunStack (TCNum 64)) \ +\ bindS VoidEv (isFinite (TCNum 64)) \ +\ (mseq VoidEv (TCNum 64) Bool) \ +\ (assertFiniteS VoidEv (TCNum 64)) \ \ (\\(x'' : (isFinite (TCNum 64))) -> \ -\ ite (SpecM VoidEv emptyFunStack (mseq VoidEv emptyFunStack (TCNum 64) Bool)) \ -\ (ecLt (mseq VoidEv emptyFunStack (TCNum 64) Bool) (PCmpMSeqBool VoidEv emptyFunStack (TCNum 64) x') x \ -\ (ecNumber (TCNum 0) (mseq VoidEv emptyFunStack (TCNum 64) Bool) (PLiteralSeqBoolM VoidEv emptyFunStack (TCNum 64) x''))) \ -\ (bindS VoidEv emptyFunStack (isFinite (TCNum 64)) \ -\ (mseq VoidEv emptyFunStack (TCNum 64) Bool) \ -\ (assertFiniteS VoidEv emptyFunStack (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 emptyFunStack \ -\ (mseq VoidEv emptyFunStack (TCNum 64) Bool) \ -\ (ecNeg (mseq VoidEv emptyFunStack (TCNum 64) Bool) (PRingMSeqBool VoidEv emptyFunStack (TCNum 64) x''') x))) \ -\ (retS VoidEv emptyFunStack (mseq VoidEv emptyFunStack (TCNum 64) Bool) x)))"; +\ 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; err_if_lt0 <- unfold_term ["err_if_lt0"] {{ err_if_lt0 }}; err_if_lt0_M <- parse_core_mod "CryptolM" "\ -\ \\(x : (mseq VoidEv emptyFunStack (TCNum 64) Bool)) -> \ -\ bindS VoidEv emptyFunStack (isFinite (TCNum 64)) (mseq VoidEv emptyFunStack (TCNum 64) Bool) (assertFiniteS VoidEv emptyFunStack (TCNum 64)) \ +\ \\(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 emptyFunStack (isFinite (TCNum 64)) (mseq VoidEv emptyFunStack (TCNum 64) Bool) (assertFiniteS VoidEv emptyFunStack (TCNum 64)) \ +\ bindS VoidEv (isFinite (TCNum 64)) (mseq VoidEv (TCNum 64) Bool) (assertFiniteS VoidEv (TCNum 64)) \ \ (\\(x'' : (isFinite (TCNum 64))) -> \ -\ ite (SpecM VoidEv emptyFunStack (mseq VoidEv emptyFunStack (TCNum 64) Bool)) \ -\ (ecLt (mseq VoidEv emptyFunStack (TCNum 64) Bool) (PCmpMSeqBool VoidEv emptyFunStack (TCNum 64) x') x \ -\ (ecNumber (TCNum 0) (mseq VoidEv emptyFunStack (TCNum 64) Bool) (PLiteralSeqBoolM VoidEv emptyFunStack (TCNum 64) x''))) \ -\ (bindS VoidEv emptyFunStack (isFinite (TCNum 8)) (mseq VoidEv emptyFunStack (TCNum 64) Bool) (assertFiniteS VoidEv emptyFunStack (TCNum 8)) \ +\ 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 emptyFunStack (mseq VoidEv emptyFunStack (TCNum 64) Bool) (TCNum 5) \ -\ (seqToMseq VoidEv emptyFunStack (TCNum 5) (mseq VoidEv emptyFunStack (TCNum 8) Bool) \ -\ [ ecNumber (TCNum 120) (mseq VoidEv emptyFunStack (TCNum 8) Bool) (PLiteralSeqBoolM VoidEv emptyFunStack (TCNum 8) x''') \ -\ , (ecNumber (TCNum 32) (mseq VoidEv emptyFunStack (TCNum 8) Bool) (PLiteralSeqBoolM VoidEv emptyFunStack (TCNum 8) x''')) \ -\ , ecNumber (TCNum 60) (mseq VoidEv emptyFunStack (TCNum 8) Bool) (PLiteralSeqBoolM VoidEv emptyFunStack (TCNum 8) x''') \ -\ , (ecNumber (TCNum 32) (mseq VoidEv emptyFunStack (TCNum 8) Bool) (PLiteralSeqBoolM VoidEv emptyFunStack (TCNum 8) x''')) \ -\ , ecNumber (TCNum 48) (mseq VoidEv emptyFunStack (TCNum 8) Bool) (PLiteralSeqBoolM VoidEv emptyFunStack (TCNum 8) x''') ]))) \ -\ (retS VoidEv emptyFunStack (mseq VoidEv emptyFunStack (TCNum 64) Bool) x)))"; +\ 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; /* @@ -79,53 +79,48 @@ print_term sha1M; fib <- unfold_term ["fib"] {{ fib }}; fibM <- parse_core_mod "CryptolM" "\ -\ \\(_x : (mseq VoidEv emptyFunStack (TCNum 64) Bool)) -> \ -\ multiArgFixS VoidEv emptyFunStack \ -\ (LRT_Fun (mseq VoidEv emptyFunStack (TCNum 64) Bool) \ -\ (\\(_ : (mseq VoidEv emptyFunStack (TCNum 64) Bool)) -> \ -\ LRT_Ret (mseq VoidEv emptyFunStack (TCNum 64) Bool))) \ -\ ((\\ (stk:FunStack) -> \ -\ (\\(fib : ((mseq VoidEv stk (TCNum 64) Bool) -> \ -\ (SpecM VoidEv stk (mseq VoidEv stk (TCNum 64) Bool)))) -> \ -\ \\(x : (mseq VoidEv stk (TCNum 64) Bool)) -> \ -\ bindS VoidEv stk (isFinite (TCNum 64)) (mseq VoidEv stk (TCNum 64) Bool) (assertFiniteS VoidEv stk (TCNum 64)) \ -\ (\\(x' : (isFinite (TCNum 64))) -> \ -\ bindS VoidEv stk (isFinite (TCNum 64)) (mseq VoidEv stk (TCNum 64) Bool) (assertFiniteS VoidEv stk (TCNum 64)) \ -\ (\\(x'' : (isFinite (TCNum 64))) -> \ -\ ite (SpecM VoidEv stk (mseq VoidEv stk (TCNum 64) Bool)) \ -\ (ecEq (mseq VoidEv stk (TCNum 64) Bool) (PEqMSeqBool VoidEv stk (TCNum 64) x') x \ -\ (ecNumber (TCNum 0) (mseq VoidEv stk (TCNum 64) Bool) (PLiteralSeqBoolM VoidEv stk (TCNum 64) x''))) \ -\ (bindS VoidEv stk (isFinite (TCNum 64)) (mseq VoidEv stk (TCNum 64) Bool) (assertFiniteS VoidEv stk (TCNum 64)) \ -\ (\\(x''' : (isFinite (TCNum 64))) -> \ -\ retS VoidEv stk (mseq VoidEv stk (TCNum 64) Bool) \ -\ (ecNumber (TCNum 1) (mseq VoidEv stk (TCNum 64) Bool) \ -\ (PLiteralSeqBoolM VoidEv stk (TCNum 64) x''')))) \ -\ (bindS VoidEv stk (isFinite (TCNum 64)) (mseq VoidEv stk (TCNum 64) Bool) (assertFiniteS VoidEv stk (TCNum 64)) \ -\ (\\(x''' : (isFinite (TCNum 64))) -> \ -\ bindS VoidEv stk (isFinite (TCNum 64)) (mseq VoidEv stk (TCNum 64) Bool) (assertFiniteS VoidEv stk (TCNum 64)) \ -\ (\\(x'''' : (isFinite (TCNum 64))) -> \ -\ bindS VoidEv stk (mseq VoidEv stk (TCNum 64) Bool) (mseq VoidEv stk (TCNum 64) Bool) \ +\ \\(_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 (mseq VoidEv stk (TCNum 64) Bool) (PRingMSeqBool VoidEv stk (TCNum 64) x''') x \ -\ (ecNumber (TCNum 1) (mseq VoidEv stk (TCNum 64) Bool) \ -\ (PLiteralSeqBoolM VoidEv stk (TCNum 64) x'''')))) \ -\ (\\(x''''' : (mseq VoidEv stk (TCNum 64) Bool)) -> \ -\ retS VoidEv stk (mseq VoidEv stk (TCNum 64) Bool) \ -\ (ecMul (mseq VoidEv stk (TCNum 64) Bool) (PRingMSeqBool VoidEv stk (TCNum 64) x''') x \ -\ x'''''))))))))) \ -\ (pushFunStack (singletonFrame (LRT_Fun (mseq VoidEv emptyFunStack (TCNum 64) Bool) \ -\ (\\ (_:Vec 64 Bool) -> \ -\ LRT_Ret (mseq VoidEv emptyFunStack (TCNum 64) Bool)))) \ -\ emptyFunStack)) \ -\ _x"; +\ (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; noErrors <- unfold_term ["noErrors"] {{ SpecPrims::noErrors }}; -noErrorsM <- parse_core_mod "CryptolM" "\\(a : sort 0) -> existsS VoidEv emptyFunStack a"; +noErrorsM <- parse_core_mod "CryptolM" "\\(a : sort 0) -> existsS VoidEv a"; run_test "noErrors" noErrors noErrorsM; fibSpecNoErrors <- unfold_term ["fibSpecNoErrors"] {{ fibSpecNoErrors }}; fibSpecNoErrorsM <- parse_core_mod "CryptolM" "\ -\ \\(__p1 : (mseq VoidEv emptyFunStack (TCNum 64) Bool)) -> \ -\ existsS VoidEv emptyFunStack (mseq VoidEv emptyFunStack (TCNum 64) Bool)"; +\ \\(__p1 : (mseq VoidEv (TCNum 64) Bool)) -> \ +\ existsS VoidEv (mseq VoidEv (TCNum 64) Bool)"; run_test "fibSpecNoErrors" fibSpecNoErrors fibSpecNoErrorsM; diff --git a/examples/mr_solver/mr_solver_test_funs.sawcore b/examples/mr_solver/mr_solver_test_funs.sawcore index ddce1f02bc..718e6c9d91 100644 --- a/examples/mr_solver/mr_solver_test_funs.sawcore +++ b/examples/mr_solver/mr_solver_test_funs.sawcore @@ -1,22 +1,22 @@ module test_funs where -import Prelude; +import SpecM; -test_fun0 : Vec 64 Bool -> SpecM VoidEv emptyFunStack (Vec 64 Bool); -test_fun0 _ = retS VoidEv emptyFunStack (Vec 64 Bool) (bvNat 64 0); +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 emptyFunStack (Vec 64 Bool); -test_fun1 _ = retS VoidEv emptyFunStack (Vec 64 Bool) (bvNat 64 1); +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 emptyFunStack (Vec 64 Bool); -test_fun2 x = retS VoidEv emptyFunStack (Vec 64 Bool) x; +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 emptyFunStack (Vec 64 Bool); +test_fun3 : Vec 64 Bool -> SpecM VoidEv (Vec 64 Bool); test_fun3 x = - ite (SpecM VoidEv emptyFunStack (Vec 64 Bool)) (bvEq 64 x (bvNat 64 0)) - (retS VoidEv emptyFunStack (Vec 64 Bool) x) - (retS VoidEv emptyFunStack (Vec 64 Bool) (bvNat 64 0)); + 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 @@ -64,4 +64,4 @@ test_fun6 x = (\ (f1:(Vec 64 Bool -> CompM (Vec 64 Bool))) (f2:(Vec 64 Bool -> CompM (Vec 64 Bool))) -> f1 x); --} \ No newline at end of file +-} diff --git a/examples/mr_solver/mr_solver_unit_tests.saw b/examples/mr_solver/mr_solver_unit_tests.saw index d04512704f..ac0f9482d4 100644 --- a/examples/mr_solver/mr_solver_unit_tests.saw +++ b/examples/mr_solver/mr_solver_unit_tests.saw @@ -17,21 +17,21 @@ let run_test name test expected = do { print "Test failed\n"; exit 1; }; }; // The constant 0 function const0 x = 0 -let ret0_core = "retS VoidEv emptyFunStack (Vec 64 Bool) (bvNat 64 0)"; +let ret0_core = "retS VoidEv (Vec 64 Bool) (bvNat 64 0)"; let const0_core = str_concat "\\ (_:Vec 64 Bool) -> " ret0_core; -const0 <- parse_core const0_core; +const0 <- parse_core_mod "SpecM" const0_core; // The constant 1 function const1 x = 1 -let const1_core = "\\ (_:Vec 64 Bool) -> retS VoidEv emptyFunStack (Vec 64 Bool) (bvNat 64 1)"; -const1 <- parse_core const1_core; +let const1_core = "\\ (_:Vec 64 Bool) -> retS VoidEv (Vec 64 Bool) (bvNat 64 1)"; +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 emptyFunStack (Vec 64 Bool) ", + 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 const0_refines) +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] |}; @@ -45,7 +45,7 @@ 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 emptyFunStack (Vec 64 Bool) ", + 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; @@ -54,9 +54,9 @@ run_test "refines [] const0 test_fun0" (is_convertible (parse_core_mod "test_fun 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 emptyFunStack (Vec 64 Bool) ", + 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 const0_const1_refines) +run_test "refines [] const0 const1" (is_convertible (parse_core_mod "SpecM" const0_const1_refines) (refines [] const0 const1)) true; // The function test_fun1 = const1 @@ -65,32 +65,32 @@ 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 emptyFunStack (Vec 64 Bool) ", + 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 emptyFunStack (Vec 64 Bool) ", + 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 emptyFunStack (Vec 64 Bool)) \ + \ ite (SpecM VoidEv (Vec 64 Bool)) \ \ (bvEq 64 x (bvNat 64 0)) \ - \ (retS VoidEv emptyFunStack (Vec 64 Bool) x) \ - \ (retS VoidEv emptyFunStack (Vec 64 Bool) (bvNat 64 0))"; -ifxEq0 <- parse_core ifxEq0_core; + \ (retS VoidEv (Vec 64 Bool) x) \ + \ (retS VoidEv (Vec 64 Bool) (bvNat 64 0))"; +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 emptyFunStack (Vec 64 Bool) ", + 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 ifxEq0_const0_refines) +run_test "refines [] ifxEq0 const0" (is_convertible (parse_core_mod "SpecM" ifxEq0_const0_refines) (refines [] ifxEq0 const0)) true; @@ -98,63 +98,58 @@ run_test "refines [] ifxEq0 const0" (is_convertible (parse_core ifxEq0_const0_re 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 emptyFunStack (Vec 64 Bool) ", + 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 ifxEq0_const1_refines) +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 emptyFunStack (Vec 64 Bool)"; -noErrors1 <- parse_core noErrors1_core; + "\\ (_:Vec 64 Bool) -> existsS VoidEv (Vec 64 Bool)"; +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 emptyFunStack (Vec 64 Bool) ", + 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 noErrors1_refines) +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 emptyFunStack (Vec 64 Bool) ", + 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 const1_noErrors1_refines) +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 emptyFunStack (Vec 64 Bool) (\\ (_:Vec 64 Bool) -> Vec 64 Bool) \ - \ (\\ (f: fixSFun VoidEv emptyFunStack \ - \ (Vec 64 Bool) (\\ (_:Vec 64 Bool) -> Vec 64 Bool)) \ - \ (x:Vec 64 Bool) -> \ - \ orS VoidEv (fixSStack (Vec 64 Bool) \ - \ (\\ (_:Vec 64 Bool) -> Vec 64 Bool)) \ + "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 (fixSStack (Vec 64 Bool) \ - \ (\\ (_:Vec 64 Bool) -> Vec 64 Bool)) \ - \ (Vec 64 Bool)) \ + \ (existsS VoidEv (Vec 64 Bool)) \ \ (f x))"; -noErrorsRec1 <- parse_core noErrorsRec1_core; +noErrorsRec1 <- parse_core_mod "SpecM" noErrorsRec1_core; // loop x = loop x let loop1_core = - "fixS VoidEv emptyFunStack (Vec 64 Bool) (\\ (_:Vec 64 Bool) -> Vec 64 Bool) \ - \ (\\ (f: fixSFun VoidEv emptyFunStack \ - \ (Vec 64 Bool) (\\ (_:Vec 64 Bool) -> Vec 64 Bool)) \ + "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)"; -loop1 <- parse_core loop1_core; +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 emptyFunStack (Vec 64 Bool) ", + 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 loop1_noErrorsRec1_refines) +run_test "refines [] loop1 noErrorsRec1" (is_convertible (parse_core_mod "SpecM" loop1_noErrorsRec1_refines) (refines [] loop1 noErrorsRec1)) true; diff --git a/heapster-saw/examples/.gitignore b/heapster-saw/examples/.gitignore index 072ccfad8e..ff04e5b9e6 100644 --- a/heapster-saw/examples/.gitignore +++ b/heapster-saw/examples/.gitignore @@ -1,3 +1,4 @@ Makefile.coq* .Makefile.coq* *_gen.v +dilithium diff --git a/heapster-saw/examples/Dilithium2.cry b/heapster-saw/examples/Dilithium2.cry new file mode 100644 index 0000000000..6d9d52a777 --- /dev/null +++ b/heapster-saw/examples/Dilithium2.cry @@ -0,0 +1,333 @@ + +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-saw/examples/Dilithium2.saw b/heapster-saw/examples/Dilithium2.saw new file mode 100644 index 0000000000..89a45c9d20 --- /dev/null +++ b/heapster-saw/examples/Dilithium2.saw @@ -0,0 +1,440 @@ +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-saw/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-saw/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 // +////////////////////////////////////////////// + +randombytes <- parse_core_mod "Dilithium2" "randombytes"; +shake256_init <- parse_core_mod "Dilithium2" "shake256_init"; +shake256_absorb <- parse_core_mod "Dilithium2" "shake256_absorb"; +shake256_finalize <- parse_core_mod "Dilithium2" "shake256_finalize"; +shake256_squeeze <- parse_core_mod "Dilithium2" "shake256_squeeze"; +shake256 <- parse_core_mod "Dilithium2" "shake256"; +poly_challenge <- parse_core_mod "Dilithium2" "poly_challenge"; +poly_ntt <- parse_core_mod "Dilithium2" "poly_ntt"; +polyvec_matrix_expand <- parse_core_mod "Dilithium2" "polyvec_matrix_expand"; +polyvec_matrix_pointwise_montgomery <- parse_core_mod "Dilithium2" "polyvec_matrix_pointwise_montgomery"; +polyvecl_uniform_eta <- parse_core_mod "Dilithium2" "polyvecl_uniform_eta"; +polyvecl_uniform_gamma1 <- parse_core_mod "Dilithium2" "polyvecl_uniform_gamma1"; +polyvecl_reduce <- parse_core_mod "Dilithium2" "polyvecl_reduce"; +polyvecl_add <- parse_core_mod "Dilithium2" "polyvecl_add"; +polyvecl_ntt <- parse_core_mod "Dilithium2" "polyvecl_ntt"; +polyvecl_invntt_tomont <- parse_core_mod "Dilithium2" "polyvecl_invntt_tomont"; +polyvecl_pointwise_poly_montgomery <- parse_core_mod "Dilithium2" "polyvecl_pointwise_poly_montgomery"; +polyvecl_chknorm <- parse_core_mod "Dilithium2" "polyvecl_chknorm"; +polyveck_uniform_eta <- parse_core_mod "Dilithium2" "polyveck_uniform_eta"; +polyveck_reduce <- parse_core_mod "Dilithium2" "polyveck_reduce"; +polyveck_caddq <- parse_core_mod "Dilithium2" "polyveck_caddq"; +polyveck_add <- parse_core_mod "Dilithium2" "polyveck_add"; +polyveck_sub <- parse_core_mod "Dilithium2" "polyveck_sub"; +polyveck_shiftl <- parse_core_mod "Dilithium2" "polyveck_shiftl"; +polyveck_ntt <- parse_core_mod "Dilithium2" "polyveck_ntt"; +polyveck_invntt_tomont <- parse_core_mod "Dilithium2" "polyveck_invntt_tomont"; +polyveck_pointwise_poly_montgomery <- parse_core_mod "Dilithium2" "polyveck_pointwise_poly_montgomery"; +polyveck_chknorm <- parse_core_mod "Dilithium2" "polyveck_chknorm"; +polyveck_power2round <- parse_core_mod "Dilithium2" "polyveck_power2round"; +polyveck_decompose <- parse_core_mod "Dilithium2" "polyveck_decompose"; +polyveck_make_hint <- parse_core_mod "Dilithium2" "polyveck_make_hint"; +polyveck_use_hint <- parse_core_mod "Dilithium2" "polyveck_use_hint"; +polyveck_pack_w1 <- parse_core_mod "Dilithium2" "polyveck_pack_w1"; +pack_pk <- parse_core_mod "Dilithium2" "pack_pk"; +unpack_pk <- parse_core_mod "Dilithium2" "unpack_pk"; +pack_sk <- parse_core_mod "Dilithium2" "pack_sk"; +unpack_sk <- parse_core_mod "Dilithium2" "unpack_sk"; +pack_sig <- parse_core_mod "Dilithium2" "pack_sig"; +unpack_sig <- parse_core_mod "Dilithium2" "unpack_sig"; +crypto_sign_keypair <- parse_core_mod "Dilithium2" "crypto_sign_keypair"; +crypto_sign_signature <- parse_core_mod "Dilithium2" "crypto_sign_signature"; +crypto_sign <- parse_core_mod "Dilithium2" "crypto_sign"; +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-saw/examples/Makefile b/heapster-saw/examples/Makefile index 7f9b6e2ebf..83d2027534 100644 --- a/heapster-saw/examples/Makefile +++ b/heapster-saw/examples/Makefile @@ -35,16 +35,36 @@ ifeq ($(CI),) 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-saw/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 -MR_SOLVER_TESTS = exp_explosion_mr_solver linked_list_mr_solver arrays_mr_solver sha512_mr_solver +# 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) -mr-solver-tests: $(MR_SOLVER_TESTS) +.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-saw/examples/SpecPrims.cry b/heapster-saw/examples/SpecPrims.cry index f62cf9782a..5a64cf7754 100644 --- a/heapster-saw/examples/SpecPrims.cry +++ b/heapster-saw/examples/SpecPrims.cry @@ -14,14 +14,6 @@ forall = error "Cannot run forall" 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 @@ -30,7 +22,7 @@ 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 +assuming _ x = x // A hint to Mr Solver that a recursive function has the given loop invariant invariantHint : {a} Bit -> a -> a diff --git a/heapster-saw/examples/_CoqProject b/heapster-saw/examples/_CoqProject index 267f4afa42..d763d13bd2 100644 --- a/heapster-saw/examples/_CoqProject +++ b/heapster-saw/examples/_CoqProject @@ -4,7 +4,7 @@ # FIXME: Uncomment _proofs files when they're updated with the latest automation linked_list_gen.v -linked_list_proofs.v +#linked_list_proofs.v xor_swap_gen.v #xor_swap_proofs.v xor_swap_rust_gen.v @@ -17,8 +17,6 @@ loops_gen.v #loops_proofs.v iter_linked_list_gen.v #iter_linked_list_proofs.v -iso_recursive_gen.v -#iso_recursive_proofs.v memcpy_gen.v #memcpy_proofs.v rust_data_gen.v @@ -32,7 +30,7 @@ clearbufs_gen.v exp_explosion_gen.v #exp_explosion_proofs.v mbox_gen.v -mbox_proofs.v +#mbox_proofs.v global_var_gen.v #global_var_proofs.v sha512_gen.v diff --git a/heapster-saw/examples/arrays.bc b/heapster-saw/examples/arrays.bc index 3d64791297..c24694e418 100644 Binary files a/heapster-saw/examples/arrays.bc and b/heapster-saw/examples/arrays.bc differ diff --git a/heapster-saw/examples/arrays.c b/heapster-saw/examples/arrays.c index dc033fe85c..9ab31a74a5 100644 --- a/heapster-saw/examples/arrays.c +++ b/heapster-saw/examples/arrays.c @@ -134,3 +134,22 @@ uint64_t alloc_sum_array_test (void) { */ 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-saw/examples/arrays.saw b/heapster-saw/examples/arrays.saw index 4a9bb1d0cf..3c2d204627 100644 --- a/heapster-saw/examples/arrays.saw +++ b/heapster-saw/examples/arrays.saw @@ -64,4 +64,18 @@ heapster_typecheck_fun env "even_odd_sums_diff" 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-saw/examples/arrays.sawcore b/heapster-saw/examples/arrays.sawcore index bdb4dedf3d..750a4ae7f9 100644 --- a/heapster-saw/examples/arrays.sawcore +++ b/heapster-saw/examples/arrays.sawcore @@ -1,43 +1,44 @@ module arrays where -import Prelude; +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 LetRecType of noErrorsContains0 -noErrorsContains0LRT : LetRecType; -noErrorsContains0LRT = - LRT_Fun (Vec 64 Bool) (\ (len:Vec 64 Bool) -> - LRT_Fun (Vec 64 Bool) (\ (_:Vec 64 Bool) -> - LRT_Fun (BVVec 64 len (Vec 64 Bool)) (\ (_:BVVec 64 len (Vec 64 Bool)) -> - LRT_Ret (BVVec 64 len (Vec 64 Bool) * Vec 64 Bool)))); -- The helper function for noErrorsContains0 -- -- noErrorsContains0H len i v = --- orS (existsS x. x) (noErrorsContains0H len (i+1) v) +-- orS existsS (noErrorsContains0H len (i+1) v) noErrorsContains0H : (len i:Vec 64 Bool) -> BVVec 64 len (Vec 64 Bool) -> - SpecM VoidEv emptyFunStack - (BVVec 64 len (Vec 64 Bool) * Vec 64 Bool); -noErrorsContains0H = - multiArgFixS VoidEv emptyFunStack noErrorsContains0LRT - (\ (f : (len i:Vec 64 Bool) -> BVVec 64 len (Vec 64 Bool) -> - SpecM VoidEv (pushFunStack (singletonFrame noErrorsContains0LRT) emptyFunStack) - (BVVec 64 len (Vec 64 Bool) * Vec 64 Bool)) -> - (\ (len:Vec 64 Bool) (i:Vec 64 Bool) (v: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 (pushFunStack (singletonFrame noErrorsContains0LRT) emptyFunStack) - (BVVec 64 len (Vec 64 Bool) * Vec 64 Bool)) + (SpecM VoidEv (BVVec 64 len (Vec 64 Bool) * Vec 64 Bool)) (and (bvsle 64 0x0000000000000000 i) (bvsle 64 i 0x0fffffffffffffff)) - (orS VoidEv (pushFunStack (singletonFrame noErrorsContains0LRT) emptyFunStack) - (BVVec 64 len (Vec 64 Bool) * Vec 64 Bool) - (existsS VoidEv (pushFunStack (singletonFrame noErrorsContains0LRT) emptyFunStack) - (BVVec 64 len (Vec 64 Bool) * Vec 64 Bool)) - (f len (bvAdd 64 i 0x0000000000000001) v)))); + (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 emptyFunStack - (BVVec 64 len (Vec 64 Bool) * 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-saw/examples/arrays_mr_solver.saw b/heapster-saw/examples/arrays_mr_solver.saw index c70ab7c986..a67d31ec6a 100644 --- a/heapster-saw/examples/arrays_mr_solver.saw +++ b/heapster-saw/examples/arrays_mr_solver.saw @@ -7,13 +7,12 @@ prove_extcore mrsolver (refines [] contains0 contains0); 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 -// 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 }}); +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-saw/examples/c_data.saw b/heapster-saw/examples/c_data.saw index 5aaabdcaed..a9ca04c642 100644 --- a/heapster-saw/examples/c_data.saw +++ b/heapster-saw/examples/c_data.saw @@ -26,7 +26,7 @@ heapster_assume_fun env "malloc" "(sz:bv 64). arg0:eq(llvmword(8*sz)) -o \ \ arg0:true, ret:array(W,0, \ - \ retS VoidEv emptyFunStack \ + \ retS VoidEv \ \ (BVVec 64 sz #()) \ \ (genBVVec 64 sz #() (\\ (i:Vec 64 Bool) (_:is_bvult 64 i sz) -> ()))"; diff --git a/heapster-saw/examples/clearbufs.saw b/heapster-saw/examples/clearbufs.saw index 359e5bf964..bf31463260 100644 --- a/heapster-saw/examples/clearbufs.saw +++ b/heapster-saw/examples/clearbufs.saw @@ -4,12 +4,14 @@ 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" - "exists len:(bv 64).ptr((W,0) |-> Bufs) * \ + "eq(x) or exists len:(bv 64).ptr((W,0) |-> Bufs) * \ \ ptr((W,8) |-> eq(llvmword(len))) * \ \ array(W, 16, ))" - "Mbox_def" "foldMbox" "unfoldMbox" "transMbox"; + "\\ (x y : Bufs) -> transMbox x y"; heapster_block_entry_hint env "clearbufs" 3 "top1:llvmptr 64" @@ -20,5 +22,6 @@ heapster_block_entry_hint env "clearbufs" 3 heapster_typecheck_fun env "clearbufs" "(). arg0:Bufs -o arg0:Bufs"; +*/ heapster_export_coq env "clearbufs_gen.v"; diff --git a/heapster-saw/examples/clearbufs.sawcore b/heapster-saw/examples/clearbufs.sawcore index 794f9a00bf..dc26285e33 100644 --- a/heapster-saw/examples/clearbufs.sawcore +++ b/heapster-saw/examples/clearbufs.sawcore @@ -1,7 +1,7 @@ module clearbufs where -import Prelude; +import SpecM; V64 : sort 0; V64 = Vec 64 Bool; @@ -10,14 +10,28 @@ V64 = Vec 64 Bool; 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]; -data Mbox : sort 0 where { - Mbox_nil : Mbox; - Mbox_cons : Mbox -> (len : Vec 64 Bool) -> BVVec 64 len (Vec 64 Bool) -> Mbox; +-- 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; } --- A definition for the Mbox datatype; currently needed as a workaround in Heapster -Mbox_def : sort 0; -Mbox_def = Mbox; +-- 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) -> diff --git a/heapster-saw/examples/dilithium.patch b/heapster-saw/examples/dilithium.patch new file mode 100644 index 0000000000..36c9e175e3 --- /dev/null +++ b/heapster-saw/examples/dilithium.patch @@ -0,0 +1,216 @@ +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, 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-saw/examples/global_var.sawcore b/heapster-saw/examples/global_var.sawcore index bc7ca9f054..9fad6aae80 100644 --- a/heapster-saw/examples/global_var.sawcore +++ b/heapster-saw/examples/global_var.sawcore @@ -1,13 +1,9 @@ module GlobalVar where -import Prelude; +import SpecM; -acquireLockM : Vec 64 Bool -> - SpecM VoidEv emptyFunStack (Vec 64 Bool * Vec 64 Bool); -acquireLockM u = - retS VoidEv emptyFunStack (Vec 64 Bool * Vec 64 Bool) (u,u); +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 emptyFunStack (Vec 64 Bool); -releaseLockM u new_u = - retS VoidEv emptyFunStack (Vec 64 Bool) new_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-saw/examples/higher_order.cry b/heapster-saw/examples/higher_order.cry new file mode 100644 index 0000000000..9326ad2160 --- /dev/null +++ b/heapster-saw/examples/higher_order.cry @@ -0,0 +1,14 @@ + +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-saw/examples/higher_order_mr_solver.saw b/heapster-saw/examples/higher_order_mr_solver.saw new file mode 100644 index 0000000000..b0b1119811 --- /dev/null +++ b/heapster-saw/examples/higher_order_mr_solver.saw @@ -0,0 +1,5 @@ +enable_experimental; + +import "higher_order.cry"; + +prove_extcore mrsolver (refines [] {{ higher_order_1 }} {{ higher_order_2 }}); diff --git a/heapster-saw/examples/io.saw b/heapster-saw/examples/io.saw index e848161823..1d3596f361 100644 --- a/heapster-saw/examples/io.saw +++ b/heapster-saw/examples/io.saw @@ -17,7 +17,7 @@ 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 emptyFunStack (writeEv fd len buf)"; + \ triggerS ioEv (writeEv fd len buf)"; /// diff --git a/heapster-saw/examples/io.sawcore b/heapster-saw/examples/io.sawcore index c4a77f4399..ae972d04a4 100644 --- a/heapster-saw/examples/io.sawcore +++ b/heapster-saw/examples/io.sawcore @@ -1,7 +1,7 @@ module io where -import Prelude; +import SpecM; bitvector : Nat -> sort 0; bitvector n = Vec n Bool; diff --git a/heapster-saw/examples/iso_recursive.bc b/heapster-saw/examples/iso_recursive.bc deleted file mode 100644 index 4f73724340..0000000000 Binary files a/heapster-saw/examples/iso_recursive.bc and /dev/null differ diff --git a/heapster-saw/examples/iso_recursive.c b/heapster-saw/examples/iso_recursive.c deleted file mode 100644 index b143a0161f..0000000000 --- a/heapster-saw/examples/iso_recursive.c +++ /dev/null @@ -1,18 +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) { - if (l == NULL) { - return 0; - } else if (l->data == x) { - return 1; - } else { - return is_elem (x, l->next); - } -} diff --git a/heapster-saw/examples/iso_recursive.saw b/heapster-saw/examples/iso_recursive.saw deleted file mode 100644 index e6b695ba95..0000000000 --- a/heapster-saw/examples/iso_recursive.saw +++ /dev/null @@ -1,21 +0,0 @@ -enable_experimental; -env <- heapster_init_env_from_file "iso_recursive.sawcore" "iso_recursive.bc"; - -// Integer types -heapster_define_perm env "int64" " " "llvmptr 64" "exists x:bv 64.eq(llvmword(x))"; - -heapster_define_irt_recursive_perm env "List" - "X:perm(llvmptr 64), l:lifetime, rw:rwmodality" - "llvmptr 64" - [ "eq(llvmword(0))", - "[l]ptr((rw,0) |-> X) * ptr((rw,8) |-> List)" ]; - -heapster_define_irt_recursive_shape env "ListS" 64 - "X:llvmshape 64" - "fieldsh(eq(llvmword(0))) orsh (fieldsh(eq(llvmword(1))); X; ListS)"; - -heapster_typecheck_fun env "is_elem" - "(x:bv 64). arg0:eq(llvmword(x)), arg1:List,always,R> -o \ - \ arg0:true, arg1:true, ret:int64<>"; - -heapster_export_coq env "iso_recursive_gen.v"; diff --git a/heapster-saw/examples/iso_recursive.sawcore b/heapster-saw/examples/iso_recursive.sawcore deleted file mode 100644 index 574df711f9..0000000000 --- a/heapster-saw/examples/iso_recursive.sawcore +++ /dev/null @@ -1,4 +0,0 @@ - -module iso_recursive where - -import Prelude; diff --git a/heapster-saw/examples/iso_recursive_proofs.v b/heapster-saw/examples/iso_recursive_proofs.v deleted file mode 100644 index 1a9ded2ac9..0000000000 --- a/heapster-saw/examples/iso_recursive_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 CryptolToCoq Require Import CompMExtra. - -Require Import Examples.iso_recursive_gen. -Import iso_recursive. - -Import SAWCorePrelude. - -Ltac list_IRT_destruct l l' := destruct l as [| ? l']. -Ltac list_IRT_induction l l' := induction l as [| ? l']. -Ltac list_IRT_simpl := simpl unfoldList_IRT in *; simpl foldList_IRT in *. - -Hint Extern 2 (IntroArg ?n (eq (unfoldList_IRT _ _ ?l) - (SAWCorePrelude.Left _ _ _)) _) => - doDestruction (list_IRT_destruct) (list_IRT_simpl) l : refinesFun. -Hint Extern 2 (IntroArg ?n (eq (unfoldList_IRT _ _ ?l) - (SAWCorePrelude.Right _ _ _)) _) => - doDestruction (list_IRT_destruct) (list_IRT_simpl) l : refinesFun. - - -Lemma no_errors_is_elem : refinesFun is_elem (fun _ _ => noErrorsSpec). -Proof. - unfold is_elem, is_elem__tuple_fun, noErrorsSpec. - time "no_errors_is_elem (IRT)" prove_refinement. -Qed. diff --git a/heapster-saw/examples/iter_linked_list.saw b/heapster-saw/examples/iter_linked_list.saw index 6f7e0363e8..3aa24e03a0 100644 --- a/heapster-saw/examples/iter_linked_list.saw +++ b/heapster-saw/examples/iter_linked_list.saw @@ -4,11 +4,13 @@ env <- heapster_init_env_from_file "iter_linked_list.sawcore" "iter_linked_list. // 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 "ListF" "X:perm(llvmptr 64), l:lifetime, rw:rwmodality, y:llvmptr 64" "llvmptr 64" - "[l]ptr((rw,0) |-> X) * [l]ptr((rw,8) |-> ListF)" - "List_def" "foldList" "unfoldList" "appendList"; + "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" @@ -44,5 +46,6 @@ heapster_block_entry_hint env "length" 3 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-saw/examples/iter_linked_list.sawcore b/heapster-saw/examples/iter_linked_list.sawcore index fbb59e816b..3e9b248aa8 100644 --- a/heapster-saw/examples/iter_linked_list.sawcore +++ b/heapster-saw/examples/iter_linked_list.sawcore @@ -1,7 +1,7 @@ module iter_linked_list where -import Prelude; +import SpecM; List_def : (a:sort 0) -> sort 0; List_def a = List a; diff --git a/heapster-saw/examples/linked_list.saw b/heapster-saw/examples/linked_list.saw index 23e0db8484..e888bb85a9 100644 --- a/heapster-saw/examples/linked_list.saw +++ b/heapster-saw/examples/linked_list.saw @@ -4,15 +4,13 @@ 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 "List" +heapster_define_recursive_perm env "LList" "X:perm(llvmptr 64), l:lifetime, rw:rwmodality" "llvmptr 64" - [ "eq(llvmword(0))", - "[l]ptr((rw,0) |-> X) * [l]ptr((rw,8) |-> List)" ] - "List_def" "foldList" "unfoldList"; + "eq(llvmword(0)) or [l]ptr((rw,0) |-> X) * [l]ptr((rw,8) |-> LList)"; heapster_typecheck_fun env "is_elem" - "(). arg0:int64<>, arg1:List,always,R> -o \ + "(). arg0:int64<>, arg1:LList,always,R> -o \ \ arg0:true, arg1:true, ret:int64<>"; heapster_assume_fun env "malloc" @@ -22,20 +20,20 @@ heapster_assume_fun env "malloc" heapster_typecheck_fun env "any" "(). arg0:llvmfunptr{1,64}((). arg0:int64<> -o arg0:true, ret:int64<>), \ - \ arg1:List,always,R> -o \ + \ arg1:LList,always,R> -o \ \ arg0:true, arg1:true, ret:int64<>"; heapster_typecheck_fun env "find_elem" - "(). arg0:int64<>, arg1:List,always,W> -o \ - \ arg0:true, arg1:true, ret:List,always,W>"; + "(). arg0:int64<>, arg1:LList,always,W> -o \ + \ arg0:true, arg1:true, ret:LList,always,W>"; heapster_typecheck_fun env "sorted_insert" - "(). arg0:int64<>, arg1:List,always,W> -o \ - \ arg0:true, arg1:true, ret:List,always,W>"; + "(). 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:List,always,W> -o \ - \ arg0:true, arg1:true, ret:List,always,W>"; + \ 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-saw/examples/linked_list.sawcore b/heapster-saw/examples/linked_list.sawcore index 5a6d008856..025fdea7d3 100644 --- a/heapster-saw/examples/linked_list.sawcore +++ b/heapster-saw/examples/linked_list.sawcore @@ -1,12 +1,9 @@ module linked_list where -import Prelude; +import SpecM; -List_def : (a:sort 0) -> sort 0; -List_def a = List a; - -mallocSpec : (sz:Vec 64 Bool) -> SpecM VoidEv emptyFunStack (BVVec 64 sz #()); +mallocSpec : (sz:Vec 64 Bool) -> SpecM VoidEv (BVVec 64 sz #()); mallocSpec sz = - retS VoidEv emptyFunStack (BVVec 64 sz #()) + retS VoidEv (BVVec 64 sz #()) (genBVVec 64 sz #() (\ (i:Vec 64 Bool) (_:is_bvult 64 i sz) -> ())); diff --git a/heapster-saw/examples/loops.sawcore b/heapster-saw/examples/loops.sawcore index 715cb66e13..dc3de6aa49 100644 --- a/heapster-saw/examples/loops.sawcore +++ b/heapster-saw/examples/loops.sawcore @@ -1,4 +1,4 @@ module loops where -import Prelude; +import SpecM; diff --git a/heapster-saw/examples/mbox.saw b/heapster-saw/examples/mbox.saw index 62b3b6ce9e..a80413cf9d 100644 --- a/heapster-saw/examples/mbox.saw +++ b/heapster-saw/examples/mbox.saw @@ -27,12 +27,14 @@ heapster_define_perm env "aes_sw_ctx" "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" - "ptr((rw,0) |-> int64<>) * ptr((rw,8) |-> int64<>) * ptr((rw,16) |-> mbox) * \ - \ array(W, 24, <128, *1, fieldsh(8,int8<>))" - "Mbox_def" "foldMbox" "unfoldMbox" "transMbox"; + "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)" @@ -68,13 +70,13 @@ heapster_define_perm env "boolean" " " "llvmptr 1" "exists x:bv 1.eq(llvmword(x) // \ 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 emptyFunStack #() ()"; + "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 emptyFunStack \ + \ retS VoidEv \ \ (BVVec 64 len (Vec 8 Bool) * BVVec 64 len (Vec 8 Bool)) (src, src)"; @@ -273,7 +275,7 @@ heapster_typecheck_fun env "mbox_randomize" heapster_typecheck_fun env "mbox_drop" "(). arg0:mbox, arg1:int64<> -o \ \ arg0:mbox, arg1:true"; - +*/ //------------------------------------------------------------------------------ // Export to coq for verification diff --git a/heapster-saw/examples/mbox.sawcore b/heapster-saw/examples/mbox.sawcore index dde2596d66..94d57cd496 100644 --- a/heapster-saw/examples/mbox.sawcore +++ b/heapster-saw/examples/mbox.sawcore @@ -1,13 +1,13 @@ module mbox where -import Prelude; +import SpecM; SigBV1 : sort 0 -> sort 0; SigBV1 a = Sigma (Vec 1 Bool) (\ (_:Vec 1 Bool) -> a); getSBoxValueSpec : Vec 64 Bool -> - SpecM VoidEv emptyFunStack (Vec 64 Bool); -getSBoxValueSpec x = retS VoidEv emptyFunStack (Vec 64 Bool) x; + SpecM VoidEv (Vec 64 Bool); +getSBoxValueSpec x = retS VoidEv (Vec 64 Bool) x; -- Harcoded 64 length bitvector value 16, used for mbox definitions bv64_16 : Vec 64 Bool; @@ -69,17 +69,17 @@ transMbox m1 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 emptyFunStack (Mbox); +mboxNewSpec : SpecM VoidEv (Mbox); mboxNewSpec = - retS VoidEv emptyFunStack Mbox + 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)))); mboxFreeSpec : BVVec 64 bv64_128 (Vec 8 Bool) -> - SpecM VoidEv emptyFunStack (Vec 32 Bool); -mboxFreeSpec _ = retS VoidEv emptyFunStack (Vec 32 Bool) (bvNat 32 0); + SpecM VoidEv (Vec 32 Bool); +mboxFreeSpec _ = retS VoidEv (Vec 32 Bool) (bvNat 32 0); -mboxAllFreedSpec : SpecM VoidEv emptyFunStack (Vec 1 Bool); -mboxAllFreedSpec = retS VoidEv emptyFunStack (Vec 1 Bool) (bvNat 1 0); +mboxAllFreedSpec : SpecM VoidEv (Vec 1 Bool); +mboxAllFreedSpec = retS VoidEv (Vec 1 Bool) (bvNat 1 0); -randSpec : SpecM VoidEv emptyFunStack (Vec 32 Bool); -randSpec = existsS VoidEv emptyFunStack (Vec 32 Bool); +randSpec : SpecM VoidEv (Vec 32 Bool); +randSpec = existsS VoidEv (Vec 32 Bool); diff --git a/heapster-saw/examples/memcpy.saw b/heapster-saw/examples/memcpy.saw index 46ed9cc2c3..dc37382064 100644 --- a/heapster-saw/examples/memcpy.saw +++ b/heapster-saw/examples/memcpy.saw @@ -5,13 +5,12 @@ env <- heapster_init_env_from_file "memcpy.sawcore" "memcpy.bc"; heapster_define_perm env "int64" " " "llvmptr 64" "exists x:bv 64.eq(llvmword(x))"; heapster_assume_fun env "llvm.memcpy.p0i8.p0i8.i64" - "(rw:rwmodality, l1:lifetime, l2:lifetime, sh:llvmshape 64, \ + "(rw:rwmodality, l1:lifetime, l2:lifetime, \ \ b:llvmblock 64, len:bv 64). \ - \ arg0:[l1]memblock(W,0,len,sh), arg1:[l2]memblock(rw,0,len,eqsh(len,b)), \ + \ 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))" - "\\ (X:sort 0) (len:Vec 64 Bool) (x:X) (_:#()) -> \ - \ retS VoidEv emptyFunStack (#() * #()) ((),())"; + "\\ (len:Vec 64 Bool) -> retS VoidEv #() ()"; heapster_typecheck_fun env "copy_int" diff --git a/heapster-saw/examples/memcpy.sawcore b/heapster-saw/examples/memcpy.sawcore index 59a036a748..0e8b8ce9a0 100644 --- a/heapster-saw/examples/memcpy.sawcore +++ b/heapster-saw/examples/memcpy.sawcore @@ -1,10 +1,9 @@ module memcpy where -import Prelude; +import SpecM; -mallocSpec : (sz:Vec 64 Bool) -> - SpecM VoidEv emptyFunStack (BVVec 64 sz #()); +mallocSpec : (sz:Vec 64 Bool) -> SpecM VoidEv (BVVec 64 sz #()); mallocSpec sz = - retS VoidEv emptyFunStack (BVVec 64 sz #()) + retS VoidEv (BVVec 64 sz #()) (genBVVec 64 sz #() (\ (i:Vec 64 Bool) (_:is_bvult 64 i sz) -> ())); diff --git a/heapster-saw/examples/rust_data.bc b/heapster-saw/examples/rust_data.bc index da8841005e..0469401e80 100644 Binary files a/heapster-saw/examples/rust_data.bc and b/heapster-saw/examples/rust_data.bc differ diff --git a/heapster-saw/examples/rust_data.rs b/heapster-saw/examples/rust_data.rs index 982abfffdb..aa6e6ec9b7 100644 --- a/heapster-saw/examples/rust_data.rs +++ b/heapster-saw/examples/rust_data.rs @@ -393,33 +393,33 @@ pub fn index_three_array (x:[u64; 3]) -> u64 { /* A linked list */ #[derive(Clone, Debug, PartialEq)] #[repr(C,u64)] -pub enum List { +pub enum LList { Nil, - Cons (X,Box>) + Cons (X,Box>) } /* Test if a list is empty */ -pub fn list_is_empty (l: &List) -> bool { +pub fn list_is_empty (l: &LList) -> bool { match l { - List::Nil => true, - List::Cons (_,_) => false + LList::Nil => true, + LList::Cons (_,_) => false } } /* Get the head of a linked list or return an error */ -pub fn list_head (l: &List) -> Box> { +pub fn list_head (l: &LList) -> Box> { match l { - List::Nil => Box::new(Sum::Right (())), - List::Cons (x,_) => Box::new(Sum::Left (*x)) + 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 List { +impl LList { pub fn list_head_impl (&self) -> Result { match self { - List::Nil => Err (()), - List::Cons (x,_) => Ok (*x) + LList::Nil => Err (()), + LList::Cons (x,_) => Ok (*x) } } } @@ -475,6 +475,22 @@ pub fn list64_head_mut <'a> (l:&'a mut List64) -> Option<&'a mut u64> { } } +/* 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 { @@ -583,7 +599,7 @@ pub enum Enum20 { Enum20_19(X), } -pub fn enum20_list_proj<'a> (x:&'a Enum20>) -> &'a List { +pub fn enum20_list_proj<'a> (x:&'a Enum20>) -> &'a LList { match x { Enum20::Enum20_0(l) => l, Enum20::Enum20_1(l) => l, @@ -624,7 +640,7 @@ pub enum List10 { List10_9(X,Box>), } -pub fn list10_head<'a> (x:&'a List10>) -> &'a List { +pub fn list10_head<'a> (x:&'a List10>) -> &'a LList { match x { List10::List10Head(l) => l, List10::List10_0(l,_) => l, @@ -667,7 +683,7 @@ pub enum List20 { List20_19(X,Box>), } -pub fn list20_head<'a> (x:&'a List20>) -> &'a List { +pub fn list20_head<'a> (x:&'a List20>) -> &'a LList { match x { List20::List20Head(l) => l, List20::List20_0(l,_) => l, diff --git a/heapster-saw/examples/rust_data.saw b/heapster-saw/examples/rust_data.saw index d7b3725f9d..f62a51212f 100644 --- a/heapster-saw/examples/rust_data.saw +++ b/heapster-saw/examples/rust_data.saw @@ -64,7 +64,7 @@ heapster_define_llvmshape env "String" 64 "" // "\\ (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 List { Nil, Cons (X,Box>) }"; +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! @@ -72,9 +72,9 @@ heapster_define_rust_type env "pub enum List { Nil, Cons (X,Box>) }"; // // 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" "#()"; +heapster_define_opaque_llvmshape env "Void" 64 "" "64" "#()" "Tp_Kind (Kind_Expr Kind_unit)"; - // Location type from std::panic +// Location type from std::panic heapster_define_llvmshape env "panic::Location" 64 "" "exsh len:bv 64.ptrsh(arraysh())); \ \ fieldsh(eq(llvmword(len))); u32<>; u32<>"; @@ -103,12 +103,14 @@ 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:sort 0) -> List T"; + "\\ (T:TpDesc) -> ListDescType T" + "ListDesc"; // Opaque type for HashMap heapster_define_opaque_llvmshape env "HashMap" 64 "T:llvmshape 64, U:llvmshape 64" "56" - "\\ (T:sort 0) (U:sort 0) -> List (T * U)"; + "\\ (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 @@ -169,7 +171,7 @@ heapster_define_llvmshape env "fmt::Result" 64 "" // "pub enum Result { Ok (), Err (fmt::Error) }"; // fmt::Formatter type -heapster_define_opaque_llvmshape env "fmt::Formatter" 64 "" "64" "#()"; +heapster_define_opaque_llvmshape env "fmt::Formatter" 64 "" "64" "#()" "Tp_Unit"; // fmt::Alignment type heapster_define_rust_type_qual env "fmt" @@ -231,31 +233,30 @@ 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:memblock(W,0,len,emptysh)" - "\\ (len:Vec 64 Bool) -> retS VoidEv emptyFunStack #() ()"; + "\\ (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 emptyFunStack \ + \ 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 emptyFunStack (Vec 1 Bool) x"; + "\\ (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, sh:llvmshape 64, \ + "(rw:rwmodality, l1:lifetime, l2:lifetime, \ \ b:llvmblock 64, len:bv 64). \ - \ arg0:[l1]memblock(W,0,len,sh), arg1:[l2]memblock(rw,0,len,eqsh(len,b)), \ + \ 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))" - "\\ (X:sort 0) (len:Vec 64 Bool) (x:X) (_:#()) -> \ - \ retS VoidEv emptyFunStack (#() * #()) ((),())"; + "\\ (len:Vec 64 Bool) -> retS VoidEv #() ()"; // Box>::clone box_list20_u64_clone_sym <- heapster_find_symbol_with_type env @@ -492,9 +493,8 @@ heapster_typecheck_fun_rename env mk_proj0_five_values_sym "mk_proj0_five_values // ref_sum ref_sum_sym <- heapster_find_symbol env "7ref_sum"; -// FIXME: Get this working again -// heapster_typecheck_fun_rename env ref_sum_sym "ref_sum" -// "<'a,'b> fn (x:&'a u64, y:&'a u64) -> u64"; +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"; @@ -542,15 +542,13 @@ heapster_typecheck_fun_rename env elim_sum_u64_u64_sym "elim_sum_u64_u64" // MixedStruct::get_i1 mixed_struct_get_i1 <- heapster_find_symbol env "11MixedStruct6get_i1"; -// FIXME: Get this working again -// heapster_typecheck_fun_rename env mixed_struct_get_i1 "MixedStruct_get_i1" -// "<'a> fn (m:&'a MixedStruct) -> u64"; +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"; -// FIXME: Get this working again -// heapster_typecheck_fun_rename env mixed_struct_get_i2 "MixedStruct_get_i2" -// "<'a> fn (m:&'a MixedStruct) -> u64"; +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 @@ -566,72 +564,63 @@ cycle_true_enum_sym <- heapster_find_symbol env "15cycle_true_enum"; TrueEnum__fmt_sym <- heapster_find_trait_method_symbol env "core::fmt::Display::fmt"; -// FIXME: Get this working again -// heapster_typecheck_fun_rename env TrueEnum__fmt_sym "TrueEnum__fmt" -// "<'a, 'b> fn (&'a TrueEnum, f: &'b mut fmt::Formatter) -> fmt::Result"; +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"; -// FIXME: Get this working again -// heapster_typecheck_fun_rename env list_is_empty_sym "list_is_empty" -// "<'a> fn (l: &'a List) -> bool"; +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"; -// FIXME: Get this working again -// heapster_typecheck_fun_rename env list_head_sym "list_head" -// "<'a> fn (l: &'a List) -> Box>"; +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:List),8,rw,always> -o \ +// "(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"; -// FIXME: Get this working again -// heapster_typecheck_fun_rename env list_head_impl_sym "list_head_impl" -// "<'a> fn (l: &'a List) -> Result"; +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:List),8,rw,always> -o \ +// "(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"; -// FIXME: Get this working again -// heapster_typecheck_fun_rename env list_is_empty_sym "list64_is_empty" -// "<'a> fn (l: &'a List64<>) -> bool"; +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"; -// FIXME: Get this working again -// heapster_assume_fun_rename_prim env box_list64_clone_sym "box_list64_clone" -// "<'a> fn(x:&'a Box) -> Box"; +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"; -// FIXME: Get this working again -// heapster_typecheck_fun_rename env list64_clone_sym "list64_clone" -// "<'a> fn (x:&'a List64) -> List64"; +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 +// 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"; -// FIXME: Get this working again -// heapster_typecheck_fun_rename env list64_head_mut_sym "list64_head_mut" -// "<'a> fn (l:&'a mut List64) -> Option<&'a mut u64>"; +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"; -// FIXME: Get this working again -// heapster_typecheck_fun_rename env list64_find_mut_sym "list64_find_mut" -// "<'a> fn (x:u64, l:&'a mut List64) -> Option<&'a mut u64>"; +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"; @@ -651,11 +640,11 @@ heapster_typecheck_fun_rename env bintree_is_leaf_sym "bintree_is_leaf" 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 List"; + "<'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 List"; + "<'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"; @@ -665,7 +654,7 @@ heapster_typecheck_fun_rename env list20_u64_clone_sym "list20_u64_clone" 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 List"; + "<'a> fn (x:&'a List20>) -> &'a LList"; */ diff --git a/heapster-saw/examples/rust_data.sawcore b/heapster-saw/examples/rust_data.sawcore index 9d39cde030..43eca0d96b 100644 --- a/heapster-saw/examples/rust_data.sawcore +++ b/heapster-saw/examples/rust_data.sawcore @@ -1,19 +1,14 @@ module rust_data where -import Prelude; +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; +-- 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))); -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)); +-- 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-saw/examples/rust_lifetimes.saw b/heapster-saw/examples/rust_lifetimes.saw index 782d413972..26e8fb29b2 100644 --- a/heapster-saw/examples/rust_lifetimes.saw +++ b/heapster-saw/examples/rust_lifetimes.saw @@ -26,13 +26,13 @@ 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 emptyFunStack (Vec 64 Bool * Vec 1 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 emptyFunStack (Vec 1 Bool) x"; + "\\ (x y:Vec 1 Bool) -> retS VoidEv (Vec 1 Bool) x"; // core::panicking::panic //panic_sym <- heapster_find_symbol env "5panic"; diff --git a/heapster-saw/examples/rust_lifetimes.sawcore b/heapster-saw/examples/rust_lifetimes.sawcore index ea6aa76bf6..4e447e3b31 100644 --- a/heapster-saw/examples/rust_lifetimes.sawcore +++ b/heapster-saw/examples/rust_lifetimes.sawcore @@ -1,7 +1,7 @@ module rust_lifetimes where -import Prelude; +import SpecM; unfoldListPermH : (a:sort 0) -> List a -> Either #() (#() * a * List a); unfoldListPermH a l = diff --git a/heapster-saw/examples/sha512.saw b/heapster-saw/examples/sha512.saw index 267ae3d109..d5968649d6 100644 --- a/heapster-saw/examples/sha512.saw +++ b/heapster-saw/examples/sha512.saw @@ -15,7 +15,7 @@ heapster_define_perm env "true_ptr" "rw:rwmodality" "llvmptr 64" "ptr((rw,0) |-> 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 emptyFunStack (Vec 64 Bool * Vec 64 Bool) (x, x)"; + "\\ (x:Vec 64 Bool) -> retS VoidEv (Vec 64 Bool * Vec 64 Bool) (x, x)"; /* heapster_typecheck_fun env "return_state" @@ -67,6 +67,8 @@ heapster_typecheck_fun env "processBlock" \ 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<>)), \ @@ -75,5 +77,6 @@ heapster_typecheck_fun env "processBlocks" \ 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-saw/examples/specPrims.saw b/heapster-saw/examples/specPrims.saw index cd57da322a..ea8a818159 100644 --- a/heapster-saw/examples/specPrims.saw +++ b/heapster-saw/examples/specPrims.saw @@ -2,8 +2,8 @@ import "SpecPrims.cry"; -set_monadification "exists" "Prelude.existsS" true; -set_monadification "forall" "Prelude.forallS" true; -set_monadification "asserting" "Prelude.asserting" true; -set_monadification "assuming" "Prelude.assuming" true; -set_monadification "invariantHint" "Prelude.invariantHint" true; +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-saw/examples/string_set.saw b/heapster-saw/examples/string_set.saw index ed7992b0c0..e52debc6a2 100644 --- a/heapster-saw/examples/string_set.saw +++ b/heapster-saw/examples/string_set.saw @@ -5,15 +5,17 @@ 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" "String"; +heapster_define_opaque_perm env "string" "" "llvmptr 64" "StringTp" "StringDesc"; -heapster_define_opaque_perm env "string_set" "rw:rwmodality, l:lifetime" "llvmptr 64" "List String"; +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" @@ -37,5 +39,6 @@ heapster_assume_fun env "string_set_remove" 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-saw/examples/string_set.sawcore b/heapster-saw/examples/string_set.sawcore index 6c45859568..3b701208d9 100644 --- a/heapster-saw/examples/string_set.sawcore +++ b/heapster-saw/examples/string_set.sawcore @@ -1,18 +1,33 @@ module string_set where -import Prelude; +import SpecM; -listInsertM : (a : sort 0) -> List a -> a -> - SpecM VoidEv emptyFunStack (List a); -listInsertM a l s = - retS VoidEv emptyFunStack (List a) (Cons a s l); +-- 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 emptyFunStack (List a * a); + SpecM VoidEv (List a * a); listRemoveM a test_eq l s = retS - VoidEv emptyFunStack + VoidEv (List a * a) (List__rec a (\ (_:List a) -> List a) @@ -28,16 +43,14 @@ listRemoveM a test_eq l s = stringList : sort 0; stringList = List String; -stringListInsertM : List String -> String -> - SpecM VoidEv emptyFunStack (List String); -stringListInsertM l s = - retS VoidEv emptyFunStack (List String) (Cons String s l); +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 emptyFunStack (stringList * String); + SpecM VoidEv (stringList * String); stringListRemoveM l s = retS - VoidEv emptyFunStack + VoidEv (stringList * String) (List__rec String (\ (_:List String) -> List String) diff --git a/heapster-saw/heapster-saw.cabal b/heapster-saw/heapster-saw.cabal index 1fb04c58b6..bcb494d810 100644 --- a/heapster-saw/heapster-saw.cabal +++ b/heapster-saw/heapster-saw.cabal @@ -52,7 +52,6 @@ library Verifier.SAW.Heapster.IDESupport Verifier.SAW.Heapster.HintExtract Verifier.SAW.Heapster.Implication - Verifier.SAW.Heapster.IRTTranslation Verifier.SAW.Heapster.Lexer Verifier.SAW.Heapster.LLVMGlobalConst Verifier.SAW.Heapster.Located diff --git a/heapster-saw/src/Verifier/SAW/Heapster/CruUtil.hs b/heapster-saw/src/Verifier/SAW/Heapster/CruUtil.hs index c1617ae2e9..40bbd1e3d4 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/CruUtil.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/CruUtil.hs @@ -275,7 +275,7 @@ instance Closable ProgramLoc where instance Liftable ProgramLoc where mbLift = unClosed . mbLift . fmap toClosed --- | Pretty-print a 'Position' with a "short" filename, without the path +-- | 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) @@ -428,7 +428,7 @@ instance Closable (BadBehavior e) where -- instance NuMatchingAny1 e => Liftable (BadBehavior e) where -- mbLift = unClosed . mbLift . fmap toClosed --- NOTE: Crucible objects can never contain any Hobbits names, but "proving" +-- 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' diff --git a/heapster-saw/src/Verifier/SAW/Heapster/GenMonad.hs b/heapster-saw/src/Verifier/SAW/Heapster/GenMonad.hs index 91bc25b060..cde8a27634 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/GenMonad.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/GenMonad.hs @@ -12,7 +12,7 @@ module Verifier.SAW.Heapster.GenMonad ( gcaptureCC, gmapRet, gabortM, gparallel, startBinding, startNamedBinding, gopenBinding, gopenNamedBinding, -- * State operations - gmodify, + gmodify, gput, -- * Transformations addReader, ) where @@ -65,7 +65,7 @@ instance (s1 ~ s2, r1 ~ r2) => MonadTrans (GenStateContT s1 r1 s2 r2) where 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 +-- | Run two generalized monad computations \"in parallel\" and combine their -- results gparallel :: (m r1 -> m r2 -> m r3) -> diff --git a/heapster-saw/src/Verifier/SAW/Heapster/HintExtract.hs b/heapster-saw/src/Verifier/SAW/Heapster/HintExtract.hs index d60397df21..919a548777 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/HintExtract.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/HintExtract.hs @@ -46,7 +46,7 @@ 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. +-- | Extract block hints from calls to @heapster.require@ in the Crucible CFG. extractHints :: forall ghosts args outs blocks init ret. PermEnv -> @@ -147,7 +147,7 @@ extractStmtsHint who env globals tops inputs = loop Ctx.zeroSize -- (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 +-- 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. @@ -198,7 +198,7 @@ extractHintFromSequence who env globals tops blockIns sz s = -- | Assemble a Hint -- --- Will throw an error if the `require` is malformed (malformed spec strings +-- 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) -} -> @@ -231,13 +231,12 @@ renameParsedCtx sub ctx = ctx { parsedCtxNames = renamed } 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")] +-- | 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 -> @@ -279,7 +278,7 @@ mkBlockEntryHint cfg blockId tops ghosts valPerms = blocks = fmapFC blockInputs $ cfgBlockMap cfg -- | Like mkArgParsedContext, but with all of the names --- set to "topi" instead of "argi" +-- set to \"topi\" instead of \"argi\" mkTopParsedCtx :: CruCtx ctx -> ParsedCtx ctx mkTopParsedCtx = mkPrefixParsedCtx "top" diff --git a/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs b/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs index b86c58b836..c23adac54c 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs @@ -30,6 +30,7 @@ import Data.Binding.Hobbits unsafeMbTypeRepr, Name, ) +import Data.Kind (Type) import Data.Maybe (catMaybes, listToMaybe, mapMaybe) import Data.Parameterized.Some (Some (..)) import qualified Data.Text as T @@ -143,8 +144,8 @@ instance (PermCheckExtC ext extExpr) let insertNames :: RL.RAssign Name (x :: RList CrucibleType) -> RL.RAssign StringF x -> - NameMap (StringF :: CrucibleType -> *)-> - NameMap (StringF :: CrucibleType -> *) + 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) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/IRTTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/IRTTranslation.hs deleted file mode 100644 index 42b5986b0e..0000000000 --- a/heapster-saw/src/Verifier/SAW/Heapster/IRTTranslation.hs +++ /dev/null @@ -1,801 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveTraversable #-} - -module Verifier.SAW.Heapster.IRTTranslation ( - translateCompletePermIRTTyVars, - translateCompleteShapeIRTTyVars, - IRTVarTree(..), pattern IRTVar, IRTVarIdxs, - translateCompleteIRTDesc, - translateCompleteIRTDef, - translateCompleteIRTFoldFun, - translateCompleteIRTUnfoldFun, - -- * Useful functions - completeOpenTermTyped, - listSortOpenTerm, - askExprCtxTerms - ) where - -import Numeric.Natural -import Data.Functor.Const -import GHC.TypeLits -import Control.Monad (zipWithM) -import Control.Monad.Except (MonadError(..)) -import Control.Monad.Reader (MonadReader(..), ReaderT(..), withReaderT) -import Control.Monad.State (MonadState(..), State, evalState) - -import qualified Data.Type.RList as RL -import Data.Binding.Hobbits -import Data.Parameterized.BoolRepr -import Data.Reflection - -import Lang.Crucible.Types -import Verifier.SAW.OpenTerm -import Verifier.SAW.SCTypeCheck -import Verifier.SAW.SharedTerm - -import Verifier.SAW.Heapster.CruUtil -import Verifier.SAW.Heapster.Permissions -import Verifier.SAW.Heapster.SAWTranslation - - --- | "Complete" an 'OpenTerm' to a closed 'TypedTerm' or 'fail' on --- type-checking error --- TODO Move this to OpenTerm.hs? -completeOpenTermTyped :: SharedContext -> OpenTerm -> IO TypedTerm -completeOpenTermTyped sc (OpenTerm termM) = - either (fail . show) return =<< - runTCM termM sc Nothing [] - --- | Get the result of applying 'exprCtxToTerms' to the current expression --- translation context --- TODO Move this to SAWTranslation.hs? -askExprCtxTerms :: TransInfo info => TransM info ctx [OpenTerm] -askExprCtxTerms = exprCtxToTerms <$> infoCtx <$> ask - - ----------------------------------------------------------------------- --- * Names of the recursive permission or shape being defined ----------------------------------------------------------------------- - --- | The name of the recursive permission or shape being defined -data IRTRecName args where - IRTRecPermName :: NamedPermName ns args tp -> IRTRecName args - IRTRecShapeName :: NatRepr w -> NamedShape 'True args w -> IRTRecName args - --- | Generic function to test if an object contains an 'IRTRecName' -class ContainsIRTRecName a where - containsIRTRecName :: IRTRecName args -> a -> Bool - -instance ContainsIRTRecName a => ContainsIRTRecName [a] where - containsIRTRecName n = any (containsIRTRecName n) - -instance ContainsIRTRecName a => ContainsIRTRecName (Mb ctx a) where - containsIRTRecName n = mbLift . fmap (containsIRTRecName n) - -instance ContainsIRTRecName (PermExpr a) where - containsIRTRecName (IRTRecShapeName w nm_sh) (PExpr_NamedShape _ _ nm_sh' _) - | Just Refl <- testEquality w (natRepr nm_sh') - , Just _ <- namedShapeEq nm_sh nm_sh' = True - containsIRTRecName n (PExpr_NamedShape _ _ _ args) = - containsIRTRecName n args - containsIRTRecName n (PExpr_PtrShape _ _ sh) = containsIRTRecName n sh - containsIRTRecName n (PExpr_FieldShape fsh) = containsIRTRecName n fsh - containsIRTRecName n (PExpr_ArrayShape _ _ sh) = containsIRTRecName n sh - containsIRTRecName n (PExpr_SeqShape sh1 sh2) = - containsIRTRecName n sh1 || containsIRTRecName n sh2 - containsIRTRecName n (PExpr_OrShape sh1 sh2) = - containsIRTRecName n sh1 || containsIRTRecName n sh2 - containsIRTRecName n (PExpr_ExShape mb_sh) = - mbLift $ fmap (containsIRTRecName n) mb_sh - containsIRTRecName n (PExpr_ValPerm p) = containsIRTRecName n p - containsIRTRecName _ _ = False - -instance ContainsIRTRecName (RAssign PermExpr tps) where - containsIRTRecName _ MNil = False - containsIRTRecName n (es :>: e) = - containsIRTRecName n es || containsIRTRecName n e - -instance ContainsIRTRecName (LLVMFieldShape a) where - containsIRTRecName n (LLVMFieldShape p) = containsIRTRecName n p - -instance ContainsIRTRecName (ValuePerm a) where - containsIRTRecName n (ValPerm_Eq e) = containsIRTRecName n e - containsIRTRecName n (ValPerm_Or p1 p2) = - containsIRTRecName n p1 || containsIRTRecName n p2 - containsIRTRecName n (ValPerm_Exists mb_p) = - mbLift $ fmap (containsIRTRecName n) mb_p - containsIRTRecName (IRTRecPermName npn) (ValPerm_Named npn' _ _) - | Just _ <- testNamedPermNameEq npn npn' = True - containsIRTRecName n (ValPerm_Named _ args _) = - containsIRTRecName n args - containsIRTRecName _ (ValPerm_Var _ _) = False - containsIRTRecName n (ValPerm_Conj ps) = containsIRTRecName n ps - containsIRTRecName _ ValPerm_False = False - -instance ContainsIRTRecName (RAssign ValuePerm tps) where - containsIRTRecName _ MNil = False - containsIRTRecName n (ps :>: p) = - containsIRTRecName n ps || containsIRTRecName n p - -instance ContainsIRTRecName (AtomicPerm a) where - containsIRTRecName n (Perm_LLVMField fp) = containsIRTRecName n fp - containsIRTRecName n (Perm_LLVMArray arrp) = - containsIRTRecName n (llvmArrayCellShape arrp) - containsIRTRecName n (Perm_LLVMBlock bp) = - containsIRTRecName n (llvmBlockShape bp) - containsIRTRecName _ (Perm_LLVMFree _) = False - containsIRTRecName _ (Perm_LLVMFunPtr _ _) = False - containsIRTRecName n (Perm_LLVMBlockShape sh) = containsIRTRecName n sh - containsIRTRecName _ Perm_IsLLVMPtr = False - containsIRTRecName (IRTRecPermName npn) (Perm_NamedConj npn' _ _) - | Just _ <- testNamedPermNameEq npn npn' = True - containsIRTRecName n (Perm_NamedConj _ args _) = containsIRTRecName n args - containsIRTRecName n (Perm_LLVMFrame fperm) = - containsIRTRecName n (map fst fperm) - containsIRTRecName _ (Perm_LOwned _ _ _ _ _) = False - containsIRTRecName _ (Perm_LOwnedSimple _ _) = False - containsIRTRecName _ (Perm_LCurrent _) = False - containsIRTRecName _ Perm_LFinished = False - containsIRTRecName n (Perm_Struct ps) = containsIRTRecName n ps - containsIRTRecName _ (Perm_Fun _) = False - containsIRTRecName _ (Perm_BVProp _) = False - containsIRTRecName _ Perm_Any = False - -instance ContainsIRTRecName (LLVMFieldPerm w sz) where - containsIRTRecName n fp = containsIRTRecName n $ llvmFieldContents fp - - ----------------------------------------------------------------------- --- * The monad for translating IRT type variables ----------------------------------------------------------------------- - -data IRTTyVarsTransCtx args ext = - IRTTyVarsTransCtx - { - irtTRecName :: IRTRecName args, - irtTArgsCtx :: RAssign (Const [OpenTerm]) args, - irtTExtCtx :: RAssign Proxy ext, - irtTPermEnv :: PermEnv - } - --- | The monad for translating IRT type variables -type IRTTyVarsTransM args ext = - ReaderT (IRTTyVarsTransCtx args ext) (Either String) - -runIRTTyVarsTransM :: PermEnv -> IRTRecName args -> CruCtx args -> - IRTTyVarsTransM args RNil a -> - Either String a -runIRTTyVarsTransM env n_rec argsCtx m = runReaderT m ctx - where args_trans = RL.map (\tp -> Const $ typeTransTypes $ - runNilTypeTransM env noChecks $ - translateClosed tp) - (cruCtxToTypes argsCtx) - ctx = IRTTyVarsTransCtx n_rec args_trans MNil env - --- | Run an IRT type variables translation computation in an extended context -inExtIRTTyVarsTransM :: IRTTyVarsTransM args (ext :> tp) a -> - IRTTyVarsTransM args ext a -inExtIRTTyVarsTransM = withReaderT $ - \ctx -> ctx { irtTExtCtx = irtTExtCtx ctx :>: Proxy } - --- | Combine a binding inside an @args :++: ext@ binding into a single --- @args :++: ext'@ binding -irtTMbCombine :: - forall args ext c a. - Mb (args :++: ext) (Binding c a) -> - IRTTyVarsTransM args ext (Mb (args :++: (ext :> c)) a) -irtTMbCombine x = - do ext <- irtTExtCtx <$> ask - return $ - mbCombine (ext :>: Proxy) $ - fmap (mbCombine RL.typeCtxProxies ) $ - mbSeparate @_ @args ext x - --- | Create an @args :++: ext@ binding -irtNus :: (RAssign Name args -> RAssign Name ext -> b) -> - IRTTyVarsTransM args ext (Mb (args :++: ext) b) -irtNus f = - do args <- irtTArgsCtx <$> ask - ext <- irtTExtCtx <$> ask - return $ mbCombine ext (nus (RL.map (\_->Proxy) args) (nus ext . f)) - --- | Turn an @args :++: ext@ binding into just an @args@ binding using --- 'partialSubst' -irtTSubstExt :: (Substable PartialSubst a Maybe, NuMatching a) => - Mb (args :++: ext) a -> - IRTTyVarsTransM args ext (Mb args a) -irtTSubstExt x = - do ext <- irtTExtCtx <$> ask - let x' = mbSwap ext (mbSeparate ext x) - emptyPS = PartialSubst $ RL.map (\_ -> PSubstElem Nothing) ext - args <- RL.map (const Proxy) . irtTArgsCtx <$> ask - case give args (partialSubst emptyPS x') of - Just x'' -> return x'' - Nothing -> throwError $ "non-array permission in a recursive perm body" - ++ " depends on an existential variable!" - - ----------------------------------------------------------------------- --- * Trees for keeping track of IRT variable indices ----------------------------------------------------------------------- - -data IRTVarTree a = IRTVarsNil - | IRTVarsCons a (IRTVarTree a) - | IRTVarsAppend (IRTVarTree a) (IRTVarTree a) - | IRTVarsConcat [IRTVarTree a] - | IRTRecVar -- the recursive case - deriving (Show, Eq, Functor, Foldable, Traversable) - -pattern IRTVar :: a -> IRTVarTree a -pattern IRTVar ix = IRTVarsCons ix IRTVarsNil - -type IRTVarTreeShape = IRTVarTree () -type IRTVarIdxs = IRTVarTree Natural - --- | Fill in all the leaves of an 'IRTVarTree' with sequential indices -setIRTVarIdxs :: IRTVarTreeShape -> IRTVarIdxs -setIRTVarIdxs tree = evalState (mapM (\_ -> nextIdx) tree) 0 - where nextIdx :: State Natural Natural - nextIdx = state (\i -> (i,i+1)) - - ----------------------------------------------------------------------- --- * Translating IRT type variables ----------------------------------------------------------------------- - --- | Given the name of a recursive permission being defined and its argument --- content, translate the permission's body to a SAW core list of its IRT type --- variables and an 'IRTVarIdxs', which is used to get indices into the list --- when calling 'translateCompleteIRTDesc' -translateCompletePermIRTTyVars :: SharedContext -> PermEnv -> - NamedPermName ns args tp -> CruCtx args -> - Mb args (ValuePerm a) -> - IO (TypedTerm, IRTVarIdxs) -translateCompletePermIRTTyVars sc env npn_rec args p = - case runIRTTyVarsTransM env (IRTRecPermName npn_rec) args (irtTyVars p) of - Left err -> fail err - Right (tps, ixs) -> - do tm <- completeOpenTermTyped sc $ - runNilTypeTransM env noChecks (lambdaExprCtx args $ - listSortOpenTerm <$> sequence tps) - return (tm, setIRTVarIdxs ixs) - --- | Given the a recursive shape being defined, translate the shape's body to --- a SAW core list of its IRT type variables and an 'IRTVarIdxs', which is --- used to get indices into the list when calling 'translateCompleteIRTDesc' -translateCompleteShapeIRTTyVars :: KnownNat w => SharedContext -> PermEnv -> - NamedShape 'True args w -> - IO (TypedTerm, IRTVarIdxs) -translateCompleteShapeIRTTyVars sc env nmsh_rec = - let args = namedShapeArgs nmsh_rec - body = unfoldNamedShape nmsh_rec <$> - nus (cruCtxProxies args) namesToExprs in - case runIRTTyVarsTransM env (IRTRecShapeName knownNat nmsh_rec) - args (irtTyVars body) of - Left err -> fail err - Right (tps, ixs) -> - do tm <- completeOpenTermTyped sc $ - runNilTypeTransM env noChecks (lambdaExprCtx args $ - listSortOpenTerm <$> sequence tps) - return (tm, setIRTVarIdxs ixs) - --- | Types from which we can get IRT type variables, e.g. ValuePerm -class IRTTyVars a where - irtTyVars :: Mb (args :++: ext) a -> - IRTTyVarsTransM args ext ([TypeTransM args OpenTerm], - IRTVarTreeShape) - --- | Get all IRT type variables in a value perm -instance IRTTyVars (ValuePerm a) where - irtTyVars mb_p = case mbMatch mb_p of - [nuMP| ValPerm_Eq _ |] -> return ([], IRTVarsNil) - [nuMP| ValPerm_Or p1 p2 |] -> - do (tps1, ixs1) <- irtTyVars p1 - (tps2, ixs2) <- irtTyVars p2 - return (tps1 ++ tps2, IRTVarsAppend ixs1 ixs2) - [nuMP| ValPerm_Exists p |] -> irtTyVars p -- see the instance for Binding! - [nuMP| ValPerm_Named npn args off |] -> - namedPermIRTTyVars mb_p npn args off - [nuMP| ValPerm_Var x _ |] -> - irtTTranslateVar mb_p x - [nuMP| ValPerm_Conj ps |] -> irtTyVars ps - [nuMP| ValPerm_False |] -> return ([], IRTVarsNil) - --- | Get all IRT type variables in a binding, including any type variables --- from the bound variable -instance (KnownRepr TypeRepr tp, IRTTyVars a) => IRTTyVars (Binding tp a) where - irtTyVars mb_x = - do let tp = mbBindingType mb_x - tp_trans = typeTransTupleType <$> translateClosed tp - xCbn <- irtTMbCombine mb_x - (tps, ixs) <- inExtIRTTyVarsTransM (irtTyVars xCbn) - return (tp_trans : tps, IRTVarsCons () ixs) - --- | Get all IRT type variables in a named permission application. The first --- argument must be either 'ValPerm_Named' or 'Perm_NamedConj' applied to the --- remaining arguments. -namedPermIRTTyVars :: forall args ext a tr ns args' tp. - (Translate TypeTransInfo args a (TypeTrans tr), - Substable PartialSubst a Maybe, NuMatching a) => - Mb (args :++: ext) a -> - Mb (args :++: ext) (NamedPermName ns args' tp) -> - Mb (args :++: ext) (PermExprs args') -> - Mb (args :++: ext) (PermOffset tp) -> - IRTTyVarsTransM args ext ([TypeTransM args OpenTerm], - IRTVarTreeShape) -namedPermIRTTyVars p npn args off = - do npn_args <- irtNus (\ns _ -> namesToExprs ns) - npn_off <- irtNus (\_ _ -> NoPermOffset @tp) - n_rec <- irtTRecName <$> ask - case n_rec of - IRTRecPermName npn_rec - | [nuMP| Just (Refl, Refl, Refl) |] - <- mbMatch $ testNamedPermNameEq npn_rec <$> npn - , npn_args == args, npn_off == off - -> return ([], IRTRecVar) - IRTRecPermName _ - -> throwError $ "recursive permission applied to different" - ++ " arguments in its definition!" - _ -> do env <- irtTPermEnv <$> ask - case lookupNamedPerm env (mbLift npn) of - Just (NamedPerm_Defined dp) -> - irtTyVars (mbMap2 (unfoldDefinedPerm dp) args off) - _ -> do p' <- irtTSubstExt p - let p_trans = typeTransTupleType <$> translate p' - return ([p_trans], IRTVar ()) - --- | Return a singleton list with the type corresponding to the given variable --- if the variable has a type translation - otherwise this function returns --- the empty list. The first argument must be either 'PExpr_Var' or --- @(\x -> 'ValPerm_Var' x off)@ applied to the second argument. -irtTTranslateVar :: (IsTermTrans tr, Translate TypeTransInfo args a tr, - Substable PartialSubst a Maybe, NuMatching a) => - Mb (args :++: ext) a -> Mb (args :++: ext) (ExprVar tp) -> - IRTTyVarsTransM args ext ([TypeTransM args OpenTerm], - IRTVarTreeShape) -irtTTranslateVar p x = - do p' <- irtTSubstExt p - let tm_trans = transTerms <$> translate p' - -- because of 'irtTSubstExt' above, we know x must be a member of args, - -- so we can safely look up its type translation - argsCtx <- irtTArgsCtx <$> ask - extCtx <- irtTExtCtx <$> ask - let err _ = error "arguments to irtTTranslateVar do not match" - memb = mbLift $ fmap (either id err . mbNameBoundP) - (mbSwap extCtx (mbSeparate extCtx x)) - tp_trans = getConst $ RL.get memb argsCtx - -- if x (and thus also p) has no translation, return an empty list - case tp_trans of - [] -> return ([], IRTVarsNil) - _ -> return ([tupleOfTypes <$> tm_trans], IRTVar ()) - --- | Get all IRT type variables in a list -instance (NuMatching a, IRTTyVars a) => IRTTyVars [a] where - irtTyVars mb_xs = - do (tps, ixs) <- unzip <$> mapM irtTyVars (mbList mb_xs) - return (concat tps, IRTVarsConcat ixs) - --- | Get all IRT type variables in an atomic perm -instance IRTTyVars (AtomicPerm a) where - irtTyVars mb_p = case mbMatch mb_p of - [nuMP| Perm_LLVMField fld |] -> - irtTyVars (fmap llvmFieldContents fld) - [nuMP| Perm_LLVMArray mb_ap |] -> - irtTyVars $ mbLLVMArrayCellShape mb_ap - [nuMP| Perm_LLVMBlock bp |] -> - irtTyVars (fmap llvmBlockShape bp) - [nuMP| Perm_LLVMFree _ |] -> return ([], IRTVarsNil) - [nuMP| Perm_LLVMFunPtr _ p |] -> - irtTyVars p - [nuMP| Perm_IsLLVMPtr |] -> return ([], IRTVarsNil) - [nuMP| Perm_LLVMBlockShape sh |] -> - irtTyVars sh - [nuMP| Perm_NamedConj npn args off |] -> - namedPermIRTTyVars mb_p npn args off - [nuMP| Perm_LLVMFrame _ |] -> return ([], IRTVarsNil) - [nuMP| Perm_LOwned _ _ _ _ _ |] -> - throwError "lowned permission in an IRT definition!" - [nuMP| Perm_LOwnedSimple _ _ |] -> - throwError "lowned permission in an IRT definition!" - [nuMP| Perm_LCurrent _ |] -> return ([], IRTVarsNil) - [nuMP| Perm_LFinished |] -> return ([], IRTVarsNil) - [nuMP| Perm_Struct ps |] -> irtTyVars ps - [nuMP| Perm_Fun _ |] -> - throwError "fun perm in an IRT definition!" - [nuMP| Perm_BVProp _ |] -> - throwError "BVProp in an IRT definition!" - [nuMP| Perm_Any |] -> - throwError "any perm in an IRT definition!" - --- | Get all IRT type variables in a shape expression -instance IRTTyVars (PermExpr (LLVMShapeType w)) where - irtTyVars mb_sh = case mbMatch mb_sh of - [nuMP| PExpr_Var x |] -> irtTTranslateVar mb_sh x - [nuMP| PExpr_EmptyShape |] -> return ([], IRTVarsNil) - [nuMP| PExpr_NamedShape maybe_rw maybe_l nmsh args |] -> - do args_rec <- irtNus (\ns _ -> namesToExprs ns) - n_rec <- irtTRecName <$> ask - case n_rec of - IRTRecShapeName w_rec nmsh_rec - | mbLift $ (namedShapeName nmsh_rec ==) . namedShapeName <$> nmsh - , [nuMP| Just Refl |] <- mbMatch $ - testEquality w_rec . shapeLLVMTypeWidth <$> mb_sh - , [nuMP| Just Refl |] <- mbMatch $ - testEquality (namedShapeArgs nmsh_rec) . namedShapeArgs <$> nmsh - , [nuMP| Just Refl |] <- mbMatch $ - testEquality TrueRepr . namedShapeCanUnfoldRepr <$> nmsh - , args_rec == args - , [nuMP| Nothing |] <- mbMatch maybe_rw - , [nuMP| Nothing |] <- mbMatch maybe_l - -> return ([], IRTRecVar) - IRTRecShapeName _ nmsh_rec - | mbLift $ (namedShapeName nmsh_rec ==) . namedShapeName <$> nmsh - -> throwError $ "recursive shape applied to different" - ++ " arguments in its definition!" - _ -> case mbMatch $ namedShapeBody <$> nmsh of - [nuMP| DefinedShapeBody _ |] -> - irtTyVars (mbMap2 unfoldNamedShape nmsh args) - _ | containsIRTRecName n_rec mb_sh -> - throwError ("recursive shape passed to an opaque or" - ++ " recursive shape in its definition!") - _ -> do sh' <- irtTSubstExt mb_sh - let sh_trans = transTupleTerm <$> translate sh' - return ([sh_trans], IRTVar ()) - [nuMP| PExpr_EqShape _ _ |] -> return ([], IRTVarsNil) - [nuMP| PExpr_PtrShape _ _ sh |] -> irtTyVars sh - [nuMP| PExpr_FieldShape fsh |] -> irtTyVars fsh - [nuMP| PExpr_ArrayShape _ _ sh |] -> irtTyVars sh - [nuMP| PExpr_SeqShape sh1 sh2 |] -> - do (tps1, ixs1) <- irtTyVars sh1 - (tps2, ixs2) <- irtTyVars sh2 - return (tps1 ++ tps2, IRTVarsAppend ixs1 ixs2) - [nuMP| PExpr_OrShape sh1 sh2 |] -> - do (tps1, ixs1) <- irtTyVars sh1 - (tps2, ixs2) <- irtTyVars sh2 - return (tps1 ++ tps2, IRTVarsAppend ixs1 ixs2) - [nuMP| PExpr_ExShape sh |] -> irtTyVars sh -- see the instance for Binding! - [nuMP| PExpr_FalseShape |] -> return ([], IRTVarsNil) - --- | Get all IRT type variables in a field shape -instance IRTTyVars (LLVMFieldShape w) where - irtTyVars (mbMatch -> [nuMP| LLVMFieldShape p |]) = irtTyVars p - --- | Get all IRT type variables in a set of value perms -instance IRTTyVars (RAssign ValuePerm ps) where - irtTyVars mb_ps = case mbMatch mb_ps of - [nuMP| ValPerms_Nil |] -> return ([], IRTVarsNil) - [nuMP| ValPerms_Cons ps p |] -> - do (tps1, ixs1) <- irtTyVars ps - (tps2, ixs2) <- irtTyVars p - return (tps1 ++ tps2, IRTVarsAppend ixs1 ixs2) - - ----------------------------------------------------------------------- --- * The IRTDesc translation monad ----------------------------------------------------------------------- - --- | Contextual info for translating IRT type descriptions -data IRTDescTransInfo ctx = - IRTDescTransInfo { irtDExprCtx :: ExprTransCtx ctx, - irtDPermEnv :: PermEnv, - irtDTyVars :: OpenTerm - } - --- | Build an empty 'IRTDescTransInfo' from a 'PermEnv' and type var 'Ident', --- setting 'irtDTyVars' to 'globalOpenTerm' of the given 'Ident' -emptyIRTDescTransInfo :: PermEnv -> Ident -> IRTDescTransInfo RNil -emptyIRTDescTransInfo env tyVarsIdent = - IRTDescTransInfo MNil env (globalOpenTerm tyVarsIdent) - --- | Apply the current 'irtDTyVars' to the current context using --- 'applyOpenTermMulti' - intended to be used only in the args context and --- when the trans info is 'emptyIRTDescTransInfo' (see its usage in --- 'translateCompleteIRTDesc'). --- The result of calling this function appropriately is that 'irtDTyVars' now --- contains a term which is the type variables identifier applied to its --- arguments, no matter how much 'IRTDescTransM's context is extended. This --- term is then used whenever an IRTDesc constructor is applied, see --- 'irtCtorOpenTerm' and 'irtCtor'. -irtDInArgsCtx :: IRTDescTransM args OpenTerm -> IRTDescTransM args OpenTerm -irtDInArgsCtx m = - do args <- askExprCtxTerms - flip local m $ \info -> - info { irtDTyVars = applyOpenTermMulti (irtDTyVars info) args } - -instance TransInfo IRTDescTransInfo where - infoCtx = irtDExprCtx - infoEnv = irtDPermEnv - extTransInfo etrans (IRTDescTransInfo {..}) = - IRTDescTransInfo - { irtDExprCtx = irtDExprCtx :>: etrans - , .. } - --- | The monad for translating IRT type descriptions -type IRTDescTransM = TransM IRTDescTransInfo - --- | Apply the given IRT constructor to the given arguments, using the --- type variable identifier applied to its arguments from the current --- 'IRTDescTransInfo' for the first argument -irtCtorOpenTerm :: Ident -> [OpenTerm] -> IRTDescTransM ctx OpenTerm -irtCtorOpenTerm c all_args = - do tyVarsTm <- irtDTyVars <$> ask - return $ ctorOpenTerm c (tyVarsTm : all_args) - --- | Like 'tupleOfTypes' but with @IRT_prod@ -irtProd :: [OpenTerm] -> IRTDescTransM ctx OpenTerm -irtProd [] = irtCtorOpenTerm "Prelude.IRT_unit" [] -irtProd [x] = return x -irtProd (x:xs) = - irtProd xs >>= \xs' -> irtCtorOpenTerm "Prelude.IRT_prod" [x, xs'] - --- | A singleton list containing the result of 'irtCtorOpenTerm' -irtCtor :: Ident -> [OpenTerm] -> IRTDescTransM ctx [OpenTerm] -irtCtor c all_args = - do tm <- irtCtorOpenTerm c all_args - return [tm] - - ----------------------------------------------------------------------- --- * Translating IRT type descriptions ----------------------------------------------------------------------- - --- | Given an identifier whose definition in the shared context is the first --- result of calling 'translateCompletePermIRTTyVars' or --- 'translateCompleteShapeIRTTyVars' on the same argument context and --- recursive permission/shape body given here, and an 'IRTVarIdxs' which is --- the second result of the same call to 'translateCompletePermIRTTyVars', --- translate the given recursive permission body to an IRT type description -translateCompleteIRTDesc :: IRTDescs a => SharedContext -> PermEnv -> - Ident -> CruCtx args -> - Mb args a -> IRTVarIdxs -> IO TypedTerm -translateCompleteIRTDesc sc env tyVarsIdent args p ixs = - do tm <- completeOpenTerm sc $ - runTransM (lambdaExprCtx args . irtDInArgsCtx $ - do in_mu <- irtDesc p ixs - irtCtorOpenTerm "Prelude.IRT_mu" [in_mu]) - (emptyIRTDescTransInfo env tyVarsIdent) - -- we manually give the type because we want to keep 'tyVarsIdent' folded - let irtDescOpenTerm ectx = return $ - dataTypeOpenTerm "Prelude.IRTDesc" - [ applyOpenTermMulti (globalOpenTerm tyVarsIdent) - (exprCtxToTerms ectx) ] - tp <- completeOpenTerm sc $ - runNilTypeTransM env noChecks (translateClosed args >>= \tptrans -> - piTransM "e" tptrans irtDescOpenTerm) - return $ TypedTerm tm tp - --- | Types from which we can get IRT type descriptions, e.g. ValuePerm -class IRTDescs a where - irtDescs :: Mb ctx a -> IRTVarIdxs -> IRTDescTransM ctx [OpenTerm] - --- | Like 'irtDescs', but returns the single IRTDesc associated to the input. --- This function simply applies 'irtProd' to the output of 'irtDescs'. -irtDesc :: IRTDescs a => Mb ctx a -> IRTVarIdxs -> IRTDescTransM ctx OpenTerm -irtDesc x ixs = irtDescs x ixs >>= irtProd - --- | Get the IRTDescs associated to a value perm -instance IRTDescs (ValuePerm a) where - irtDescs mb_p ixs = case (mbMatch mb_p, ixs) of - ([nuMP| ValPerm_Eq _ |], _) -> return [] - ([nuMP| ValPerm_Or p1 p2 |], IRTVarsAppend ixs1 ixs2) -> - do x1 <- irtDesc p1 ixs1 - x2 <- irtDesc p2 ixs2 - irtCtor "Prelude.IRT_Either" [x1, x2] - ([nuMP| ValPerm_Exists p |], IRTVarsCons ix _) - | [nuMP| ValPerm_Eq _ |] <- mbMatch (mbCombine RL.typeCtxProxies p) -> - irtCtor "Prelude.IRT_varT" [natOpenTerm ix] - ([nuMP| ValPerm_Exists p |], IRTVarsCons ix ixs') -> - do let tp = mbBindingType p - tp_trans <- tupleTypeTrans <$> translateClosed tp - xf <- lambdaTransM "x_irt" tp_trans (\x -> inExtTransM x $ - irtDesc (mbCombine RL.typeCtxProxies p) ixs') - irtCtor "Prelude.IRT_sigT" [natOpenTerm ix, xf] - ([nuMP| ValPerm_Named npn args off |], _) -> - namedPermIRTDescs npn args off ixs - ([nuMP| ValPerm_Var _ _ |], _) -> irtVarTDesc ixs - ([nuMP| ValPerm_Conj ps |], _) -> irtDescs ps ixs - _ -> error $ "malformed IRTVarIdxs: " ++ show ixs - --- | Get the IRTDescs associated to a named perm -namedPermIRTDescs :: Mb ctx (NamedPermName ns args tp) -> - Mb ctx (PermExprs args) -> - Mb ctx (PermOffset tp) -> IRTVarIdxs -> - IRTDescTransM ctx [OpenTerm] -namedPermIRTDescs npn args off ixs = case ixs of - IRTRecVar -> irtCtor "Prelude.IRT_varD" [natOpenTerm 0] - _ -> do env <- infoEnv <$> ask - case (lookupNamedPerm env (mbLift npn), ixs) of - (Just (NamedPerm_Defined dp), _) -> - irtDescs (mbMap2 (unfoldDefinedPerm dp) args off) ixs - (_, IRTVar ix) -> irtCtor "Prelude.IRT_varT" [natOpenTerm ix] - _ -> error $ "malformed IRTVarIdxs: " ++ show ixs - --- | Get the IRTDescs associated to a variable -irtVarTDesc :: IRTVarIdxs -> IRTDescTransM ctx [OpenTerm] -irtVarTDesc ixs = case ixs of - IRTVarsNil -> return [] - IRTVar ix -> irtCtor "Prelude.IRT_varT" [natOpenTerm ix] - _ -> error $ "malformed IRTVarIdxs: " ++ show ixs - --- | Get the IRTDescs associated to a list -instance (NuMatching a, IRTDescs a) => IRTDescs [a] where - irtDescs mb_xs ixs = case ixs of - IRTVarsConcat ixss -> concat <$> zipWithM irtDescs (mbList mb_xs) ixss - _ -> error $ "malformed IRTVarIdxs: " ++ show ixs - --- | Get the IRTDescs associated to an atomic perm -instance IRTDescs (AtomicPerm a) where - irtDescs mb_p ixs = case (mbMatch mb_p, ixs) of - ([nuMP| Perm_LLVMField fld |], _) -> - irtDescs (fmap llvmFieldContents fld) ixs - ([nuMP| Perm_LLVMArray mb_ap |], _) -> - do let w = natVal2 mb_ap - w_term = natOpenTerm w - len_term <- translate1 (fmap llvmArrayLen mb_ap) - sh_desc_term <- irtDesc (mbLLVMArrayCellShape mb_ap) ixs - irtCtor "Prelude.IRT_BVVec" [w_term, len_term, sh_desc_term] - ([nuMP| Perm_LLVMBlock bp |], _) -> - irtDescs (fmap llvmBlockShape bp) ixs - ([nuMP| Perm_LLVMFree _ |], _) -> return [] - ([nuMP| Perm_LLVMFunPtr _ p |], _) -> - irtDescs p ixs - ([nuMP| Perm_IsLLVMPtr |], _) -> return [] - ([nuMP| Perm_LLVMBlockShape sh |], _) -> - irtDescs sh ixs - ([nuMP| Perm_NamedConj npn args off |], _) -> - namedPermIRTDescs npn args off ixs - ([nuMP| Perm_LLVMFrame _ |], _) -> return [] - ([nuMP| Perm_LOwned _ _ _ _ _ |], _) -> - error "lowned permission made it to IRTDesc translation" - ([nuMP| Perm_LOwnedSimple _ _ |], _) -> - error "lowned permission made it to IRTDesc translation" - ([nuMP| Perm_LCurrent _ |], _) -> return [] - ([nuMP| Perm_LFinished |], _) -> return [] - ([nuMP| Perm_Struct ps |], _) -> - irtDescs ps ixs - ([nuMP| Perm_Fun _ |], _) -> - error "fun perm made it to IRTDesc translation" - ([nuMP| Perm_BVProp _ |], _) -> - error "BVProp made it to IRTDesc translation" - ([nuMP| Perm_Any |], _) -> - error "any perm made it to IRTDesc translation" - --- | Get the IRTDescs associated to a shape expression -instance IRTDescs (PermExpr (LLVMShapeType w)) where - irtDescs mb_expr ixs = case (mbMatch mb_expr, ixs) of - ([nuMP| PExpr_Var _ |], _) -> irtVarTDesc ixs - ([nuMP| PExpr_EmptyShape |], _) -> return [] - ([nuMP| PExpr_EqShape _ _ |], _) -> return [] - ([nuMP| PExpr_NamedShape _ _ nmsh args |], _) -> - case (mbMatch $ namedShapeBody <$> nmsh, ixs) of - (_, IRTRecVar) -> - irtCtor "Prelude.IRT_varD" [natOpenTerm 0] - ([nuMP| DefinedShapeBody _ |], _) -> - irtDescs (mbMap2 unfoldNamedShape nmsh args) ixs - (_, IRTVar ix) -> irtCtor "Prelude.IRT_varT" [natOpenTerm ix] - _ -> error $ "malformed IRTVarIdxs: " ++ show ixs - ([nuMP| PExpr_PtrShape _ _ sh |], _) -> - irtDescs sh ixs - ([nuMP| PExpr_FieldShape fsh |], _) -> - irtDescs fsh ixs - ([nuMP| PExpr_ArrayShape mb_len _ mb_sh |], _) -> - do let w = natVal4 mb_len - w_term = natOpenTerm w - len_term <- translate1 mb_len - sh_desc_term <- irtDesc mb_sh ixs - irtCtor "Prelude.IRT_BVVec" [w_term, len_term, sh_desc_term] - ([nuMP| PExpr_SeqShape sh1 sh2 |], IRTVarsAppend ixs1 ixs2) -> - do x1 <- irtDesc sh1 ixs1 - x2 <- irtDesc sh2 ixs2 - irtCtor "Prelude.IRT_prod" [x1, x2] - ([nuMP| PExpr_OrShape sh1 sh2 |], IRTVarsAppend ixs1 ixs2) -> - do x1 <- irtDesc sh1 ixs1 - x2 <- irtDesc sh2 ixs2 - irtCtor "Prelude.IRT_Either" [x1, x2] - ([nuMP| PExpr_ExShape mb_sh |], IRTVarsCons ix ixs') -> - do let tp = mbBindingType mb_sh - tp_trans <- tupleTypeTrans <$> translateClosed tp - xf <- lambdaTransM "x_irt" tp_trans (\x -> inExtTransM x $ - irtDesc (mbCombine RL.typeCtxProxies mb_sh) ixs') - irtCtor "Prelude.IRT_sigT" [natOpenTerm ix, xf] - _ -> error $ "malformed IRTVarIdxs: " ++ show ixs - --- | Get the IRTDescs associated to a field shape -instance IRTDescs (LLVMFieldShape w) where - irtDescs (mbMatch -> [nuMP| LLVMFieldShape p |]) ixs = irtDescs p ixs - --- | Get the IRTDescs associated to a set of value perms -instance IRTDescs (RAssign ValuePerm ps) where - irtDescs mb_ps ixs = case (mbMatch mb_ps, ixs) of - ([nuMP| ValPerms_Nil |], _) -> return [] - ([nuMP| ValPerms_Cons ps p |], IRTVarsAppend ixs1 ixs2) -> - do xs <- irtDescs ps ixs1 - x <- irtDescs p ixs2 - return $ xs ++ x - _ -> error $ "malformed IRTVarIdxs: " ++ show ixs - - ----------------------------------------------------------------------- --- * Translating IRT definitions ----------------------------------------------------------------------- - --- | Given identifiers whose definitions in the shared context are the results --- of corresponding calls to 'translateCompleteIRTDesc' and --- 'translateCompletePermIRTTyVars' or 'translateCompleteShapeIRTTyVars', --- return a term which is @IRT@ applied to these identifiers -translateCompleteIRTDef :: SharedContext -> PermEnv -> - Ident -> Ident -> CruCtx args -> - IO TypedTerm -translateCompleteIRTDef sc env tyVarsIdent descIdent args = - completeOpenTermTyped sc $ - runNilTypeTransM env noChecks (lambdaExprCtx args $ - irtDefinition tyVarsIdent descIdent) - --- | Given identifiers whose definitions in the shared context are the results --- of corresponding calls to 'translateCompleteIRTDef', --- 'translateCompleteIRTDesc', and 'translateCompletePermIRTTyVars' or --- 'translateCompleteShapeIRTTyVars', return a term which is @foldIRT@ applied --- to these identifiers -translateCompleteIRTFoldFun :: SharedContext -> PermEnv -> - Ident -> Ident -> Ident -> CruCtx args -> - IO Term -translateCompleteIRTFoldFun sc env tyVarsIdent descIdent _ args = - completeOpenTerm sc $ - runNilTypeTransM env noChecks (lambdaExprCtx args $ - irtFoldFun tyVarsIdent descIdent) - --- | Given identifiers whose definitions in the shared context are the results --- of corresponding calls to 'translateCompleteIRTDef', --- 'translateCompleteIRTDesc', and 'translateCompletePermIRTTyVars' or --- 'translateCompleteShapeIRTTyVars', return a term which is @unfoldIRT@ --- applied to these identifiers -translateCompleteIRTUnfoldFun :: SharedContext -> PermEnv -> - Ident -> Ident -> Ident -> CruCtx args -> - IO Term -translateCompleteIRTUnfoldFun sc env tyVarsIdent descIdent _ args = - completeOpenTerm sc $ - runNilTypeTransM env noChecks (lambdaExprCtx args $ - irtUnfoldFun tyVarsIdent descIdent) - --- | Get the terms for the arguments to @IRT@, @foldIRT@, and @unfoldIRT@ --- given the appropriate identifiers -irtDefArgs :: Ident -> Ident -> TypeTransM args (OpenTerm, OpenTerm, OpenTerm) -irtDefArgs tyVarsIdent descIdent = - do args <- askExprCtxTerms - let tyVars = applyOpenTermMulti (globalOpenTerm tyVarsIdent) args - substs = ctorOpenTerm "Prelude.IRTs_Nil" [tyVars] - desc = applyOpenTermMulti (globalOpenTerm descIdent) args - return (tyVars, substs, desc) - -irtDefinition :: Ident -> Ident -> TypeTransM args OpenTerm -irtDefinition tyVarsIdent descIdent = - do (tyVars, substs, desc) <- irtDefArgs tyVarsIdent descIdent - return $ dataTypeOpenTerm "Prelude.IRT" [tyVars, substs, desc] - -irtFoldFun :: Ident -> Ident -> TypeTransM args OpenTerm -irtFoldFun tyVarsIdent descIdent = - do (tyVars, substs, desc) <- irtDefArgs tyVarsIdent descIdent - return $ applyOpenTermMulti (globalOpenTerm "Prelude.foldIRT") - [tyVars, substs, desc] - -irtUnfoldFun :: Ident -> Ident -> TypeTransM args OpenTerm -irtUnfoldFun tyVarsIdent descIdent = - do (tyVars, substs, desc) <- irtDefArgs tyVarsIdent descIdent - return $ applyOpenTermMulti (globalOpenTerm "Prelude.unfoldIRT") - [tyVars, substs, desc] diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs b/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs index 620a3d77a0..e86cb7649d 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs @@ -62,6 +62,7 @@ import Verifier.SAW.Term.Functor (Ident) import Lang.Crucible.LLVM.Bytes import Data.Binding.Hobbits +import Verifier.SAW.Utils (panic) import Verifier.SAW.Heapster.CruUtil import Verifier.SAW.Heapster.PatternMatchUtil import Verifier.SAW.Heapster.Permissions @@ -972,7 +973,7 @@ data SimplImpl ps_in ps_out where -- 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](x:F, ps_in -o x:F, 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 @@ -1118,6 +1119,20 @@ data SimplImpl ps_in ps_out where (1 <= w, KnownNat w) => 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) @@ -1465,7 +1480,9 @@ data PermImpl1 ps_in ps_outs where -- same input permissions to both branches: -- -- > ps -o ps \/ ps - Impl1_Catch :: PermImpl1 ps (RNil :> '(RNil, ps) :> '(RNil, 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: -- @@ -1484,7 +1501,11 @@ data PermImpl1 ps_in ps_outs where -- -- > ps * x:(p1 \/ (p2 \/ (... \/ pn))) -- > -o (ps * x:p1) \/ ... \/ (ps * x:pn) - Impl1_ElimOrs :: ExprVar a -> OrList ps a disjs -> PermImpl1 (ps :> a) disjs + -- + -- 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: -- @@ -1635,7 +1656,7 @@ type OrList ps a = RAssign (OrListDisj ps a) -- 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@. +-- \"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 @@ -1665,7 +1686,7 @@ data MbPermImpls r bs_pss where newtype LocalPermImpl ps_in ps_out = LocalPermImpl (PermImpl (LocalImplRet ps_out) ps_in) --- | The "success" condition of a 'LocalPermImpl', which essentially is just a +-- | 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') @@ -1845,15 +1866,15 @@ permImplCatch pimpl1 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 +-- | 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 +permImplSucceeds (PermImpl_Step (Impl1_Catch _) (MbPermImpls_Cons _ (MbPermImpls_Cons _ _ mb_impl1) mb_impl2)) = max (mbLift $ fmap permImplSucceeds mb_impl1) (mbLift $ fmap permImplSucceeds mb_impl2) @@ -1861,7 +1882,7 @@ 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) = +permImplSucceeds (PermImpl_Step (Impl1_ElimOrs _ _ _) mb_impls) = mbImplsSucc mb_impls where mbImplsSucc :: MbPermImpls r ps_outs -> Int mbImplsSucc MbPermImpls_Nil = 0 @@ -2156,6 +2177,11 @@ 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) = @@ -2478,14 +2504,10 @@ simplImplOut (SImpl_LLVMBlockIsPtr x 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 - (appendCruCtx (singletonCruCtx $ exprType x) tps_in) - (appendCruCtx (singletonCruCtx $ exprType x) tps_out) - (RL.append (MNil :>: - ExprAndPerm (PExpr_Var x) - (ltFuncMinApply f (PExpr_Var l2))) ps_in) - (RL.append (MNil :>: - ExprAndPerm (PExpr_Var x) - (ltFuncApply f args l)) ps_out)) + (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) = @@ -2537,6 +2559,11 @@ simplImplOut (SImpl_CoerceLLVMBlockEmpty x bp) = 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 = @@ -2766,7 +2793,7 @@ mbOrListPermImpls 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 _ (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 @@ -2790,7 +2817,7 @@ applyImpl1 pp_info (Impl1_Pop x p) ps = 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 = +applyImpl1 _ (Impl1_ElimOrs _ x or_list) ps = if ps ^. topDistPerm x == orListPerm or_list then orListMbPermSets ps x or_list else @@ -3162,6 +3189,10 @@ instance m ~ Identity => 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 |] -> @@ -3256,13 +3287,13 @@ 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 |] -> return Impl1_Catch + [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 x or_list |] -> - Impl1_ElimOrs <$> genSubst s x <*> genSubst s or_list + [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 |] -> @@ -3964,6 +3995,11 @@ implDebugM reqlvl 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 @@ -4001,10 +4037,10 @@ 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 ("Inserting catch in " ++ f ++ " for proving:") - <> line <> permPretty i p) >>> + implTraceM (\i -> pretty ("Catch in " ++ f ++ " for proving:") + <> line <> permPretty i p) >>>= \catch_str -> implApplyImpl1 - Impl1_Catch + (Impl1_Catch catch_str) (MNil :>: Impl1Cont (const $ implTraceM (\i -> pretty ("Case 1 of catch in " ++ f @@ -4017,9 +4053,9 @@ implCatchM f p m1 m2 = <> line <> permPretty i p) >>> m2)) --- | "Push" all of the permissions in the permission set for a variable, which +-- | \"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@. +-- 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 = @@ -4071,8 +4107,8 @@ 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 p) >>> - implApplyImpl1 (Impl1_ElimOrs x or_list) + 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" @@ -4455,7 +4491,7 @@ elimOrsExistsNamesM x = p -> pure p -- | Eliminate any disjunctions, existentials, recursive permissions, or defined --- permissions for a variable and then return the resulting "simple" permission +-- 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 = @@ -4745,7 +4781,7 @@ 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 +-- 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) -> @@ -5453,7 +5489,7 @@ implElimLLVMBlock :: (1 <= w, KnownNat w, NuMatchingAny1 r) => 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 +-- 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 @@ -5514,6 +5550,10 @@ implElimLLVMBlock x bp -- 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 @@ -5632,9 +5672,9 @@ permIndicesForProvingOffset ps imprecise_p off = -- 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 +-- 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@ @@ -6142,6 +6182,16 @@ proveEqH psubst e mb_e = case (e, mbMatch mb_e) of 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 @@ -6583,7 +6633,7 @@ solveForPermListImplH vars ps_l (CruCtxCons 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 +-- 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 @@ -6991,8 +7041,8 @@ proveVarLLVMArray x ps mb_ap = -- -- 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. +-- 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 @@ -7972,6 +8022,35 @@ proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps 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 @@ -8802,7 +8881,7 @@ proveVarConjImpl x ps_lhs mb_ps = ---------------------------------------------------------------------- -- | Prove @x:p'@, where @p@ may have existentially-quantified variables in --- it. The "@Int@" suffix indicates that this call is internal to the +-- 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) -> @@ -9146,7 +9225,7 @@ 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 +-- | 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 = diff --git a/heapster-saw/src/Verifier/SAW/Heapster/LLVMGlobalConst.hs b/heapster-saw/src/Verifier/SAW/Heapster/LLVMGlobalConst.hs index da6e07c0bb..c203a8b2f4 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/LLVMGlobalConst.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/LLVMGlobalConst.hs @@ -32,12 +32,15 @@ import Lang.Crucible.LLVM.DataLayout import Lang.Crucible.LLVM.MemModel import Lang.Crucible.LLVM.PrettyPrint +import Verifier.SAW.Name (mkSafeIdent) import Verifier.SAW.OpenTerm import Verifier.SAW.Term.Functor (ModuleName) import Verifier.SAW.SharedTerm import Verifier.SAW.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 @@ -94,27 +97,26 @@ ppLLVMConstExpr :: L.ConstExpr -> String ppLLVMConstExpr ce = ppLLVMLatest (show $ PPHPJ.nest 2 $ L.ppConstExpr ce) --- | Translate a typed LLVM 'L.Value' to a Heapster shape + an element of the --- translation of that shape to a SAW core type +-- | 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) + 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) + return (sh, [bvLitOfIntOpenTerm (fromIntegral n) i]) translateLLVMValue w _ (L.ValSymbol sym) = do env <- llvmTransInfoEnv <$> ask -- (p, ts) <- lift (lookupGlobalSymbol env (GlobalSymbol sym) w) - (p, t) <- case (lookupGlobalSymbol env (GlobalSymbol sym) w) of - Just (p, Right [t]) -> return (p,t) - Just (p, Right ts) -> return (p,tupleOpenTerm ts) - Just (_, Left _) -> error "translateLLVMValue: Unexpected recursive call" + (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), t) + return (PExpr_FieldShape (LLVMFieldShape p), ts) translateLLVMValue w _ (L.ValArray tp elems) = do -- First, translate the elements and their type - ts <- map snd <$> mapM (translateLLVMValue w tp) elems - (sh, saw_tp) <- translateLLVMType w tp + 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 @@ -122,22 +124,26 @@ translateLLVMValue w _ (L.ValArray tp elems) = -- Generate a default element of type tp using the zero initializer; this is -- currently needed by bvVecValueOpenTerm - (_,def_tm) <- translateZeroInit w tp + (_,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) + [bvVecValueOpenTerm w saw_tp ts def_tm]) translateLLVMValue w _ (L.ValPackedStruct elems) = - mapM (translateLLVMTypedValue w) elems >>= \(unzip -> (shs,ts)) -> - return (foldr PExpr_SeqShape PExpr_EmptyShape shs, tupleOpenTerm ts) + 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 - return (sh, tm) + -- 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 {- @@ -166,13 +172,13 @@ translateLLVMValue _ _ v = -- | Helper function for 'translateLLVMValue' translateLLVMTypedValue :: (1 <= w, KnownNat w) => NatRepr w -> L.Typed L.Value -> - LLVMTransM (PermExpr (LLVMShapeType w), OpenTerm) + 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 type of elements of --- the translation of that shape +-- | 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) + 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 = @@ -180,14 +186,14 @@ translateLLVMType _ (L.PrimType (L.Integer n)) return (PExpr_FieldShape (LLVMFieldShape $ ValPerm_Exists $ nu $ \bv -> ValPerm_Eq $ PExpr_LLVMWord $ PExpr_Var (bv :: Name (BVType n))), - (bvTypeOpenTerm 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) + 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 @@ -212,9 +218,9 @@ translateLLVMConstExpr _ ce = -- 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) -> + (PermExpr (LLVMShapeType w), [OpenTerm]) -> [L.Typed L.Value] -> - LLVMTransM (PermExpr (LLVMShapeType w), OpenTerm) + LLVMTransM (PermExpr (LLVMShapeType w), [OpenTerm]) translateLLVMGEP _ tp vtrans ixs | all (isZeroIdx . L.typedValue) ixs = return vtrans @@ -229,13 +235,15 @@ translateLLVMGEP _ tp vtrans ixs -- | 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) + 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_tm) <- translateZeroInit w tp - (_, saw_tp) <- translateLLVMType w tp + 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 @@ -244,20 +252,21 @@ translateZeroInit w (L.Array len tp) = 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) + [repeatBVVecOpenTerm w saw_len saw_tp elem_tm]) translateZeroInit w (L.PackedStruct tps) = - mapM (translateZeroInit w) tps >>= \(unzip -> (shs,ts)) -> - return (foldr PExpr_SeqShape PExpr_EmptyShape shs, tupleOpenTerm ts) + 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) + Maybe (PermExpr (LLVMShapeType w), [OpenTerm]) translateLLVMValueTop dlevel endianness w env global = let sym = show (L.globalSym global) in let trans_info = LLVMTransInfo { llvmTransInfoEnv = env, @@ -267,7 +276,10 @@ translateLLVMValueTop dlevel endianness w env global = maybe "None" ppLLVMValue (L.globalValue global)) $ (\x -> case x of - Just _ -> debugTraceTraceLvl dlevel (sym ++ " translated") x + 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 @@ -281,15 +293,21 @@ permEnvAddGlobalConst :: (1 <= w, KnownNat w) => SharedContext -> ModuleName -> permEnvAddGlobalConst sc mod_name dlevel endianness w env global = case translateLLVMValueTop dlevel endianness w env global of Nothing -> return env - Just (sh, t) -> + 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 - tp <- completeOpenTermType sc t - scInsertDef sc mod_name ident tp complete_t + let tps = map openTermType ts + complete_tp <- completeOpenTerm sc $ tupleTypeOpenTerm' tps + scInsertDef sc mod_name ident complete_tp complete_t let p = ValPerm_LLVMBlock $ llvmReadBlockOfShape sh - let t_ident = globalOpenTerm ident return $ permEnvAddGlobalSyms env - [PermEnvGlobalEntry (GlobalSymbol $ - L.globalSym global) p (Right [t_ident])] + [PermEnvGlobalEntry (GlobalSymbol $ L.globalSym global) p + (GlobalTrans [globalOpenTerm ident])] diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Lexer.x b/heapster-saw/src/Verifier/SAW/Heapster/Lexer.x index 3dca3dc4d6..3e09d39192 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Lexer.x +++ b/heapster-saw/src/Verifier/SAW/Heapster/Lexer.x @@ -69,6 +69,7 @@ $white+ ; "ptrsh" { token_ TPtrSh } "fieldsh" { token_ TFieldSh } "arraysh" { token_ TArraySh } +"tuplesh" { token_ TTupleSh } "exsh" { token_ TExSh } "orsh" { token_ TOrSh } "memblock" { token_ TMemBlock } diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Parser.y b/heapster-saw/src/Verifier/SAW/Heapster/Parser.y index 5a93de1d8d..0430c30ade 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Parser.y +++ b/heapster-saw/src/Verifier/SAW/Heapster/Parser.y @@ -82,6 +82,7 @@ import Verifier.SAW.Heapster.UntypedAST 'ptrsh' { Located $$ TPtrSh } 'fieldsh' { Located $$ TFieldSh } 'arraysh' { Located $$ TArraySh } +'tuplesh' { Located $$ TTupleSh } 'exsh' { Located $$ TExSh } 'orsh' { Located $$ TOrSh } 'memblock' { Located $$ TMemBlock } @@ -173,6 +174,7 @@ expr :: { AstExpr } | 'fieldsh' '(' expr ')' { ExFieldSh (pos $1) Nothing $3 } | 'arraysh' '(' '<' expr ',' '*' expr ',' expr ')' { ExArraySh (pos $1) $4 $7 $9 } + | 'tuplesh' '(' expr ')' { ExTupleSh (pos $1) $3 } | 'exsh' IDENT ':' type '.' expr { ExExSh (pos $1) (locThing $2) $4 $6 } -- Value Permissions diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs index fc38f5c7ac..acf3677232 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs @@ -29,9 +29,7 @@ module Verifier.SAW.Heapster.Permissions where import Prelude hiding (pred) -import Numeric (showHex) import Data.Char -import qualified Data.Text as Text import Data.Word import Data.Maybe import Data.Either @@ -53,7 +51,7 @@ 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 (MonadPlus(..), (>=>)) import Control.Monad.Extra (concatMapM) import Control.Monad.Identity () import Control.Monad.Reader (MonadReader(..), Reader, ReaderT(..), runReader) @@ -81,14 +79,13 @@ import Data.Parameterized.Pair import Prettyprinter as PP import Prettyprinter.Render.String (renderString) +import Verifier.SAW.Utils (panic) 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 Verifier.SAW.Term.Functor (ModuleName) -import Verifier.SAW.Module import Verifier.SAW.SharedTerm hiding (Constant) import Verifier.SAW.OpenTerm import Verifier.SAW.Heapster.NamedMb @@ -111,7 +108,7 @@ 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 +-- 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) @@ -166,7 +163,7 @@ 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 +-- | 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 @@ -254,15 +251,18 @@ data PermExpr (a :: CrucibleType) where 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 + -- | 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) @@ -376,7 +376,7 @@ data AtomicPerm (a :: CrucibleType) where Perm_LLVMFree :: (1 <= w, KnownNat w) => PermExpr (BVType w) -> AtomicPerm (LLVMPointerType w) - -- | Says that we known an LLVM value is a function pointer whose function has + -- | 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) -> @@ -405,13 +405,13 @@ data AtomicPerm (a :: CrucibleType) where -- | 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. + -- 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] -> @@ -456,8 +456,8 @@ data AtomicPerm (a :: CrucibleType) where -- | 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). +-- (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 @@ -522,7 +522,7 @@ data LLVMArrayIndex 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/, +-- \"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 = @@ -658,18 +658,21 @@ data NamedShapeBody b args w where DefinedShapeBody :: Mb args (PermExpr (LLVMShapeType w)) -> NamedShapeBody 'True args w - -- | An opaque shape has no body, just a length and a translation to a type - OpaqueShapeBody :: Mb args (PermExpr (BVType w)) -> Ident -> + -- | 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 - -- identifiers for the type it is translated to, along with fold and unfold - -- functions for mapping to and from this type. The fold and unfold functions - -- can be undefined if we are in the process of defining this recusive shape. + -- 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 -> Maybe (Ident, Ident) -> - NamedShapeBody 'True args 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...?) @@ -692,7 +695,8 @@ data NamedPerm ns args a where -- identifier that it is translated to data OpaquePerm b args a = OpaquePerm { opaquePermName :: NamedPermName (OpaqueSort b) args a, - opaquePermTrans :: Ident + opaquePermTrans :: Ident, + opaquePermTransDesc :: Ident } -- | The interpretation of a recursive permission as a reachability permission. @@ -716,22 +720,26 @@ data ReachMethods reach args a where } -> ReachMethods (args :> a) a 'True NoReachMethods :: ReachMethods args a 'False --- | A recursive permission is a disjunction of 1 or more permissions, each of --- which can contain the recursive permission itself. NOTE: it is an error to --- have an empty list of cases. A recursive permission is also associated with a --- SAW datatype, given by a SAW 'Ident', and each disjunctive permission case is --- associated with a constructor of that datatype. The @b@ flag indicates --- whether this recursive permission can be used as an atomic permission, which --- should be 'True' iff all of the cases are conjunctive permissions as in --- 'isConjPerm'. If the recursive permission is a reachability permission, then --- it also has a 'ReachMethods' structure. +-- | 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, - recPermFoldFun :: Ident, - recPermUnfoldFun :: Ident, + recPermTransDesc :: Ident, recPermReachMethods :: ReachMethods args a reach, - recPermCases :: [Mb args (ValuePerm a)] + recPermBody :: Mb (args :> ValuePermType a) (ValuePerm a) } -- | A defined permission is a name and a permission to which it is @@ -747,7 +755,7 @@ data DefinedPerm b args a = DefinedPerm { -- 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 +-- | A list of \"distinguished\" permissions to named variables -- FIXME: just call these VarsAndPerms or something like that... type DistPerms = RAssign VarAndPerm @@ -854,6 +862,11 @@ 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 @@ -861,8 +874,7 @@ data SomeNamedShape where data PermEnvGlobalEntry where PermEnvGlobalEntry :: (1 <= w, KnownNat w) => GlobalSymbol -> ValuePerm (LLVMPointerType w) -> - Either Natural [OpenTerm] -> - PermEnvGlobalEntry + GlobalTrans -> PermEnvGlobalEntry -- | The different sorts hints for blocks data BlockHintSort args where @@ -884,14 +896,10 @@ data BlockHint blocks init ret args where BlockID blocks args -> BlockHintSort args -> BlockHint blocks init ret args --- | A "hint" from the user for type-checking +-- | A \"hint\" from the user for type-checking data Hint where Hint_Block :: BlockHint blocks init ret args -> Hint --- | The default event type uses the @Void@ type for events -defaultSpecMEventType :: Ident -defaultSpecMEventType = fromString "Prelude.VoidEv" - -- | A permission environment that maps function names, permission names, and -- 'GlobalSymbols' to their respective permission structures data PermEnv = PermEnv { @@ -900,9 +908,13 @@ data PermEnv = PermEnv { permEnvNamedShapes :: [SomeNamedShape], permEnvGlobalSyms :: [PermEnvGlobalEntry], permEnvHints :: [Hint], - permEnvSpecMEventType :: Ident + permEnvEventType :: EventType } +-- | Get the 'EventType' of a 'PermEnv' as a SAW core term +permEnvEventTypeTerm :: PermEnv -> OpenTerm +permEnvEventTypeTerm = evTypeTerm . permEnvEventType + ---------------------------------------------------------------------- -- * Template Haskell–generated instances @@ -960,11 +972,13 @@ $(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... @@ -1084,34 +1098,6 @@ nameSetFromFlags ns flags = data RecurseFlag = RecLeft | RecRight | RecNone deriving (Eq, Show, Read) --- | Make a "coq-safe" identifier from a string that might contain --- non-identifier characters, where we use the SAW core notion of identifier --- characters as letters, digits, underscore and primes. Any disallowed --- character is mapped to the string @__xNN@, where @NN@ is the hexadecimal code --- for that character. Additionally, a SAW core identifier is not allowed to --- start with a prime, so a leading underscore is added in such a case. -mkSafeIdent :: ModuleName -> String -> Ident -mkSafeIdent _ [] = fromString "_" -mkSafeIdent mnm nm = - let is_safe_char c = isAlphaNum c || c == '_' || c == '\'' in - mkIdent mnm $ Text.pack $ - (if nm!!0 == '\'' then ('_' :) else id) $ - concatMap - (\c -> if is_safe_char c then [c] else - "__x" ++ showHex (ord c) "") - nm - --- | Insert a definition into a SAW core module -scInsertDef :: SharedContext -> ModuleName -> Ident -> Term -> Term -> IO () -scInsertDef sc mnm ident def_tp def_tm = - do t <- scConstant' sc (ModuleIdentifier ident) def_tm def_tp - scRegisterGlobal sc ident t - scModifyModule sc mnm $ \m -> - insDef m $ Def { defIdent = ident, - defQualifier = NoQualifier, - defType = def_tp, - defBody = Just def_tm } - ---------------------------------------------------------------------- -- * Pretty-printing @@ -1168,8 +1154,8 @@ 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 +-- 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. @@ -1701,6 +1687,9 @@ instance Eq (PermExpr a) where 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 @@ -1782,6 +1771,9 @@ instance PermPretty (PermExpr a) where 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 @@ -1837,7 +1829,7 @@ pattern PExpr_Write = PExpr_RWModality Write pattern PExpr_Read :: PermExpr RWModalityType pattern PExpr_Read = PExpr_RWModality Read --- | Build a "default" expression for a given type +-- | 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 @@ -1946,8 +1938,8 @@ bvZeroable (PExpr_BV _ _) = -- | 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. +-- 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 @@ -1957,10 +1949,10 @@ 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@. +-- 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 @@ -1969,9 +1961,9 @@ 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@. +-- 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) = @@ -1989,7 +1981,7 @@ 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 +-- 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'. @@ -2007,9 +1999,9 @@ 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 +-- | 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. +-- 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) @@ -2207,7 +2199,7 @@ 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, +-- | 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 @@ -2221,7 +2213,7 @@ mbRWModCovers _ [nuP| PExpr_Var mb_x |] 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 +-- | 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 @@ -2745,7 +2737,8 @@ 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 :: (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 @@ -2816,6 +2809,12 @@ exprPermVarAndPerm _ = Nothing 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 = [] @@ -2854,6 +2853,19 @@ mbDistPermsToExprPerms = mbMapCl $(mkClosed [| distPermsToExprPerms |]) 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] @@ -3046,7 +3058,7 @@ mbNamedShapeIsRecursive = -- unfolded namedShapeCanUnfoldRepr :: NamedShape b args w -> BoolRepr b namedShapeCanUnfoldRepr (NamedShape _ _ (DefinedShapeBody _)) = TrueRepr -namedShapeCanUnfoldRepr (NamedShape _ _ (OpaqueShapeBody _ _)) = FalseRepr +namedShapeCanUnfoldRepr (NamedShape _ _ (OpaqueShapeBody _ _ _)) = FalseRepr namedShapeCanUnfoldRepr (NamedShape _ _ (RecShapeBody _ _ _)) = TrueRepr -- | Get a 'BoolRepr' for the Boolean flag for whether a named shape in a @@ -3253,7 +3265,7 @@ 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 +-- | A list of \"distinguished\" permissions with types type TypedDistPerms = RAssign (Typed VarAndPerm) -- | Get the 'CruCtx' for a 'TypedDistPerms' @@ -3369,7 +3381,7 @@ ltFuncApply (LTFunctorArray off len stride sh bs) (MNil :>: rw) l = 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 +-- | 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 = @@ -4296,6 +4308,7 @@ llvmPermContainsArray (Perm_LLVMBlock bp) = shapeContainsArray (PExpr_ArrayShape _ _ _) = True shapeContainsArray (PExpr_SeqShape sh1 sh2) = shapeContainsArray sh1 || shapeContainsArray sh2 + shapeContainsArray (PExpr_TupShape sh) = shapeContainsArray sh shapeContainsArray _ = False llvmPermContainsArray _ = False @@ -4362,6 +4375,7 @@ findEqVarFieldsInShapeH (PExpr_FieldShape (LLVMFieldShape 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) = @@ -4380,7 +4394,7 @@ llvmShapeLength (PExpr_NamedShape _ _ nmsh@(NamedShape _ _ (DefinedShapeBody _)) args) = llvmShapeLength (unfoldNamedShape nmsh args) llvmShapeLength (PExpr_NamedShape _ _ (NamedShape _ _ - (OpaqueShapeBody mb_len _)) args) = + (OpaqueShapeBody mb_len _ _)) args) = Just $ subst (substOfExprs args) mb_len llvmShapeLength (PExpr_NamedShape _ _ nmsh@(NamedShape _ _ (RecShapeBody _ _ _)) args) = @@ -4394,6 +4408,7 @@ llvmShapeLength (PExpr_PtrShape _ _ sh) 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) = @@ -4545,6 +4560,7 @@ instance Modalize (PermExpr (LLVMShapeType w)) where 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) = @@ -4842,6 +4858,8 @@ splitLLVMBlockPerm _ off bp@(llvmBlockShape -> PExpr_ArrayShape len 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) @@ -4891,7 +4909,7 @@ 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 + -- 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 @@ -4983,11 +5001,13 @@ shapeToTag _ = Nothing -- 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 @@ -5089,7 +5109,7 @@ llvmArrayCellToOffset :: (1 <= w, KnownNat w) => LLVMArrayPerm w -> llvmArrayCellToOffset ap cell = bvMult (bytesToInteger $ llvmArrayStride ap) cell --- | Convert an array cell number @cell@ to the "absolute" byte offset for that +-- | 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 -> @@ -5117,7 +5137,7 @@ llvmArrayAbsOffsetsToCells _ _ = Nothing 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)@ +-- | 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) @@ -5194,7 +5214,7 @@ llvmArrayBorrowRange :: (1 <= w, KnownNat w) => llvmArrayBorrowRange ap borrow = llvmArrayCellsToOffsets ap (llvmArrayBorrowCells borrow) --- | Get the "absolute" range of offsets spanned by a borrow relative to the +-- | 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 @@ -5373,7 +5393,7 @@ matchLLVMArrayCell ap off 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 +-- 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 -> @@ -6115,7 +6135,7 @@ shapeIsCopyable rw (PExpr_NamedShape maybe_rw' _ nmsh args) = 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 _ _ -> + 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 @@ -6128,6 +6148,7 @@ shapeIsCopyable rw (PExpr_PtrShape maybe_rw' _ sh) = 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) = @@ -6286,8 +6307,9 @@ funPermDistOuts fun_perm ghosts gexprs args gouts_ret = unfoldRecPerm :: RecPerm b reach args a -> PermExprs args -> PermOffset a -> ValuePerm a unfoldRecPerm rp args off = - offsetPerm off $ foldr1 ValPerm_Or $ map (subst (substOfExprs args)) $ - recPermCases rp + 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 -> @@ -6312,8 +6334,7 @@ unfoldConjPerm npn args off , TrueRepr <- nameIsConjRepr npn' = [Perm_NamedConj npn' args' off'] unfoldConjPerm _ _ _ = - -- NOTE: this should never happen - error "unfoldConjPerm" + panic "unfoldConjPerm" [] -- | Test if two expressions are definitely unequal exprsUnequal :: PermExpr a -> PermExpr a -> Bool @@ -6388,6 +6409,7 @@ instance FreeVars (PermExpr a) where 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) = @@ -6504,7 +6526,7 @@ instance FreeVars (NamedShape b args w) where instance FreeVars (NamedShapeBody b args w) where freeVars (DefinedShapeBody mb_sh) = freeVars mb_sh - freeVars (OpaqueShapeBody mb_len _) = freeVars mb_len + freeVars (OpaqueShapeBody mb_len _ _) = freeVars mb_len freeVars (RecShapeBody mb_sh _ _) = freeVars mb_sh @@ -6539,7 +6561,7 @@ instance ContainedEqVars (PermExpr (LLVMShapeType w)) where (DefinedShapeBody _)) args) = containedEqVars (unfoldNamedShape nmsh args) containedEqVars (PExpr_NamedShape _ _ (NamedShape _ _ - (OpaqueShapeBody _ _)) _) = + (OpaqueShapeBody _ _ _)) _) = NameSet.empty containedEqVars (PExpr_NamedShape _ _ (NamedShape _ _ (RecShapeBody mb_sh _ _)) args) = @@ -6550,6 +6572,7 @@ instance ContainedEqVars (PermExpr (LLVMShapeType w)) where 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) = @@ -6661,6 +6684,7 @@ readOnlyShape (PExpr_PtrShape _ Nothing 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) = @@ -6878,6 +6902,7 @@ instance SubstVar s m => Substable s (PermExpr a) m where [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 |] -> @@ -6952,12 +6977,13 @@ genSubstNSB :: 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 |] -> + [nuMP| OpaqueShapeBody mb_len trans_id desc_id |] -> OpaqueShapeBody <$> genSubstMb px s mb_len <*> return (mbLift trans_id) - [nuMP| RecShapeBody mb_sh trans_id fold_ids |] -> + <*> 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 fold_ids) + <*> return (mbLift desc_id) instance SubstVar s m => Substable s (NamedPermName ns args a) m where genSubst _ mb_rpn = return $ mbLift mb_rpn @@ -6974,13 +7000,14 @@ instance SubstVar s m => Substable s (NamedPerm ns args a) m where [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 i |]) = - return $ OpaquePerm (mbLift n) (mbLift i) + 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 f_i u_i reachMeths cases |]) = - RecPerm (mbLift rpn) (mbLift dt_i) (mbLift f_i) (mbLift u_i) - (mbLift reachMeths) <$> mapM (genSubstMb (cruCtxProxies (mbLift (fmap namedPermNameArgs rpn))) s) (mbList cases) + 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 |]) = @@ -7279,6 +7306,10 @@ newtype PartialSubst ctx = 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) @@ -7316,7 +7347,7 @@ psubstSet memb e (PartialSubst elems) = RL.modify memb (\pse -> case pse of PSubstElem Nothing -> PSubstElem $ Just e - PSubstElem (Just _) -> error "psubstSet: value already set for variable") + PSubstElem (Just _) -> panic "psubstSet" ["value already set for variable"]) elems -- | Extend a partial substitution with an unassigned variable @@ -7473,7 +7504,7 @@ 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 _ = error "abstractFreeVars" +abstractFreeVars _ = panic "abstractFreeVars" [] -- | Try to close an expression by calling 'abstractPEVars' with an empty list @@ -7643,6 +7674,9 @@ instance AbstractVars (PermExpr a) where `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 @@ -7896,15 +7930,16 @@ 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) = - absVarsReturnH ns1 ns2 ($(mkClosed [| \i l -> OpaqueShapeBody l i |]) - `clApply` toClosed trans_id) + 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 fold_ids) = + 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 fold_ids) + `clApply` toClosed trans_id + `clApply` toClosed desc_id) `clMbMbApplyM` abstractPEVars ns1 ns2 mb_sh instance AbstractVars (NamedPermName ns args a) where @@ -7919,8 +7954,8 @@ instance AbstractVars (NamedPermName ns args a) where -- * Abstracting out named shapes ---------------------------------------------------------------------- --- | An existentially quantified, partially defined LLVM shape applied to --- some arguments +-- | 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 @@ -7999,6 +8034,7 @@ instance AbstractNamedShape w (PermExpr a) where 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) = @@ -8184,67 +8220,39 @@ permEnvAddNamedShape env ns = -- | Add an opaque named permission to a 'PermEnv' permEnvAddOpaquePerm :: PermEnv -> String -> CruCtx args -> TypeRepr a -> - Ident -> PermEnv -permEnvAddOpaquePerm env str args tp i = + 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 i - --- | Add a recursive named permission to a 'PermEnv', assuming that the --- 'recPermCases' and the fold and unfold functions depend recursively on the --- recursive named permission being defined. This is handled by adding a --- "temporary" version of the named permission to the environment to be used to --- compute the 'recPermCases' and the fold and unfold functions and then passing --- the expanded environment with this temporary named permission to the supplied --- functions for computing these values. This temporary named permission has its --- 'recPermCases' and its fold and unfold functions undefined, so the supplied --- functions cannot depend on these values being defined, which makes sense --- because they are defining them! Note that the function for computing the --- 'recPermCases' can be called multiple times, so should not perform any --- non-idempotent mutation in the monad @m@. + 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 -> + 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 [Mb args (ValuePerm a)]) -> - (forall b. NamedPermName (RecursiveSort b reach) args a -> - [Mb args (ValuePerm a)] -> PermEnv -> m (Ident, Ident)) -> (forall b. NamedPermName (RecursiveSort b reach) args a -> PermEnv -> m (ReachMethods args a reach)) -> m PermEnv -permEnvAddRecPermM env nm args tp trans_ident reachC casesF foldIdentsF reachMethsF = - -- NOTE: we start by assuming nm is conjoinable, and then, if it's not, we - -- call casesF again, and thereby compute a fixed-point - do let reach = nameReachConstrBool reachC - let mkTmpEnv :: NamedPermName (RecursiveSort b reach) args a -> PermEnv - mkTmpEnv npn = - permEnvAddNamedPerm env $ NamedPerm_Rec $ - RecPerm npn trans_ident - (error "Analyzing recursive perm cases before it is defined!") - (error "Folding recursive perm before it is defined!") - (error "Using reachability methods for recursive perm before it is defined!") - (error "Unfolding recursive perm before it is defined!") - mkRealEnv :: Monad m => NamedPermName (RecursiveSort b reach) args a -> - [Mb args (ValuePerm a)] -> - (PermEnv -> m (Ident, Ident)) -> - (PermEnv -> m (ReachMethods args a reach)) -> - m PermEnv - mkRealEnv npn cases identsF rmethsF = - do let tmp_env = mkTmpEnv npn - (fold_ident, unfold_ident) <- identsF tmp_env - reachMeths <- rmethsF tmp_env - return $ permEnvAddNamedPerm env $ NamedPerm_Rec $ - RecPerm npn trans_ident fold_ident unfold_ident reachMeths cases - let npn1 = NamedPermName nm tp args (RecursiveSortRepr TrueRepr reach) reachC - cases1 <- casesF npn1 (mkTmpEnv npn1) - case someBool $ all (mbLift . fmap isConjPerm) cases1 of - Some TrueRepr -> mkRealEnv npn1 cases1 (foldIdentsF npn1 cases1) (reachMethsF npn1) - Some FalseRepr -> - do let npn2 = NamedPermName nm tp args (RecursiveSortRepr - FalseRepr reach) reachC - cases2 <- casesF npn2 (mkTmpEnv npn2) - mkRealEnv npn2 cases2 (foldIdentsF npn2 cases2) (reachMethsF npn2) - +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 -> @@ -8268,20 +8276,23 @@ permEnvAddDefinedShape env nm args mb_sh = -- | Add an opaque LLVM shape to a permission environment permEnvAddOpaqueShape :: (1 <= w, KnownNat w) => PermEnv -> String -> CruCtx args -> Mb args (PermExpr (BVType w)) -> - Ident -> PermEnv -permEnvAddOpaqueShape env nm args mb_len tp_id = + Ident -> Ident -> PermEnv +permEnvAddOpaqueShape env nm args mb_len tp_id d_id = env { permEnvNamedShapes = SomeNamedShape (NamedShape nm args $ - OpaqueShapeBody mb_len tp_id) : permEnvNamedShapes env } + OpaqueShapeBody mb_len tp_id d_id) + : permEnvNamedShapes env } --- | Add a global symbol with a function permission to a 'PermEnv' +-- | 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 (Right [t]) : permEnvGlobalSyms env } + 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 -> @@ -8290,7 +8301,8 @@ permEnvAddGlobalSymFunMulti :: (1 <= w, KnownNat w) => 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 (Right $ map snd ps_ts) : permEnvGlobalSyms env } + PermEnvGlobalEntry sym p (GlobalTrans $ map snd ps_ts) + : permEnvGlobalSyms env } -- | Add some 'PermEnvGlobalEntry's to a 'PermEnv' permEnvAddGlobalSyms :: PermEnv -> [PermEnvGlobalEntry] -> PermEnv @@ -8359,8 +8371,8 @@ requireNamedPerm :: PermEnv -> NamedPermName ns args a -> NamedPerm ns args a requireNamedPerm env npn | Just np <- lookupNamedPerm env npn = np requireNamedPerm _ npn = - error ("requireNamedPerm: named perm does not exist: " - ++ namedPermNameName 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 @@ -8371,11 +8383,10 @@ lookupNamedShape env nm = -- | Look up the permissions and translation for a 'GlobalSymbol' at a -- particular machine word width lookupGlobalSymbol :: PermEnv -> GlobalSymbol -> NatRepr w -> - Maybe (ValuePerm (LLVMPointerType w), - Either Natural [OpenTerm]) + Maybe (ValuePerm (LLVMPointerType w), GlobalTrans) lookupGlobalSymbol env = helper (permEnvGlobalSyms env) where helper :: [PermEnvGlobalEntry] -> GlobalSymbol -> NatRepr w -> - Maybe (ValuePerm (LLVMPointerType w), Either Natural [OpenTerm]) + Maybe (ValuePerm (LLVMPointerType w), GlobalTrans) helper (PermEnvGlobalEntry sym' (p :: ValuePerm (LLVMPointerType w')) tr:_) sym w | sym' == sym @@ -8438,7 +8449,7 @@ lookupBlockJoinPointHint env h blocks blkID = -- longer need -- | A permission set associates permissions with expression variables, and also --- has a stack of "distinguished permissions" that are used for intro rules +-- has a stack of \"distinguished permissions\" that are used for intro rules data PermSet ps = PermSet { _varPermMap :: NameMap ValuePerm, _distPerms :: DistPerms ps } @@ -8471,7 +8482,7 @@ setVarPerm x p = over (varPerm x) $ \p' -> case p' of ValPerm_True -> p - _ -> error "setVarPerm: permission for variable already set!" + _ -> panic "setVarPerm" ["permission for variable already set!"] -- | Get a permission list for multiple variables varPermsMulti :: RAssign Name ns -> PermSet ps -> DistPerms ns @@ -8613,6 +8624,7 @@ getShapeDetVarsClauses (PExpr_PtrShape _ _ 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 @@ -8734,7 +8746,7 @@ getAllPerms perms = helper (NameMap.assocs $ perms ^. varPermMap) where deletePerm :: ExprVar a -> ValuePerm a -> PermSet ps -> PermSet ps deletePerm x p = over (varPerm x) $ \p' -> - if p' == p then ValPerm_True else error "deletePerm" + if p' == p then ValPerm_True else panic "deletePerm" [] -- | Push a new distinguished permission onto the top of the stack pushPerm :: ExprVar a -> ValuePerm a -> PermSet ps -> PermSet (ps :> a) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/RustTypes.hs b/heapster-saw/src/Verifier/SAW/Heapster/RustTypes.hs index 81fc1f2096..7d70595935 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/RustTypes.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/RustTypes.hs @@ -292,8 +292,8 @@ 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 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 @@ -349,7 +349,7 @@ mkShapeFun nm ctx f = \some_exprs exprs_str -> case some_exprs of 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 +-- | 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 -- @@ -360,7 +360,7 @@ constShapeFun nm sh = mkShapeFun nm CruCtxNil (const sh) -- > (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. +-- \"payload\" shape. matchOptionLikeShape :: PermExpr (LLVMShapeType w) -> Maybe (PermExpr (LLVMShapeType w)) matchOptionLikeShape top_sh = case asTaggedUnionShape top_sh of @@ -372,7 +372,7 @@ matchOptionLikeShape top_sh = case asTaggedUnionShape top_sh of [sh, PExpr_EmptyShape])) -> Just sh _ -> Nothing --- | Test if a shape-in-binding is "option-like" as per 'matchOptionLikeShape' +-- | 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 = @@ -442,7 +442,7 @@ namedShapeShapeFun _ w (SomeNamedShape nmsh) = -- @Foo::Bar::Baz@ just becomes @[Foo,Bar,Baz]@ newtype RustName = RustName [Ident] deriving (Eq) --- | Convert a 'RustName' to a string by interspersing "::" +-- | Convert a 'RustName' to a string by interspersing @"::"@ flattenRustName :: RustName -> String flattenRustName (RustName ids) = concat $ intersperse "::" $ map name ids @@ -459,7 +459,7 @@ instance RsConvert w RustName (ShapeFun w) where do n <- lookupName str (LLVMShapeRepr (natRepr w)) return $ constShapeFun nm (PExpr_Var n) --- | Get the "name" = sequence of identifiers out of a Rust path +-- | 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 @@ -484,7 +484,7 @@ 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"; +-- | 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 @@ -1325,7 +1325,7 @@ instance App.Applicative SomeMbWithPerms where 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 +-- 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. {- diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index c8ca5a60d8..2a267ff182 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -25,6 +25,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ImplicitParams #-} +{-# Language DeriveFunctor #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# HLINT ignore "Move brackets to avoid $" #-} @@ -39,14 +40,18 @@ import Data.Text (pack) import GHC.TypeLits (KnownNat, natVal) import Data.BitVector.Sized (BV) import qualified Data.BitVector.Sized as BV -import Data.Functor.Compose +import Data.Functor.Constant import qualified Control.Applicative as App -import Control.Lens hiding ((:>), Index, ix, op) +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) -import Control.Monad.State (MonadState(..), StateT, evalStateT) +import Control.Monad.IO.Class (MonadIO(..)) +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(..), Writer, runWriter) +import Control.Monad.Writer (MonadWriter(..), WriterT(..)) import qualified Control.Monad.Fail as Fail import What4.ProgramLoc @@ -69,12 +74,14 @@ import Lang.Crucible.CFG.Expr import qualified Lang.Crucible.CFG.Expr as Expr import Lang.Crucible.CFG.Core +import Verifier.SAW.Utils (panic) +import Verifier.SAW.Name import Verifier.SAW.OpenTerm -import Verifier.SAW.Term.Functor -import Verifier.SAW.SharedTerm +import Verifier.SAW.Term.Functor hiding (Constant) +import Verifier.SAW.SharedTerm hiding (Constant) +-- import Verifier.SAW.Heapster.GenMonad import Verifier.SAW.Heapster.CruUtil -import Verifier.SAW.Heapster.PatternMatchUtil import Verifier.SAW.Heapster.Permissions import Verifier.SAW.Heapster.Implication import Verifier.SAW.Heapster.TypedCrucible @@ -90,15 +97,33 @@ suffixMembers _ MNil = MNil suffixMembers ctx1 (ctx2 :>: _) = RL.map Member_Step (suffixMembers ctx1 ctx2) :>: Member_Base --- | Build a SAW core term of type @ListSort@ from a list of types -listSortOpenTerm :: [OpenTerm] -> OpenTerm -listSortOpenTerm = - foldr (\x y -> ctorOpenTerm "Prelude.LS_Cons" [x,y]) - (ctorOpenTerm "Prelude.LS_Nil" []) +-- | 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 ---------------------------------------------------------------------- --- * Translation Monads +-- * Type Translations ---------------------------------------------------------------------- -- | Call 'prettyCallStack' and insert a newline in front @@ -114,7 +139,7 @@ data TypeTrans tr = TypeTrans { typeTransTypes :: [OpenTerm], typeTransFun :: [OpenTerm] -> tr } --- | Apply the 'typeTransFun' of a 'TypeTrans' with the call stack +-- | 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 = @@ -146,75 +171,58 @@ mkTypeTrans1 tp f = TypeTrans [tp] $ \case 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 _ = error ("typeTransType1" ++ nlPrettyCallStack callStack) - --- | Build the tuple type @T1 * (T2 * ... * (Tn-1 * Tn))@ of @n@ types, with the --- special case that 0 types maps to the unit type @#()@ (and 1 type just maps --- to itself). Note that this is different from 'tupleTypeOpenTerm', which --- always ends with unit, i.e., which returns @T1*(T2*...*(Tn-1*(Tn*#())))@. -tupleOfTypes :: [OpenTerm] -> OpenTerm -tupleOfTypes [] = unitTypeOpenTerm -tupleOfTypes [tp] = tp -tupleOfTypes (tp:tps) = pairTypeOpenTerm tp $ tupleOfTypes tps - --- | Build the tuple @(t1,(t2,(...,(tn-1,tn))))@ of @n@ terms, with the --- special case that 0 types maps to the unit value @()@ (and 1 value just maps --- to itself). Note that this is different from 'tupleOpenTerm', which --- always ends with unit, i.e., which returns @t1*(t2*...*(tn-1*(tn*())))@. -tupleOfTerms :: [OpenTerm] -> OpenTerm -tupleOfTerms [] = unitOpenTerm -tupleOfTerms [t] = t -tupleOfTerms (t:ts) = pairOpenTerm t $ tupleOfTerms ts - --- | Project the @i@th element from a term of type @'tupleOfTypes' tps@. Note --- that this requires knowing the length of @tps@. -projTupleOfTypes :: [OpenTerm] -> Integer -> OpenTerm -> OpenTerm -projTupleOfTypes [] _ _ = error "projTupleOfTypes: projection of empty tuple!" -projTupleOfTypes [_] 0 tup = tup -projTupleOfTypes (_:_) 0 tup = pairLeftOpenTerm tup -projTupleOfTypes (_:tps) i tup = - projTupleOfTypes tps (i-1) $ pairRightOpenTerm tup +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 = tupleOfTypes . typeTransTypes +typeTransTupleType = tupleTypeOpenTerm' . typeTransTypes --- | Convert a 'TypeTrans' over 0 or more types to one over the one type --- returned by 'tupleOfTypes' +-- | 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 [tupleOfTypes tps] + TypeTrans [tupleTypeOpenTerm' tps] (\case [t] -> - typeTransF ttrans $ map (\i -> projTupleOfTypes tps i t) $ - take (length $ typeTransTypes ttrans) [0..] - _ -> error "tupleTypeTrans: incorrect number of terms") - --- | Convert a 'TypeTrans' over 0 or more types to one over 1 type of the form --- @#(tp1, #(tp2, ... #(tpn, #()) ...))@. This is "strict" in the sense that --- even a single type is tupled. -strictTupleTypeTrans :: TypeTrans tr -> TypeTrans tr -strictTupleTypeTrans ttrans = - TypeTrans [tupleTypeOpenTerm $ typeTransTypes ttrans] - (\case - [t] -> - typeTransF ttrans $ map (\i -> projTupleOpenTerm i t) $ - take (length $ typeTransTypes ttrans) [0..] - _ -> error "strictTupleTypeTrans: incorrect number of terms") + 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. @@ -248,14 +256,43 @@ data ExprTrans (a :: CrucibleType) where -- | 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 :: OpenTerm -> ExprTrans a + 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 @@ -266,23 +303,23 @@ class IsTermTrans tr where -- 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 (transTerms -> [t]) = t -transTupleTerm tr = tupleOfTerms $ transTerms tr +transTupleTerm = tupleOpenTerm' . transTerms --- | Build a tuple of the terms contained in a translation. This is "strict" in --- that it always makes a tuple, even for a single type, unlike --- 'transTupleTerm'. If @ttrans@ is a 'TypeTrans' describing the SAW types --- associated with a @tr@ translation, then this function returns an element of --- the type @'strictTupleTypeTrans' ttrans@. -strictTransTupleTerm :: IsTermTrans tr => tr -> OpenTerm -strictTransTupleTerm tr = tupleOpenTerm $ transTerms tr +-- | 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 (transTerms -> []) = unitOpenTerm -transTerm1 (transTerms -> [t]) = t -transTerm1 _ = error ("transTerm1" ++ nlPrettyCallStack callStack) +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 @@ -301,30 +338,173 @@ instance IsTermTrans (ExprTrans tp) where transTerms ETrans_Fun = [] transTerms ETrans_Unit = [] transTerms ETrans_AnyVector = [] - transTerms (ETrans_Term t) = [t] + 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 MNil = [] - transTerms (ctx :>: etrans) = transTerms ctx ++ transTerms etrans + transTerms = concat . RL.mapToList transTerms -- | Map a context of expression translations to a list of 'OpenTerm's exprCtxToTerms :: ExprTransCtx tps -> [OpenTerm] -exprCtxToTerms = concat . RL.mapToList transTerms +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 "translation monad" is a 'Reader' monad with some info type that is +-- | 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) + deriving (Functor, Applicative, Monad, OpenTermLike) instance Fail.MonadFail (TransM info ctx) where fail = error @@ -355,13 +535,37 @@ 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 -> +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" (typeTransTypes tp_trans) tp_ret (transTerms etrans) $ + 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 @@ -393,29 +597,27 @@ applyTransM :: 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] -> +applyMultiTransM :: TransM info ctx OpenTerm -> + [TransM info ctx OpenTerm] -> TransM info ctx OpenTerm applyMultiTransM m ms = foldl applyTransM m ms --- | Build a lambda-abstraction inside the 'TransM' monad -lambdaOpenTermTransM :: String -> OpenTerm -> - (OpenTerm -> TransM info ctx OpenTerm) -> - TransM info ctx OpenTerm -lambdaOpenTermTransM x tp body_f = - ask >>= \info -> - return (lambdaOpenTerm (pack x) tp $ \t -> runTransM (body_f t) info) +-- | 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' inside a translation monad, using the --- 'String' as a variable name prefix for the @xi@ variables +-- 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 tps body_f = +lambdaTrans x (TypeTrans tps tr_f) body_f = lambdaOpenTermMulti - (zipWith (\i tp -> (pack (x ++ show (i :: Integer)), tp)) [0..] $ typeTransTypes tps) - (body_f . typeTransF tps) + (zipWith (\i tp -> (pack (x ++ show (i :: Integer)), tp)) [0..] tps) + (body_f . tr_f) -- | Build a nested lambda-abstraction -- @@ -425,11 +627,8 @@ lambdaTrans x tps body_f = -- '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 tps body_f = - ask >>= \info -> - return (lambdaOpenTermMulti - (zipWith (\i tp -> (pack (x ++ show (i :: Integer)), tp)) [0..] $ typeTransTypes tps) - (\ts -> runTransM (body_f $ typeTransF tps ts) info)) +lambdaTransM x tp body_f = + ask >>= \info -> return (lambdaTrans x tp (flip runTransM info . body_f)) -- | Build a lambda-abstraction -- @@ -449,9 +648,11 @@ piTransM :: String -> TypeTrans tr -> (tr -> 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) + (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) -> @@ -459,6 +660,7 @@ piOpenTermTransM :: String -> 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 -> @@ -467,58 +669,32 @@ letTransM :: String -> 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 sawLet-binding in a translation monad -sawLetTransM :: String -> OpenTerm -> OpenTerm -> TransM info ctx OpenTerm -> - (OpenTerm -> TransM info ctx OpenTerm) -> - TransM info ctx OpenTerm -sawLetTransM x tp tp_ret rhs_m body_m = - do r <- ask - return $ - sawLetOpenTerm (pack x) tp tp_ret (runTransM rhs_m r) - (\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 (return rhs) $ \var_tm -> - sawLetTransMultiM x tps ret_tp rhss (\var_tms -> f (var_tm:var_tms)) -sawLetTransMultiM _ _ _ _ _ = - error "sawLetTransMultiM: numbers of types and right-hand sides disagree" + 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 = - applyMultiTransM (return $ globalOpenTerm "Prelude.Vec") - [m, return $ globalOpenTerm "Prelude.Bool"] +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 = - dataTypeOpenTerm "Prelude.Either" - [typeTransTupleType tp_l, typeTransTupleType 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 :: IsTermTrans trL => TypeTrans trL -> TypeTrans trR -> trL -> - OpenTerm -leftTrans tp_l tp_r tr = - ctorOpenTerm "Prelude.Left" - [typeTransTupleType tp_l, typeTransTupleType tp_r, transTupleTerm tr] +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 :: IsTermTrans trR => TypeTrans trL -> TypeTrans trR -> trR -> - OpenTerm -rightTrans tp_l tp_r tr = - ctorOpenTerm "Prelude.Right" - [typeTransTupleType tp_l, typeTransTupleType tp_r, transTupleTerm tr] +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 -> @@ -528,7 +704,7 @@ eitherElimTransM :: TypeTrans trL -> TypeTrans trR -> 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 $ applyOpenTermMulti (globalOpenTerm "Prelude.either") + return $ applyGlobalOpenTerm "Prelude.either" [ typeTransTupleType tp_l, typeTransTupleType tp_r, typeTransTupleType tp_ret, fl_trans, fr_trans, eith ] @@ -549,170 +725,168 @@ eithersElimTransM tps tp_ret fs eith = (return $ ctorOpenTerm "Prelude.FunsTo_Nil" [typeTransTupleType tp_ret]) (zip tps fs) >>= \elims_trans -> - return (applyOpenTermMulti (globalOpenTerm "Prelude.eithers") + return (applyGlobalOpenTerm "Prelude.eithers" [typeTransTupleType tp_ret, elims_trans, eith]) --- | Build the dependent pair type whose first projection type is the --- 'typeTransTupleType' of the supplied 'TypeTrans' and whose second projection --- is the 'typeTransTupleType' of the supplied monadic function. As a special --- case, just return the latter if the 'TypeTrans' contains 0 types. -sigmaTypeTransM :: String -> TypeTrans trL -> + +-- | 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 _ ttrans@(typeTransTypes -> []) tp_f = - typeTransTupleType <$> tp_f (typeTransF ttrans []) -sigmaTypeTransM x ttrans tp_f = - do tp_f_trm <- lambdaTupleTransM x ttrans (\tr -> - typeTransTupleType <$> tp_f tr) - return (dataTypeOpenTerm "Prelude.Sigma" - [typeTransTupleType ttrans, tp_f_trm]) - --- | Like `sigmaTypeTransM`, but translates `exists x.eq(y)` into just `x` -sigmaTypePermTransM :: TransInfo info => String -> TypeTrans (ExprTrans trL) -> +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 p_cbn = case mbMatch p_cbn of +sigmaTypePermTransM x ttrans mb_p = case mbMatch mb_p of [nuMP| ValPerm_Eq _ |] -> return $ typeTransTupleType ttrans - _ -> sigmaTypeTransM x ttrans (flip inExtTransM $ translate p_cbn) - --- | Build a 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 allow for this. -sigmaTransM :: (IsTermTrans trL, IsTermTrans trR2) => String -> TypeTrans trL -> + _ -> + 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 tp_r_trm <- lambdaTupleTransM x tp_l ((typeTransTupleType <$>) . tp_r) - rhs <- transTupleTerm <$> rhs_m - return (ctorOpenTerm "Prelude.exists" - [typeTransTupleType tp_l, tp_r_trm, transTupleTerm lhs, rhs]) + 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) => - String -> TypeTrans (ExprTrans trL) -> + LocalName -> TypeTrans (ExprTrans trL) -> Mb (ctx :> trL) (ValuePerm trR1) -> ExprTrans trL -> TransM info ctx trR2 -> TransM info ctx OpenTerm -sigmaPermTransM x ttrans p_cbn etrans rhs_m = case mbMatch p_cbn of +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 p_cbn) - etrans rhs_m + _ -> sigmaTransM x ttrans (flip inExtTransM $ translate mb_p) etrans rhs_m + -- | Eliminate a dependent pair of the type returned by 'sigmaTypeTransM' -sigmaElimTransM :: (IsTermTrans trL, IsTermTrans trR) => - String -> TypeTrans trL -> +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 proj1 = typeTransF tp_l [] - proj2 <- flip (typeTransF . tupleTypeTrans) [sigma] <$> tp_r proj1 - f proj1 proj2 -sigmaElimTransM x tp_l tp_r _tp_ret_m f sigma = - do let tp_l_trm = typeTransTupleType tp_l - tp_r_trm <- lambdaTupleTransM x tp_l (\tr -> - typeTransTupleType <$> tp_r tr) - let proj_l_trm = - applyOpenTermMulti (globalOpenTerm "Prelude.Sigma_proj1") - [tp_l_trm, tp_r_trm, sigma] - let proj_l = typeTransF (tupleTypeTrans tp_l) [proj_l_trm] - tp_r_app <- tp_r proj_l - let proj_r_trm = - applyOpenTermMulti (globalOpenTerm "Prelude.Sigma_proj2") - [tp_l_trm, tp_r_trm, sigma] - let proj_r = typeTransF (tupleTypeTrans tp_r_app) [proj_r_trm] + 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 = tp_r_f ts_l in + flip runTransM info $ f trL (typeTransF tp_r ts_r)) -{- NOTE: the following is the version that inserts a Sigma__rec -sigmaElimTransM x tp_l tp_r tp_ret_m f sigma = - do tp_r_trm <- lambdaTupleTransM x tp_l (\tr -> - typeTransTupleType <$> tp_r tr) - sigma_tp <- sigmaTypeTransM x tp_l tp_r - tp_ret <- lambdaTransM x (mkTypeTrans1 sigma_tp id) - (const (typeTransTupleType <$> tp_ret_m)) - f_trm <- - lambdaTupleTransM (x ++ "_proj1") tp_l $ \x_l -> - tp_r x_l >>= \tp_r_app -> - lambdaTupleTransM (x ++ "_proj2") tp_r_app (f x_l) - return (applyOpenTermMulti (globalOpenTerm "Prelude.Sigma__rec") - [ typeTransTupleType tp_l, tp_r_trm, tp_ret, f_trm, sigma ]) --} -- | Like `sigmaElimTransM`, but translates `exists x.eq(y)` into just `x` sigmaElimPermTransM :: (TransInfo info) => - String -> TypeTrans (ExprTrans trL) -> + 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 p_cbn tp_ret_m f sigma = case mbMatch p_cbn of - [nuMP| ValPerm_Eq e |] -> f (typeTransF (tupleTypeTrans tp_l) [sigma]) - (PTrans_Eq e) - _ -> sigmaElimTransM x tp_l (flip inExtTransM $ translate p_cbn) - tp_ret_m f sigma +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 <- identOpenTerm <$> permEnvSpecMEventType <$> infoEnv <$> ask + 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 +applyNamedEventOpM f args = applyEventOpM (globalOpenTerm f) args --- | Generate the type @SpecM E evRetType stack A@ using the current event type --- and the supplied @stack@ and type @A@ -specMTypeTransM :: TransInfo info => OpenTerm -> OpenTerm -> - TransM info ctx OpenTerm -specMTypeTransM stack tp = applyNamedEventOpM "Prelude.SpecM" [stack,tp] +-- | The current non-monadic return type +returnTypeM :: TransInfoM info => TransM info ctx OpenTerm +returnTypeM = infoRetType <$> ask --- | Generate the type @SpecM E evRetType emptyFunStack A@ using the current --- event type and the supplied type @A@ -emptyStackSpecMTypeTransM :: TransInfo info => OpenTerm -> - TransM info ctx OpenTerm -emptyStackSpecMTypeTransM tp = - specMTypeTransM (globalOpenTerm "Prelude.emptyFunStack") tp +-- | 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 --- | Lambda-abstract a function stack variable of type @FunStack@ -lambdaFunStackM :: (OpenTerm -> TransM info ctx OpenTerm) -> - TransM info ctx OpenTerm -lambdaFunStackM f = - lambdaOpenTermTransM "stk" (globalOpenTerm "Prelude.FunStack") f +-- | Like 'compReturnTypeM' but build a 'TypeTrans' +compReturnTypeTransM :: TransInfoM info => TransM info ctx (TypeTrans OpenTerm) +compReturnTypeTransM = openTermTypeTrans <$> compReturnTypeM --- | Pi-abstract a function stack variable of type @FunStack@ -piFunStackM :: (OpenTerm -> TransM info ctx OpenTerm) -> +-- | 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 -piFunStackM f = - piOpenTermTransM "stk" (globalOpenTerm "Prelude.FunStack") f - --- | Apply @pushFunStack@ to push a frame onto a @FunStack@ -pushFunStackOpenTerm :: OpenTerm -> OpenTerm -> OpenTerm -pushFunStackOpenTerm frame stack = - applyGlobalOpenTerm "Prelude.pushFunStack" [frame, stack] +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 using --- 'transTupleTerm' -translateToTuple :: (IsTermTrans tr, Translate info ctx a tr) => - Mb ctx a -> TransM info ctx OpenTerm -translateToTuple a = transTupleTerm <$> translate a - -- | 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) => @@ -722,7 +896,7 @@ translate1 a = translate a >>= \tr -> case transTerms tr of ts -> error ("translate1: expected 1 term, found " ++ show (length ts) ++ nlPrettyCallStack callStack) --- | Translate a "closed" term, that is not in a binding +-- | 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 @@ -757,8 +931,6 @@ data TypeTransInfo ctx = ttiChecksFlag :: ChecksFlag } --- (ExprTransCtx ctx) PermEnv ChecksFlag - -- | Build an empty 'TypeTransInfo' from a 'PermEnv' emptyTypeTransInfo :: PermEnv -> ChecksFlag -> TypeTransInfo RNil emptyTypeTransInfo = TypeTransInfo MNil @@ -766,16 +938,30 @@ 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 = @@ -784,103 +970,102 @@ inEmptyCtxTransM = instance TransInfo info => Translate info ctx (NatRepr n) OpenTerm where translate mb_n = return $ natOpenTerm $ mbLift $ fmap natValue mb_n --- | Helper for writing the 'Translate' instance for 'TypeRepr' -returnType1 :: OpenTerm -> TransM info ctx (TypeTrans (ExprTrans a)) -returnType1 tp = return $ mkTypeTrans1 tp ETrans_Term - - --- FIXME: explain this translation +-- | 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 mb_tp = case mbMatch mb_tp of - [nuMP| AnyRepr |] -> - return $ error "Translate: Any" - [nuMP| UnitRepr |] -> - return $ mkTypeTrans0 ETrans_Unit - [nuMP| BoolRepr |] -> - returnType1 $ globalOpenTerm "Prelude.Bool" - [nuMP| NatRepr |] -> - returnType1 $ dataTypeOpenTerm "Prelude.Nat" [] - [nuMP| IntegerRepr |] -> - return $ error "translate: IntegerRepr" - [nuMP| RealValRepr |] -> - return $ error "translate: RealValRepr" - [nuMP| ComplexRealRepr |] -> - return $ error "translate: ComplexRealRepr" - [nuMP| SequenceRepr{} |] -> - return $ error "translate: SequenceRepr" - [nuMP| BVRepr w |] -> - returnType1 =<< bitvectorTransM (translate w) - [nuMP| VectorRepr AnyRepr |] -> - return $ mkTypeTrans0 ETrans_AnyVector - - -- Our special-purpose intrinsic types, whose translations do not have - -- computational content - [nuMP| LLVMPointerRepr _ |] -> - return $ mkTypeTrans0 ETrans_LLVM - [nuMP| LLVMBlockRepr _ |] -> - return $ mkTypeTrans0 ETrans_LLVMBlock - [nuMP| LLVMFrameRepr _ |] -> - return $ mkTypeTrans0 ETrans_LLVMFrame - [nuMP| LifetimeRepr |] -> - return $ mkTypeTrans0 ETrans_Lifetime - [nuMP| PermListRepr |] -> - returnType1 (sortOpenTerm $ mkSort 0) - [nuMP| RWModalityRepr |] -> - return $ mkTypeTrans0 ETrans_RWModality - - -- Permissions and LLVM shapes translate to types - [nuMP| ValuePermRepr _ |] -> - returnType1 (sortOpenTerm $ mkSort 0) - [nuMP| LLVMShapeRepr _ |] -> - returnType1 (sortOpenTerm $ mkSort 0) - - -- We can't handle any other special-purpose types - [nuMP| IntrinsicRepr _ _ |] -> - return $ error "translate: IntrinsicRepr" - - [nuMP| RecursiveRepr _ _ |] -> - return $ error "translate: RecursiveRepr" - [nuMP| FloatRepr _ |] -> - returnType1 $ dataTypeOpenTerm "Prelude.Float" [] - [nuMP| IEEEFloatRepr _ |] -> - return $ error "translate: IEEEFloatRepr" - [nuMP| CharRepr |] -> - return $ error "translate: CharRepr" - [nuMP| StringRepr UnicodeRepr |] -> - returnType1 stringTypeOpenTerm - [nuMP| StringRepr _ |] -> - return $ error "translate: StringRepr non-unicode" - [nuMP| FunctionHandleRepr _ _ |] -> - -- NOTE: function permissions translate to the SAW function, but the - -- function handle itself has no SAW translation - return $ mkTypeTrans0 ETrans_Fun - [nuMP| MaybeRepr _ |] -> - return $ error "translate: MaybeRepr" - [nuMP| VectorRepr _ |] -> - return $ error "translate: VectorRepr (can't map to Vec without size)" - [nuMP| StructRepr tps |] -> - fmap ETrans_Struct <$> translate (fmap mkCruCtx tps) - [nuMP| VariantRepr _ |] -> - return $ error "translate: VariantRepr" - [nuMP| ReferenceRepr _ |] -> - return $ error "translate: ReferenceRepr" - [nuMP| WordMapRepr _ _ |] -> - return $ error "translate: WordMapRepr" - [nuMP| StringMapRepr _ |] -> - return $ error "translate: StringMapRepr" - [nuMP| SymbolicArrayRepr _ _ |] -> - return $ error "translate: SymbolicArrayRepr" - [nuMP| SymbolicStructRepr _ |] -> - return $ error "translate: SymbolicStructRepr" - + 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 mb_ctx = case mbMatch mb_ctx of - [nuMP| CruCtxNil |] -> return $ mkTypeTrans0 MNil - [nuMP| CruCtxCons ctx tp |] -> - App.liftA2 (:>:) <$> translate ctx <*> translate tp + 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 -> @@ -889,9 +1074,17 @@ 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 -> +piExprCtx :: TransInfo info => CruCtx ctx -> TransM info ctx OpenTerm -> TransM info RNil OpenTerm piExprCtx ctx m = translateClosed ctx >>= \tptrans -> @@ -900,15 +1093,175 @@ piExprCtx ctx 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 (ctx :++: ctx2) OpenTerm -> - TransM info ctx OpenTerm + TransM info (ctx1 :++: ctx2) OpenTerm -> + TransM info ctx1 OpenTerm piExprCtxApp ctx m = translateClosed ctx >>= \tptrans -> piTransM "e" tptrans (\ectx -> inExtMultiTransM ectx m) ---------------------------------------------------------------------- --- * Translating Pure Expressions +-- * 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 @@ -935,30 +1288,24 @@ bvMulOpenTerm n x y = bvSplitOpenTerm :: EndianForm -> OpenTerm -> OpenTerm -> OpenTerm -> (OpenTerm, OpenTerm) bvSplitOpenTerm BigEndian sz1 sz2 e = - (applyOpenTermMulti (globalOpenTerm "Prelude.take") [boolTypeOpenTerm, - sz1, sz2, e], - applyOpenTermMulti (globalOpenTerm "Prelude.drop") [boolTypeOpenTerm, - sz1, sz2, e]) + (applyGlobalOpenTerm "Prelude.take" [boolTypeOpenTerm, sz1, sz2, e], + applyGlobalOpenTerm "Prelude.drop" [boolTypeOpenTerm, sz1, sz2, e]) bvSplitOpenTerm LittleEndian sz1 sz2 e = - (applyOpenTermMulti (globalOpenTerm "Prelude.drop") [boolTypeOpenTerm, - sz2, sz1, e], - applyOpenTermMulti (globalOpenTerm "Prelude.take") [boolTypeOpenTerm, - sz2, sz1, 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 = - applyOpenTermMulti (globalOpenTerm "Prelude.append") - [sz1, sz2, boolTypeOpenTerm, e1, e2] + applyGlobalOpenTerm "Prelude.append" [sz1, sz2, boolTypeOpenTerm, e1, e2] bvConcatOpenTerm LittleEndian sz1 sz2 e1 e2 = - applyOpenTermMulti (globalOpenTerm "Prelude.append") - [sz2, sz1, boolTypeOpenTerm, e2, e1] + 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 _ = error "translateVar: unbound variable!" +translateVar _ = panic "translateVar" ["unbound variable!"] -- | Get the 'TypeRepr' of an expression mbExprType :: KnownRepr TypeRepr a => Mb ctx (PermExpr a) -> TypeRepr a @@ -986,27 +1333,27 @@ instance TransInfo info => instance TransInfo info => Translate info ctx (PermExpr a) (ExprTrans a) where - translate mb_tr = case mbMatch mb_tr of + 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 $ globalOpenTerm "Prelude.True" + return $ ETrans_Term knownRepr $ globalOpenTerm "Prelude.True" [nuMP| PExpr_Bool False |] -> - return $ ETrans_Term $ globalOpenTerm "Prelude.False" + return $ ETrans_Term knownRepr $ globalOpenTerm "Prelude.False" [nuMP| PExpr_Nat i |] -> - return $ ETrans_Term $ natOpenTerm $ mbLift i + return $ ETrans_Term knownRepr $ natOpenTerm $ mbLift i [nuMP| PExpr_String str |] -> - return $ ETrans_Term $ stringLitOpenTerm $ pack $ mbLift str + return $ ETrans_Term knownRepr $ stringLitOpenTerm $ pack $ mbLift str [nuMP| PExpr_BV bvfactors@[] off |] -> let w = natRepr3 bvfactors in - return $ ETrans_Term $ bvBVOpenTerm w $ mbLift off + return $ ETrans_Term knownRepr $ bvBVOpenTerm w $ mbLift off [nuMP| PExpr_BV bvfactors (BV.BV 0) |] -> let w = natVal3 bvfactors in - ETrans_Term <$> foldr1 (bvAddOpenTerm w) <$> translate bvfactors + 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 $ + return $ ETrans_Term knownRepr $ foldr (bvAddOpenTerm $ natValue w) (bvBVOpenTerm w $ mbLift off) bv_transs [nuMP| PExpr_Struct args |] -> ETrans_Struct <$> translate args @@ -1015,61 +1362,117 @@ instance TransInfo info => [nuMP| PExpr_LLVMWord _ |] -> return ETrans_LLVM [nuMP| PExpr_LLVMOffset _ _ |] -> return ETrans_LLVM [nuMP| PExpr_Fun _ |] -> return ETrans_Fun - [nuMP| PExpr_PermListNil |] -> return $ ETrans_Term unitTypeOpenTerm + [nuMP| PExpr_PermListNil |] -> return $ ETrans_Term knownRepr unitTypeOpenTerm [nuMP| PExpr_PermListCons _ _ p l |] -> - ETrans_Term <$> (pairTypeOpenTerm <$> - (typeTransTupleType <$> translate p) <*> - (translate1 l)) + ETrans_Term knownRepr <$> (pairTypeOpenTerm <$> + (typeTransTupleType <$> translate p) <*> + (translate1 l)) [nuMP| PExpr_RWModality _ |] -> return ETrans_RWModality - -- LLVM shapes are translated to types - [nuMP| PExpr_EmptyShape |] -> return $ ETrans_Term unitTypeOpenTerm + -- 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 _ trans_id |] -> - ETrans_Term <$> applyOpenTermMulti (globalOpenTerm $ mbLift trans_id) <$> - transTerms <$> translate args - [nuMP| RecShapeBody _ trans_id _ |] -> - ETrans_Term <$> applyOpenTermMulti (globalOpenTerm $ mbLift trans_id) <$> - transTerms <$> translate args - [nuMP| PExpr_EqShape _ _ |] -> return $ ETrans_Term unitTypeOpenTerm + [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 |] -> - ETrans_Term <$> tupleOfTypes <$> translate 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_tp <- translate1 mb_sh - return $ ETrans_Term $ - applyOpenTermMulti (globalOpenTerm "Prelude.BVVec") - [w_term, len_term, elem_tp] + (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 |] -> - ETrans_Term <$> (pairTypeOpenTerm <$> translate1 sh1 <*> translate1 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 |] -> - ETrans_Term <$> - ((\t1 t2 -> dataTypeOpenTerm "Prelude.Either" [t1,t2]) - <$> translate1 sh1 <*> translate1 sh2) - [nuMP| PExpr_ExShape mb_sh |] -> - do tp_trans <- translate $ fmap bindingType mb_sh - tp_f_trm <- lambdaTupleTransM "x_exsh" tp_trans $ \e -> - transTupleTerm <$> inExtTransM e (translate $ mbCombine RL.typeCtxProxies mb_sh) - return $ ETrans_Term (dataTypeOpenTerm "Prelude.Sigma" - [typeTransTupleType tp_trans, tp_f_trm]) + 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_Term $ globalOpenTerm "Prelude.FalseProp" + return $ + ETrans_Shape $ Just (voidTpDesc, dataTypeOpenTerm "Prelude.Void" []) [nuMP| PExpr_ValPerm p |] -> - ETrans_Term <$> typeTransTupleType <$> translate p + ETrans_Perm <$> descTransM (translateDescs p) <*> (typeTransTypes <$> + translate p) + --- LLVM field shapes translate to the types that the permission they contain --- translates to +-- 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 + 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 @@ -1077,6 +1480,7 @@ instance TransInfo info => [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) @@ -1085,12 +1489,167 @@ instance TransInfo info => Translate info ctx (BVFactor w) OpenTerm where 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) + ---------------------------------------------------------------------- --- * Translating Permissions to Types +-- * Permission Translations ---------------------------------------------------------------------- --- | The result of translating a "proof element" of a permission of type +-- | 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@. @@ -1134,9 +1693,10 @@ data AtomicPermTrans ctx a where AtomicPermTrans ctx (LLVMPointerType w) -- | The translation of an LLVM block permission is an element of the - -- translation of its shape to a type + -- 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) -> OpenTerm -> + Mb ctx (LLVMBlockPerm w) -> Maybe OpenTerm -> AtomicPermTrans ctx (LLVMPointerType w) -- | LLVM free permissions have no computational content @@ -1156,9 +1716,11 @@ data AtomicPermTrans ctx a where AtomicPermTrans ctx (LLVMPointerType w) -- | The translation of an LLVMBlockShape permission is an element of the - -- translation of its shape to a type + -- 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)) -> OpenTerm -> + Mb ctx (PermExpr (LLVMShapeType w)) -> + Maybe OpenTerm -> AtomicPermTrans ctx (LLVMBlockType w) -- | Perm_NamedConj permissions are a permission + a term @@ -1182,11 +1744,11 @@ data AtomicPermTrans ctx a where -- | @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) -> - OpenTerm -> AtomicPermTrans ctx LifetimeType + 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 @@ -1205,12 +1767,9 @@ data AtomicPermTrans ctx a where APTrans_Struct :: PermTransCtx ctx (CtxToRList args) -> AtomicPermTrans ctx (StructType args) - -- | The translation of functional permission is either a SAW term of - -- functional type or a recursive call to the @n@th function in the most - -- recently bound frame of recursive functions + -- | The translation of functional permission is a SAW term of @specFun@ type APTrans_Fun :: Mb ctx (FunPerm ghosts (CtxToRList cargs) gouts ret) -> - Either Natural OpenTerm -> - AtomicPermTrans ctx (FunctionHandleType cargs ret) + FunTrans -> AtomicPermTrans ctx (FunctionHandleType cargs ret) -- | Propositional permissions are represented by a SAW term APTrans_BVProp :: (1 <= w, KnownNat w) => BVPropTrans ctx w -> @@ -1241,36 +1800,39 @@ bvRangeTransOff (BVRangeTrans _ off _) = off bvRangeTransLen :: BVRangeTrans ctx w -> ExprTrans (BVType w) bvRangeTransLen (BVRangeTrans _ _ len) = len --- | The translation of an LLVM array permission is a SAW term of @BVVec@ type, --- along with a 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 = typeTransType1 . 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] } --} - -- | 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 -> @@ -1318,11 +1880,35 @@ unPTransLLVMArray :: String -> PermTrans ctx (LLVMPointerType w) -> unPTransLLVMArray _ (PTrans_Conj [APTrans_LLVMArray aptrans]) = aptrans unPTransLLVMArray str _ = error (str ++ ": not an LLVM array permission") --- | Add a borrow translation to the translation of an 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 @@ -1343,34 +1929,26 @@ instance IsTermTrans (PermTrans ctx a) where transTerms (PTrans_Term _ t) = [t] instance IsTermTrans (PermTransCtx ctx ps) where - transTerms MNil = [] - transTerms (ctx :>: ptrans) = transTerms ctx ++ transTerms ptrans + 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 _ t) = [t] + transTerms (APTrans_LLVMBlock _ ts) = maybeToList ts transTerms (APTrans_LLVMFree _) = [] transTerms (APTrans_LLVMFunPtr _ trans) = transTerms trans transTerms APTrans_IsLLVMPtr = [] - transTerms (APTrans_LLVMBlockShape _ t) = [t] + transTerms (APTrans_LLVMBlockShape _ ts) = maybeToList ts transTerms (APTrans_NamedConj _ _ _ t) = [t] transTerms (APTrans_DefinedNamedConj _ _ _ ptrans) = transTerms ptrans transTerms (APTrans_LLVMFrame _) = [] - transTerms (APTrans_LOwned _ _ _ _ _ t) = [t] + 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 _ (Right t)) = [t] - transTerms (APTrans_Fun _ (Left _)) = - -- FIXME: handling this would probably require polymorphism over FunStack - -- arguments in the translation of functions, because passing a pointer to a - -- recursively defined function would not be in the empty FunStack - [failOpenTerm - ("Heapster cannot (yet) translate recursive calls into terms; " ++ - "This probably resulted from a function that takes a pointer to " ++ - "a function that is recursively defined with it")] + transTerms (APTrans_Fun _ f) = [funTransTerm f] transTerms (APTrans_BVProp prop) = transTerms prop transTerms APTrans_Any = [] @@ -1390,10 +1968,6 @@ instance IsTermTrans (LLVMArrayBorrowTrans ctx w) where transTerms (LLVMArrayBorrowTrans _ prop_transs) = transTerms prop_transs -} --- | Map a context of perm translations to a list of 'OpenTerm's, dropping the --- "invisible" ones whose permissions are translated to 'Nothing' -permCtxToTerms :: PermTransCtx ctx tps -> [OpenTerm] -permCtxToTerms = concat . RL.mapToList transTerms -- | Extract out the permission of a permission translation result permTransPerm :: RAssign Proxy ctx -> PermTrans ctx a -> Mb ctx (ValuePerm a) @@ -1423,7 +1997,8 @@ atomicPermTransPerm _ (APTrans_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 _) = +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 @@ -1454,57 +2029,78 @@ 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) -extsMb :: CruCtx ctx2 -> Mb ctx a -> Mb (ctx :++: ctx2) a -extsMb ctx = mbCombine proxies . fmap (nus proxies . const) - where - proxies = cruCtxProxies ctx -- | Generic function to extend the context of the translation of a permission class ExtPermTrans f where - extPermTrans :: f ctx a -> f (ctx :> tp) a + extPermTransMulti :: ExprTransCtx ctx2 -> f ctx1 a -> f (ctx1 :++: ctx2) a instance ExtPermTrans PermTrans where - extPermTrans (PTrans_Eq e) = PTrans_Eq $ extMb e - extPermTrans (PTrans_Conj aps) = - PTrans_Conj (map extPermTrans aps) - extPermTrans (PTrans_Defined n args a ptrans) = - PTrans_Defined n (extMb args) (extMb a) (extPermTrans ptrans) - extPermTrans (PTrans_Term p t) = PTrans_Term (extMb p) t + 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 - extPermTrans (APTrans_LLVMField fld ptrans) = - APTrans_LLVMField (extMb fld) (extPermTrans ptrans) - extPermTrans (APTrans_LLVMArray arr_trans) = - APTrans_LLVMArray $ extPermTrans arr_trans - extPermTrans (APTrans_LLVMBlock mb_bp t) = APTrans_LLVMBlock (extMb mb_bp) t - extPermTrans (APTrans_LLVMFree e) = APTrans_LLVMFree $ extMb e - extPermTrans (APTrans_LLVMFunPtr tp ptrans) = - APTrans_LLVMFunPtr tp (extPermTrans ptrans) - extPermTrans APTrans_IsLLVMPtr = APTrans_IsLLVMPtr - extPermTrans (APTrans_LLVMBlockShape mb_sh t) = - APTrans_LLVMBlockShape (extMb mb_sh) t - extPermTrans (APTrans_NamedConj npn args off t) = - APTrans_NamedConj npn (extMb args) (extMb off) t - extPermTrans (APTrans_DefinedNamedConj npn args off ptrans) = - APTrans_DefinedNamedConj npn (extMb args) (extMb off) (extPermTrans ptrans) - extPermTrans (APTrans_LLVMFrame fp) = APTrans_LLVMFrame $ extMb fp - extPermTrans (APTrans_LOwned ls tps_in tps_out ps_in ps_out t) = - APTrans_LOwned (extMb ls) tps_in tps_out (extMb ps_in) (extMb ps_out) t - extPermTrans (APTrans_LOwnedSimple tps lops) = - APTrans_LOwnedSimple tps (extMb lops) - extPermTrans (APTrans_LCurrent p) = APTrans_LCurrent $ extMb p - extPermTrans APTrans_LFinished = APTrans_LFinished - extPermTrans (APTrans_Struct ps) = APTrans_Struct $ RL.map extPermTrans ps - extPermTrans (APTrans_Fun fp trans) = APTrans_Fun (extMb fp) trans - extPermTrans (APTrans_BVProp prop_trans) = - APTrans_BVProp $ extPermTrans prop_trans - extPermTrans APTrans_Any = APTrans_Any + 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 - extPermTrans (LLVMArrayPermTrans ap len sh {- bs -} t) = - LLVMArrayPermTrans (extMb ap) len (fmap extPermTrans sh) - {- (map extPermTrans bs) -} t + 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 @@ -1513,14 +2109,22 @@ instance ExtPermTrans LLVMArrayBorrowTrans where -} instance ExtPermTrans BVPropTrans where - extPermTrans (BVPropTrans prop t) = BVPropTrans (extMb prop) t + extPermTransMulti ectx (BVPropTrans prop t) = + BVPropTrans (extMbAny ectx prop) t instance ExtPermTrans BVRangeTrans where - extPermTrans (BVRangeTrans rng t1 t2) = BVRangeTrans (extMb rng) t1 t2 + 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 -extPermTransCtx :: PermTransCtx ctx ps -> PermTransCtx (ctx :> tp) ps -extPermTransCtx = RL.map extPermTrans +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 -> @@ -1540,12 +2144,12 @@ 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 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) - t + ts offsetLLVMAtomicPermTrans _ (APTrans_LLVMFree _) = Nothing offsetLLVMAtomicPermTrans _ (APTrans_LLVMFunPtr _ _) = Nothing offsetLLVMAtomicPermTrans _ p@APTrans_IsLLVMPtr = Just p @@ -1581,6 +2185,37 @@ 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 -> @@ -1634,8 +2269,8 @@ getLLVMArrayTransCell arr_trans mb_cell cell_tm (BVPropTrans _ in_rng_pf:_) = -- substitutes for all the names offsetLLVMAtomicPermTrans (mbMap2 llvmArrayCellToOffset (llvmArrayTransPerm arr_trans) mb_cell) $ - typeTransF (llvmArrayTransHeadCell arr_trans) - [applyOpenTermMulti (globalOpenTerm "Prelude.atBVVec") + typeTransF (tupleTypeTrans (llvmArrayTransHeadCell arr_trans)) + [applyGlobalOpenTerm "Prelude.atBVVec" [natOpenTerm w, llvmArrayTransLen arr_trans, llvmArrayTransCellType arr_trans, llvmArrayTransTerm arr_trans, cell_tm, in_rng_pf]] @@ -1645,17 +2280,18 @@ getLLVMArrayTransCell _ _ _ _ = -- | Write an array cell of the translation of an LLVM array permission at a -- given index -setLLVMArrayTransCell :: (1 <= w, KnownNat w) => LLVMArrayPermTrans ctx w -> +setLLVMArrayTransCell :: (1 <= w, KnownNat w) => + LLVMArrayPermTrans ctx w -> OpenTerm -> AtomicPermTrans ctx (LLVMPointerType w) -> LLVMArrayPermTrans ctx w -setLLVMArrayTransCell arr_trans cell_tm cell_value = +setLLVMArrayTransCell arr_trans cell_ix_tm cell_value = let w = fromInteger $ natVal arr_trans in arr_trans { llvmArrayTransTerm = - applyOpenTermMulti (globalOpenTerm "Prelude.updBVVec") + applyGlobalOpenTerm "Prelude.updBVVec" [natOpenTerm w, llvmArrayTransLen arr_trans, llvmArrayTransCellType arr_trans, llvmArrayTransTerm arr_trans, - cell_tm, transTerm1 cell_value] } + cell_ix_tm, transTupleTerm cell_value] } -- | Read a slice (= a sub-array) of the translation of an LLVM array permission @@ -1669,18 +2305,18 @@ getLLVMArrayTransSlice :: (1 <= w, KnownNat w) => LLVMArrayPermTrans ctx w -> LLVMArrayPermTrans ctx w getLLVMArrayTransSlice arr_trans sub_arr_tp rng_trans prop_transs = let w = fromInteger $ natVal arr_trans - _mb_ap = llvmArrayTransPerm 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, _) = expectLengthAtLeastTwo prop_transs + (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 - [applyOpenTermMulti - (globalOpenTerm "Prelude.sliceBVVec") + [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 @@ -1691,7 +2327,6 @@ setLLVMArrayTransSlice :: (1 <= w, KnownNat w) => LLVMArrayPermTrans ctx w -> LLVMArrayPermTrans ctx w setLLVMArrayTransSlice arr_trans sub_arr_trans off_tm = let w = fromInteger $ natVal arr_trans - _mb_ap = llvmArrayTransPerm arr_trans elem_tp = llvmArrayTransCellType arr_trans len_tm = llvmArrayTransLen arr_trans arr_tm = llvmArrayTransTerm arr_trans @@ -1699,77 +2334,405 @@ setLLVMArrayTransSlice arr_trans sub_arr_trans off_tm = sub_arr_tm = llvmArrayTransTerm sub_arr_trans in arr_trans { llvmArrayTransTerm = - applyOpenTermMulti - (globalOpenTerm "Prelude.updSliceBVVec") + applyGlobalOpenTerm "Prelude.updSliceBVVec" [natOpenTerm w, len_tm, elem_tp, arr_tm, off_tm, len'_tm, sub_arr_tm] } --- | Weaken a monadic function of type @(T1*...*Tn) -> SpecM(U1*...*Um)@ to one --- of type @(V*T1*...*Tn) -> SpecM(V*U1*...*Um)@, @n@-ary tuple types are built --- using 'tupleOfTypes' -weakenMonadicFun1 :: OpenTerm -> [OpenTerm] -> [OpenTerm] -> OpenTerm -> - ImpTransM ext blocks tops rets ps ctx OpenTerm -weakenMonadicFun1 v ts us f = - -- First form a term f1 of type V*(T1*...*Tn) -> SpecM(V*(U1*...*Um)) - do let t_tup = tupleOfTypes ts - u_tup = tupleOfTypes us - f1 <- applyNamedSpecOpEmptyM "Prelude.tupleSpecMFunBoth" [t_tup, u_tup, v, f] - - let f2 = case ts of - -- If ts is empty, form the term \ (x:V) -> f1 (x, ()) to coerce f1 - -- from type V*#() -> SpecM(V*Us) to type V -> SpecM(V*Us) - [] -> - lambdaOpenTerm "x" v $ \x -> - applyOpenTerm f1 (pairOpenTerm x unitOpenTerm) - -- Otherwise, leave f1 unchanged - _ -> f1 - - case us of - -- If us is empty, compose f2 with \ (x:V*#()) -> returnM V x.(1) to - -- coerce from V*Us -> SpecM (V*#()) to V*Us -> SpecM V - [] -> - do fun_tm <- - lambdaOpenTermTransM "x" (pairTypeOpenTerm v unitTypeOpenTerm) - (\x -> applyNamedSpecOpEmptyM "Prelude.retS" [v, pairLeftOpenTerm x]) - applyNamedSpecOpEmptyM "Prelude.composeS" - [tupleOfTypes (v:ts), pairTypeOpenTerm v unitTypeOpenTerm, - v, f2, fun_tm] - -- Otherwise, leave f2 unchanged - _ -> return f2 - - --- | Weaken a monadic function of type --- --- > (T1*...*Tn) -> SpecM e eTp emptyFunStack (U1*...*Um) --- --- to one of type --- --- > (V1*...*Vk*T1*...*Tn) -> SpecM e eTp emptyFunStack (V1*...*Vk*U1*...*Um) --- --- where tuples of 2 or more types are right-nested and and in a unit type, --- i.e., have the form @(T1 * (T2 * (... * (Tn * #()))))@ -weakenMonadicFun :: [OpenTerm] -> [OpenTerm] -> [OpenTerm] -> OpenTerm -> - ImpTransM ext blocks tops rets ps ctx OpenTerm -weakenMonadicFun vs ts_top us_top f_top = - foldr (\v rest_m -> - do (ts,us,f) <- rest_m - f' <- weakenMonadicFun1 v ts us f - return (v:ts, v:us, f')) - (return (ts_top, us_top, f_top)) - vs - >>= \(_,_,ret) -> return ret - --- | Weaken a monadic function which is the translation of an ownership --- permission @lowned(ps_in -o ps_out)@ to @lowned(P * ps_in -o P * ps_out)@ -weakenLifetimeFun :: TypeTrans (PermTrans ctx a) -> - TypeTrans (PermTransCtx ctx ps_in) -> - TypeTrans (PermTransCtx ctx ps_out) -> - OpenTerm -> - ImpTransM ext blocks tops rets ps ctx OpenTerm -weakenLifetimeFun tp_trans ps_in_trans ps_out_trans f = - weakenMonadicFun (transTerms - tp_trans) (transTerms - ps_in_trans) (transTerms ps_out_trans) f +---------------------------------------------------------------------- +-- * 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 @@ -1778,54 +2741,51 @@ instance (1 <= w, KnownNat w, TransInfo info) => do let w = natVal4 e1 t1 <- translate1 e1 t2 <- translate1 e2 - return $ flip mkTypeTrans1 (BVPropTrans prop) $ - (dataTypeOpenTerm "Prelude.Eq" - [applyOpenTermMulti (globalOpenTerm "Prelude.Vec") - [natOpenTerm w, - globalOpenTerm "Prelude.Bool"], - t1, t2]) + 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 $ mkTypeTrans1 unitTypeOpenTerm (BVPropTrans prop) + return $ mkBVPropTrans prop unitTypeOpenTerm [nuMP| BVProp_ULt e1 e2 |] -> do let w = natVal4 e1 t1 <- translate1 e1 t2 <- translate1 e2 - return $ flip mkTypeTrans1 (BVPropTrans prop) - (dataTypeOpenTerm "Prelude.Eq" - [globalOpenTerm "Prelude.Bool", - applyOpenTermMulti (globalOpenTerm "Prelude.bvult") - [natOpenTerm w, t1, t2], - trueOpenTerm]) + 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 $ flip mkTypeTrans1 (BVPropTrans prop) - (dataTypeOpenTerm "Prelude.Eq" - [globalOpenTerm "Prelude.Bool", - applyOpenTermMulti (globalOpenTerm "Prelude.bvule") - [natOpenTerm w, t1, t2], - trueOpenTerm]) + 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 $ flip mkTypeTrans1 (BVPropTrans prop) - (dataTypeOpenTerm "Prelude.Eq" - [globalOpenTerm "Prelude.Bool", - applyOpenTermMulti (globalOpenTerm "Prelude.bvule") - [natOpenTerm w, t1, - applyOpenTermMulti (globalOpenTerm "Prelude.bvSub") + 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]) + trueOpenTerm] instance (1 <= w, KnownNat w, TransInfo info) => Translate info ctx (BVRange w) (BVRangeTrans ctx w) where @@ -1834,7 +2794,9 @@ instance (1 <= w, KnownNat w, TransInfo info) => len_tm <- translate len return $ BVRangeTrans rng off_tm len_tm --- [| p :: ValuePerm |] = type of the impl translation of reg with perms p +-- 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 @@ -1850,27 +2812,65 @@ instance TransInfo info => sigmaTypePermTransM "x_ex" tp_trans (mbCombine RL.typeCtxProxies p1) [nuMP| ValPerm_Named npn args off |] -> do env <- infoEnv <$> ask - args_trans <- translate args case lookupNamedPerm env (mbLift npn) of Just (NamedPerm_Opaque op) -> - return $ mkPermTypeTrans1 p (applyOpenTermMulti - (globalOpenTerm $ opaquePermTrans op) - (transTerms args_trans)) + mkPermTypeTrans1 p <$> + applyGlobalOpenTerm (opaquePermTrans op) <$> + transTerms <$> translate args Just (NamedPerm_Rec rp) -> - return $ mkPermTypeTrans1 p (applyOpenTermMulti - (globalOpenTerm $ recPermTransType rp) - (transTerms args_trans)) + 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 -> error "Unknown permission name!" + Nothing -> panic "translate" ["Unknown permission name!"] [nuMP| ValPerm_Conj ps |] -> fmap PTrans_Conj <$> listTypeTrans <$> translate ps [nuMP| ValPerm_Var x _ |] -> - mkPermTypeTrans1 p <$> translate1 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 @@ -1882,9 +2882,10 @@ instance TransInfo info => fmap APTrans_LLVMArray <$> translate ap [nuMP| Perm_LLVMBlock bp |] -> - do tp <- translate1 (fmap llvmBlockShape bp) - return $ mkTypeTrans1 tp (APTrans_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 |] -> @@ -1893,8 +2894,10 @@ instance TransInfo info => [nuMP| Perm_IsLLVMPtr |] -> return $ mkTypeTrans0 APTrans_IsLLVMPtr [nuMP| Perm_LLVMBlockShape sh |] -> - do tp <- translate1 sh - return $ mkTypeTrans1 tp (APTrans_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 @@ -1912,12 +2915,20 @@ instance TransInfo info => [nuMP| Perm_LLVMFrame fp |] -> return $ mkTypeTrans0 $ APTrans_LLVMFrame fp [nuMP| Perm_LOwned ls tps_in tps_out ps_in ps_out |] -> - do tp_in <- typeTransTupleType <$> translate ps_in - tp_out <- typeTransTupleType <$> translate ps_out - specm_tp <- emptyStackSpecMTypeTransM tp_out - let tp = arrowOpenTerm "ps" tp_in specm_tp - return $ mkTypeTrans1 tp (APTrans_LOwned ls - (mbLift tps_in) (mbLift 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 |] -> @@ -1927,12 +2938,48 @@ instance TransInfo info => [nuMP| Perm_Struct ps |] -> fmap APTrans_Struct <$> translate ps [nuMP| Perm_Fun fun_perm |] -> - translate fun_perm >>= \tp_term -> - return $ mkTypeTrans1 tp_term (APTrans_Fun fun_perm . Right) + 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 @@ -1944,20 +2991,20 @@ translateLLVMArrayPerm :: (1 <= w, KnownNat w, TransInfo info) => translateLLVMArrayPerm mb_ap = do let w = natVal2 mb_ap let w_term = natOpenTerm w - sh_trans <- translate $ mbMapCl $(mkClosed [| Perm_LLVMBlock . - llvmArrayPermHead |]) mb_ap - let elem_tp = typeTransType1 sh_trans + -- 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 = - applyOpenTermMulti (globalOpenTerm "Prelude.BVVec") - [w_term, len_term, elem_tp] + 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 sh_trans) - {- <*> bs_trans -} ) + 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 @@ -1965,6 +3012,18 @@ instance (1 <= w, KnownNat w, TransInfo info) => 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, @@ -1988,12 +3047,23 @@ instance TransInfo info => [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 @@ -2008,10 +3078,18 @@ instance TransInfo info => error ("Translating expression permissions that could not be converted " ++ "to variable permissions:" ++ permPrettyString emptyPPInfo mb_ps) -emptyStackOpenTerm :: OpenTerm -emptyStackOpenTerm = globalOpenTerm "Prelude.emptyFunStack" +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 pi-abstraction (FIXME HERE NOW: document translation) +-- 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 -> @@ -2020,14 +3098,36 @@ instance TransInfo info => tops_prxs = cruCtxProxies tops rets = CruCtxCons (mbLift gouts) (mbLift ret) rets_prxs = cruCtxProxies rets in - (infoCtx <$> ask) >>= \ctx -> + (RL.map (const Proxy) <$> infoCtx <$> ask) >>= \ctx -> + (infoEvType <$> ask) >>= \ev -> case RL.appendAssoc ctx tops_prxs rets_prxs of Refl -> piExprCtxApp tops $ - piPermCtx (mbCombine tops_prxs perms_in) $ \_ -> - specMTypeTransM emptyStackOpenTerm =<< - translateRetType rets (mbCombine - (RL.append tops_prxs rets_prxs) perms_out) + 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) -> @@ -2043,24 +3143,27 @@ lambdaPermCtx :: TransInfo info => Mb ctx (ValuePerms ps) -> lambdaPermCtx ps f = translate ps >>= \tptrans -> lambdaTransM "p" tptrans f --- | Pi-abstraction over a sequence of permissions -piPermCtx :: TransInfo info => Mb ctx (ValuePerms ps) -> - (PermTransCtx ctx ps -> TransM info ctx OpenTerm) -> - TransM info ctx OpenTerm -piPermCtx ps f = - translate ps >>= \tptrans -> piTransM "p" tptrans f - - --- | Build the return type for a function; FIXME: documentation +-- | 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 (flip inExtMultiTransM - (translate ret_perms)) - --- | Build the return type for the function resulting from an entrypoint + 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 @@ -2078,14 +3181,14 @@ translateEntryRetType (TypedEntry {..} -- * The Implication Translation Monad ---------------------------------------------------------------------- --- | A mapping from a block entrypoint to a corresponding SAW variable that is --- bound to its translation if it has one: only those entrypoints marked as the --- heads of strongly-connect components have translations as letrec-bound --- variables +-- | 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, - typedEntryTransRecIx :: Maybe Natural } + typedEntryTransFun :: Maybe OpenTerm } -- | A mapping from a block to the SAW functions for each entrypoint data TypedBlockTrans ext blocks tops rets args = @@ -2096,6 +3199,10 @@ data TypedBlockTrans ext blocks tops rets args = 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 -> @@ -2139,35 +3246,6 @@ lookupCallSite siteID blkMap show (map (\(Some site) -> show $ typedCallSiteID site) (typedEntryCallers $ typedEntryTransEntry entry_trans))) --- | A Haskell representation of a function stack, which is either the empty --- stack or a push of some top frame onto a previous stack -data FunStack = EmptyFunStack | PushFunStack OpenTerm OpenTerm - --- | Build a 'FunStack' with a single frame -singleFunStack :: OpenTerm -> FunStack -singleFunStack frame = PushFunStack frame emptyStackOpenTerm - --- | Convert a 'FunStack' to the term it represents -funStackTerm :: FunStack -> OpenTerm -funStackTerm EmptyFunStack = emptyStackOpenTerm -funStackTerm (PushFunStack frame prev_stack) = - pushFunStackOpenTerm frame prev_stack - --- | Get the top frame of a 'FunStack' if it is non-empty -funStackTop :: FunStack -> Maybe OpenTerm -funStackTop EmptyFunStack = Nothing -funStackTop (PushFunStack frame _) = Just frame - --- | Get the previous stack from a 'FunStack' if it is non-empty -funStackPrev :: FunStack -> Maybe OpenTerm -funStackPrev EmptyFunStack = Nothing -funStackPrev (PushFunStack _ prev_stack) = Just prev_stack - --- | Get the top frame and previous stack of a 'FunStack' if it is non-empty -funStackTopAndPrev :: FunStack -> Maybe (OpenTerm, OpenTerm) -funStackTopAndPrev EmptyFunStack = Nothing -funStackTopAndPrev (PushFunStack frame prev_stack) = Just (frame, prev_stack) - -- | Contextual info for an implication translation data ImpTransInfo ext blocks tops rets ps ctx = @@ -2180,23 +3258,25 @@ data ImpTransInfo ext blocks tops rets ps ctx = itiPermEnv :: PermEnv, itiBlockMapTrans :: TypedBlockMapTrans ext blocks tops rets, itiReturnType :: OpenTerm, - itiChecksFlag :: ChecksFlag, - itiFunStack :: FunStack + 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 itiPermCtx) PTrans_True - , itiPermStack = extPermTransCtx itiPermStack + , 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 translating permission implications +-- | The monad for impure translations type ImpTransM ext blocks tops rets ps = TransM (ImpTransInfo ext blocks tops rets ps) @@ -2204,11 +3284,10 @@ type ImpTransM ext blocks tops rets ps = -- 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 -> - FunStack -> OpenTerm -> + TypedBlockMapTrans ext blocks tops rets -> OpenTerm -> ImpTransM ext blocks tops rets ps ctx a -> TypeTransM ctx a -impTransM pvars pctx mapTrans stack retType = +impTransM pvars pctx mapTrans retType = withInfoM $ \(TypeTransInfo ectx penv pflag) -> ImpTransInfo { itiExprCtx = ectx, itiPermCtx = RL.map (const $ PTrans_True) ectx, @@ -2217,19 +3296,18 @@ impTransM pvars pctx mapTrans stack retType = itiPermEnv = penv, itiBlockMapTrans = mapTrans, itiReturnType = retType, - itiChecksFlag = pflag, - itiFunStack = stack + itiChecksFlag = pflag } --- | Embed a type translation into an impure translation --- FIXME: should no longer need this... -tpTransM :: TypeTransM ctx a -> ImpTransM ext blocks tops rets ps ctx a -tpTransM = +-- | 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 {..}) -> - TypeTransInfo itiExprCtx itiPermEnv itiChecksFlag) + ImpTransInfo { itiBlockMapTrans = emptyTypedBlockMapTrans, .. }) --- | Run an implication translation computation in an "empty" environment, where --- there are no variables in scope and no permissions held anywhere +-- | 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 = @@ -2237,6 +3315,16 @@ inEmptyEnvImpTransM = 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 @@ -2260,6 +3348,33 @@ withPermStackM f_vars f_p = 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)) @@ -2373,76 +3488,234 @@ clearVarPermsM = local $ \info -> info { itiPermCtx = RL.map (const PTrans_True) $ itiPermCtx info } --- | Return the current @FunStack@ as a term -funStackTermM :: ImpTransM ext blocks tops rets ps ctx OpenTerm -funStackTermM = funStackTerm <$> itiFunStack <$> ask - --- | Apply an 'OpenTerm' to the current event type @E@, @evRetType@, @stack@, --- and a list of other arguments -applySpecOpM :: OpenTerm -> [OpenTerm] -> - ImpTransM ext blocks tops rets ps ctx OpenTerm -applySpecOpM f args = - do stack <- funStackTermM - applyEventOpM f (stack : args) - --- | Like 'applySpecOpM' but where the function is given by name -applyNamedSpecOpM :: Ident -> [OpenTerm] -> - ImpTransM ext blocks tops rets ps ctx OpenTerm -applyNamedSpecOpM f args = applySpecOpM (globalOpenTerm f) args - --- | Apply a named @SpecM@ operation to the current event type @E@ and --- @evRetType@, to the empty function stack, and to additional arguments -applyNamedSpecOpEmptyM :: Ident -> [OpenTerm] -> - ImpTransM ext blocks tops rets ps ctx OpenTerm -applyNamedSpecOpEmptyM f args = - applyNamedEventOpM f (emptyStackOpenTerm : args) - --- | Generate the type @SpecM E evRetType stack A@ using the current event type --- and @stack@ and the supplied type @A@. This is different from --- 'specMTypeTransM' because it uses the current @stack@ in an 'ImpTransM' --- computation, and so does not need it passed as an argument. -specMImpTransM :: OpenTerm -> ImpTransM ext blocks tops rets ps ctx OpenTerm -specMImpTransM tp = applyNamedSpecOpM "Prelude.SpecM" [tp] +-- | 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 --- | 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 -bindSpecMTransM :: OpenTerm -> TypeTrans tr -> String -> - (tr -> ImpTransM ext blocks tops rets ps ctx OpenTerm) -> - ImpTransM ext blocks tops rets ps ctx OpenTerm -bindSpecMTransM m m_tp str f = - do ret_tp <- returnTypeM - k_tm <- lambdaTransM str m_tp f - applyNamedSpecOpM "Prelude.bindS" [typeTransType1 m_tp, ret_tp, m, k_tm] --- | The current non-monadic return type -returnTypeM :: ImpTransM ext blocks tops rets ps_out ctx OpenTerm -returnTypeM = itiReturnType <$> ask +-- | A flag to indicate whether a 'PImplTerm' calls its failure continuation +data HasFailures = HasFailures | NoFailures deriving Eq --- | Build the monadic return type @SpecM E evRetType stack ret@, where @ret@ is --- the current return type in 'itiReturnType' -compReturnTypeM :: ImpTransM ext blocks tops rets ps_out ctx OpenTerm -compReturnTypeM = returnTypeM >>= specMImpTransM +instance Semigroup HasFailures where + HasFailures <> _ = HasFailures + _ <> HasFailures = HasFailures + NoFailures <> NoFailures = NoFailures --- | Like 'compReturnTypeM' but build a 'TypeTrans' -compReturnTypeTransM :: - ImpTransM ext blocks tops rets ps_out ctx (TypeTrans OpenTerm) -compReturnTypeTransM = flip mkTypeTrans1 id <$> compReturnTypeM +instance Monoid HasFailures where + mempty = NoFailures --- | Build an @errorS@ computation with the given error message -mkErrorComp :: String -> ImpTransM ext blocks tops rets ps_out ctx OpenTerm -mkErrorComp msg = - do ret_tp <- returnTypeM - applyNamedSpecOpM "Prelude.errorS" [ret_tp, stringLitOpenTerm (pack msg)] +-- | 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)) --- | 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 +-- | 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 ----------------------------------------------------------------------- --- * Translating Permission Implication Constructs ----------------------------------------------------------------------- -- | Translate the output permissions of a 'SimplImpl' translateSimplImplOut :: Mb ctx (SimplImpl ps_in ps_out) -> @@ -2523,18 +3796,18 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of do tp1 <- translate p1 tp2 <- translate p2 tptrans <- translateSimplImplOutHead mb_simpl - withPermStackM id - (\(ps :>: p_top) -> - ps :>: typeTransF tptrans [leftTrans tp1 tp2 p_top]) + 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 - withPermStackM id - (\(ps :>: p_top) -> - ps :>: typeTransF tptrans [rightTrans tp1 tp2 p_top]) + withPermStackTopTermsM id + (\ts (ps :>: _p_top) -> + ps :>: typeTransF tptrans [rightTrans tp1 tp2 (tupleOpenTerm' ts)]) m [nuMP| SImpl_IntroExists _ e p |] -> @@ -2542,8 +3815,9 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of tp_trans <- translateClosed tp out_trans <- translateSimplImplOutHead mb_simpl etrans <- translate e - trm <- sigmaPermTransM "x_ex" tp_trans (mbCombine RL.typeCtxProxies p) - etrans getTopPermM + trm <- + sigmaPermTransM "x_ex" tp_trans (mbCombine RL.typeCtxProxies p) + etrans getTopPermM withPermStackM id (\(pctx :>: _) -> pctx :>: typeTransF out_trans [trm]) m @@ -2559,10 +3833,12 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of let prxs1 = mbLift $ mbMapCl $(mkClosed [| distPermsToProxies . eqProofPerms |]) eqp let prxs = RL.append prxs_a prxs1 - withPermStackM id - (\pctx -> - let (pctx1, pctx2) = RL.split ps0 prxs pctx in - RL.append pctx1 (typeTransF ttrans (transTerms pctx2))) + 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 |] -> @@ -2669,14 +3945,14 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of m [nuMP| SImpl_IntroStructField _ _ memb _ |] -> - do tptrans <- translateSimplImplOutHead mb_simpl - withPermStackM RL.tail - (\case - (pctx :>: PTrans_Conj [APTrans_Struct pctx_str] :>: ptrans) -> - pctx :>: typeTransF tptrans (transTerms $ - RL.set (mbLift memb) ptrans pctx_str) - _ -> error "translateSimplImpl: SImpl_IntroStructField") - m + 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 @@ -2710,9 +3986,8 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of -- FIXME: offsetLLVMPerm can throw away conjuncts, like free and llvmfunptr -- permissions, that change the type of the translation do tptrans <- translateSimplImplOutHead mb_simpl - withPermStackM RL.tail - (\(pctx :>: _ :>: ptrans) -> - pctx :>: typeTransF tptrans (transTerms ptrans)) + withPermStackTopTermsM RL.tail + (\ts (pctx :>: _ :>: _) -> pctx :>: typeTransF tptrans ts) m [nuMP| SImpl_CastLLVMFree _ _ e2 |] -> @@ -2722,9 +3997,10 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of [nuMP| SImpl_CastLLVMFieldOffset _ _ _ |] -> do tptrans <- translateSimplImplOutHead mb_simpl - withPermStackM RL.tail - (\(pctx :>: ptrans :>: _) -> - pctx :>: typeTransF tptrans (transTerms ptrans)) + withPermStackTermsM + (\(_ :>: ptrans :>: _) -> ptrans) + RL.tail + (\ts (pctx :>: _ :>: _) -> pctx :>: typeTransF tptrans ts) m [nuMP| SImpl_IntroLLVMFieldContents x _ mb_fld |] -> @@ -2766,9 +4042,8 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of [nuMP| SImpl_DemoteLLVMArrayRW _ _ |] -> do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackM id - (\(pctx :>: ptrans) -> - pctx :>: typeTransF ttrans (transTerms ptrans)) + withPermStackTopTermsM id + (\ts (pctx :>: _) -> pctx :>: typeTransF ttrans ts) m [nuMP| SImpl_LLVMArrayCopy _ mb_ap _ _ |] -> @@ -2858,7 +4133,8 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of m [nuMP| SImpl_LLVMArrayAppend _ mb_ap1 mb_ap2 |] -> - do (w_term, len1_tm, elem_tp, _) <- translateLLVMArrayPerm mb_ap1 + 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 <- @@ -2868,19 +4144,19 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of _ -> error "translateSimplImpl: SImpl_LLVMArrayAppend") $ fmap distPermsHeadPerm $ mbSimplImplOut mb_simpl (_ :>: ptrans1 :>: ptrans2) <- itiPermStack <$> ask - arr_out_comp_tm <- - applyNamedSpecOpM "Prelude.appendCastBVVecS" - [w_term, len1_tm, len2_tm, len3_tm, elem_tp, - transTerm1 ptrans1, transTerm1 ptrans2] - bindSpecMTransM arr_out_comp_tm tp_trans "appended_array" $ \ptrans_arr' -> + 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 - withPermStackM id - (\(pctx :>: ptrans) -> pctx :>: typeTransF ttrans [transTerm1 ptrans]) + withPermStackTopTermsM id + (\ts (pctx :>: _) -> pctx :>: typeTransF ttrans ts) m [nuMP| SImpl_LLVMArrayToField _ _ _ |] -> @@ -2898,10 +4174,11 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of let bvZero_nat_tm = applyGlobalOpenTerm "Prelude.bvToNat" [w_tm, bvLitOpenTerm (replicate w False)] - vec_cast_m <- - applyNamedSpecOpM "Prelude.castVecS" [elem_tp, natOpenTerm 0, - bvZero_nat_tm, vec_tm] - bindSpecMTransM vec_cast_m ap_tp_trans "empty_vec" $ \ptrans_arr -> + 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 @@ -2909,11 +4186,11 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of -- 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 - withPermStackM (:>: translateVar x) - (\(pctx :>: ptrans_block) -> + withPermStackTopTermsM (:>: translateVar x) + (\ts (pctx :>: ptrans_block) -> let arr_term = - applyOpenTermMulti (globalOpenTerm "Prelude.repeatBVVec") - [w_tm, len_tm, elem_tp, transTerm1 ptrans_block] in + 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) @@ -2926,18 +4203,18 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of _ -> error ("translateSimplImpl: SImpl_LLVMArrayFromBlock: " ++ "unexpected form of output permission") (w_tm, len_tm, elem_tp, ap_tp_trans) <- translateLLVMArrayPerm mb_ap - withPermStackM id - (\(pctx :>: ptrans_cell) -> + 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, transTerm1 ptrans_cell] + [w_tm, elem_tp, ts] -} - applyOpenTermMulti (globalOpenTerm "Prelude.repeatBVVec") - [w_tm, len_tm, elem_tp, transTerm1 ptrans_cell] in + applyGlobalOpenTerm "Prelude.repeatBVVec" + [w_tm, len_tm, elem_tp, tupleOpenTerm' ts] in pctx :>: PTrans_Conj [APTrans_LLVMArray $ typeTransF ap_tp_trans [arr_term]]) m @@ -2990,18 +4267,17 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of ++ "found non-field perm where field perm was expected") let arr_trans = unPTransLLVMArray - "translateSimplImpl: SImpl_LLVMArrayCellCopy" ptrans_array + "translateSimplImpl: SImpl_LLVMArrayCellReturn" ptrans_array {- let b_trans = llvmArrayTransFindBorrow (fmap FieldBorrow cell) arr_trans -} - cell_tm <- translate1 mb_cell - let arr_trans' = - (setLLVMArrayTransCell arr_trans cell_tm - {- (llvmArrayBorrowTransProps b_trans) -} aptrans_cell) + 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']) + pctx :>: PTrans_Conj [APTrans_LLVMArray arr_trans'']) m [nuMP| SImpl_LLVMArrayContents _ mb_ap mb_sh impl |] -> @@ -3021,18 +4297,20 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of inExtTransM ETrans_LLVM $ translateCurryLocalPermImpl "Error mapping array cell permissions:" (mbCombine RL.typeCtxProxies impl) MNil MNil - (fmap ((MNil :>:) . extPermTrans) cell_in_trans) (MNil :>: Member_Base) - (fmap ((MNil :>:) . extPermTrans) cell_out_trans) + (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 - arr_out_comp_tm <- - applyNamedSpecOpM "Prelude.mapBVVecS" - [elem_tp, typeTransType1 cell_out_trans, impl_tm, - w_term, len_term, transTerm1 ptrans_arr] + 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 - bindSpecMTransM arr_out_comp_tm p_out_trans "mapped_array" $ \ptrans_arr' -> + bindTransM arr_out_comp_tm p_out_trans "mapped_array" $ \ptrans_arr' -> withPermStackM id (\(pctx :>: _) -> pctx :>: ptrans_arr') m [nuMP| SImpl_LLVMFieldIsPtr x _ |] -> @@ -3053,175 +4331,179 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of pctx :>: PTrans_Conj [APTrans_IsLLVMPtr] :>: ptrans) m - [nuMP| SImpl_SplitLifetime _ f args l _ _ _ _ ps_in ps_out |] -> - do pctx_out_trans <- translateSimplImplOut mb_simpl - ps_in_trans <- translate ps_in - ps_out_trans <- translate ps_out - -- FIXME: write a fun to translate-and-apply a lifetimefunctor - x_tp_trans <- translate (mbMap3 ltFuncApply f args l) - ptrans_l <- getTopPermM - f_tm <- - weakenLifetimeFun x_tp_trans ps_in_trans ps_out_trans $ - transTerm1 ptrans_l - withPermStackM + [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) - (\(pctx :>: ptrans_x :>: _ :>: _) -> - -- The permission for x does not change type, just its lifetime; the - -- permission for l has the (tupled) type of x added as a new input and - -- output with tupleSpecMFunBoth - RL.append pctx $ - typeTransF pctx_out_trans (transTerms ptrans_x ++ [f_tm])) + (\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 _ _ _ _ _ _ _ |] -> - do pctx_out_trans <- translateSimplImplOut mb_simpl - withPermStackM id - (\(pctx :>: ptrans_l) -> - RL.append pctx $ typeTransF pctx_out_trans (transTerms ptrans_l)) - 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 pctx_out_trans <- translateSimplImplOut mb_simpl + do ttr_lcur <- translateSimplImplOutTailHead mb_simpl withPermStackM (\(ns :>: l1) -> ns :>: l1 :>: l1) (\(pctx :>: ptrans_l) -> - -- Note: lcurrent perms do not contain any terms and the term for the - -- lowned permission does not change, so the only terms in both the - -- input and the output are in ptrans_l - RL.append pctx $ typeTransF pctx_out_trans (transTerms ptrans_l)) + pctx :>: typeTransF ttr_lcur [] :>: ptrans_l) m - [nuMP| SImpl_RemoveContainedLifetime _ _ _ _ _ _ _ |] -> - do pctx_out_trans <- translateSimplImplOut mb_simpl - withPermStackM - (\(ns :>: l1 :>: _) -> ns :>: l1) - (\(pctx :>: ptrans_l :>: _) -> - -- Note: lcurrent perms do not contain any terms and the term for the - -- lowned permission does not change, so the only terms in both the - -- input and the output are in ptrans_l - RL.append pctx $ typeTransF pctx_out_trans (transTerms 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 - withPermStackM RL.tail - (\(pctx :>: ptrans_x :>: _) -> + 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 $ transTerms ptrans_x)) + RL.append pctx (typeTransF pctx_out_trans ts)) m - [nuMP| SImpl_MapLifetime l _ _ _ ps_in ps_out _ _ + [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 output permissions and all of the perm lists - do pctx_out_trans <- translateSimplImplOut mb_simpl - ps_in_trans <- tupleTypeTrans <$> translate ps_in - ps_out_trans <- tupleTypeTrans <$> translate ps_out - ps_in'_trans <- tupleTypeTrans <$> translate ps_in' - ps_out'_trans <- tupleTypeTrans <$> translate ps_out' - -- ps1_trans <- translate ps1 - -- ps2_trans <- translate ps2 + -- 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 - (pctx_ps, pctx12 :>: ptrans_l) <- pure $ RL.split ps0 prxs_in pctx + 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 - let vars_out = vars_ps :>: translateVar l - - -- Now build the output lowned function by composing the input lowned - -- function with the translations of the implications on inputs and outputs - let fromJustOrError (Just x) = x - fromJustOrError Nothing = error "translateSimplImpl: SImpl_MapLifetime" - ps_in'_vars = - RL.map (translateVar . getCompose) $ mbRAssign $ - fmap (fromJustOrError . exprPermsVars) ps_in' - ps_out_vars = - RL.map (translateVar . getCompose) $ mbRAssign $ - fmap (fromJustOrError . exprPermsVars) ps_out - impl_in_tm <- - translateCurryLocalPermImpl "Error mapping lifetime input perms:" impl_in - pctx1 vars1 ps_in'_trans ps_in'_vars ps_in_trans - impl_out_tm <- - translateCurryLocalPermImpl "Error mapping lifetime output perms:" impl_out - pctx2 vars2 ps_out_trans ps_out_vars ps_out'_trans - l_res_tm_h <- - applyNamedSpecOpEmptyM "Prelude.composeS" - [typeTransType1 ps_in_trans, typeTransType1 ps_out_trans, - typeTransType1 ps_out'_trans, transTerm1 ptrans_l, impl_out_tm] - l_res_tm <- - applyNamedSpecOpEmptyM "Prelude.composeS" - [typeTransType1 ps_in'_trans, typeTransType1 ps_in_trans, - typeTransType1 ps_out'_trans, impl_in_tm, l_res_tm_h] - - -- Finally, update the permissions + + -- Finally, modify the PTrans_LOwned on top of the stack using + -- mapLtLOwnedTrans withPermStackM - (\_ -> vars_out) - (\_ -> RL.append pctx_ps $ typeTransF pctx_out_trans [l_res_tm]) + (\(_ :>: 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 _ _ _ ps_in ps_out |] -> - -- First, translate the output permissions and the input and output types of - -- the monadic function for the lifeime ownership permission - do ps_out_trans <- tupleTypeTrans <$> translate ps_out + [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 fromJustHelper (Just x) = x - fromJustHelper _ = error "translateSimplImpl: SImpl_EndLifetime" - let vars_out = - RL.append ps_vars $ RL.map (translateVar . getCompose) $ - mbRAssign $ fmap (fromJustHelper . exprPermsVars) ps_out + 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 - lifted_m <- - applyNamedSpecOpM "Prelude.liftStackS" - [typeTransType1 ps_out_trans, - applyOpenTerm (transTerm1 ptrans_l) (transTupleTerm pctx_in)] - bindSpecMTransM - lifted_m - ps_out_trans - "endl_ps" - (\pctx_out -> + 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) -> vars_out :>: l) + (\(_ :>: l) -> RL.append ps_vars vars_out :>: l) (\_ -> RL.append pctx_ps pctx_out :>: PTrans_Conj [APTrans_LFinished]) - m) + m [nuMP| SImpl_IntroLOwnedSimple _ _ _ |] -> do let prx_ps_l = mbRAssignProxies $ mbSimplImplIn mb_simpl ttrans <- translateSimplImplOut mb_simpl - withPermStackM id + withPermStackTermsM (\pctx -> - let (pctx0, pctx_ps :>: _) = RL.split ps0 prx_ps_l pctx in - RL.append pctx0 $ typeTransF ttrans (transTerms pctx_ps)) + 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_lops |] -> - do ttrans <- translateSimplImplOutHead mb_simpl - lops_tp <- typeTransTupleType <$> translate mb_lops - f_tm <- - lambdaOpenTermTransM "ps" lops_tp $ \x -> - applyNamedSpecOpEmptyM "Prelude.retS" [lops_tp, x] - withPermStackM id - (\(pctx0 :>: _) -> pctx0 :>: typeTransF ttrans [f_tm]) - 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 @@ -3234,20 +4516,20 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of [nuMP| SImpl_DemoteLLVMBlockRW _ _ |] -> do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackM id - (\(pctx :>: ptrans) -> pctx :>: typeTransF ttrans (transTerms ptrans)) + 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 [unitOpenTerm]) + (\pctx -> pctx :>: typeTransF ttrans []) m [nuMP| SImpl_CoerceLLVMBlockEmpty _ _ |] -> do ttrans <- translateSimplImplOutHead mb_simpl withPermStackM id - (\(pctx :>: _) -> pctx :>: typeTransF ttrans [unitOpenTerm]) + (\(pctx :>: _) -> pctx :>: typeTransF ttrans []) m [nuMP| SImpl_ElimLLVMBlockToBytes _ mb_bp |] -> @@ -3258,239 +4540,257 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of withPermStackM id (\(pctx :>: _) -> let arr_term = - applyOpenTermMulti (globalOpenTerm "Prelude.repeatBVVec") + 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 - withPermStackM id - (\(pctx :>: ptrans) -> - pctx :>: typeTransF ttrans [pairOpenTerm (transTerm1 ptrans) - unitOpenTerm]) + withPermStackTopTermsM id + (\ts (pctx :>: _) -> + pctx :>: typeTransF ttrans ts) m [nuMP| SImpl_ElimLLVMBlockSeqEmpty _ _ |] -> do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackM id - (\(pctx :>: ptrans) -> - pctx :>: typeTransF ttrans [pairLeftOpenTerm (transTerm1 ptrans)]) + withPermStackTopTermsM id + (\ts (pctx :>: _) -> pctx :>: typeTransF ttrans ts) m [nuMP| SImpl_SplitLLVMBlockEmpty _ _ _ |] -> do ttrans <- translateSimplImplOutHead mb_simpl withPermStackM id - (\(pctx :>: _) -> - pctx :>: typeTransF ttrans [unitOpenTerm, unitOpenTerm]) + (\(pctx :>: _) -> pctx :>: typeTransF ttrans []) m - -- Intro for a recursive named shape applies the fold function to the - -- translations of the arguments plus the translations of the proofs of the - -- permissions + -- Intro for a recursive named shape applies the fold function for the shape [nuMP| SImpl_IntroLLVMBlockNamed _ bp nmsh |] - | [nuMP| RecShapeBody _ _ fold_ids |] <- mbMatch $ fmap namedShapeBody nmsh - , [nuMP| PExpr_NamedShape _ _ _ args |] <- mbMatch $ fmap llvmBlockShape bp -> + | [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 - args_trans <- translate args - fold_id <- - case fold_ids of - [nuP| Just (fold_id,_) |] -> return fold_id - _ -> error "Folding recursive shape before it is defined!" - withPermStackM id - (\(pctx :>: ptrans_x) -> - pctx :>: typeTransF ttrans [applyOpenTermMulti - (globalOpenTerm $ mbLift fold_id) - (transTerms args_trans ++ - transTerms ptrans_x)]) - m + 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 - withPermStackM id - (\(pctx :>: ptrans) -> - pctx :>: typeTransF ttrans [transTerm1 ptrans]) + withPermStackTopTermsM id + (\ts (pctx :>: _) -> pctx :>: typeTransF ttrans ts) m - | otherwise -> fail "translateSimplImpl: SImpl_IntroLLVMBlockNamed, unknown named shape" - -- Elim for a recursive named shape applies the unfold function to the - -- translations of the arguments plus the translations of the proofs of the - -- permissions + | 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 _ _ fold_ids |] <- mbMatch $ fmap namedShapeBody nmsh - , [nuMP| PExpr_NamedShape _ _ _ args |] <- mbMatch $ fmap llvmBlockShape bp -> + | [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 - args_trans <- translate args - unfold_id <- - case fold_ids of - [nuP| Just (_,unfold_id) |] -> return unfold_id - _ -> error "Unfolding recursive shape before it is defined!" - withPermStackM id - (\(pctx :>: ptrans_x) -> - pctx :>: typeTransF ttrans [applyOpenTermMulti - (globalOpenTerm $ mbLift unfold_id) - (transTerms args_trans ++ - transTerms ptrans_x)]) + 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 - -- Intro for a defined named shape (the other case) is a no-op + -- Elim for a defined named shape (the other case) is a no-op | [nuMP| DefinedShapeBody _ |] <- mbMatch $ fmap namedShapeBody nmsh -> do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackM id - (\(pctx :>: ptrans) -> - pctx :>: typeTransF ttrans [transTerm1 ptrans]) + withPermStackTopTermsM id + (\ts (pctx :>: _) -> + pctx :>: typeTransF ttrans ts) m - | otherwise -> fail "translateSimplImpl: ElimLLVMBlockNamed, unknown named shape" + | otherwise -> + panic "translateSimplImpl" ["ElimLLVMBlockNamed, unknown named shape"] [nuMP| SImpl_IntroLLVMBlockNamedMods _ _ |] -> do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackM id - (\(pctx :>: ptrans) -> - pctx :>: typeTransF ttrans (transTerms ptrans)) + withPermStackTopTermsM id + (\ts (pctx :>: _) -> + pctx :>: typeTransF ttrans ts) m [nuMP| SImpl_ElimLLVMBlockNamedMods _ _ |] -> do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackM id - (\(pctx :>: ptrans) -> - pctx :>: typeTransF ttrans (transTerms ptrans)) + withPermStackTopTermsM id + (\ts (pctx :>: _) -> + pctx :>: typeTransF ttrans ts) m [nuMP| SImpl_IntroLLVMBlockFromEq _ _ _ |] -> do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackM RL.tail - (\(pctx :>: _ :>: ptrans) -> - pctx :>: typeTransF ttrans [transTerm1 ptrans]) + withPermStackTopTermsM RL.tail + (\ts (pctx :>: _ :>: _) -> + pctx :>: typeTransF ttrans ts) m [nuMP| SImpl_IntroLLVMBlockPtr _ _ |] -> do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackM id - (\(pctx :>: ptrans) -> - pctx :>: typeTransF ttrans (transTerms ptrans)) + withPermStackTopTermsM id + (\ts (pctx :>: _) -> + pctx :>: typeTransF ttrans ts) m [nuMP| SImpl_ElimLLVMBlockPtr _ _ |] -> do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackM id - (\(pctx :>: ptrans) -> - pctx :>: typeTransF ttrans (transTerms ptrans)) + withPermStackTopTermsM id + (\ts (pctx :>: _) -> + pctx :>: typeTransF ttrans ts) m [nuMP| SImpl_IntroLLVMBlockField _ _ |] -> do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackM id - (\(pctx :>: ptrans) -> - pctx :>: typeTransF ttrans [transTupleTerm ptrans]) + withPermStackTopTermsM id + (\ts (pctx :>: _) -> + pctx :>: typeTransF ttrans (tupleOpenTermList ts)) m [nuMP| SImpl_ElimLLVMBlockField _ _ |] -> do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackM id - (\(pctx :>: ptrans) -> - pctx :>: typeTransF (tupleTypeTrans ttrans) [transTerm1 ptrans]) + 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 - withPermStackM id - (\(pctx :>: ptrans) -> - pctx :>: typeTransF ttrans [transTerm1 ptrans]) + withPermStackTopTermsM id + (\ts (pctx :>: _) -> + pctx :>: typeTransF ttrans [termsExpect1 ts]) m [nuMP| SImpl_ElimLLVMBlockArray _ _ |] -> do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackM id - (\(pctx :>: ptrans) -> - pctx :>: typeTransF ttrans [transTerm1 ptrans]) + withPermStackTopTermsM id + (\ts (pctx :>: _) -> + pctx :>: typeTransF ttrans ts) m [nuMP| SImpl_IntroLLVMBlockSeq _ _ _ _ |] -> do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackM RL.tail - (\(pctx :>: ptrans1 :>: ptrans2) -> - let pair_term = - pairOpenTerm (transTerm1 ptrans1) (transTerm1 ptrans2) in - pctx :>: typeTransF ttrans [pair_term]) + withPermStackTermsM + (\(_ :>: ptrans1 :>: ptrans2) -> (ptrans1,ptrans2)) + RL.tail + (\ts (pctx :>: _ :>: _) -> + pctx :>: typeTransF ttrans (tupleOpenTermList ts)) m - [nuMP| SImpl_ElimLLVMBlockSeq _ _ _ |] -> + [nuMP| SImpl_ElimLLVMBlockSeq _ mb_bp mb_sh2 |] -> do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackM id - (\(pctx :>: ptrans) -> - pctx :>: typeTransF ttrans [pairLeftOpenTerm (transTerm1 ptrans), - pairRightOpenTerm (transTerm1 ptrans)]) + 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 - withPermStackM id - (\(pctx :>: ptrans) -> pctx :>: typeTransF ttrans [transTerm1 ptrans]) + withPermStackTopTermsM id + (\ts (pctx :>: _) -> pctx :>: typeTransF ttrans [termsExpect1 ts]) m [nuMP| SImpl_ElimLLVMBlockOr _ _ _ |] -> do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackM id - (\(pctx :>: ptrans) -> pctx :>: typeTransF ttrans [transTerm1 ptrans]) + withPermStackTopTermsM id + (\ts (pctx :>: _) -> pctx :>: typeTransF ttrans [termsExpect1 ts]) m [nuMP| SImpl_IntroLLVMBlockEx _ _ |] -> do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackM id - (\(pctx :>: ptrans) -> pctx :>: typeTransF ttrans [transTerm1 ptrans]) + withPermStackTopTermsM id + (\ts (pctx :>: _) -> pctx :>: typeTransF ttrans [termsExpect1 ts]) m [nuMP| SImpl_ElimLLVMBlockEx _ _ |] -> do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackM id - (\(pctx :>: ptrans) -> pctx :>: typeTransF ttrans [transTerm1 ptrans]) + withPermStackTopTermsM id + (\ts (pctx :>: _) -> pctx :>: typeTransF ttrans [termsExpect1 ts]) m [nuMP| SImpl_ElimLLVMBlockFalse _ _ |] -> do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackM id - (\(pctx :>: ptrans) -> pctx :>: typeTransF ttrans [transTerm1 ptrans]) - m - - [nuMP| SImpl_FoldNamed _ (NamedPerm_Rec rp) args _ |] -> - do args_trans <- translate args - ttrans <- translateSimplImplOutHead mb_simpl - let fold_ident = mbLift $ fmap recPermFoldFun rp - withPermStackM id - (\(pctx :>: ptrans_x) -> - pctx :>: typeTransF ttrans [applyOpenTermMulti - (globalOpenTerm fold_ident) - (transTerms args_trans - ++ transTerms ptrans_x)]) + withPermStackTopTermsM id + (\ts (pctx :>: _) -> pctx :>: typeTransF ttrans [termsExpect1 ts]) m - [nuMP| SImpl_UnfoldNamed _ (NamedPerm_Rec rp) args _ |] -> - do args_trans <- translate args - ttrans <- translateSimplImplOutHead mb_simpl - let unfold_ident = mbLift $ fmap recPermUnfoldFun rp - withPermStackM id - (\(pctx :>: ptrans_x) -> + [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 (tupleTypeTrans ttrans) [applyOpenTermMulti - (globalOpenTerm unfold_ident) - (transTerms args_trans - ++ [transTerm1 ptrans_x])]) + typeTransF ttrans [applyGlobalOpenTerm "SpecM.unfoldTpElem" + [evTypeTerm ev, d, tupleOpenTerm' ts]]) m [nuMP| SImpl_FoldNamed _ (NamedPerm_Defined _) _ _ |] -> do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackM id - (\(pctx :>: ptrans) -> - pctx :>: typeTransF ttrans (transTerms ptrans)) + withPermStackTopTermsM id + (\ts (pctx :>: _) -> pctx :>: typeTransF ttrans ts) m [nuMP| SImpl_UnfoldNamed _ (NamedPerm_Defined _) _ _ |] -> do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackM id - (\(pctx :>: ptrans) -> - pctx :>: typeTransF ttrans (transTerms ptrans)) + withPermStackTopTermsM id + (\ts (pctx :>: _) -> pctx :>: typeTransF ttrans ts) m {- @@ -3499,40 +4799,41 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of -} [nuMP| SImpl_NamedToConj _ _ _ _ |] -> - do tp_trans <- translateSimplImplOutHead mb_simpl - withPermStackM id - (\(pctx :>: ptrans) -> - pctx :>: typeTransF tp_trans (transTerms ptrans)) m + do ttrans <- translateSimplImplOutHead mb_simpl + withPermStackTopTermsM id + (\ts (pctx :>: _) -> pctx :>: typeTransF ttrans ts) + m [nuMP| SImpl_NamedFromConj _ _ _ _ |] -> - do tp_trans <- translateSimplImplOutHead mb_simpl - withPermStackM id - (\(pctx :>: ptrans) -> - pctx :>: typeTransF tp_trans (transTerms ptrans)) m + do ttrans <- translateSimplImplOutHead mb_simpl + withPermStackTopTermsM id + (\ts (pctx :>: _) -> pctx :>: typeTransF ttrans ts) + m [nuMP| SImpl_NamedArgAlways _ _ _ _ _ _ |] -> - do tp_trans <- translateSimplImplOutHead mb_simpl - withPermStackM id - (\(pctx :>: ptrans) -> - pctx :>: typeTransF tp_trans (transTerms ptrans)) m + do ttrans <- translateSimplImplOutHead mb_simpl + withPermStackTopTermsM id + (\ts (pctx :>: _) -> pctx :>: typeTransF ttrans ts) + m [nuMP| SImpl_NamedArgCurrent _ _ _ _ _ _ |] -> - do tp_trans <- translateSimplImplOutHead mb_simpl - withPermStackM RL.tail - (\(pctx :>: ptrans :>: _) -> - pctx :>: typeTransF tp_trans (transTerms ptrans)) m + do ttrans <- translateSimplImplOutHead mb_simpl + withPermStackTermsM (\ (_ :>: ptrans :>: _) -> ptrans) + RL.tail + (\ts (pctx :>: _ :>: _) -> pctx :>: typeTransF ttrans ts) + m [nuMP| SImpl_NamedArgWrite _ _ _ _ _ _ |] -> - do tp_trans <- translateSimplImplOutHead mb_simpl - withPermStackM id - (\(pctx :>: ptrans) -> - pctx :>: typeTransF tp_trans (transTerms ptrans)) m + do ttrans <- translateSimplImplOutHead mb_simpl + withPermStackTopTermsM id + (\ts (pctx :>: _) -> pctx :>: typeTransF ttrans ts) + m [nuMP| SImpl_NamedArgRead _ _ _ _ _ |] -> - do tp_trans <- translateSimplImplOutHead mb_simpl - withPermStackM id - (\(pctx :>: ptrans) -> - pctx :>: typeTransF tp_trans (transTerms ptrans)) m + 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 @@ -3540,17 +4841,21 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of y_trans <- translate y ttrans <- translateSimplImplOutHead mb_simpl let trans_ident = mbLift $ fmap recPermTransMethod rp - withPermStackM RL.tail - (\(pctx :>: ptrans_x :>: ptrans_y) -> - pctx :>: - typeTransF (tupleTypeTrans ttrans) [applyOpenTermMulti - (globalOpenTerm trans_ident) - (transTerms args_trans - ++ transTerms e_trans - ++ transTerms y_trans - ++ transTerms e_trans - ++ [transTerm1 ptrans_x, - transTerm1 ptrans_y])]) + 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 _ _ _ |] -> @@ -3578,137 +4883,38 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of pctx :>: typeTransF tp_trans []) m --- | A flag to indicate whether the translation of a permission implication --- contains any failures -data HasFailures = HasFailures | NoFailures deriving Eq - -instance Semigroup HasFailures where - HasFailures <> _ = HasFailures - _ <> HasFailures = HasFailures - NoFailures <> NoFailures = NoFailures - -instance Monoid HasFailures where - mempty = NoFailures - --- | The monad for translating 'PermImpl's, which accumulates all failure --- messages in all branches of a 'PermImpl' and either returns a result or --- results in only failures -type PermImplTransM = MaybeT (Writer ([String], HasFailures)) - --- | Run a 'PermImplTransM' computation -runPermImplTransM :: PermImplTransM a -> (Maybe a, ([String], HasFailures)) -runPermImplTransM = runWriter . runMaybeT - --- | Signal a failure in a 'PermImplTransM' computation with the given string -pitmFail :: String -> PermImplTransM a -pitmFail str = tell ([str],HasFailures) >> mzero - --- | Catch any failures in a 'PermImplTransM' computation, returning 'Nothing' --- if the computation completely fails, or an @a@ paired with a 'HasFailures' --- flag to indicate if that @a@ contains some partial failures. Reset the --- 'HasFailures' flag so that @'pitmCatching' m@ is marked as having no failures --- even if @m@ has failures. -pitmCatching :: PermImplTransM a -> PermImplTransM (Maybe a, HasFailures) -pitmCatching m = - do let (maybe_a, (strs,hasf)) = runPermImplTransM m - tell (strs,NoFailures) - return (maybe_a,hasf) - --- | Return or fail depending on whether the input is present or 'Nothing' -pitmMaybeRet :: Maybe a -> PermImplTransM a -pitmMaybeRet (Just a) = return a -pitmMaybeRet Nothing = mzero - --- | 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 - | ImplFailContMsg String - --- | "Force" the translation of a possibly failing computation to always return --- a computation, even if it is just the failing computation -forceImplTrans :: Maybe (ImplFailCont -> - ImpTransM ext blocks tops rets ps ctx OpenTerm) -> - ImplFailCont -> - ImpTransM ext blocks tops rets ps ctx OpenTerm -forceImplTrans (Just trans) k = trans k -forceImplTrans Nothing (ImplFailContTerm errM) = return errM -forceImplTrans Nothing (ImplFailContMsg str) = - returnTypeM >>= \tp -> - applyNamedSpecOpM "Prelude.errorS" [tp, stringLitOpenTerm (pack str)] - --- | Perform a failure by jumping to a failure continuation or signaling an --- error, using an alternate error message in the latter case -implTransAltErr :: String -> ImplFailCont -> - ImpTransM ext blocks tops rets ps ctx OpenTerm -implTransAltErr _ (ImplFailContTerm errM) = return errM -implTransAltErr str (ImplFailContMsg _) = - returnTypeM >>= \tp -> - applyNamedSpecOpM "Prelude.errorS" [tp, stringLitOpenTerm (pack str)] - -- | 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 :: - RL.TypeCtx bs => - ImplTranslateF r ext blocks tops rets => + 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) -> - PermImplTransM (ImplFailCont -> - ImpTransM ext blocks tops rets ps ctx OpenTerm) + PImplTransMTerm r ext blocks tops rets ps ctx translatePermImplUnary (mbMatch -> [nuMP| MbPermImpls_Cons _ _ mb_impl |]) f = - translatePermImpl Proxy (mbCombine RL.typeCtxProxies mb_impl) >>= \trans -> - return $ \k -> f $ trans k - + 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 :: ImplTranslateF r ext blocks tops rets => - Proxy '(ext, blocks, tops, ret) -> +translatePermImpl1 :: NuMatchingAny1 r => Mb ctx (PermImpl1 ps ps_outs) -> Mb ctx (MbPermImpls r ps_outs) -> - PermImplTransM - (ImplFailCont -> - ImpTransM ext blocks tops rets ps ctx OpenTerm) -translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) of + 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 |], _) -> - tell ([mbLift (fmap ppError err)],HasFailures) >> mzero + pimplFailM (mbLift (fmap ppError err)) - ([nuMP| Impl1_Catch |], + ([nuMP| Impl1_Catch dbg_str |], [nuMP| (MbPermImpls_Cons _ (MbPermImpls_Cons _ _ mb_impl1) mb_impl2) |]) -> - pitmCatching (translatePermImpl prx $ - mbCombine RL.typeCtxProxies mb_impl1) >>= \case - -- Short-circuit: if mb_impl1 succeeds, don't translate mb_impl2 - (Just trans, NoFailures) -> return trans - (mtrans1, hasf1) -> - pitmCatching (translatePermImpl prx $ - mbCombine RL.typeCtxProxies mb_impl2) >>= \(mtrans2, - hasf2) -> - - -- Only report the possibility of failures if both branches have them - (if hasf1 == HasFailures && hasf2 == HasFailures - then tell ([],HasFailures) - else return ()) >> - - -- Combine the two continuations - case (mtrans1, hasf1, mtrans2, hasf2) of - -- If mb_impl2 has no failures, drop mb_impl1 - (_, _, Just trans, NoFailures) -> return trans - -- If both sides are defined but have failures, insert a catchpoint - (Just trans1, _, Just trans2, _) -> - return $ \k -> - compReturnTypeM >>= \ret_tp -> - letTransM "catchpoint" ret_tp (trans2 k) - (\catchpoint -> trans1 $ ImplFailContTerm catchpoint) - -- Otherwise, use whichever side is defined - (Just trans, _, Nothing, _) -> return trans - (Nothing, _, Just trans, _) -> return trans - (Nothing, _, Nothing, _) -> mzero + 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 |], _) -> @@ -3729,34 +4935,35 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl -- 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 x mb_or_list |], _) -> + ([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 - mapM (pitmCatching . translatePermImpl prx) - (mbOrListPermImpls mb_or_list mb_impls) >>= \transs -> - let (mtranss, hasfs) = unzip transs in - tell ([], mconcat hasfs) >> + 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 mtranss then mzero else - return $ \k -> + 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 mtranss $ \mtrans ptrans -> + (flip map maybe_transs $ \maybe_trans ptrans -> withPermStackM id ((:>: ptrans) . RL.tail) $ - forceImplTrans mtrans k) - (transTupleTerm top_ptrans) + 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 () <- assertTopPermM "Impl1_ElimExists" x (fmap ValPerm_Exists p) - let tp = mbBindingType p + 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 @@ -3769,12 +4976,12 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl -- A false elimination becomes a call to efq ([nuMP| Impl1_ElimFalse mb_x |], _) -> - return $ const $ + return $ PImplTerm $ const $ do mb_false <- nuMultiTransM $ const ValPerm_False () <- assertTopPermM "Impl1_ElimFalse" mb_x mb_false top_ptrans <- getTopPermM - applyMultiTransM (return $ globalOpenTerm "Prelude.efq") - [compReturnTypeM, return $ transTerm1 top_ptrans] + applyGlobalTransM "Prelude.efq" [compReturnTypeM, + return (transTerm1 top_ptrans)] -- A SimplImpl is translated using translateSimplImpl ([nuMP| Impl1_Simpl simpl mb_prx |], _) -> @@ -3848,10 +5055,9 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl . Perm_LLVMBlockShape . modalizeBlockShape |]) $ extMb mb_bp tp_trans2 <- translate mb_p_out2 - withPermStackM (:>: Member_Base) - (\(pctx :>: ptrans) -> - pctx :>: typeTransF tp_trans1 [unitOpenTerm] :>: - typeTransF tp_trans2 [transTerm1 ptrans]) + withPermStackTopTermsM (:>: Member_Base) + (\ts (pctx :>: _) -> + pctx :>: typeTransF tp_trans1 [] :>: typeTransF tp_trans2 ts) m ([nuMP| Impl1_SplitLLVMWordField _ mb_fp mb_sz1 mb_endianness |], _) -> @@ -3862,12 +5068,11 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl e_tm <- translate1 mb_e sz1_tm <- translate mb_sz1 sz2_tm <- translateClosed $ mbLLVMFieldSize mb_fp - let sz2m1_tm = - applyOpenTermMulti (globalOpenTerm "Prelude.subNat") [sz2_tm, - sz1_tm] + 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 e1_tm) $ inExtTransM (ETrans_Term e2_tm) $ + inExtTransM (ETrans_Term knownRepr e1_tm) $ + inExtTransM (ETrans_Term knownRepr e2_tm) $ translate (mbCombine RL.typeCtxProxies $ flip mbMapCl mb_fp ($(mkClosed @@ -3892,12 +5097,10 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl e_tm <- translate1 mb_e sz1_tm <- translate mb_sz1 sz2_tm <- translateClosed $ mbLLVMFieldSize mb_fp - let sz2m1_tm = - applyOpenTermMulti (globalOpenTerm "Prelude.subNat") [sz2_tm, - sz1_tm] + 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 e1_tm) $ + inExtTransM (ETrans_Term knownRepr e1_tm) $ translate (mbCombine RL.typeCtxProxies $ flip mbMapCl mb_fp ($(mkClosed @@ -3923,7 +5126,7 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl 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 e_tm) $ + inExtTransM (ETrans_Term knownRepr e_tm) $ translate (mbCombine RL.typeCtxProxies $ mbMap2 (\fp1 e2 -> impl1ConcatLLVMWordFieldsOutPerms fp1 e2 endianness) @@ -3939,12 +5142,17 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl ([nuMP| Impl1_BeginLifetime |], _) -> translatePermImplUnary mb_impls $ \m -> inExtTransM ETrans_Lifetime $ - do tp_trans <- translateClosed (ValPerm_LOwned - [] CruCtxNil CruCtxNil MNil MNil) - id_fun <- - lambdaOpenTermTransM "ps_empty" unitTypeOpenTerm $ \x -> - applyNamedSpecOpM "Prelude.retS" [unitTypeOpenTerm, x] - withPermStackM (:>: Member_Base) (:>: typeTransF tp_trans [id_fun]) m + 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 @@ -3961,7 +5169,7 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl -- 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) -> - pitmFail (mbLift prop_str) + 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 @@ -3970,18 +5178,20 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl -- 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 prx (mbCombine RL.typeCtxProxies mb_impl') >>= \trans -> - return $ \k -> + translatePermImpl (mbCombine RL.typeCtxProxies mb_impl') >>= \trans -> + return $ PImplTerm $ \k -> do prop_tp_trans <- translate prop - applyMultiTransM (return $ globalOpenTerm "Prelude.maybe") - [ return (typeTransType1 prop_tp_trans), compReturnTypeM - , implTransAltErr (mbLift prop_str) k + 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) $ - trans k) - , applyMultiTransM (return $ globalOpenTerm "Prelude.bvEqWithProof") - [ return (natOpenTerm $ natVal2 prop) , translate1 e1, translate1 e2]] + popPImplTerm trans k) + ] -- If e1 and e2 are already unequal, short-circuit and do nothing ([nuMP| Impl1_TryProveBVProp x prop@(BVProp_Neq e1 e2) _ |], _) @@ -3993,158 +5203,171 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl -- 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 prx (mbCombine RL.typeCtxProxies mb_impl') >>= \trans -> - return $ \k -> + translatePermImpl (mbCombine RL.typeCtxProxies mb_impl') >>= \trans -> + return $ PImplTerm $ \k -> let w = natVal2 prop in - applyMultiTransM (return $ globalOpenTerm "Prelude.ite") + applyGlobalTransM "Prelude.ite" [ compReturnTypeM - , applyMultiTransM (return $ globalOpenTerm "Prelude.bvEq") + , applyGlobalTransM "Prelude.bvEq" [ return (natOpenTerm w), translate1 e1, translate1 e2 ] - , implTransAltErr (mbLift prop_str) k + , (\ret_tp -> + implFailAltContTerm ret_tp (mbLift prop_str) k) <$> returnTypeM , withPermStackM (:>: translateVar x) (:>: PTrans_Conj [APTrans_BVProp (BVPropTrans prop unitOpenTerm)]) $ - trans k] + 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 prx (mbCombine RL.typeCtxProxies mb_impl') >>= \trans -> - return $ \k -> + translatePermImpl (mbCombine RL.typeCtxProxies mb_impl') >>= \trans -> + return $ PImplTerm $ \k -> do let w = natVal4 e1 t1 <- translate1 e1 t2 <- translate1 e2 let pf_tm = - applyOpenTermMulti (globalOpenTerm "Prelude.unsafeAssertBVULt") + applyGlobalOpenTerm "Prelude.unsafeAssertBVULt" [natOpenTerm w, t1, t2] withPermStackM (:>: translateVar x) (:>: bvPropPerm (BVPropTrans prop pf_tm)) - (trans k) + (popPImplTerm trans k) - -- If we don't know e1 < e2 statically, translate to bvultWithProof + -- 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 prx (mbCombine RL.typeCtxProxies mb_impl') >>= \trans -> - return $ \k -> + translatePermImpl (mbCombine RL.typeCtxProxies mb_impl') >>= \trans -> + return $ PImplTerm $ \k -> do prop_tp_trans <- translate prop - applyMultiTransM (return $ globalOpenTerm "Prelude.maybe") - [ return (typeTransType1 prop_tp_trans), compReturnTypeM - , implTransAltErr (mbLift prop_str) k + 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) $ - trans k) - , applyMultiTransM (return $ globalOpenTerm "Prelude.bvultWithProof") - [ return (natOpenTerm $ natVal2 prop), translate1 e1, translate1 e2] + 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 prx (mbCombine RL.typeCtxProxies mb_impl') >>= \trans -> - return $ \k -> + translatePermImpl (mbCombine RL.typeCtxProxies mb_impl') >>= \trans -> + return $ PImplTerm $ \k -> do let w = natVal4 e1 t1 <- translate1 e1 t2 <- translate1 e2 let pf_tm = - applyOpenTermMulti (globalOpenTerm "Prelude.unsafeAssertBVULe") + applyGlobalOpenTerm "Prelude.unsafeAssertBVULe" [natOpenTerm w, t1, t2] withPermStackM (:>: translateVar x) (:>: bvPropPerm (BVPropTrans prop pf_tm)) - (trans k) + (popPImplTerm trans k) - -- If we don't know e1 <= e2 statically, translate to bvuleWithProof + -- 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 prx (mbCombine RL.typeCtxProxies mb_impl') >>= \trans -> - return $ \k -> + translatePermImpl (mbCombine RL.typeCtxProxies mb_impl') >>= \trans -> + return $ PImplTerm $ \k -> do prop_tp_trans <- translate prop - applyMultiTransM (return $ globalOpenTerm "Prelude.maybe") - [ return (typeTransType1 prop_tp_trans), compReturnTypeM - , implTransAltErr (mbLift prop_str) k + 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) $ - trans k) - , applyMultiTransM (return $ globalOpenTerm "Prelude.bvuleWithProof") - [ return (natOpenTerm $ natVal2 prop), translate1 e1, translate1 e2] + 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 prx (mbCombine RL.typeCtxProxies mb_impl') >>= \trans -> - return $ \k -> + 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 = - applyOpenTermMulti (globalOpenTerm "Prelude.unsafeAssertBVULe") + applyGlobalOpenTerm "Prelude.unsafeAssertBVULe" [natOpenTerm w, t1, - applyOpenTermMulti (globalOpenTerm - "Prelude.bvSub") [natOpenTerm w, t2, t3]] + applyGlobalOpenTerm "Prelude.bvSub" [natOpenTerm w, t2, t3]] withPermStackM (:>: translateVar x) (:>: bvPropPerm (BVPropTrans prop pf_tm)) - (trans k) + (popPImplTerm trans k) - -- If we don't know e1 <= e2-e3 statically, translate to bvuleWithProof + -- 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 prx (mbCombine RL.typeCtxProxies mb_impl') >>= \trans -> - return $ \k -> + translatePermImpl (mbCombine RL.typeCtxProxies mb_impl') >>= \trans -> + return $ PImplTerm $ \k -> do prop_tp_trans <- translate prop - applyMultiTransM (return $ globalOpenTerm "Prelude.maybe") - [ return (typeTransType1 prop_tp_trans), compReturnTypeM - , implTransAltErr (mbLift prop_str) k + 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) $ - trans k) - , applyMultiTransM (return $ globalOpenTerm "Prelude.bvuleWithProof") - [ return (natOpenTerm $ natVal2 prop), translate1 e1, - applyMultiTransM (return $ globalOpenTerm "Prelude.bvSub") - [return (natOpenTerm $ natVal2 prop), translate1 e2, translate1 e3]] + popPImplTerm trans k) ] ([nuMP| Impl1_TryProveBVProp _ _ _ |], _) -> - pitmFail ("translatePermImpl1: Unhandled BVProp case") - + 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 :: ImplTranslateF r ext blocks tops rets => - Proxy '(ext, blocks, tops, ret) -> - Mb ctx (PermImpl r ps) -> - PermImplTransM - (ImplFailCont -> - ImpTransM ext blocks tops rets ps ctx OpenTerm) -translatePermImpl prx mb_impl = case mbMatch mb_impl of +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 |] -> - return $ const $ translateF r + do f <- pimplRTransFunM + return $ PImplTerm $ const $ appImpTransFun f reflCtxExt r [nuMP| PermImpl_Step impl1 mb_impls |] -> - translatePermImpl1 prx 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 impl |]) = - let (transF, (errs,_)) = runPermImplTransM $ translatePermImpl Proxy impl in - forceImplTrans transF $ - ImplFailContMsg (mbLift err ++ "\n\n" - ++ concat (intersperse - "\n\n--------------------\n\n" errs)) + 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 - applyNamedSpecOpM "Prelude.retS" [ret_tp, transTupleTerm pctx] + 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) -> @@ -4166,12 +5389,28 @@ translateCurryLocalPermImpl :: 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 = typeTransType1 tp_trans_out }) $ + 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 @@ -4198,14 +5437,14 @@ instance TransInfo info => -- | Translate a 'RegWithVal' to exactly one SAW term via 'transTerm1' translateRWV :: TransInfo info => Mb ctx (RegWithVal a) -> TransM info ctx OpenTerm -translateRWV mb_rwv = transTerm1 <$> translate mb_rwv +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 <$> + ETrans_Term knownRepr <$> applyMultiTransM (return $ globalOpenTerm "Prelude.boolEq") [translateRWV e1, translateRWV e2] -- [nuMP| BaseIsEq BaseNatRepr e1 e2 |] -> @@ -4213,7 +5452,7 @@ instance (PermCheckExtC ext exprExt, TransInfo info) => -- applyMultiTransM (return $ globalOpenTerm "Prelude.equalNat") -- [translateRWV e1, translateRWV e2] [nuMP| BaseIsEq (BaseBVRepr w) e1 e2 |] -> - ETrans_Term <$> + ETrans_Term knownRepr <$> applyMultiTransM (return $ globalOpenTerm "Prelude.bvEq") [translate w, translateRWV e1, translateRWV e2] @@ -4221,56 +5460,56 @@ instance (PermCheckExtC ext exprExt, TransInfo info) => -- Booleans [nuMP| BoolLit True |] -> - return $ ETrans_Term $ globalOpenTerm "Prelude.True" + return $ ETrans_Term knownRepr $ globalOpenTerm "Prelude.True" [nuMP| BoolLit False |] -> - return $ ETrans_Term $ globalOpenTerm "Prelude.False" + return $ ETrans_Term knownRepr $ globalOpenTerm "Prelude.False" [nuMP| Not e |] -> - ETrans_Term <$> + ETrans_Term knownRepr <$> applyMultiTransM (return $ globalOpenTerm "Prelude.not") [translateRWV e] [nuMP| And e1 e2 |] -> - ETrans_Term <$> + ETrans_Term knownRepr <$> applyMultiTransM (return $ globalOpenTerm "Prelude.and") [translateRWV e1, translateRWV e2] [nuMP| Or e1 e2 |] -> - ETrans_Term <$> + ETrans_Term knownRepr <$> applyMultiTransM (return $ globalOpenTerm "Prelude.or") [translateRWV e1, translateRWV e2] [nuMP| BoolXor e1 e2 |] -> - ETrans_Term <$> + ETrans_Term knownRepr <$> applyMultiTransM (return $ globalOpenTerm "Prelude.xor") [translateRWV e1, translateRWV e2] -- Natural numbers [nuMP| Expr.NatLit n |] -> - return $ ETrans_Term $ natOpenTerm $ mbLift n + return $ ETrans_Term knownRepr $ natOpenTerm $ mbLift n [nuMP| NatLt e1 e2 |] -> - ETrans_Term <$> + ETrans_Term knownRepr <$> applyMultiTransM (return $ globalOpenTerm "Prelude.ltNat") [translateRWV e1, translateRWV e2] -- [nuMP| NatLe _ _ |] -> [nuMP| NatEq e1 e2 |] -> - ETrans_Term <$> + ETrans_Term knownRepr <$> applyMultiTransM (return $ globalOpenTerm "Prelude.equalNat") [translateRWV e1, translateRWV e2] [nuMP| NatAdd e1 e2 |] -> - ETrans_Term <$> + ETrans_Term knownRepr <$> applyMultiTransM (return $ globalOpenTerm "Prelude.addNat") [translateRWV e1, translateRWV e2] [nuMP| NatSub e1 e2 |] -> - ETrans_Term <$> + ETrans_Term knownRepr <$> applyMultiTransM (return $ globalOpenTerm "Prelude.subNat") [translateRWV e1, translateRWV e2] [nuMP| NatMul e1 e2 |] -> - ETrans_Term <$> + ETrans_Term knownRepr <$> applyMultiTransM (return $ globalOpenTerm "Prelude.mulNat") [translateRWV e1, translateRWV e2] [nuMP| NatDiv e1 e2 |] -> - ETrans_Term <$> + ETrans_Term knownRepr <$> applyMultiTransM (return $ globalOpenTerm "Prelude.divNat") [translateRWV e1, translateRWV e2] [nuMP| NatMod e1 e2 |] -> - ETrans_Term <$> + ETrans_Term knownRepr <$> applyMultiTransM (return $ globalOpenTerm "Prelude.modNat") [translateRWV e1, translateRWV e2] @@ -4282,130 +5521,132 @@ instance (PermCheckExtC ext exprExt, TransInfo info) => [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 $ bvBVOpenTerm (mbLift w) $ BV.zero (mbLift w) + return $ ETrans_Term (BVRepr $ mbLift w) $ + bvBVOpenTerm (mbLift w) $ BV.zero (mbLift w) [nuMP| BVLit w mb_bv |] -> - return $ ETrans_Term $ bvBVOpenTerm (mbLift w) $ mbLift mb_bv + return $ ETrans_Term (BVRepr $ mbLift w) $ + bvBVOpenTerm (mbLift w) $ mbLift mb_bv [nuMP| BVConcat w1 w2 e1 e2 |] -> - ETrans_Term <$> + 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 <$> + 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 <$> + 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 <$> + 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 <$> + ETrans_Term (BVRepr $ mbLift w) <$> applyMultiTransM (return $ globalOpenTerm "Prelude.bvNot") [translate w, translateRWV e] [nuMP| BVAnd w e1 e2 |] -> - ETrans_Term <$> + ETrans_Term (BVRepr $ mbLift w) <$> applyMultiTransM (return $ globalOpenTerm "Prelude.bvAnd") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVOr w e1 e2 |] -> - ETrans_Term <$> + ETrans_Term (BVRepr $ mbLift w) <$> applyMultiTransM (return $ globalOpenTerm "Prelude.bvOr") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVXor w e1 e2 |] -> - ETrans_Term <$> + ETrans_Term (BVRepr $ mbLift w) <$> applyMultiTransM (return $ globalOpenTerm "Prelude.bvXor") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVNeg w e |] -> - ETrans_Term <$> + ETrans_Term (BVRepr $ mbLift w) <$> applyMultiTransM (return $ globalOpenTerm "Prelude.bvNeg") [translate w, translateRWV e] [nuMP| BVAdd w e1 e2 |] -> - ETrans_Term <$> + ETrans_Term (BVRepr $ mbLift w) <$> applyMultiTransM (return $ globalOpenTerm "Prelude.bvAdd") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVSub w e1 e2 |] -> - ETrans_Term <$> + ETrans_Term (BVRepr $ mbLift w) <$> applyMultiTransM (return $ globalOpenTerm "Prelude.bvSub") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVMul w e1 e2 |] -> - ETrans_Term <$> + ETrans_Term (BVRepr $ mbLift w) <$> applyMultiTransM (return $ globalOpenTerm "Prelude.bvMul") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVUdiv w e1 e2 |] -> - ETrans_Term <$> + ETrans_Term (BVRepr $ mbLift w) <$> applyMultiTransM (return $ globalOpenTerm "Prelude.bvUDiv") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVSdiv w e1 e2 |] -> - ETrans_Term <$> + ETrans_Term (BVRepr $ mbLift w) <$> applyMultiTransM (return $ globalOpenTerm "Prelude.bvSDiv") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVUrem w e1 e2 |] -> - ETrans_Term <$> + ETrans_Term (BVRepr $ mbLift w) <$> applyMultiTransM (return $ globalOpenTerm "Prelude.bvURem") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVSrem w e1 e2 |] -> - ETrans_Term <$> + ETrans_Term (BVRepr $ mbLift w) <$> applyMultiTransM (return $ globalOpenTerm "Prelude.bvSRem") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVUle w e1 e2 |] -> - ETrans_Term <$> + ETrans_Term knownRepr <$> applyMultiTransM (return $ globalOpenTerm "Prelude.bvule") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVUlt w e1 e2 |] -> - ETrans_Term <$> + ETrans_Term knownRepr <$> applyMultiTransM (return $ globalOpenTerm "Prelude.bvult") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVSle w e1 e2 |] -> - ETrans_Term <$> + ETrans_Term knownRepr <$> applyMultiTransM (return $ globalOpenTerm "Prelude.bvsle") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVSlt w e1 e2 |] -> - ETrans_Term <$> + ETrans_Term knownRepr <$> applyMultiTransM (return $ globalOpenTerm "Prelude.bvslt") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVCarry w e1 e2 |] -> - ETrans_Term <$> + 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 <$> + 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 <$> + ETrans_Term knownRepr <$> applyMultiTransM (return $ globalOpenTerm "Prelude.bvSBorrow") [return w_minus_1, translateRWV e1, translateRWV e2] [nuMP| BVShl w e1 e2 |] -> - ETrans_Term <$> + 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 <$> + 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 <$> + 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 <$> + ETrans_Term (BVRepr w) <$> applyMultiTransM (return $ globalOpenTerm "Prelude.ite") [bitvectorTransM (translate mb_w), translateRWV e, @@ -4413,7 +5654,7 @@ instance (PermCheckExtC ext exprExt, TransInfo info) => return (bvBVOpenTerm w (BV.zero w))] [nuMP| BVNonzero mb_w e |] -> let w = mbLift mb_w in - ETrans_Term <$> + ETrans_Term knownRepr <$> applyTransM (return $ globalOpenTerm "Prelude.not") (applyMultiTransM (return $ globalOpenTerm "Prelude.bvEq") [translate mb_w, translateRWV e, @@ -4421,7 +5662,7 @@ instance (PermCheckExtC ext exprExt, TransInfo info) => -- Strings [nuMP| Expr.StringLit (UnicodeLiteral text) |] -> - return $ ETrans_Term $ stringLitOpenTerm $ + return $ ETrans_Term knownRepr $ stringLitOpenTerm $ mbLift text -- Everything else is an error @@ -4459,6 +5700,7 @@ debugPrettyPermCtx prxs (ptranss :>: 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 @@ -4480,6 +5722,7 @@ translateApply nm f perms = 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 @@ -4487,50 +5730,49 @@ translateApply nm f perms = 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 :++: args)) -> + 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_args mb_ghosts = +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 <- translate $ mbMap2 RL.append mb_tops_args mb_ghosts - stack <- itiPermStack <$> ask + 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 (\tops_args ghosts -> - permVarSubstOfNames $ RL.append tops_args ghosts) + 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 multiFixS-bound function - case typedEntryTransRecIx entry_trans of - Just ix -> - -- If so, build the associated CallS term - -- FIXME: refactor the code that gets the exprs for the stack - do expr_ctx <- itiExprCtx <$> ask - arg_membs <- itiPermStackVars <$> ask - let e_args = RL.map (flip RL.get expr_ctx) arg_membs - i_args <- itiPermStack <$> ask - applyCallS ix (exprCtxToTerms e_args ++ permCtxToTerms i_args) + -- 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 -> - inEmptyEnvImpTransM $ inCtxTransM ectx $ - do perms_trans <- translate $ typedEntryPermsIn entry - withPermStackM - (const $ RL.members ectx) - (const $ typeTransF perms_trans $ transTerms stack) - (translate $ _mbBinding $ typedEntryBody entry) + -- 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_tavars mb_gvars |]) = + [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_tavars mb_gvars + translateCallEntry "CallSiteImplRet" entry_trans mb_tvars mb_avars mb_gvars instance PermCheckExtC ext exprExt => ImplTranslateF (CallSiteImplRet blocks tops args ghosts) @@ -4570,7 +5812,7 @@ translateStmt loc mb_stmt m = case mbMatch mb_stmt of etrans <- tpTransM $ translate e let ptrans = exprOutPerm e inExtTransSAWLetBindM tp_trans tp_ret etrans $ - withPermStackM (:>: Member_Base) (:>: extPermTrans ptrans) m + withPermStackM (:>: Member_Base) (:>: extPermTrans etrans ptrans) m [nuMP| TypedSetRegPermExpr _ e |] -> do etrans <- tpTransM $ translate e @@ -4593,37 +5835,36 @@ translateStmt loc mb_stmt m = case mbMatch mb_stmt of pctx_in <- RL.tail <$> itiPermStack <$> ask let (pctx_ghosts_args, _) = RL.split (RL.append ectx_gexprs ectx_args) ectx_gexprs pctx_in - fret_tp <- sigmaTypeTransM "ret" rets_trans (flip inExtMultiTransM - (translate perms_out)) + fret_tp <- + openTermTypeTrans <$> + sigmaTypeTransM "ret" rets_trans + (\ectx -> inExtMultiTransM ectx (translate perms_out)) let all_args = exprCtxToTerms ectx_gexprs ++ exprCtxToTerms ectx_args ++ - permCtxToTerms pctx_ghosts_args - fret_trm <- case f_trans of - PTrans_Conj [APTrans_Fun _ (Right f)] -> - applyNamedSpecOpM "Prelude.liftStackS" - [fret_tp, applyOpenTermMulti f all_args] - PTrans_Conj [APTrans_Fun _ (Left ix)] -> - applyCallS ix all_args - _ -> error "translateStmt: TypedCall: unexpected function permission" - bindSpecMTransM - fret_trm (openTermTypeTrans fret_tp) "call_ret_val" $ \ret_val -> + 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 + (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 _ |] -> - applyMultiTransM (return $ globalOpenTerm "Prelude.ite") + applyGlobalTransM "Prelude.ite" [compReturnTypeM, translate1 e, m, mkErrorComp ("Failed Assert at " ++ renderDoc (ppShortFileName (plSourceLoc loc)))] @@ -4643,7 +5884,7 @@ translateLLVMStmt mb_stmt m = case mbMatch mb_stmt of fmap (PExpr_LLVMWord . PExpr_Var) x)) m [nuMP| AssertLLVMWord reg _ |] -> - inExtTransM (ETrans_Term $ natOpenTerm 0) $ + inExtTransM (ETrans_Term knownRepr $ natOpenTerm 0) $ withPermStackM ((:>: Member_Base) . RL.tail) ((:>: (PTrans_Eq $ fmap (const $ PExpr_Nat 0) $ extMb reg)) . RL.tail) m @@ -4722,9 +5963,9 @@ translateLLVMStmt mb_stmt m = case mbMatch mb_stmt of :>: PTrans_Conj [APTrans_LLVMFrame $ flip nuMultiWithElim1 (extMb mb_fperm) $ \(_ :>: ret) fperm -> (PExpr_Var ret, sz):fperm] - -- the unitOpenTerm argument is because ptrans_tp is a memblock permission + -- 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 [unitOpenTerm]) + :>: typeTransF ptrans_tp []) m [nuMP| TypedLLVMCreateFrame |] -> @@ -4755,22 +5996,13 @@ translateLLVMStmt mb_stmt m = case mbMatch mb_stmt of do env <- infoEnv <$> ask let w :: NatRepr w = knownRepr case lookupGlobalSymbol env (mbLift gsym) w of - Nothing -> error ("translateLLVMStmt: TypedLLVMResolveGlobal: " - ++ " no translation of symbol " - ++ globalSymbolName (mbLift gsym)) - Just (_, Left i) - | [nuP| ValPerm_LLVMFunPtr fun_tp (ValPerm_Fun fun_perm) |] <- p -> - let ptrans = PTrans_Conj [APTrans_LLVMFunPtr (mbLift fun_tp) $ - PTrans_Conj [APTrans_Fun - fun_perm (Left i)]] in - withPermStackM (:>: Member_Base) (:>: extPermTrans ptrans) m - Just (_, Left _) -> - error ("translateLLVMStmt: TypedLLVMResolveGlobal: " - ++ " unexpected recursive call translation for symbol " - ++ globalSymbolName (mbLift gsym)) - Just (_, Right ts) -> - translate (extMb p) >>= \ptrans -> - withPermStackM (:>: Member_Base) (:>: typeTransF ptrans ts) m + 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 $ @@ -4781,7 +6013,7 @@ translateLLVMStmt mb_stmt m = case mbMatch mb_stmt of [| \stmt -> nu $ \ret -> distPermsHeadPerm $ typedLLVMStmtOut stmt ret |]) mb_stmt - let t = applyOpenTerm (globalOpenTerm "Prelude.boolToEither") b + let t = applyGlobalTermLike "Prelude.boolToEither" [b] withPermStackM (:>: Member_Base) (:>: typeTransF tptrans [t]) m @@ -4793,7 +6025,8 @@ 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 let perms = + do ev <- infoEvType <$> ask + let perms = mbMap2 (\rets_ns ps -> varSubst (permVarSubstOfNames rets_ns) ps) mb_rets_ns mb_perms @@ -4802,12 +6035,11 @@ instance PermCheckExtC ext exprExt => let rets_prxs = cruCtxProxies $ mbLift mb_rets rets_ns_trans <- translate mb_rets_ns ret_tp <- returnTypeM - sigma_trm <- + retSOpenTerm ev ret_tp <$> sigmaTransM "r" rets_trans (flip inExtMultiTransM $ translate $ mbCombine rets_prxs mb_perms) rets_ns_trans (itiPermStack <$> ask) - applyNamedSpecOpM "Prelude.retS" [ret_tp, sigma_trm] instance PermCheckExtC ext exprExt => ImplTranslateF (TypedRet tops rets) ext blocks tops rets where @@ -4819,7 +6051,7 @@ instance PermCheckExtC ext exprExt => translate mb_x = case mbMatch mb_x of [nuMP| TypedJump impl_tgt |] -> translate impl_tgt [nuMP| TypedBr reg impl_tgt1 impl_tgt2 |] -> - applyMultiTransM (return $ globalOpenTerm "Prelude.ite") + applyGlobalTransM "Prelude.ite" [compReturnTypeM, translate1 reg, translate impl_tgt1, translate impl_tgt2] [nuMP| TypedReturn impl_ret |] -> translate impl_ret @@ -4853,14 +6085,11 @@ 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 letrec-bound --- variables, which is all entrypoints with in-degree > 1 --- --- FIXME: consider whether we want let and not letRec for entrypoints that have --- in-degree > 1 but are not the heads of loops -typedBlockLetRecEntries :: TypedBlockMap TransPhase ext blocks tops rets -> - [SomeTypedEntry ext blocks tops rets] -typedBlockLetRecEntries = +-- | 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) @@ -4868,171 +6097,183 @@ typedBlockLetRecEntries = -- | Fold a function over each 'TypedEntry' in a 'TypedBlockMap' that -- corresponds to a letrec-bound variable -foldBlockMapLetRec :: +foldBlockMapRec :: (forall args ghosts. TypedEntry TransPhase ext blocks tops rets args ghosts -> b -> b) -> b -> TypedBlockMap TransPhase ext blocks tops rets -> b -foldBlockMapLetRec f r = - foldr (\(SomeTypedEntry entry) -> f entry) r . typedBlockLetRecEntries +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 -mapBlockMapLetRec :: +mapBlockMapRecs :: (forall args ghosts. TypedEntry TransPhase ext blocks tops rets args ghosts -> b) -> TypedBlockMap TransPhase ext blocks tops rets -> [b] -mapBlockMapLetRec f = - map (\(SomeTypedEntry entry) -> f entry) . typedBlockLetRecEntries - --- | Construct a @LetRecType@ inductive description --- --- > LRT_Fun tp1 \(x1 : tp1) -> ... -> LRT_Fun tpn \(xn : tpn) -> body x1 ... xn --- --- of a pi abstraction over the types @tpi@ in a 'TypeTrans', passing the --- abstracted variables to the supplied @body@ function -piLRTTransM :: String -> TypeTrans tr -> (tr -> TransM info ctx OpenTerm) -> - TransM info ctx OpenTerm -piLRTTransM x tps body_f = - foldr (\(i,tp) rest_f vars -> - (\t -> ctorOpenTerm "Prelude.LRT_Fun" [tp, t]) <$> - lambdaOpenTermTransM (x ++ show (i :: Integer)) tp - (\var -> rest_f (vars ++ [var]))) - (body_f . typeTransF tps) (zip [0..] $ typeTransTypes tps) [] - --- | Build a @LetRecType@ that describes the type of the translation of a --- 'TypedEntry' -translateEntryLRT :: PermEnv -> - TypedEntry TransPhase ext blocks tops rets args ghosts -> - OpenTerm -translateEntryLRT env entry@(TypedEntry {..}) = - runNilTypeTransM env noChecks $ - translateClosed (typedEntryAllArgs entry) >>= \arg_tps -> - piLRTTransM "arg" arg_tps $ \ectx -> - inCtxTransM ectx $ - translate typedEntryPermsIn >>= \perms_in_tps -> - piLRTTransM "p" perms_in_tps $ \_ -> - translateEntryRetType entry >>= \retType -> - return $ ctorOpenTerm "Prelude.LRT_Ret" [retType] - --- | Build a list of @LetRecType@ values that describe the types of all of the --- entrypoints in a 'TypedBlockMap' that will be bound as recursive functions -translateBlockMapLRTs :: PermEnv -> - TypedBlockMap TransPhase ext blocks tops rets -> - [OpenTerm] -translateBlockMapLRTs env blkMap = - mapBlockMapLetRec (translateEntryLRT env) blkMap - --- | Return a @LetRecType@ value for the translation of the function permission --- of a CFG -translateCFGInitEntryLRT :: PermEnv -> - TypedCFG ext blocks ghosts inits gouts ret -> - OpenTerm -translateCFGInitEntryLRT env (tpcfgFunPerm -> - (FunPerm ghosts args gouts ret perms_in perms_out)) = - runNilTypeTransM env noChecks $ - translateClosed (appendCruCtx ghosts args) >>= \ctx_trans -> - piLRTTransM "arg" ctx_trans $ \ectx -> - inCtxTransM ectx $ - translate perms_in >>= \perms_trans -> - piLRTTransM "perm" perms_trans $ \_ -> - translateRetType (CruCtxCons gouts ret) perms_out >>= \ret_tp -> - return $ ctorOpenTerm "Prelude.LRT_Ret" [ret_tp] - --- | FIXME HERE NOW: docs -translateCFGLRTs :: PermEnv -> TypedCFG ext blocks ghosts inits gouts ret -> - [OpenTerm] -translateCFGLRTs env cfg = - translateCFGInitEntryLRT env cfg : - translateBlockMapLRTs env (tpcfgBlockMap cfg) - --- | Apply @mkFrameCall@ to a frame, an index @n@ in that frame, and list of --- arguments to build a recursive call to the @n@th function in the frame -mkFrameCall :: OpenTerm -> Natural -> [OpenTerm] -> OpenTerm -mkFrameCall frame ix args = - applyGlobalOpenTerm "Prelude.mkFrameCall" (frame : natOpenTerm ix : args) - --- | Apply the @callS@ operation to some arguments to build a recursive call -applyCallS :: Natural -> [OpenTerm] -> - ImpTransM ext blocks tops rets ps ctx OpenTerm -applyCallS ix args = - do stack <- itiFunStack <$> ask - case funStackTopAndPrev stack of - Just (frame, prev_stack) -> - let call = mkFrameCall frame ix args in - applyNamedEventOpM "Prelude.callS" [prev_stack, frame, call] - Nothing -> - error "applyCallS: Attempt to call a recursive function that is not in scope" - --- | FIXME HERE NOW: docs +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 Natural (TypeTransM ctx) (Some (TypedEntryTrans ext blocks tops rets args)) + StateT [OpenTerm] (TypeTransM tops) (Some + (TypedEntryTrans ext blocks tops rets args)) translateTypedEntry (Some entry) = if typedEntryHasMultiInDegree entry then - do i <- get - put (i+1) - return (Some (TypedEntryTrans entry $ Just i)) + do fs <- get + let f = + case fs of + [] -> panic "translateTypedEntry" ["Ran out of functions"] + _ -> head fs + put $ tail fs + return (Some (TypedEntryTrans entry $ Just f)) else return $ Some (TypedEntryTrans entry Nothing) --- | Computes a list of @TypedEntryTrans@ values from a list of --- @TypedEntry@ values that pair each entry with their translation +-- | Translate a 'TypedBlock' to a 'TypedBlockTrans' by translating each +-- entrypoint in the block using 'translateTypedEntry' translateTypedBlock :: TypedBlock TransPhase ext blocks tops rets args -> - StateT Natural (TypeTransM ctx) (TypedBlockTrans ext blocks tops rets args) + StateT [OpenTerm] (TypeTransM tops) (TypedBlockTrans ext blocks tops rets args) translateTypedBlock blk = - TypedBlockTrans <$> - mapM translateTypedEntry (blk ^. typedBlockEntries) - --- | Translate a @TypedBlockMap@ to a @TypedBlockMapTrans@ by generating --- @CallS@ calls for each of the entrypoints that represents a recursive call + 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 :: - TypedBlockMap TransPhase ext blocks tops rets -> - StateT Natural (TypeTransM ctx) (TypedBlockMapTrans ext blocks tops rets) -translateTypedBlockMap blkMap = - traverseRAssign translateTypedBlock blkMap + [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 -- --- > \top1 ... topn arg1 ... argm ghost1 ... ghostk p1 ... pj -> stmts_trans +-- > \arg1 ... argm ghost1 ... ghostk p1 ... pj -> stmts_trans -- --- over the top-level, local, and ghost arguments and (the translations of) the --- input permissions of the entrypoint +-- 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 => - FunStack -> TypedBlockMapTrans ext blocks tops rets -> + TypedBlockMapTrans ext blocks tops rets -> TypedEntry TransPhase ext blocks tops rets args ghosts -> - TypeTransM RNil OpenTerm -translateEntryBody stack mapTrans entry = - lambdaExprCtx (typedEntryAllArgs entry) $ + 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 stack retType $ + impTransM (RL.members pctx) pctx mapTrans retType $ translate $ _mbBinding $ typedEntryBody entry --- | Translate all the entrypoints in a 'TypedBlockMap' that correspond to --- letrec-bound functions to SAW core functions as in 'translateEntryBody' -translateBlockMapBodies :: PermCheckExtC ext exprExt => FunStack -> +-- | 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 RNil [OpenTerm] -translateBlockMapBodies stack mapTrans blkMap = - sequence $ - mapBlockMapLetRec (translateEntryBody stack mapTrans) blkMap - --- | FIXME HERE NOW: docs -translateCFGInitEntryBody :: - PermCheckExtC ext exprExt => FunStack -> + 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 -> - TypeTransM RNil OpenTerm -translateCFGInitEntryBody stack mapTrans (cfg :: 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 - ctx = typedFnHandleAllArgs h inits = typedFnHandleArgs h ghosts = typedFnHandleGhosts h retTypes = typedFnHandleRetTypes h in - lambdaExprCtx ctx $ 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 @@ -5041,72 +6282,55 @@ translateCFGInitEntryBody stack mapTrans (cfg :: TypedCFG ext blocks ghosts init -- the same as those top-level arguments and so get eq perms to relate them inExtMultiTransCopyLastM ghosts (cruCtxProxies inits) $ - lambdaPermCtx (funPermToBlockInputs fun_perm) $ \pctx -> - let all_membs = RL.members pctx - all_px = RL.map (\_ -> Proxy) pctx + -- 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 - impTransM all_membs pctx mapTrans stack retTypeTrans $ - translateCallEntry "CFG" init_entry (nuMulti all_px id) (nuMulti all_px $ - const MNil) - --- | FIXME HERE NOW: docs -translateCFGBodies :: PermCheckExtC ext exprExt => FunStack -> Natural -> - TypedCFG ext blocks ghosts inits gouts ret -> - TypeTransM RNil [OpenTerm] -translateCFGBodies stack start_ix cfg = - do let blkMap = tpcfgBlockMap cfg - mapTrans <- - evalStateT (translateTypedBlockMap blkMap) (start_ix+1) - bodies <- translateBlockMapBodies stack mapTrans blkMap - init_body <- translateCFGInitEntryBody stack mapTrans cfg - return (init_body : bodies) - --- | Lambda-abstract over all the expression and permission arguments of the --- translation of a CFG, passing them to a Haskell function -lambdaCFGArgs :: PermEnv -> TypedCFG ext blocks ghosts inits gouts ret -> - ([OpenTerm] -> TypeTransM (ghosts :++: inits) OpenTerm) -> - OpenTerm -lambdaCFGArgs env cfg bodyF = - runNilTypeTransM env noChecks $ - lambdaExprCtx (typedFnHandleAllArgs (tpcfgHandle cfg)) $ - lambdaPermCtx (funPermIns $ tpcfgFunPerm cfg) $ \pctx -> - do ectx <- infoCtx <$> ask - bodyF (transTerms ectx ++ transTerms pctx) - --- | Pi-abstract over all the expression and permission arguments of the --- translation of a CFG, passing them to a Haskell function -piCFGArgs :: PermEnv -> TypedCFG ext blocks ghosts inits gouts ret -> - ([OpenTerm] -> TypeTransM (ghosts :++: inits) OpenTerm) -> - OpenTerm -piCFGArgs env cfg bodyF = - runNilTypeTransM env noChecks $ - piExprCtx (typedFnHandleAllArgs (tpcfgHandle cfg)) $ - piPermCtx (funPermIns $ tpcfgFunPerm cfg) $ \pctx -> - do ectx <- infoCtx <$> ask - bodyF (transTerms ectx ++ transTerms pctx) - --- | Translate a typed CFG to a SAW term (FIXME HERE NOW: explain the term that --- is generated and the fun args) -translateCFG :: PermEnv -> OpenTerm -> OpenTerm -> OpenTerm -> Natural -> - TypedCFG ext blocks ghosts inits gouts ret -> - OpenTerm -translateCFG env prev_stack frame bodies ix cfg = - lambdaCFGArgs env cfg $ \args -> - applyNamedEventOpM "Prelude.multiFixS" [prev_stack, frame, bodies, - mkFrameCall frame ix args] + 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 '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 - -- | An existentially quantified tuple of a 'TypedCFG', its 'GlobalSymbol', and -- a 'String' name we want to translate it to data SomeTypedCFG ext where @@ -5114,6 +6338,116 @@ data SomeTypedCFG ext where 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 @@ -5122,61 +6456,31 @@ someCFGAndPermSym (SomeCFGAndPerm sym _ _ _) = sym someCFGAndPermToName :: SomeCFGAndPerm ext -> String someCFGAndPermToName (SomeCFGAndPerm _ nm _ _) = nm --- | 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 - -- | Map a 'SomeCFGAndPerm' to a 'PermEnvGlobalEntry' with no translation, i.e., --- with an 'error' term for the translation +-- 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) $ - error "someCFGAndPermGlobalEntry: unexpected translation during type-checking" - --- | Convert the 'FunPerm' of a 'SomeCFGAndPerm' to an inductive @LetRecType@ --- description of the SAW core type it translates to -someCFGAndPermLRT :: PermEnv -> SomeCFGAndPerm ext -> OpenTerm -someCFGAndPermLRT env (SomeCFGAndPerm _ _ _ - (FunPerm ghosts args gouts ret perms_in perms_out)) = - runNilTypeTransM env noChecks $ - translateClosed (appendCruCtx ghosts args) >>= \ctx_trans -> - piLRTTransM "arg" ctx_trans $ \ectx -> - inCtxTransM ectx $ - translate perms_in >>= \perms_trans -> - piLRTTransM "perm" perms_trans $ \_ -> - translateRetType (CruCtxCons gouts ret) perms_out >>= \ret_tp -> - return $ ctorOpenTerm "Prelude.LRT_Ret" [ret_tp] - --- | 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 + panic "someCFGAndPermGlobalEntry" + ["Attempt to translate CFG during its own type-checking"] --- | Make a term of type @LetRecTypes@ from a list of @LetRecType@ terms -lrtsOpenTerm :: [OpenTerm] -> OpenTerm -lrtsOpenTerm lrts = - let tp = dataTypeOpenTerm "Prelude.LetRecType" [] in - foldr (\hd tl -> ctorOpenTerm "Prelude.Cons1" [tp, hd, tl]) - (ctorOpenTerm "Prelude.Nil1" [tp]) - lrts - --- | Make the type @List1 LetRecType@ of recursive function frames -frameTypeOpenTerm :: OpenTerm -frameTypeOpenTerm = dataTypeOpenTerm "Prelude.List1" [dataTypeOpenTerm - "Prelude.LetRecType" []] - --- | FIXME HERE NOW: docs +-- | 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 = - withKnownNat ?ptrWidth $ do -- First, we type-check all the CFGs, mapping them to SomeTypedCFGs; this -- uses a temporary PermEnv where all the function symbols being @@ -5184,7 +6488,7 @@ tcTranslateAddCFGs sc mod_name env checks endianness dlevel cfgs_and_perms = let tmp_env1 = permEnvAddGlobalSyms env $ map someCFGAndPermGlobalEntry cfgs_and_perms - let tcfgs = + let tc_cfgs = flip map cfgs_and_perms $ \(SomeCFGAndPerm gsym nm cfg fun_perm) -> SomeTypedCFG gsym nm $ debugTraceTraceLvl dlevel ("Type-checking " ++ show gsym) $ @@ -5192,111 +6496,130 @@ tcTranslateAddCFGs sc mod_name env checks endianness dlevel cfgs_and_perms = ("With type:\n" ++ permPrettyString emptyPPInfo fun_perm) $ tcCFG ?ptrWidth tmp_env1 endianness dlevel fun_perm cfg - -- Next, generate a frame, i.e., a list of all the LetRecTypes in all of the - -- functions, along with a list of indices into that list of where the LRTs - -- of each function are in that list, and make a definition for the frame - let gen_lrts_ixs (i::Natural) (SomeTypedCFG _ _ tcfg : tcfgs') = - let lrts = translateCFGLRTs env tcfg in - (i, lrts) : gen_lrts_ixs (i + fromIntegral (length lrts)) tcfgs' - gen_lrts_ixs _ [] = [] - let (fun_ixs, lrtss) = unzip $ gen_lrts_ixs 0 tcfgs - let lrts = concat lrtss - frame_tm <- completeNormOpenTerm sc $ lrtsOpenTerm lrts - let (cfg_and_perm, _) = expectLengthAtLeastOne cfgs_and_perms - let frame_ident = - mkSafeIdent mod_name (someCFGAndPermToName cfg_and_perm - ++ "__frame") - frame_tp <- completeNormOpenTerm sc frameTypeOpenTerm - scInsertDef sc mod_name frame_ident frame_tp frame_tm - let frame = globalOpenTerm frame_ident - let stack = singleFunStack frame - - -- Now, generate a SAW core tuple of all the bodies of mutually recursive - -- functions for all the CFGs - bodies_tm <- - completeNormOpenTerm sc $ - runNilTypeTransM env checks $ - -- Create a temporary PermEnv that maps each Crucible symbol with a CFG in - -- our list to a recursive call to the corresponding function in our new - -- frame of recursive functions - do tmp_env <- - permEnvAddGlobalSyms env <$> - zipWithM (\some_tpcfg@(SomeTypedCFG sym _ _) i -> - do let fun_p = someTypedCFGPtrPerm some_tpcfg - return $ PermEnvGlobalEntry sym fun_p (Left i)) - tcfgs fun_ixs - bodiess <- - local (\info -> info { ttiPermEnv = tmp_env }) $ - zipWithM (\i (SomeTypedCFG _ _ cfg) -> - translateCFGBodies stack i cfg) fun_ixs tcfgs - return $ tupleOpenTerm $ concat bodiess - - -- Add a named definition for bodies_tm - let bodies_ident = - mkSafeIdent mod_name (someCFGAndPermToName cfg_and_perm + -- 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 (head cfgs_and_perms) ++ "__bodies") - bodies_tp <- - completeNormOpenTerm sc $ - runNilTypeTransM env checks $ - applyNamedEventOpM "Prelude.FrameTuple" [funStackTerm stack, frame] - scInsertDef sc mod_name bodies_ident bodies_tp bodies_tm - let bodies = globalOpenTerm bodies_ident - - -- Finally, generate definitions for each of our functions as applications - -- of multiFixS to our the bodies function defined above + bodies_tp <- completeOpenTerm sc $ multiFixBodiesOpenTerm ev ds + bodies_tm <- completeOpenTerm sc bodies + scInsertDef sc mod_name 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) i -> - do tp <- - completeNormOpenTerm sc $ piCFGArgs env cfg $ \_ -> - let fun_perm = tpcfgFunPerm cfg in - translateRetType (funPermRets fun_perm) (funPermOuts fun_perm) >>= - specMTypeTransM emptyStackOpenTerm - tm <- completeNormOpenTerm sc $ - translateCFG env emptyStackOpenTerm frame bodies i cfg + (\(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 mod_name ident tp tm + scInsertDef sc mod_name ident tp_trm f_trm let perm = mkPtrFunPerm $ tpcfgFunPerm cfg - return $ PermEnvGlobalEntry sym perm (Right [globalOpenTerm ident])) - tcfgs fun_ixs - return (permEnvAddGlobalSyms env new_entries, tcfgs) + 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 'FunPerm' to the SAW core type it represents +-- | 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 (translate $ emptyMb fun_perm) + runNilTypeTransM env noChecks (translateClosed fun_perm) --- | Translate a 'TypeRepr' to the SAW core type it represents +-- | 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 typ_perm = - completeNormOpenTerm sc $ typeTransType1 $ - runNilTypeTransM env noChecks $ translate $ emptyMb typ_perm +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 = - completeNormOpenTerm sc $ - runNilTypeTransM env noChecks (piExprCtx args (typeTransType1 <$> - translate ret)) - --- | Translate an input list of 'ValuePerms' and an output 'ValuePerm' to a SAW --- core function type in a manner similar to 'translateCompleteFunPerm', except --- that the returned function type is not in the @SpecM@ monad. -translateCompletePureFun :: SharedContext -> PermEnv - -> CruCtx ctx -- ^ Type arguments - -> Mb ctx (ValuePerms args) -- ^ Input perms - -> Mb ctx (ValuePerm ret) -- ^ Return type perm - -> IO Term -translateCompletePureFun sc env ctx args ret = + let ?ev = permEnvEventType env in completeNormOpenTerm sc $ runNilTypeTransM env noChecks $ - piExprCtx ctx $ piPermCtx args $ const $ - typeTransTupleType <$> translate ret + 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-saw/src/Verifier/SAW/Heapster/Token.hs b/heapster-saw/src/Verifier/SAW/Heapster/Token.hs index 94d94b148b..bd2e9f49af 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Token.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Token.hs @@ -65,6 +65,7 @@ data Token | TPtrSh -- ^ keyword @ptrsh@ | TFieldSh -- ^ keyword @fieldsh@ | TArraySh -- ^ keyword @arraysh@ + | TTupleSh -- ^ keyword @tuplesh@ | TExSh -- ^ keyword @exsh@ | TOrSh -- ^ keyword @orsh@ | TMemBlock -- ^ keyword @memblock@ @@ -149,6 +150,7 @@ describeToken t = TPtrSh -> "keyword 'ptrsh'" TFieldSh -> "keyword 'fieldsh'" TArraySh -> "keyword 'arraysh'" + TTupleSh -> "keyword 'tuplesh'" TExSh -> "keyword 'exsh'" TOrSh -> "keyword 'orsh'" TMemBlock -> "keyword 'memblock'" diff --git a/heapster-saw/src/Verifier/SAW/Heapster/TypeChecker.hs b/heapster-saw/src/Verifier/SAW/Heapster/TypeChecker.hs index e8a83498db..967ebd923b 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/TypeChecker.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/TypeChecker.hs @@ -454,6 +454,7 @@ tcLLVMShape (ExArraySh _ len stride sh) = <$> 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" diff --git a/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs b/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs index 708b73eda5..b44ec909bf 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs @@ -206,7 +206,7 @@ regWithValExpr (RegNoVal (TypedReg x)) = PExpr_Var x data TypedExpr ext tp = TypedExpr !(App ext RegWithVal tp) !(Maybe (PermExpr tp)) --- | A "typed" function handle is a normal function handle along with contexts +-- | 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) -> @@ -269,7 +269,7 @@ 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 +-- 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) = @@ -1053,7 +1053,7 @@ data TypedEntryInDegree -- one of which is a back edge | EntryInDegree_Loop --- | "Add" two in-degrees +-- | \"Add\" two in-degrees addInDegrees :: TypedEntryInDegree -> TypedEntryInDegree -> TypedEntryInDegree addInDegrees EntryInDegree_Loop _ = EntryInDegree_Loop addInDegrees _ EntryInDegree_Loop = EntryInDegree_Loop @@ -1093,7 +1093,7 @@ type family TransData phase a where data CallSiteImplRet blocks tops args ghosts ps_out = CallSiteImplRet (TypedEntryID blocks args) (CruCtx ghosts) ((tops :++: args) :++: ghosts :~: ps_out) - (RAssign ExprVar (tops :++: args)) (RAssign ExprVar ghosts) + (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 |]) @@ -1101,9 +1101,10 @@ $(mkNuMatching [t| forall 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 tavars gvars |]) = + genSubst s (mbMatch -> + [nuMP| CallSiteImplRet entryID ghosts Refl tvars avars gvars |]) = CallSiteImplRet (mbLift entryID) (mbLift ghosts) Refl <$> - genSubst s tavars <*> genSubst s gvars + genSubst s tvars <*> genSubst s avars <*> genSubst s gvars instance SubstVar PermVarSubst m => Substable1 PermVarSubst (CallSiteImplRet @@ -1125,9 +1126,10 @@ 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_args_ns vars_ns + 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 = @@ -1186,9 +1188,9 @@ 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. +-- 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 { @@ -1820,8 +1822,8 @@ applyDeltasToTopState :: [TypedBlockMapDelta 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' +-- | The state that can be modified by \"inner\" computations = a list of +-- changes / \"deltas\" to the current 'TypedBlockMap' data InnerPermCheckState blocks tops rets = InnerPermCheckState { @@ -1833,7 +1835,7 @@ clEmptyInnerPermCheckState :: Closed (InnerPermCheckState blocks tops rets) clEmptyInnerPermCheckState = $(mkClosed [| InnerPermCheckState [] |]) --- | The "inner" monad that runs inside 'PermCheckM' continuations. It can see +-- | 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 = @@ -2133,7 +2135,7 @@ getRegPerm :: TypedReg 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 +-- 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 @@ -2146,7 +2148,7 @@ getPushSimpleRegPerm r = pure p_ret -- | Eliminate any disjunctions, existentials, or recursive permissions for a --- register and then return the resulting "simple" permission +-- register and then return the resulting \"simple\" permission getSimpleRegPerm :: PermCheckExtC ext exprExt => TypedReg a -> StmtPermCheckM ext cblocks blocks tops rets ps ps (ValuePerm a) @@ -2329,7 +2331,7 @@ setVarTypes (ns :>: n) (CruCtxCons ts t) = setVarType n t allocateDebugNames :: - Maybe String -> -- ^ The base name of the variable (e.g., "top", "arg", etc.) + Maybe String -> -- ^ The base name of the variable (e.g., \"top\", \"arg\", etc.) RAssign (Constant (Maybe String)) tps -> CruCtx tps -> PPInfo -> @@ -2349,7 +2351,7 @@ allocateDebugNames base (ds :>: Constant dbg) (CruCtxCons ts tp) ppi = allocateDebugNamesM :: - Maybe String -> -- ^ The base name of the variable (e.g., "top", "arg", etc.) + 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 @@ -2504,10 +2506,21 @@ stmtRecombinePerms = pcmEmbedImplM TypedImplStmt emptyCruCtx (recombinePerms dist_perms) >>> pure () --- | Helper function to pretty print "Could not prove ps" for permissions @ps@ -ppProofError :: PermPretty a => PPInfo -> a -> Doc () -ppProofError ppInfo mb_ps = - nest 2 $ sep [pretty "Could not prove", PP.group (permPretty ppInfo mb_ps)] +-- | 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 @@ -2517,7 +2530,7 @@ stmtProvePermsAppend :: PermCheckExtC ext exprExt => (ps_in :++: ps) ps_in (PermSubst vars) stmtProvePermsAppend vars ps = permGetPPInfo >>>= \ppInfo -> - let err = ppProofError ppInfo ps in + 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 @@ -2528,7 +2541,7 @@ stmtProvePerms :: PermCheckExtC ext exprExt => ps RNil (PermSubst vars) stmtProvePerms vars ps = permGetPPInfo >>>= \ppInfo -> - let err = ppProofError ppInfo ps in + 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 @@ -2540,7 +2553,7 @@ stmtProvePermsFreshLs :: PermCheckExtC ext exprExt => ps RNil (PermSubst vars) stmtProvePermsFreshLs vars ps = permGetPPInfo >>>= \ppInfo -> - let err = ppProofError ppInfo ps in + let err = ppProofError ppInfo "stmtProvePermsFreshLs" ps in fst <$> pcmEmbedImplWithErrM TypedImplStmt vars err (instantiateLifetimeVars ps >>> proveVarsImpl ps) @@ -2551,7 +2564,7 @@ stmtProvePerm :: (PermCheckExtC ext exprExt, KnownRepr CruCtx vars) => (ps :> a) ps (PermSubst vars) stmtProvePerm (TypedReg x) mb_p = permGetPPInfo >>>= \ppInfo -> - let err = ppProofError ppInfo (fmap (distPerms1 x) mb_p) in + let err = ppProofError ppInfo "stmtProvePerm" (fmap (distPerms1 x) mb_p) in fst <$> pcmEmbedImplWithErrM TypedImplStmt knownRepr err (proveVarImpl x mb_p) @@ -2758,7 +2771,7 @@ 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 +-- | 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 -> @@ -4124,7 +4137,7 @@ tcTermStmt ctx (Return reg) = mb_req_perms = fmap (varSubst (singletonVarSubst ret_n)) $ mbSeparate (MNil :>: Proxy) mb_ret_perms - err = ppProofError (stPPInfo st) mb_req_perms in + 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 -> @@ -4235,10 +4248,9 @@ proveCallSiteImpl srcID destID args ghosts vars mb_perms_in mb_perms_out = pretty "-o" <> line <> indent 2 (permPretty i perms_out)) >>> permGetPPInfo >>>= \ppInfo -> - -- FIXME HERE NOW: add the input perms and call site to our error message - let err = ppProofError ppInfo perms_out in + let err = ppImplProofError ppInfo "proveCallSiteImpl" perms_in perms_out in pcmRunImplM ghosts err - (CallSiteImplRet destID ghosts Refl ns) + (CallSiteImplRet destID ghosts Refl tops_ns args_ns) (handleUnitVars ns >>> recombinePerms perms_in >>> proveVarsImplVarEVars perms_out @@ -4294,8 +4306,8 @@ widenEntry dlevel env (TypedEntry {..}) = -- 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. +-- 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] -> diff --git a/heapster-saw/src/Verifier/SAW/Heapster/UntypedAST.hs b/heapster-saw/src/Verifier/SAW/Heapster/UntypedAST.hs index 96e70e0d89..85814a07cc 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/UntypedAST.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/UntypedAST.hs @@ -66,6 +66,7 @@ data AstExpr | 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 @@ -110,6 +111,7 @@ instance HasPos AstExpr where 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 diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Widening.hs b/heapster-saw/src/Verifier/SAW/Heapster/Widening.hs index 278e25f211..79f059b39b 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Widening.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Widening.hs @@ -81,7 +81,7 @@ newtype ExtVarPermsFun vars = RAssign Name vars -> ExtVarPerms vars } -- | A map from free variables to their permissions and whether they have been --- "visited" yet +-- \"visited\" yet type WidNameMap = NameMap (Product ValuePerm (Constant Bool)) -- | Modify the entry in a 'WidNameMap' associated with a particular free diff --git a/saw-core-coq/README.md b/saw-core-coq/README.md index ad8ca7c9e5..de65b7f952 100644 --- a/saw-core-coq/README.md +++ b/saw-core-coq/README.md @@ -31,7 +31,7 @@ sh <(curl -sL https://raw.githubusercontent.com/ocaml/opam/master/shell/install. opam init opam repo add coq-released https://coq.inria.fr/opam/released opam install -y coq-bits -opam pin -y entree-specs https://github.com/GaloisInc/entree-specs.git#52c4868f1f65c7ce74e90000214de27e23ba98fb +opam pin -y entree-specs https://github.com/GaloisInc/entree-specs.git#5cf91e69c08376bcb17a95a8d2bf2daf406ae8cd ``` We have pinned the `entree-specs` dependency's commit to ensure that it points diff --git a/saw-core-coq/coq/_CoqProject b/saw-core-coq/coq/_CoqProject index 1ca05b0d81..410aba5b65 100644 --- a/saw-core-coq/coq/_CoqProject +++ b/saw-core-coq/coq/_CoqProject @@ -3,10 +3,12 @@ generated/CryptolToCoq/SAWCorePrelude.v generated/CryptolToCoq/CryptolPrimitivesForSAWCore.v -generated/CryptolToCoq/CryptolMPrimitivesForSAWCore.v +generated/CryptolToCoq/SpecMPrimitivesForSAWCore.v +# generated/CryptolToCoq/CryptolMPrimitivesForSAWCore.v -handwritten/CryptolToCoq/CompM.v -handwritten/CryptolToCoq/CompMExtra.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 @@ -15,6 +17,6 @@ handwritten/CryptolToCoq/SAWCorePrelude_proofs.v handwritten/CryptolToCoq/SAWCorePreludeExtra.v handwritten/CryptolToCoq/SAWCoreScaffolding.v handwritten/CryptolToCoq/SAWCoreVectorsAsCoqVectors.v -handwritten/CryptolToCoq/SpecMExtra.v +# handwritten/CryptolToCoq/SpecMExtra.v handwritten/CryptolToCoq/Everything.v diff --git a/saw-core-coq/coq/handwritten/CryptolToCoq/CryptolPrimitivesForSAWCoreExtra.v b/saw-core-coq/coq/handwritten/CryptolToCoq/CryptolPrimitivesForSAWCoreExtra.v index 75371e79c1..d78192a415 100644 --- a/saw-core-coq/coq/handwritten/CryptolToCoq/CryptolPrimitivesForSAWCoreExtra.v +++ b/saw-core-coq/coq/handwritten/CryptolToCoq/CryptolPrimitivesForSAWCoreExtra.v @@ -10,6 +10,7 @@ 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. @@ -18,7 +19,7 @@ Import ListNotations. (** It is annoying to have to wrap natural numbers into [TCNum] to use them at type [Num], so these coercions will do it for us. *) -Coercion TCNum : nat >-> Num. +Coercion TCNum : nat >-> TpDesc.Num. Definition natToNat (n : nat) : Nat := n. Coercion natToNat : nat >-> Nat. @@ -81,7 +82,7 @@ Fixpoint iterNat {a : Type} (n : nat) (f : a -> a) : a -> a := Definition iter {a : Type} (n : Num) (f : a -> a) : a -> a := match n with - | TCNum n => fun xs => iterNat n f xs - | TCInf => fun xs => xs + | TpDesc.TCNum n => fun xs => iterNat n f xs + | TpDesc.TCInf => fun xs => xs end . diff --git a/saw-core-coq/coq/handwritten/CryptolToCoq/Everything.v b/saw-core-coq/coq/handwritten/CryptolToCoq/Everything.v index 0383dba9ec..516dce0398 100644 --- a/saw-core-coq/coq/handwritten/CryptolToCoq/Everything.v +++ b/saw-core-coq/coq/handwritten/CryptolToCoq/Everything.v @@ -6,8 +6,6 @@ From CryptolToCoq Require Import CryptolPrimitivesForSAWCore. From CryptolToCoq Require Import SAWCorePrelude. (* handwritten *) -From CryptolToCoq Require Import CompM. -From CryptolToCoq Require Import CompMExtra. From CryptolToCoq Require Import CoqVectorsExtra. From CryptolToCoq Require Import CryptolPrimitivesForSAWCoreExtra. From CryptolToCoq Require Import SAWCoreBitvectors. @@ -15,4 +13,4 @@ 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. +(* From CryptolToCoq Require Import SpecMExtra. *) diff --git a/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreBitvectors.v b/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreBitvectors.v index e98b772b2e..3327585a22 100644 --- a/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreBitvectors.v +++ b/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreBitvectors.v @@ -6,11 +6,12 @@ From Coq Require Import Program.Basics. From Coq Require Program.Equality. From Coq Require Import Vectors.Vector. From Coq Require Import Logic.Eqdep. +From Coq Require Import Classes.RelationClasses. +From Coq Require Import Classes.Morphisms. From CryptolToCoq Require Import SAWCorePrelude. From CryptolToCoq Require Import SAWCoreScaffolding. From CryptolToCoq Require Import SAWCoreVectorsAsCoqVectors. -From CryptolToCoq Require Import CompMExtra. Import SAWCorePrelude. Import VectorNotations. @@ -81,7 +82,7 @@ Ltac compute_bv_funs_tac H t compute_bv_binrel compute_bv_binop end end. -Ltac unfold_bv_funs := unfold bvNat, bvultWithProof, bvuleWithProof, +Ltac unfold_bv_funs := unfold bvNat, bvsge, bvsgt, bvuge, bvugt, bvSCarry, bvSBorrow, xorb. @@ -105,13 +106,13 @@ Tactic Notation "compute_bv_funs" "in" ident(H) := Definition bvsmax w : bitvector w := match w with - | O => nil _ - | S w => cons _ false _ (gen w _ (fun _ => true)) + | O => Vector.nil _ + | S w => Vector.cons _ false _ (gen w _ (fun _ => true)) end. Definition bvsmin w : bitvector w := match w with - | O => nil _ - | S w => cons _ true _ (gen w _ (fun _ => false)) + | O => Vector.nil _ + | S w => Vector.cons _ true _ (gen w _ (fun _ => false)) end. Definition bvumax w : bitvector w := gen w _ (fun _ => true). @@ -490,6 +491,9 @@ Qed. (** Proof automation - computing and rewriting bv funs **) +(* FIXME: update to include support for the new refinement automation whenever +that is defined... *) +(* Hint Extern 1 (StartAutomation _) => progress compute_bv_funs: refinesFun. Ltac FreshIntroArg_bv_eq T := @@ -784,6 +788,7 @@ Hint Extern 3 (IntroArg _ (@eq bool ?x ?y) _) => | msb _ _ => simple apply IntroArg_msb_false_iff_bvsle end end : refinesFun. +*) (* Tactics for solving bitvector inequalities *) diff --git a/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCorePreludeExtra.v b/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCorePreludeExtra.v index c9921e60b5..ebb4a1a93e 100644 --- a/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCorePreludeExtra.v +++ b/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCorePreludeExtra.v @@ -12,6 +12,16 @@ From CryptolToCoq Require Import SAWCorePrelude. From CryptolToCoq Require Import SAWCoreVectorsAsCoqVectors. Import SAWCorePrelude. +(* NOTE: the Num type has to be defined in the TpDesc module in entree-specs +because it must be defined *before* type descriptions so type descriptions can +refer to it. Thus we map the definition in Cryptol.sawcore to that definition, +and we re-export it here. *) +Definition Num := TpDesc.Num. +Definition Num_rect := TpDesc.Num_rect. +Definition TCNum := TpDesc.TCNum. +Definition TCInf := TpDesc.TCInf. + + Fixpoint Nat_cases2_match a f1 f2 f3 (x y : nat) : a := match (x, y) with | (O, _) => f1 y @@ -35,9 +45,10 @@ Proof. induction x; induction y; simpl; auto. Defined. +(* NOTE: addNat is now defined as Coq plus, so this is trivial *) Theorem addNat_add : forall x y, addNat x y = x + y. Proof. - induction x; simpl; auto. + reflexivity. Defined. Theorem subNat_sub : forall x y, subNat x y = x - y. @@ -45,11 +56,10 @@ Proof. induction x; induction y; simpl; auto. Defined. +(* NOTE: mulNat is now defined as Coq mult, so this is trivial *) Theorem mulNat_mul : forall x y, mulNat x y = x * y. Proof. - induction x; simpl; intros; auto. - rewrite IHx. - apply addNat_add. + reflexivity. Defined. Definition streamScanl (a b : sort 0) (f : b -> a -> b) (z:b) (xs:Stream a) : Stream b := @@ -126,28 +136,3 @@ Proof. rewrite (le_unique _ _ pf2 pf). reflexivity. Qed. - - -Theorem fold_unfold_IRT As Ds D : forall x, foldIRT As Ds D (unfoldIRT As Ds D x) = x. -Proof. - induction x; simpl; unfold uncurry; f_equal; try easy. - (* All that remains is the IRT_BVVec case, which requires functional extensionality - and the fact that genBVVec and atBVVec define an isomorphism *) - repeat (apply functional_extensionality_dep; intro). - rewrite at_gen_BVVec; eauto. -Qed. - -Theorem unfold_fold_IRT As Ds D : forall u, unfoldIRT As Ds D (foldIRT As Ds D u) = u. -Proof. - revert Ds; induction D; intros; try destruct u; simpl(*; f_equal; try easy*). - (* For some reason using `f_equal` above generates universe constraints like - `prod.u0 < eq.u0` which cause problems later on when it is assumed that - `eq.u0 = Coq.Relations.Relation_Definitions.1 <= prod.u0` by - `returnM_injective`. The easiest solution is just to not use `f_equal` - here, and rewrite by the relevant induction hypotheses instead. *) - all: try rewrite IHD; try rewrite IHD1; try rewrite IHD2; try rewrite H; try easy. - (* All that remains is the IRT_BVVec case, which requires functional extensionality - and the fact that genBVVec and atBVVec define an isomorphism *) - etransitivity; [ | apply gen_at_BVVec ]. - f_equal; repeat (apply functional_extensionality_dep; intro); eauto. -Qed. diff --git a/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCorePrelude_proofs.v b/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCorePrelude_proofs.v index df79fe61bb..dd02568e34 100644 --- a/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCorePrelude_proofs.v +++ b/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCorePrelude_proofs.v @@ -109,13 +109,13 @@ Proof. Defined. Theorem sawAt_zero T size h t : - sawAt (S size) T (cons T h size t) 0 = h. + sawAt (S size) T (Vector.cons T h size t) 0 = h. Proof. unfold sawAt. now simpl. Qed. Theorem sawAt_S T size h t index : - sawAt (S size) T (cons T h size t) (S index) = sawAt size T t index. + sawAt (S size) T (Vector.cons T h size t) (S index) = sawAt size T t index. Proof. unfold sawAt. now simpl. Qed. @@ -137,9 +137,9 @@ Proof. Qed. Lemma append_cons m n T {HT:Inhabited T} h t v - : append m.+1 n T (cons T h m t) v + : append m.+1 n T (Vector.cons T h m t) v = - cons T h _ (append m n T t v). + Vector.cons T h _ (append m n T t v). Proof. reflexivity. Qed. diff --git a/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreScaffolding.v b/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreScaffolding.v index 3c3063709d..44144b7e96 100644 --- a/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreScaffolding.v +++ b/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreScaffolding.v @@ -5,12 +5,9 @@ From Coq Require Import Lists.List. From Coq Require Numbers.NatInt.NZLog. From Coq Require Import Strings.String. From Coq Require Export Logic.Eqdep. -From CryptolToCoq Require Export CompM. -From EnTree Require Export - Basics.HeterogeneousRelations - Basics.QuantType - Ref.SpecM. +From EnTree Require Import EnTreeSpecs. + (*** *** sawLet @@ -143,7 +140,7 @@ Qed. Definition coerce (a b : sort 0) (p : @eq (sort 0) a b) (x : a) : b := match p in eq _ a' return a' with - | eq_refl _ => x + | @eq_refl _ _ => x end . Check eq_sym. @@ -237,8 +234,8 @@ Definition IsLeNat__rec : forall (m : nat) (Hm : IsLeNat n m), p m Hm := fix rec (m:nat) (Hm : IsLeNat n m) {struct Hm} : p m Hm := match Hm as Hm' in le _ m' return p m' Hm' with - | le_n _ => Hbase - | le_S _ m H => Hstep m H (rec m H) + | @le_n _ => Hbase + | @le_S _ m H => Hstep m H (rec m H) end. (* We could have SAW autogenerate this definition in SAWCorePrelude, but it is @@ -273,6 +270,9 @@ Arguments Datatypes.snd {_ _}. Definition Zero := O. Definition Succ := S. +Definition addNat := Nat.add. +Definition mulNat := Nat.mul. + Global Instance Inhabited_Pair (a b:Type) {Ha : Inhabited a} {Hb : Inhabited b} : Inhabited (PairType a b) := MkInhabited (PairType a b) (PairValue a b inhabitant inhabitant). Global Instance Inhabited_prod (a b:Type) {Ha : Inhabited a} {Hb : Inhabited b} : Inhabited (prod a b) := @@ -358,15 +358,19 @@ Global Instance Inhabited_RecordCons (fnm:string) (tp rest_tp:Type) := MkInhabited (RecordTypeCons fnm tp rest_tp) (RecordCons fnm inhabitant inhabitant). (* Get the head element of a non-empty record type *) +(* NOTE: more recent versions of Coq seem to have changed constructor patterns +so that the parameters of an inductive type are not required, even when they are +specified in the Arguments declaration, so we use the explicit arguments +@RecordCons pattern, since that does not change between Coq versions *) Definition recordHead {str tp rest_tp} (r:RecordTypeCons str tp rest_tp) : tp := match r with - | RecordCons _ x _ => x + | @RecordCons _ _ _ x _ => x end. (* Get the tail of a non-empty record type *) Definition recordTail {str tp rest_tp} (r:RecordTypeCons str tp rest_tp) : rest_tp := match r with - | RecordCons _ _ rest => rest + | @RecordCons _ _ _ _ rest => rest end. (* An inductive description of a string being a field in a record type *) @@ -382,8 +386,8 @@ Global Hint Constructors IsRecordField : typeclass_instances. (* If str is a field in record type rtp, get its associated type *) Fixpoint getRecordFieldType rtp str `{irf:IsRecordField str rtp} : Type := match irf with - | IsRecordField_Base _ tp rtp => tp - | IsRecordField_Step _ _ _ _ irf' => @getRecordFieldType _ _ irf' + | @IsRecordField_Base _ tp rtp => tp + | @IsRecordField_Step _ _ _ _ irf' => @getRecordFieldType _ _ irf' end. (* If str is a field in record r of record type rtp, get its associated value *) @@ -391,8 +395,8 @@ Fixpoint getRecordField {rtp} str `{irf:IsRecordField str rtp} : rtp -> getRecordFieldType rtp str := match irf in IsRecordField _ rtp return rtp -> getRecordFieldType rtp str (irf:=irf) with - | IsRecordField_Base _ tp rtp' => fun r => recordHead r - | IsRecordField_Step _ _ _ _ irf' => + | @IsRecordField_Base _ tp rtp' => fun r => recordHead r + | @IsRecordField_Step _ _ _ _ irf' => fun r => @getRecordField _ _ irf' (recordTail r) end. diff --git a/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreVectorsAsCoqVectors.v b/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreVectorsAsCoqVectors.v index 866c163a67..80dfbf3522 100644 --- a/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreVectorsAsCoqVectors.v +++ b/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreVectorsAsCoqVectors.v @@ -23,6 +23,8 @@ From mathcomp Require Import tuple. From Coq Require Export ZArith.BinIntDef. From Coq Require Export PArith.BinPos. +From EnTree Require Import EnTreeSpecs. + Import VectorNotations. Definition Vec (n : nat) (a : Type) : Type := VectorDef.t a n. @@ -68,8 +70,8 @@ Fixpoint gen (n : nat) (a : Type) (f : nat -> a) {struct n} : Vec n a. ). Defined. -Definition head (n : nat) (a : Type) (v : Vec (S n) a) : a := hd v. -Definition tail (n : nat) (a : Type) (v : Vec (S n) a) : Vec n a := tl v. +Definition head (n : nat) (a : Type) (v : Vec (S n) a) : a := VectorDef.hd v. +Definition tail (n : nat) (a : Type) (v : Vec (S n) a) : Vec n a := VectorDef.tl v. Lemma head_gen (n : nat) (a : Type) (f : nat -> a) : head n a (gen (Succ n) a f) = f 0. @@ -213,7 +215,8 @@ Proof. Qed. Lemma foldr_cons (a b : Type) (n : nat) (f : a -> b -> b) (base : b) - (v : Vec (S n) a) : foldr a b (S n) f base v = f (hd v) (foldr a b n f base (tl v)). + (v : Vec (S n) a) : foldr a b (S n) f base v + = f (VectorDef.hd v) (foldr a b n f base (VectorDef.tl v)). Proof. destruct (Vec_S_cons _ _ v) as [ x [ xs pf ]]. rewrite pf. reflexivity. @@ -234,7 +237,7 @@ Qed. Lemma foldl_cons (a b : Type) (n : nat) (f : b -> a -> b) (base : b) (v : Vec (S n) a) : - foldl a b (S n) f base v = foldl a b n f (f base (hd v)) (tl v). + foldl a b (S n) f base v = foldl a b n f (f base (VectorDef.hd v)) (VectorDef.tl v). Proof. destruct (Vec_S_cons _ _ v) as [ x [ xs pf ]]. rewrite pf. reflexivity. @@ -479,7 +482,7 @@ Definition shiftL1 (n:nat) (A:Type) (x:A) (v : Vector.t A n) := (* right shift by one element, shifting in the value of x on the left *) Definition shiftR1 (n:nat) (A:Type) (x:A) (v : Vector.t A n) := - Vector.shiftout (cons _ x _ v). + Vector.shiftout (VectorDef.cons _ x _ v). Definition rotateL (n : nat) : forall (A : Type) (v : Vector.t A n) (i : nat), Vector.t A n := match n with diff --git a/saw-core-coq/coq/handwritten/CryptolToCoq/SpecM.v b/saw-core-coq/coq/handwritten/CryptolToCoq/SpecM.v new file mode 100644 index 0000000000..d3be33b3a8 --- /dev/null +++ b/saw-core-coq/coq/handwritten/CryptolToCoq/SpecM.v @@ -0,0 +1,140 @@ + +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 index 9ffbe67deb..69f98036a2 100644 --- a/saw-core-coq/coq/handwritten/CryptolToCoq/SpecMExtra.v +++ b/saw-core-coq/coq/handwritten/CryptolToCoq/SpecMExtra.v @@ -9,7 +9,7 @@ From CryptolToCoq Require Import SAWCoreBitvectors. From EnTree Require Export Basics.HeterogeneousRelations Basics.QuantType - Ref.SpecM + Ref.SpecM. Automation. Import SAWCorePrelude. diff --git a/saw-core-coq/saw/generate_scaffolding.saw b/saw-core-coq/saw/generate_scaffolding.saw index 708552fe18..5a6bb96a19 100644 --- a/saw-core-coq/saw/generate_scaffolding.saw +++ b/saw-core-coq/saw/generate_scaffolding.saw @@ -1,3 +1,6 @@ enable_experimental; write_coq_sawcore_prelude "../coq/generated/CryptolToCoq/SAWCorePrelude.v" [] []; -write_coq_cryptol_primitives_for_sawcore "../coq/generated/CryptolToCoq/CryptolPrimitivesForSAWCore.v" "../coq/generated/CryptolToCoq/CryptolMPrimitivesForSAWCore.v" [] []; +write_coq_cryptol_primitives_for_sawcore + "../coq/generated/CryptolToCoq/CryptolPrimitivesForSAWCore.v" + "../coq/generated/CryptolToCoq/SpecMPrimitivesForSAWCore.v" + "../coq/generated/CryptolToCoq/CryptolMPrimitivesForSAWCore.v" [] []; diff --git a/saw-core-coq/src/Verifier/SAW/Translation/Coq/SpecialTreatment.hs b/saw-core-coq/src/Verifier/SAW/Translation/Coq/SpecialTreatment.hs index 309338f8f7..195ce7c999 100644 --- a/saw-core-coq/src/Verifier/SAW/Translation/Coq/SpecialTreatment.hs +++ b/saw-core-coq/src/Verifier/SAW/Translation/Coq/SpecialTreatment.hs @@ -197,13 +197,17 @@ stringModule = sawDefinitionsModule :: ModuleName sawDefinitionsModule = mkModuleName ["SAWCoreScaffolding"] --- | The @CompM@ module -compMModule :: ModuleName -compMModule = mkModuleName ["CompM"] - specMModule :: ModuleName specMModule = mkModuleName ["SpecM"] +tpDescModule :: ModuleName +tpDescModule = mkModuleName ["TpDesc"] + +{- +polyListModule :: ModuleName +polyListModule = mkModuleName ["PolyList"] +-} + sawVectorDefinitionsModule :: TranslationConfiguration -> ModuleName sawVectorDefinitionsModule (TranslationConfiguration {..}) = mkModuleName [Text.pack vectorModule] @@ -214,21 +218,29 @@ cryptolPrimitivesModule = mkModuleName ["CryptolPrimitivesForSAWCore"] preludeExtraModule :: ModuleName preludeExtraModule = mkModuleName ["SAWCorePreludeExtra"] +specialTreatmentMap :: TranslationConfiguration -> + Map.Map ModuleName (Map.Map String IdentSpecialTreatment) +specialTreatmentMap configuration = Map.fromList $ + over _1 (mkModuleName . (: [])) <$> + [ ("Cryptol", cryptolPreludeSpecialTreatmentMap) + , ("Prelude", sawCorePreludeSpecialTreatmentMap configuration) + , ("SpecM", specMSpecialTreatmentMap configuration) + ] + cryptolPreludeSpecialTreatmentMap :: Map.Map String IdentSpecialTreatment cryptolPreludeSpecialTreatmentMap = Map.fromList $ [] + -- NOTE: Num has to be defined in the entree-specs library, because it must be + -- defined *before* type descriptions, so we have to map Num and some of its + -- operations to that library ++ - [ ("Num_rec", mapsTo cryptolPrimitivesModule "Num_rect") -- automatically defined + [ ("Num", mapsTo tpDescModule "Num") + , ("TCNum", mapsTo tpDescModule "TCNum") + , ("TCInf", mapsTo tpDescModule "TCInf") + , ("Num_rec", mapsTo tpDescModule "Num_rect") , ("unsafeAssert_same_Num", skip) -- unsafe and unused ] -specialTreatmentMap :: TranslationConfiguration -> Map.Map ModuleName (Map.Map String IdentSpecialTreatment) -specialTreatmentMap configuration = Map.fromList $ - over _1 (mkModuleName . (: [])) <$> - [ ("Cryptol", cryptolPreludeSpecialTreatmentMap) - , ("Prelude", sawCorePreludeSpecialTreatmentMap configuration) - ] - -- NOTE: while I initially did the mapping from SAW core names to the -- corresponding Coq construct here, it makes the job of translating SAW core -- axioms into Coq theorems much more annoying, because one needs to manually @@ -237,7 +249,8 @@ specialTreatmentMap configuration = Map.fromList $ -- during this translation (it is sometimes impossible, for instance, `at` is a -- reserved keyword in Coq), so that primitives' and axioms' types can be -- copy-pasted as is on the Coq side. -sawCorePreludeSpecialTreatmentMap :: TranslationConfiguration -> Map.Map String IdentSpecialTreatment +sawCorePreludeSpecialTreatmentMap :: TranslationConfiguration -> + Map.Map String IdentSpecialTreatment sawCorePreludeSpecialTreatmentMap configuration = let vectorsModule = sawVectorDefinitionsModule configuration in Map.fromList $ @@ -280,6 +293,10 @@ sawCorePreludeSpecialTreatmentMap configuration = , ("RecordType__rec", skip) ] + -- Void + ++ + [ ("Void", mapsTo datatypesModule "Empty_set")] + -- Decidable equality, does not make sense in Coq unless turned into a type -- class -- Apparently, this is not used much for Cryptol, so we can skip it. @@ -362,6 +379,8 @@ sawCorePreludeSpecialTreatmentMap configuration = , ("widthNat", mapsTo sawDefinitionsModule "widthNat") , ("Zero", mapsTo sawDefinitionsModule "Zero") , ("Succ", mapsTo sawDefinitionsModule "Succ") + , ("addNat", mapsTo sawDefinitionsModule "addNat") + , ("mulNat", mapsTo sawDefinitionsModule "mulNat") ] -- Vectors @@ -494,76 +513,11 @@ sawCorePreludeSpecialTreatmentMap configuration = , ("test_fun6", skip) ] - -- The computation monad + -- Either ++ - [ ("CompM", replace (Coq.Var "CompM")) - , ("returnM", replace (Coq.App (Coq.ExplVar "returnM") - [Coq.Var "CompM", Coq.Var "_"])) - , ("bindM", replace (Coq.App (Coq.ExplVar "bindM") - [Coq.Var "CompM", Coq.Var "_"])) - , ("errorM", replace (Coq.App (Coq.ExplVar "errorM") - [Coq.Var "CompM", Coq.Var "_"])) - , ("catchM", skip) - , ("existsM", mapsToExpl compMModule "existsM") - , ("forallM", mapsToExpl compMModule "forallM") - , ("orM", mapsToExpl compMModule "orM") - , ("assertingM", mapsToExpl compMModule "assertingM") - , ("assumingM", mapsToExpl compMModule "assumingM") - , ("asserting", skip) - , ("assuming", skip) - , ("fixM", replace (Coq.App (Coq.ExplVar "fixM") - [Coq.Var "CompM", Coq.Var "_"])) - , ("LetRecType", mapsTo specMModule "LetRecType") - , ("LRT_Ret", mapsTo specMModule "LRT_Ret") - , ("LRT_Fun", mapsTo specMModule "LRT_Fun") - , ("lrtToType", mapsTo compMModule "lrtToType") - , ("LetRecTypes", mapsTo compMModule "LetRecTypes") - , ("LRT_Cons", mapsTo compMModule "LRT_Cons") - , ("LRT_Nil", mapsTo compMModule "LRT_Nil") - , ("lrtPi", mapsTo compMModule "lrtPi") - , ("lrtTupleType", mapsTo compMModule "lrtTupleType") - , ("multiFixM", mapsToExpl compMModule "multiFixM") - , ("letRecM", mapsToExpl compMModule "letRecM") - ] - - -- The specification monad - ++ - [ ("EvType", mapsTo specMModule "EvType") - , ("Build_EvType", mapsTo specMModule "Build_EvType") - , ("evTypeType", mapsTo specMModule "evTypeType") - , ("evRetType", mapsTo specMModule "evRetType") - , ("SpecM", mapsToExpl specMModule "SpecM") - , ("retS", mapsToExpl specMModule "RetS") - , ("bindS", mapsToExpl specMModule "BindS") - , ("errorS", mapsToExpl specMModule "ErrorS") - , ("liftStackS", mapsToExpl specMModule "liftStackS") - , ("existsS", mapsToExplInferArg "SpecM.ExistsS" 3) - , ("forallS", mapsToExplInferArg "SpecM.ForallS" 3) - , ("FunStack", mapsTo specMModule "FunStack") - , ("LRTInput", mapsToExpl specMModule "LRTInput") - , ("LRTOutput", mapsToExpl specMModule "LRTOutput") - , ("lrt1Pi", mapsToExpl specMModule "lrtPi") - , ("lrtLambda", mapsToExpl specMModule "lrtLambda") - , ("nthLRT", mapsToExpl specMModule "nthLRT") - , ("FrameCall", mapsToExpl specMModule "FrameCall") - , ("FrameCallOfArgs", mapsToExpl specMModule "FrameCallOfArgs") - , ("mkFrameCall", mapsToExpl specMModule "mkFrameCall") - , ("FrameCallRet", mapsToExpl specMModule "FrameCallRet") - , ("LRTType", mapsToExpl specMModule "LRTType") - , ("FrameTuple", mapsToExpl specMModule "FrameTuple") - , ("callS", mapsToExpl specMModule "CallS") - , ("multiFixS", mapsToExpl specMModule "MultiFixS") - , ("FunStackE_type", mapsToExpl specMModule "FunStackE") - , ("FunStackE_enc", replace (Coq.Lambda [Coq.Binder "E" (Just (Coq.Var "SpecM.EvType"))] - (Coq.App (Coq.ExplVar "SpecM.FunStackE_encodes") - [Coq.App (Coq.Var "SpecM.evTypeType") [Coq.Var "E"], - Coq.App (Coq.Var "SpecM.evRetType") [Coq.Var "E"]]))) - , ("SpecPreRel", mapsToExpl specMModule "SpecPreRel") - , ("SpecPostRel", mapsToExpl specMModule "SpecPostRel") - , ("eqPreRel", mapsToExpl specMModule "eqPreRel") - , ("eqPostRel", mapsToExpl specMModule "eqPostRel") - , ("refinesS", mapsToExpl specMModule "spec_refines") - , ("refinesS_eq", mapsToExpl specMModule "spec_refines_eq") + [ ("Either", mapsTo datatypesModule "sum") + , ("Left", mapsToExpl datatypesModule "inl") + , ("Right", mapsToExpl datatypesModule "inr") ] -- Dependent pairs @@ -584,20 +538,64 @@ sawCorePreludeSpecialTreatmentMap configuration = ] -- Lists at sort 1 + {- FIXME: in order to support lists at a higher sort, we need a universe + polymorphic version of them ++ - [ ("List1", mapsToExpl datatypesModule "list") - , ("Nil1", mapsToExpl datatypesModule "nil") - , ("Cons1", mapsToExpl datatypesModule "cons") + [ ("List1", mapsToExpl polyListModule "plist") + , ("Nil1", mapsToExpl polyListModule "pnil") + , ("Cons1", mapsToExpl polyListModule "pcons") + ] + -} + +specMSpecialTreatmentMap :: TranslationConfiguration -> + Map.Map String IdentSpecialTreatment +specMSpecialTreatmentMap _configuration = + Map.fromList $ + + -- Type descriptions + map (\str -> (str, mapsTo specMModule 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" ] - -- Lists at sort 2 + -- The specification monad ++ - [ ("List2", mapsToExpl datatypesModule "list") - , ("Nil2", mapsToExpl datatypesModule "nil") - , ("Cons2", mapsToExpl datatypesModule "cons") - , ("List2__rec", mapsToExpl datatypesModule "list_rect") + [ ("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 :: String -> String escapeIdent str | all okChar str = str diff --git a/saw-core-coq/src/Verifier/SAW/Translation/Coq/Term.hs b/saw-core-coq/src/Verifier/SAW/Translation/Coq/Term.hs index 90d393ddd6..db43a4c74c 100644 --- a/saw-core-coq/src/Verifier/SAW/Translation/Coq/Term.hs +++ b/saw-core-coq/src/Verifier/SAW/Translation/Coq/Term.hs @@ -211,7 +211,7 @@ withSharedTerms ((idx,t):ts) f = -- | The set of reserved identifiers in Coq, obtained from section --- "Gallina Specification Language" of the Coq reference manual. +-- \"Gallina Specification Language\" of the Coq reference manual. -- reservedIdents :: Set.Set Coq.Ident reservedIdents = @@ -476,7 +476,7 @@ flatTermFToExpr tf = -- traceFTermF "flatTermFToExpr" tf $ r_trans <- translateTerm r return (Coq.App (Coq.Var "RecordProj") [r_trans, Coq.StringLit (Text.unpack f)]) --- | Recognizes an $App (App "Cryptol.seq" n) x$ and returns ($n$, $x$). +-- | Recognizes an @App (App "Cryptol.seq" n) x@ and returns @(n, x)@. asSeq :: Recognizer Term (Term, Term) asSeq t = do (f, args) <- asApplyAllRecognizer t fid <- asGlobalDef f @@ -719,7 +719,7 @@ translateTermUnshared t = do badTerm = Except.throwError $ BadTerm t -- | In order to turn fixpoint computations into iterative computations, we need --- to be able to create "dummy" values at the type of the computation. +-- to be able to create \"dummy\" values at the type of the computation. defaultTermForType :: TermTranslationMonad m => Term -> m Coq.Term diff --git a/saw-core/prelude/Prelude.sawcore b/saw-core/prelude/Prelude.sawcore index 997d6d8f77..5c48fdcc83 100644 --- a/saw-core/prelude/Prelude.sawcore +++ b/saw-core/prelude/Prelude.sawcore @@ -355,6 +355,21 @@ ite_false (a : sort 1) (x y : a) : Eq a (ite a False x y) y = trans a (ite a False x y) (iteDep (\ (b:Bool) -> a) False x y) y (ite_eq_iteDep a False x y) (iteDep_False (\ (_:Bool) -> a) x y); +-- A version of ite that includes an Eq proof term in each branch +iteWithProof : (a : sort 0) -> (b:Bool) -> (Eq Bool b True -> a) -> + (Eq Bool b False -> a) -> a; +iteWithProof a b f1 f2 = + iteDep (\ (b1:Bool) -> Eq Bool b b1 -> a) b f1 f2 (Refl Bool b); + -- NOTE: we cannot use unsafeAssert in the Prelude, because the translation + -- for it into Coq is currently defined in CryptolPrimitivesForSAWCoreExtra.v, + -- which is defined *after* the Prelude + -- + -- ite a b (f1 (unsafeAssert Bool b True)) (f2 (unsafeAssert Bool b False)); + +-- A version of ite that includes an Eq proof term only in the True branch +ifWithProof : (a : sort 0) -> (b:Bool) -> a -> (Eq Bool b True -> a) -> a; +ifWithProof a b x f = iteWithProof a b f (\(_:Eq Bool b False) -> x); + -- -- Converting between Bools and Bits (cause why not?) -- @@ -840,7 +855,7 @@ Nat_cases2 a f1 f2 f3 n m = Nat__rec (\ (m':Nat) -> a) (f2 n) (\ (m':Nat) -> \ (frec':a) -> f3 n m' (f_rec m')) m) n m; -eqNat : Nat -> Nat -> sort 1; +eqNat : Nat -> Nat -> Prop; eqNat x y = Eq Nat x y; eqNatSucc : (x y : Nat) -> eqNat x y -> eqNat (Succ x) (Succ y); @@ -879,7 +894,21 @@ primitive natCompareLe : (m n : Nat) -> Either (IsLtNat m n) (IsLeNat n m); -- | Test if m = n -- FIXME: implement this! -primitive proveEqNat : (m n : Nat) -> Maybe (Eq Nat m n); +proveEqNat : (m n : Nat) -> Maybe (Eq Nat m n); +proveEqNat = + Nat__rec (\ (m:Nat) -> (n:Nat) -> Maybe (Eq Nat m n)) + (Nat__rec (\ (n:Nat) -> Maybe (Eq Nat 0 n)) + (Just (Eq Nat 0 0) (Refl Nat 0)) + (\ (n:Nat) (_:Maybe (Eq Nat 0 n)) -> Nothing (Eq Nat 0 (Succ n)))) + (\ (m:Nat) (rec: (n:Nat) -> Maybe (Eq Nat m n)) -> + Nat__rec (\ (n:Nat) -> Maybe (Eq Nat (Succ m) n)) + (Nothing (Eq Nat (Succ m) 0)) + (\ (n:Nat) (_:Maybe (Eq Nat (Succ m) n)) -> + maybe (Eq Nat m n) (Maybe (Eq Nat (Succ m) (Succ n))) + (Nothing (Eq Nat (Succ m) (Succ n))) + (\ (e:Eq Nat m n) -> + Just (Eq Nat (Succ m) (Succ n)) (eqNatSucc m n e)) + (rec n))); -- | Try to prove x <= y (FIXME: implement this from natCompareLe!) primitive proveLeNat : (x y : Nat) -> Maybe (IsLeNat x y); @@ -950,6 +979,17 @@ equalNat x y = Nat_cases Bool False (\ (m':Nat) -> \ (b:Bool) -> eqN m') m) x y; +-- Convert a equalNat equality to an equality of Nats +-- FIXME: Implement this in the same way as proveEqNat +primitive equalNatToEqNat : (m n : Nat) -> + Eq Bool (equalNat m n) True -> eqNat m n; + +-- An ite on Nat equality with a proof term in the True branch +ifEqNatWithProof : (a : sort 0) -> (m n : Nat) -> a -> (eqNat m n -> a) -> a; +ifEqNatWithProof a m n x f = + ifWithProof a (equalNat m n) x + (\ (pf:Eq Bool (equalNat m n) True) -> f (equalNatToEqNat m n pf)); + ltNat : Nat -> Nat -> Bool; ltNat x y = Nat_cases2 Bool (\ (x':Nat) -> False) @@ -1700,7 +1740,7 @@ data List (a : sort 0) : sort 0 } List__rec : - (a : sort 0) -> (P : List a -> sort 0) -> P (Nil a) -> + (a : sort 0) -> (P : List a -> sort 1) -> P (Nil a) -> ((x : a) -> (l : List a) -> P l -> P (Cons a x l)) -> (l : List a) -> P l; List__rec a P f1 f2 l = List#rec a P f1 f2 l; @@ -1843,6 +1883,34 @@ eithers a = eithers1 tp (FunsToIns a elims) a eiths f rec); +-------------------------------------------------------------------------------- +-- Nested Sigma types + +-- FIXME: Sigmas isn't used yet, but is here in case we need it later + +-- Form the multiple arrow type a1 -> ... -> an -> b +arrowsType : ListSort -> sort 0 -> sort 0; +arrowsType as b = + ListSort__rec (\ (_:ListSort) -> sort 0) b + (\ (a:sort 0) (_:ListSort) (rec:sort 0) -> a -> rec) + as; + +-- Form the type a1 -> ... -> an -> sort 0 of a type-level function over the as +arrowsSort : ListSort -> sort 1; +arrowsSort as = + ListSort#rec (\ (_:ListSort) -> sort 1) (sort 0) + (\ (a:sort 0) (_:ListSort) (rec:sort 1) -> a -> rec) + as; + +-- The right-nested sigma type Sigma a1 (\ x1 -> Sigma a2 (\ x2 -> ... (b x1 ... xn))) +Sigmas : (as:ListSort) -> arrowsSort as -> sort 0; +Sigmas = + ListSort__rec (\ (as:ListSort) -> arrowsSort as -> sort 0) + (\ (b:sort 0) -> b) + (\ (a:sort 0) (as:ListSort) (rec:arrowsSort as -> sort 0) + (b:a -> arrowsSort as) -> Sigma a (\ (x:a) -> rec (b x))); + + -------------------------------------------------------------------------------- -- Lists of 64-bit words (for testing Heapster) @@ -1887,25 +1955,16 @@ axiom unsafeAssertBVULt : (n : Nat) -> (x : Vec n Bool) -> (y : Vec n Bool) -> axiom unsafeAssertBVULe : (n : Nat) -> (x : Vec n Bool) -> (y : Vec n Bool) -> Eq Bool (bvule n x y) True; --- Decide equality on two bitvectors, returning a proof if they are equal -primitive bvEqWithProof : (n : Nat) -> (v1 v2 : Vec n Bool) -> - Maybe (Eq (Vec n Bool) v1 v2); - --- Compare two bitvectors with bvult, returning a proof if bvult succeeds -bvultWithProof : (n : Nat) -> (v1 v2 : Vec n Bool) -> - Maybe (Eq Bool (bvult n v1 v2) True); -bvultWithProof n v1 v2 = - iteDep (\ (b:Bool) -> Maybe (Eq Bool b True)) (bvult n v1 v2) - (Just (Eq Bool True True) (Refl Bool True)) - (Nothing (Eq Bool False True)); - --- Compare two bitvectors with bvule, returning a proof if bvule succeeds -bvuleWithProof : (n : Nat) -> (v1 v2 : Vec n Bool) -> - Maybe (Eq Bool (bvule n v1 v2) True); -bvuleWithProof n v1 v2 = - iteDep (\ (b:Bool) -> Maybe (Eq Bool b True)) (bvule n v1 v2) - (Just (Eq Bool True True) (Refl Bool True)) - (Nothing (Eq Bool False True)); +-- Convert a bvEq equality to an equality of bitvectors +primitive bvEqToEq : (n : Nat) -> (v1 v2 : Vec n Bool) -> + Eq Bool (bvEq n v1 v2) True -> Eq (Vec n Bool) v1 v2; + +-- An ite on bitvector equality with a proof term in the True branch +ifBvEqWithProof : (a : sort 0) -> (n : Nat) -> (v1 v2 : Vec n Bool) -> + a -> (Eq (Vec n Bool) v1 v2 -> a) -> a; +ifBvEqWithProof a n v1 v2 x f = + ifWithProof a (bvEq n v1 v2) x + (\ (pf:Eq Bool (bvEq n v1 v2) True) -> f (bvEqToEq n v1 v2 pf)); -- Convert a proof of bitvector equality to one of Nat equality primitive bvEqToEqNat : (n : Nat) -> (v1 v2 : Vec n Bool) -> @@ -1989,6 +2048,13 @@ genBVVec n len a f = (\ (i:Nat) (pf:IsLtNat i (bvToNat n len)) -> f (bvNat n i) (IsLtNat_to_bvult n len i pf)); +-- Generate a BVVec from a function from bitvector indices to elements, in a +-- manner similar to genBVVec but where the function does not take proofs +genBVVecNoPf : (n : Nat) -> (len : Vec n Bool) -> (a : sort 0) -> + (Vec n Bool -> a) -> BVVec n len a; +genBVVecNoPf n len a f = + gen (bvToNat n len) a (\ (i:Nat) -> f (bvNat n i)); + -- Generate a BVVec from the elements of an existing vector, using a default -- value when we run out of the existing vector genBVVecFromVec : (m : Nat) -> (a : sort 0) -> Vec m a -> a -> @@ -2035,6 +2101,12 @@ atBVVec n len a x ix pf = (bvNat_bvToNat n ix) Bool (\ (y:Vec n Bool) -> bvult n y len)) pf)); +-- Read the ixth element of a BVVec, assuming that ix < len but with no proof of +-- that fact +atBVVecNoPf : (n : Nat) -> (len : Vec n Bool) -> (a : isort 0) -> + BVVec n len a -> (ix : Vec n Bool) -> a; +atBVVecNoPf n len a v ix = at (bvToNat n len) a v (bvToNat n ix); + -- Indexing a generated BVVec just returns the generating function axiom at_gen_BVVec : (n : Nat) -> (len : Vec n Bool) -> (a : sort 0) -> (f : (i:Vec n Bool) -> is_bvult n i len -> a) -> @@ -2100,11 +2172,10 @@ updSliceBVVec n len a v start' len' v_sub = genBVVec n len a (\ (i:Vec n Bool) (pf:is_bvult n i len) -> ite a (bvule n start' i) - (maybe (is_bvult n (bvSub n i start') len') a + (ifWithProof a (bvult n (bvSub n i start') len') (atBVVec n len a v i pf) (\ (pf_sub:is_bvult n (bvSub n i start') len') -> - atBVVec n len' a v_sub (bvSub n i start') pf_sub) - (bvultWithProof n (bvSub n i start') len')) + atBVVec n len' a v_sub (bvSub n i start') pf_sub)) (atBVVec n len a v i pf)); -- Append two BVVecs @@ -2113,14 +2184,11 @@ appendBVVec : (n : Nat) -> (len1 len2 : Vec n Bool) -> (a : sort 0) -> appendBVVec n len1 len2 a v1 v2 = genBVVec n (bvAdd n len1 len2) a (\ (i:Vec n Bool) (pf12:is_bvult n i (bvAdd n len1 len2)) -> - iteDep - (\ (b:Bool) -> Eq Bool (bvult n i len1) b -> a) - (bvult n i len1) + iteWithProof a (bvult n i len1) (\ (pf1:is_bvult n i len1) -> atBVVec n len1 a v1 i pf1) (\ (not_pf1:Eq Bool (bvult n i len1) False) -> atBVVec n len2 a v2 (bvSub n i len1) - (bvult_sum_bvult_sub n i len1 len2 pf12 not_pf1)) - (Refl Bool (bvult n i len1))); + (bvult_sum_bvult_sub n i len1 len2 pf12 not_pf1))); -- | The complete induction principle on bitvectors @@ -2147,1198 +2215,49 @@ BV_complete_induction w p f x0 = -------------------------------------------------------------------------------- --- Iso-recursive types - -data IRTDesc (As:ListSort) : sort 0 where { - IRT_varD : Nat -> IRTDesc As; -- an IRTDesc var - IRT_mu : IRTDesc As -> IRTDesc As; -- binds a varD - IRT_Either : IRTDesc As -> IRTDesc As -> IRTDesc As; - IRT_prod : IRTDesc As -> IRTDesc As -> IRTDesc As; - IRT_sigT : (i:Nat) -> (listSortGet As i -> IRTDesc As) -> IRTDesc As; - IRT_BVVec : (n:Nat) -> Vec n Bool -> (D:IRTDesc As) -> IRTDesc As; - IRT_unit : IRTDesc As; - IRT_empty : IRTDesc As; - IRT_varT : (i:Nat) -> IRTDesc As; -- a sort var, i.e. an index into `As` -} - -IRTDesc__rec : (As:ListSort) -> (P : IRTDesc As -> sort 1) -> - ((i:Nat) -> P (IRT_varD As i)) -> - ((D:IRTDesc As) -> P D -> P (IRT_mu As D)) -> - ((Dl:IRTDesc As) -> P Dl -> (Dr:IRTDesc As) -> P Dr -> - P (IRT_Either As Dl Dr)) -> - ((Dl:IRTDesc As) -> P Dl -> (Dr:IRTDesc As) -> P Dr -> - P (IRT_prod As Dl Dr)) -> - ((i:Nat) -> (Df : listSortGet As i -> IRTDesc As) -> - ((a:listSortGet As i) -> P (Df a)) -> P (IRT_sigT As i Df)) -> - ((n:Nat) -> (len:Vec n Bool) -> (D:IRTDesc As) -> P D -> - P (IRT_BVVec As n len D)) -> - P (IRT_unit As) -> P (IRT_empty As) -> - ((i:Nat) -> P (IRT_varT As i)) -> - (D:IRTDesc As) -> P D; -IRTDesc__rec As P f1 f2 f3 f4 f5 f6 f7 f8 f9 D = IRTDesc#rec As P f1 f2 f3 f4 f5 f6 f7 f8 f9 D; - --- A list of substitutions for a context of iso-recursive type descriptions -data IRTSubsts (As:ListSort) : sort 0 where { - IRTs_Nil : IRTSubsts As; - IRTs_Cons : IRTDesc As -> IRTSubsts As -> IRTSubsts As; -} - -IRTSubsts__rec : (As:ListSort) -> (P : IRTSubsts As -> sort 1) -> P (IRTs_Nil As) -> - ((D:IRTDesc As) -> (Ds:IRTSubsts As) -> P Ds -> P (IRTs_Cons As D Ds)) -> - (Ds:IRTSubsts As) -> P Ds; -IRTSubsts__rec As P f1 f2 Ds = IRTSubsts#rec As P f1 f2 Ds; - --- The IRTDesc at the given index in an IRTSubsts or IRT_empty if the --- index is out of bounds -atIRTs : (As:ListSort) -> IRTSubsts As -> Nat -> IRTDesc As; -atIRTs As = IRTSubsts__rec As (\ (_:IRTSubsts As) -> Nat -> IRTDesc As) - (\ (_:Nat) -> IRT_empty As) - (\ (D:IRTDesc As) (_:IRTSubsts As) (rec : Nat -> IRTDesc As) -> - Nat_cases (IRTDesc As) D (\ (n:Nat) (_:IRTDesc As) -> rec n)); - --- A IRTSubsts with the first n (or all, if n > length) entries removed -dropIRTs : (As:ListSort) -> IRTSubsts As -> Nat -> IRTSubsts As; -dropIRTs As = IRTSubsts__rec As (\ (_:IRTSubsts As) -> Nat -> IRTSubsts As) - (\ (_:Nat) -> IRTs_Nil As) - (\ (_:IRTDesc As) (Ds:IRTSubsts As) (rec : Nat -> IRTSubsts As) -> - Nat_cases (IRTSubsts As) Ds (\ (n:Nat) (_ : IRTSubsts As) -> rec n)); - --- The type corresponding to an iso-recursive type description -data IRT (As:ListSort) : IRTSubsts As -> IRTDesc As -> sort 0 where { - IRT_elemD : (Ds:IRTSubsts As) -> (i:Nat) -> - IRT As (dropIRTs As Ds (Succ i)) (atIRTs As Ds i) -> - IRT As Ds (IRT_varD As i); - IRT_fold : (Ds:IRTSubsts As) -> (D:IRTDesc As) -> - IRT As (IRTs_Cons As (IRT_mu As D) Ds) D -> IRT As Ds (IRT_mu As D); - IRT_Left : (Ds:IRTSubsts As) -> (Dl:IRTDesc As) -> (Dr:IRTDesc As) -> - IRT As Ds Dl -> IRT As Ds (IRT_Either As Dl Dr); - IRT_Right : (Ds:IRTSubsts As) -> (Dl:IRTDesc As) -> (Dr:IRTDesc As) -> - IRT As Ds Dr -> IRT As Ds (IRT_Either As Dl Dr); - IRT_pair : (Ds:IRTSubsts As) -> (Dl:IRTDesc As) -> (Dr:IRTDesc As) -> - IRT As Ds Dl -> IRT As Ds Dr -> IRT As Ds (IRT_prod As Dl Dr); - IRT_existT : (Ds:IRTSubsts As) -> (i:Nat) -> (Df : listSortGet As i -> IRTDesc As) -> - (a:listSortGet As i) -> IRT As Ds (Df a) -> IRT As Ds (IRT_sigT As i Df); - IRT_genBVVec : (Ds:IRTSubsts As) -> (n:Nat) -> (len:Vec n Bool) -> (D:IRTDesc As) -> - ((i:Vec n Bool) -> is_bvult n i len -> IRT As Ds D) -> IRT As Ds (IRT_BVVec As n len D); - IRT_tt : (Ds:IRTSubsts As) -> IRT As Ds (IRT_unit As); - IRT_elemT : (Ds:IRTSubsts As) -> (i:Nat) -> - listSortGet As i -> IRT As Ds (IRT_varT As i); -} - -IRT__rec : (As:ListSort) -> (P : (Ds:IRTSubsts As) -> (D:IRTDesc As) -> IRT As Ds D -> sort 1) -> - ((Ds:IRTSubsts As) -> (i:Nat) -> - (x:IRT As (dropIRTs As Ds (Succ i)) (atIRTs As Ds i)) -> - P (dropIRTs As Ds (Succ i)) (atIRTs As Ds i) x -> - P Ds (IRT_varD As i) (IRT_elemD As Ds i x)) -> - ((Ds:IRTSubsts As) -> (D:IRTDesc As) -> - (x:IRT As (IRTs_Cons As (IRT_mu As D) Ds) D) -> - P (IRTs_Cons As (IRT_mu As D) Ds) D x -> - P Ds (IRT_mu As D) (IRT_fold As Ds D x)) -> - ((Ds:IRTSubsts As) -> (Dl:IRTDesc As) -> (Dr:IRTDesc As) -> (xl:IRT As Ds Dl) -> - P Ds Dl xl -> P Ds (IRT_Either As Dl Dr) (IRT_Left As Ds Dl Dr xl)) -> - ((Ds:IRTSubsts As) -> (Dl:IRTDesc As) -> (Dr:IRTDesc As) -> (xr:IRT As Ds Dr) -> - P Ds Dr xr -> P Ds (IRT_Either As Dl Dr) (IRT_Right As Ds Dl Dr xr)) -> - ((Ds:IRTSubsts As) -> (Dl:IRTDesc As) -> (Dr:IRTDesc As) -> - (xl:IRT As Ds Dl) -> P Ds Dl xl -> - (xr:IRT As Ds Dr) -> P Ds Dr xr -> - P Ds (IRT_prod As Dl Dr) (IRT_pair As Ds Dl Dr xl xr)) -> - ((Ds:IRTSubsts As) -> (i:Nat) -> (Df : listSortGet As i -> IRTDesc As) -> - (a:listSortGet As i) -> (xf:IRT As Ds (Df a)) -> P Ds (Df a) xf -> - P Ds (IRT_sigT As i Df) (IRT_existT As Ds i Df a xf)) -> - ((Ds:IRTSubsts As) -> (n:Nat) -> (len:Vec n Bool) -> (D:IRTDesc As) -> - (xg : (i:Vec n Bool) -> is_bvult n i len -> IRT As Ds D) -> - ((i:Vec n Bool) -> (pf:is_bvult n i len) -> P Ds D (xg i pf)) -> - P Ds (IRT_BVVec As n len D) (IRT_genBVVec As Ds n len D xg)) -> - ((Ds:IRTSubsts As) -> P Ds (IRT_unit As) (IRT_tt As Ds)) -> - ((Ds:IRTSubsts As) -> (i:Nat) -> (a:listSortGet As i) -> - P Ds (IRT_varT As i) (IRT_elemT As Ds i a)) -> - (Ds:IRTSubsts As) -> (D:IRTDesc As) -> (x:IRT As Ds D) -> P Ds D x; -IRT__rec As P f1 f2 f3 f4 f5 f6 f7 f8 f9 Ds D x = IRT#rec As P f1 f2 f3 f4 f5 f6 f7 f8 f9 Ds D x; - --- The type of a once-unfolded iso-recursive type -UnfoldedIRT : (As:ListSort) -> IRTSubsts As -> IRTDesc As -> sort 0; -UnfoldedIRT As Ds D = IRTDesc__rec As (\ (_:IRTDesc As) -> IRTSubsts As -> sort 0) - (\ (i:Nat) (Ds:IRTSubsts As) -> - IRT As (dropIRTs As Ds (Succ i)) (atIRTs As Ds i)) - (\ (D:IRTDesc As) (rec : IRTSubsts As -> sort 0) (Ds:IRTSubsts As) -> - rec (IRTs_Cons As (IRT_mu As D) Ds)) - (\ (_:IRTDesc As) (recl : IRTSubsts As -> sort 0) - (_:IRTDesc As) (recr : IRTSubsts As -> sort 0) (Ds:IRTSubsts As) -> - Either (recl Ds) (recr Ds)) - (\ (_:IRTDesc As) (recl : IRTSubsts As -> sort 0) - (_:IRTDesc As) (recr : IRTSubsts As -> sort 0) (Ds:IRTSubsts As) -> - recl Ds * recr Ds) - (\ (i:Nat) (_ : listSortGet As i -> IRTDesc As) - (recf : listSortGet As i -> IRTSubsts As -> sort 0) (Ds:IRTSubsts As) -> - Sigma (listSortGet As i) (\ (a:listSortGet As i) -> recf a Ds)) - (\ (n:Nat) (len:Vec n Bool) (_:IRTDesc As) - (rec : IRTSubsts As -> sort 0) (Ds:IRTSubsts As) -> - BVVec n len (rec Ds)) - (\ (_:IRTSubsts As) -> #()) - (\ (_:IRTSubsts As) -> Eq Bool True False) - (\ (i:Nat) (_:IRTSubsts As) -> listSortGet As i) D Ds; - --- `fold` and `unfold` for IRTs - -unfoldIRT : (As:ListSort) -> (Ds:IRTSubsts As) -> (D:IRTDesc As) -> - IRT As Ds D -> UnfoldedIRT As Ds D; -unfoldIRT As = IRT__rec As (\ (Ds:IRTSubsts As) (D:IRTDesc As) (_:IRT As Ds D) -> UnfoldedIRT As Ds D) - (\ (Ds:IRTSubsts As) (i:Nat) (x:IRT As (dropIRTs As Ds (Succ i)) (atIRTs As Ds i)) - (_:UnfoldedIRT As (dropIRTs As Ds (Succ i)) (atIRTs As Ds i)) -> x) - (\ (Ds:IRTSubsts As) (D:IRTDesc As) (_:IRT As (IRTs_Cons As (IRT_mu As D) Ds) D) - (rec: UnfoldedIRT As (IRTs_Cons As (IRT_mu As D) Ds) D) -> rec) - (\ (Ds:IRTSubsts As) (Dl:IRTDesc As) (Dr:IRTDesc As) - (_:IRT As Ds Dl) (recl:UnfoldedIRT As Ds Dl) -> - Left (UnfoldedIRT As Ds Dl) (UnfoldedIRT As Ds Dr) recl) - (\ (Ds:IRTSubsts As) (Dl:IRTDesc As) (Dr:IRTDesc As) - (_:IRT As Ds Dr) (recr:UnfoldedIRT As Ds Dr) -> - Right (UnfoldedIRT As Ds Dl) (UnfoldedIRT As Ds Dr) recr) - (\ (Ds:IRTSubsts As) (Dl:IRTDesc As) (Dr:IRTDesc As) - (_:IRT As Ds Dl) (recl:UnfoldedIRT As Ds Dl) - (_:IRT As Ds Dr) (recr:UnfoldedIRT As Ds Dr) -> - (recl, recr)) - (\ (Ds:IRTSubsts As) (i:Nat) (Df : listSortGet As i -> IRTDesc As) (a:listSortGet As i) - (_:IRT As Ds (Df a)) (recf:UnfoldedIRT As Ds (Df a)) -> - exists (listSortGet As i) (\ (a:listSortGet As i) -> UnfoldedIRT As Ds (Df a)) a recf) - (\ (Ds:IRTSubsts As) (n:Nat) (len:Vec n Bool) (D:IRTDesc As) - (_ : (i:Vec n Bool) -> is_bvult n i len -> IRT As Ds D) - (recg : (i:Vec n Bool) -> is_bvult n i len -> UnfoldedIRT As Ds D) -> - genBVVec n len (UnfoldedIRT As Ds D) recg) - (\ (Ds:IRTSubsts As) -> ()) - (\ (Ds:IRTSubsts As) (i:Nat) (a:listSortGet As i) -> a); - -foldIRT : (As:ListSort) -> (Ds:IRTSubsts As) -> (D:IRTDesc As) -> - UnfoldedIRT As Ds D -> IRT As Ds D; -foldIRT As Ds D = IRTDesc__rec As (\ (D:IRTDesc As) -> (Ds:IRTSubsts As) -> UnfoldedIRT As Ds D -> IRT As Ds D) - (\ (i:Nat) (Ds:IRTSubsts As) (x:IRT As (dropIRTs As Ds (Succ i)) (atIRTs As Ds i)) -> - IRT_elemD As Ds i x) - (\ (D:IRTDesc As) (rec : (Ds:IRTSubsts As) -> UnfoldedIRT As Ds D -> IRT As Ds D) - (Ds:IRTSubsts As) (x:UnfoldedIRT As (IRTs_Cons As (IRT_mu As D) Ds) D) -> - IRT_fold As Ds D (rec (IRTs_Cons As (IRT_mu As D) Ds) x)) - (\ (Dl:IRTDesc As) (recl : (Ds:IRTSubsts As) -> UnfoldedIRT As Ds Dl -> IRT As Ds Dl) - (Dr:IRTDesc As) (recr : (Ds:IRTSubsts As) -> UnfoldedIRT As Ds Dr -> IRT As Ds Dr) - (Ds:IRTSubsts As) (x:Either (UnfoldedIRT As Ds Dl) (UnfoldedIRT As Ds Dr)) -> - either (UnfoldedIRT As Ds Dl) (UnfoldedIRT As Ds Dr) (IRT As Ds (IRT_Either As Dl Dr)) - (\ (xl:UnfoldedIRT As Ds Dl) -> IRT_Left As Ds Dl Dr (recl Ds xl)) - (\ (xr:UnfoldedIRT As Ds Dr) -> IRT_Right As Ds Dl Dr (recr Ds xr)) x) - (\ (Dl:IRTDesc As) (recl : (Ds:IRTSubsts As) -> UnfoldedIRT As Ds Dl -> IRT As Ds Dl) - (Dr:IRTDesc As) (recr : (Ds:IRTSubsts As) -> UnfoldedIRT As Ds Dr -> IRT As Ds Dr) - (Ds:IRTSubsts As) (x:UnfoldedIRT As Ds Dl * UnfoldedIRT As Ds Dr) -> - uncurry (UnfoldedIRT As Ds Dl) (UnfoldedIRT As Ds Dr) (IRT As Ds (IRT_prod As Dl Dr)) - (\ (xl:UnfoldedIRT As Ds Dl) (xr:UnfoldedIRT As Ds Dr) -> - IRT_pair As Ds Dl Dr (recl Ds xl) (recr Ds xr)) x) - (\ (i:Nat) (Df : listSortGet As i -> IRTDesc As) - (recf : (a:listSortGet As i) -> (Ds:IRTSubsts As) -> UnfoldedIRT As Ds (Df a) -> IRT As Ds (Df a)) - (Ds:IRTSubsts As) (x:Sigma (listSortGet As i) (\ (a:listSortGet As i) -> UnfoldedIRT As Ds (Df a))) -> - uncurrySigma (listSortGet As i) (\ (a:listSortGet As i) -> UnfoldedIRT As Ds (Df a)) (IRT As Ds (IRT_sigT As i Df)) - (\ (a:listSortGet As i) (xf:UnfoldedIRT As Ds (Df a)) -> - IRT_existT As Ds i Df a (recf a Ds xf)) x) - (\ (n:Nat) (len:Vec n Bool) (D:IRTDesc As) (recg : (Ds:IRTSubsts As) -> UnfoldedIRT As Ds D -> IRT As Ds D) - (Ds:IRTSubsts As) (x : BVVec n len (UnfoldedIRT As Ds D)) -> - IRT_genBVVec As Ds n len D (\ (i:Vec n Bool) (pf:is_bvult n i len) -> - recg Ds (atBVVec n len (UnfoldedIRT As Ds D) x i pf))) - (\ (Ds:IRTSubsts As) (x:#()) -> IRT_tt As Ds) - (\ (Ds:IRTSubsts As) (x:Eq Bool True False) -> efq (IRT As Ds (IRT_empty As)) x) - (\ (i:Nat) (Ds:IRTSubsts As) (x:listSortGet As i) -> IRT_elemT As Ds i x) D Ds; - - --------------------------------------------------------------------------------- --- Computation monad - -primitive CompM : sort 0 -> sort 0; - -primitive returnM : (a:sort 0) -> a -> CompM a; -primitive bindM : (a b:sort 0) -> CompM a -> (a -> CompM b) -> CompM b; - --- Raise an error in the computation monad -primitive errorM : (a:sort 0) -> String -> CompM a; - --- Apply a pure function to a computation -fmapM : (a b: sort 0) -> (a -> b) -> CompM a -> CompM b; -fmapM a b f m = bindM a b m (\ (x:a) -> returnM b (f x)); - --- Apply a computation of a function to a computation of an argument -applyM : (a b: sort 0) -> CompM (a -> b) -> CompM a -> CompM b; -applyM a b f m = - bindM (a -> b) b f (\ (f:a->b) -> bindM a b m (\ (x:a) -> returnM b (f x))); - --- Apply a binary pure function to a computation -fmapM2 : (a b c: sort 0) -> (a -> b -> c) -> CompM a -> CompM b -> CompM c; -fmapM2 a b c f m1 m2 = applyM b c (fmapM a (b -> c) f m1) m2; - --- Apply a trinary pure function to a computation -fmapM3 : (a b c d: sort 0) -> (a -> b -> c -> d) -> - CompM a -> CompM b -> CompM c -> CompM d; -fmapM3 a b c d f m1 m2 m3 = applyM c d (fmapM2 a b (c -> d) f m1 m2) m3; - --- Bind two values and pass them to a binary function -bindM2 : (a b c: sort 0) -> CompM a -> CompM b -> (a -> b -> CompM c) -> CompM c; -bindM2 a b c m1 m2 f = bindM a c m1 (\ (x:a) -> bindM b c m2 (f x)); - --- Bind three values and pass them to a trinary function -bindM3 : (a b c d: sort 0) -> CompM a -> CompM b -> CompM c -> - (a -> b -> c -> CompM d) -> CompM d; -bindM3 a b c d m1 m2 m3 f = bindM a d m1 (\ (x:a) -> bindM2 b c d m2 m3 (f x)); - --- A version of bind that takes the function first -bindApplyM : (a b : sort 0) -> (a -> CompM b) -> CompM a -> CompM b; -bindApplyM a b f m = bindM a b m f; - --- A version of bindM2 that takes the function first -bindApplyM2 : (a b c: sort 0) -> (a -> b -> CompM c) -> CompM a -> CompM b -> CompM c; -bindApplyM2 a b c f m1 m2 = bindM a c m1 (\ (x:a) -> bindM b c m2 (f x)); - --- A version of bindM3 that takes the function first -bindApplyM3 : (a b c d: sort 0) -> (a -> b -> c -> CompM d) -> - CompM a -> CompM b -> CompM c -> CompM d; -bindApplyM3 a b c d f m1 m2 m3 = bindM3 a b c d m1 m2 m3 f; - --- Compose two monadic functions -composeM : (a b c: sort 0) -> (a -> CompM b) -> (b -> CompM c) -> a -> CompM c; -composeM a b c f g x = bindM b c (f x) g; - --- Tuple a type onto the input and output types of a monadic function -tupleCompMFunBoth : (a b c: sort 0) -> (a -> CompM b) -> (c * a -> CompM (c * b)); -tupleCompMFunBoth a b c f = - \ (x:c * a) -> - bindM b (c * b) (f x.(2)) (\ (y:b) -> returnM (c*b) (x.(1), y)); - --- Tuple a valu onto the output of a monadic function -tupleCompMFunOut : (a b c: sort 0) -> c -> (a -> CompM b) -> (a -> CompM (c * b)); -tupleCompMFunOut a b c x f = - \ (y:a) -> bindM b (c*b) (f y) (\ (z:b) -> returnM (c*b) (x,z)); - --- Map a monadic function across a vector -mapM : (a :sort 0) -> (b : isort 0) -> (a -> CompM b) -> (n : Nat) -> Vec n a -> CompM (Vec n b); -mapM a b f = - Nat__rec - (\ (n:Nat) -> Vec n a -> CompM (Vec n b)) - (\ (_:Vec 0 a) -> returnM (Vec 0 b) (EmptyVec b)) - (\ (n:Nat) (rec_f:Vec n a -> CompM (Vec n b)) (v:Vec (Succ n) a) -> - fmapM2 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 -mapBVVecM : (a : sort 0) -> (b : isort 0) -> (a -> CompM b) -> - (n : Nat) -> (len : Vec n Bool) -> BVVec n len a -> - CompM (BVVec n len b); -mapBVVecM a b f n len = mapM a b f (bvToNat n len); - --- Append two BVVecs and cast the resulting size, if possible -appendCastBVVecM : (n : Nat) -> (len1 len2 len3 : Vec n Bool) -> (a : sort 0) -> - BVVec n len1 a -> BVVec n len2 a -> - CompM (BVVec n len3 a); -appendCastBVVecM n len1 len2 len3 a v1 v2 = - maybe - (Eq (Vec n Bool) (bvAdd n len1 len2) len3) (CompM (BVVec n len3 a)) - (errorM (BVVec n len3 a) "Could not cast BVVec") - (\ (pf:Eq (Vec n Bool) (bvAdd n len1 len2) len3) -> - returnM - (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))) - (bvEqWithProof n (bvAdd n len1 len2) len3); - --- Run the first computation, and, if it raises an error, catch the error and --- run the second computation --- primitive catchM : (a:sort 0) -> CompM a -> CompM a -> CompM a; - --- The computation that nondeterministically chooses a value of type a and --- passes it to the supplied function f to get a computation of type b. As a --- specification, this is the union of computations f x. -primitive existsM : (a b:sort 0) -> (a -> CompM b) -> CompM b; - --- The computation that nondeterministically chooses one computation or another. --- As a specification, represents the disjunction of two specifications. -orM : (a : sort 0) -> CompM a -> CompM a -> CompM a; -orM a m1 m2 = existsM Bool a (\ (b:Bool) -> ite (CompM a) b m1 m2); - --- The specification that matches any computation -anySpec : (a : sort 0) -> CompM a; -anySpec a = existsM (CompM a) a (\ (m:CompM a) -> m); - --- The specification formed from the intersection of all computations f x for --- all possible inputs x. Computationally, this is sort of like running f for --- all possible inputs x at the same time and then raising an error if any of --- those computations diverge from each other. -primitive forallM : (a b:sort 0) -> (a -> CompM b) -> CompM b; - --- The specification which asserts that the first argument is True and then --- runs the second argument -assertingM : (a : sort 0) -> Bool -> CompM a -> CompM a; -assertingM a b m = ite (CompM a) b m (errorM a "Assertion failed"); - --- The specification which assumes that the first argument is True and then --- runs the second argument -assumingM : (a : sort 0) -> Bool -> CompM a -> CompM a; -assumingM a b m = ite (CompM a) b m (anySpec a); - --- 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 version of assertingM which appears in un-monadified Cryptol (this gets --- converted to assertingM during monadification, see assertingOrAssumingMacro) -asserting : (a : isort 0) -> Bool -> a -> a; -asserting a b x = ite a b x (error a "Assertion failed"); - --- The version of assumingM which appears in un-monadified Cryptol (this gets --- converted to assumingM during monadification, see assertingOrAssumingMacro) -assuming : (a : isort 0) -> Bool -> a -> a; -assuming a b x = ite a b x (error a "Assuming failed"); - --- NOTE: for the simplicity and efficiency of MR solver, we define all --- fixed-point computations in CompM via a primitive multiFixM, defined below. --- Thus, even though fixM is really the primitive operation, we write this file --- as if multiFixM is, but I am leaving this version of fixM commented out here --- to keep this decision explicitly documented and to make it easier to switch --- back to having fixM be primitive if we decide to do so later. --- -{- -primitive fixM : (a:sort 0) -> (b:a -> sort 0) -> - (((x:a) -> CompM (b x)) -> ((x:a) -> CompM (b x))) -> - (x:a) -> CompM (b x); --} - --- A representation of the type (x1:A1) -> ... -> (xn:An) -> CompM (B x1 ... xn) -data LetRecType : sort 1 where { - LRT_Ret : sort 0 -> LetRecType; - LRT_Fun : (a:sort 0) -> (a -> LetRecType) -> LetRecType; -} - --- Convert a LetRecType to the type it represents -lrtToType : LetRecType -> sort 0; -lrtToType lrt = - LetRecType#rec - (\ (lrt:LetRecType) -> sort 0) - (\ (b:sort 0) -> CompM b) - (\ (a:sort 0) (_: a -> LetRecType) (b: a -> sort 0) -> (x:a) -> b x) - lrt; - --- NOTE: the following are needed to define multiFixM instead of making it a --- primitive, which we are keeping commented here in case that is needed -{- --- Convert the argument types of a LetRecType to their "flat" version of the --- form { x1:A1 & { x2:A2 & ... { xn:An & unit } ... }} -lrtToFlatArgs : LetRecType -> sort 0; -lrtToFlatArgs lrt = - LetRecType#rec - (\ (lrt:LetRecType) -> sort 0) - (\ (_:sort 0) -> #()) - (\ (a:sort 0) (_: a -> LetRecType) (b: a -> sort 0) -> Sigma a b) - lrt; - --- Get the dependent return type fun (args:lrtToFlatArgs) => B x.1 ... of a --- LetRecType in terms of the flat arguments -lrtToFlatRet : (lrt:LetRecType) -> lrtToFlatArgs lrt -> sort 0; -lrtToFlatRet lrt = - LetRecType#rec - (\ (lrt:LetRecType) -> lrtToFlatArgs lrt -> sort 0) - (\ (a:sort 0) (_:#()) -> a) - (\ (a:sort 0) (lrtF: a -> LetRecType) - (retF: (x:a) -> lrtToFlatArgs (lrtF x) -> sort 0) - (args: Sigma a (\ (x:a) -> lrtToFlatArgs (lrtF x))) -> - retF (Sigma_proj1 a (\ (x:a) -> lrtToFlatArgs (lrtF x)) args) - (Sigma_proj2 a (\ (x:a) -> lrtToFlatArgs (lrtF x)) args)) - lrt; - --- Extract out the "flat" version of a LetRecType -lrtToFlatType : LetRecType -> sort 0; -lrtToFlatType lrt = (args:lrtToFlatArgs lrt) -> CompM (lrtToFlatRet lrt args); - - --- "Flatten" a function described by a LetRecType -flattenLRTFun : (lrt:LetRecType) -> lrtToType lrt -> lrtToFlatType lrt; -flattenLRTFun lrt = - LetRecType#rec - (\ (lrt:LetRecType) -> lrtToType lrt -> lrtToFlatType lrt) - (\ (b:sort 0) (f:CompM b) (_:#()) -> f) - (\ (a:sort 0) (lrtF: a -> LetRecType) - (restF: (x:a) -> lrtToType (lrtF x) -> lrtToFlatType (lrtF x)) - (f: lrtToType (LRT_Fun a lrtF)) (args:lrtToFlatArgs (LRT_Fun a lrtF)) -> - restF (Sigma_proj1 a (\ (x:a) -> lrtToFlatArgs (lrtF x)) args) - (f (Sigma_proj1 a (\ (x:a) -> lrtToFlatArgs (lrtF x)) args)) - (Sigma_proj2 a (\ (x:a) -> lrtToFlatArgs (lrtF x)) args)) - lrt; - --- "Unflatten" a function described by a LetRecType -unflattenLRTFun : (lrt:LetRecType) -> lrtToFlatType lrt -> lrtToType lrt; -unflattenLRTFun lrt = - LetRecType#rec - (\ (lrt:LetRecType) -> lrtToFlatType lrt -> lrtToType lrt) - (\ (b:sort 0) (f:#() -> CompM b) -> f ()) - (\ (a:sort 0) (lrtF: a -> LetRecType) - (restF: (x:a) -> lrtToFlatType (lrtF x) -> lrtToType (lrtF x)) - (f: lrtToFlatType (LRT_Fun a lrtF)) (x:a) -> - restF x (\ (args:lrtToFlatArgs (lrtF x)) -> - f (exists a (\ (y:a) -> lrtToFlatArgs (lrtF y)) x args))) - lrt; --} - --- A list of 0 or more LetRecTypes -data LetRecTypes : sort 1 where { - LRT_Nil : LetRecTypes; - LRT_Cons : LetRecType -> LetRecTypes -> LetRecTypes; -} - --- Build the function type lrtToType lrt1 -> ... -> lrtToType lrtn -> b from the --- LetRecTypes list [lrt1, ..., lrtn] -lrtPi : LetRecTypes -> sort 0 -> sort 0; -lrtPi lrts b = - LetRecTypes#rec - (\ (lrts:LetRecTypes) -> sort 0) - b - (\ (lrt:LetRecType) (_:LetRecTypes) (rest:sort 0) -> lrtToType lrt -> rest) - lrts; - --- Build the product type (lrtToType lrt1, ..., lrtToType lrtn) from the --- LetRecTypes list [lrt1, ..., lrtn] -lrtTupleType : LetRecTypes -> sort 0; -lrtTupleType lrts = - LetRecTypes#rec - (\ (lrts:LetRecTypes) -> sort 0) - #() - (\ (lrt:LetRecType) (_:LetRecTypes) (rest:sort 0) -> #(lrtToType lrt, rest)) - lrts; - --- NOTE: the following are needed to define letRecM instead of making it a --- primitive, which we are keeping commented here in case that is needed -{- --- Apply a multi-arity function of type lrtPi lrts B to an lrtTupleType lrts -lrtApply : (lrts:LetRecTypes) -> (B:sort 0) -> lrtPi lrts B -> lrtTupleType lrts -> B; -lrtApply top_lrts B = - LetRecTypes#rec - (\ (lrts:LetRecTypes) -> lrtPi lrts B -> lrtTupleType lrts -> B) - (\ (F:B) (_:#()) -> F) - (\ (lrt:LetRecType) (lrts:LetRecTypes) (rest:lrtPi lrts B -> lrtTupleType lrts -> B) - (F:lrtPi (LRT_Cons lrt lrts) B) (fs:lrtTupleType (LRT_Cons lrt lrts)) -> - rest (F fs.(1)) fs.(2)) - top_lrts; - --- Construct a multi-arity function of type lrtPi lrts B from one of type --- lrtTupleType lrts -> B -lrtLambda : (lrts:LetRecTypes) -> (B:sort 0) -> (lrtTupleType lrts -> B) -> lrtPi lrts B; -lrtLambda top_lrts B = - LetRecTypes#rec - (\ (lrts:LetRecTypes) -> (lrtTupleType lrts -> B) -> lrtPi lrts B) - (\ (F:#() -> B) -> F ()) - (\ (lrt:LetRecType) (lrts:LetRecTypes) - (rest:(lrtTupleType lrts -> B) -> lrtPi lrts B) - (F:lrtTupleType (LRT_Cons lrt lrts) -> B) (f:lrtToType lrt) -> - rest (\ (fs:lrtTupleType lrts) -> F (f, fs))) - top_lrts; - --- Build a multi-argument fixed-point of type A1 -> ... -> An -> CompM B -multiArgFixM : (lrt:LetRecType) -> (lrtToType lrt -> lrtToType lrt) -> - lrtToType lrt; -multiArgFixM lrt F = - unflattenLRTFun - lrt - (fixM (lrtToFlatArgs lrt) (lrtToFlatRet lrt) - (\ (f:lrtToFlatType lrt) -> - flattenLRTFun lrt (F (unflattenLRTFun lrt f)))); - --- Construct a mutual fixed-point over tuples of LRT functions -multiTupleFixM : (lrts:LetRecTypes) -> (lrtTupleType lrts -> lrtTupleType lrts) -> - lrtTupleType lrts; -multiTupleFixM top_lrts = - LetRecTypes#rec - (\ (lrts:LetRecTypes) -> (lrtTupleType lrts -> lrtTupleType lrts) -> lrtTupleType lrts) - (\ (_:#() -> #()) -> ()) - (\ (lrt:LetRecType) (lrts:LetRecTypes) - (restF: (lrtTupleType lrts -> lrtTupleType lrts) -> lrtTupleType lrts) - (F:lrtTupleType (LRT_Cons lrt lrts) -> lrtTupleType (LRT_Cons lrt lrts)) -> - (multiArgFixM lrt (\ (f:lrtToType lrt) -> - (F (f, restF (\ (fs:lrtTupleType lrts) -> - (F (f, fs)).(2)))).(1)), - restF (\ (fs:lrtTupleType lrts) -> - (F (multiArgFixM lrt - (\ (f:lrtToType lrt) -> - (F (f, restF (\ (fs:lrtTupleType lrts) -> - (F (f, fs)).(2)))).(1)), - fs)).(2)))) - top_lrts; - --- A nicer version of multiTupleFixM that abstracts the functions one at a time -multiFixM : (lrts:LetRecTypes) -> lrtPi lrts (lrtTupleType lrts) -> - lrtTupleType lrts; -multiFixM lrts F = - multiTupleFixM lrts (\ (fs:lrtTupleType lrts) -> lrtApply lrts (lrtTupleType lrts) F fs); --} - --- This is like let rec in ML: letRecM defs body defines N recursive functions --- in terms of themselves using defs, and then passes them to body. We use this --- instead of the more standard fixM because it offers a more compact --- representation, and because fixM messes with functional extensionality by --- introducing an irreducible term at function type. -primitive letRecM : (lrts : LetRecTypes) -> (B:sort 0) -> - lrtPi lrts (lrtTupleType lrts) -> - lrtPi lrts (CompM B) -> CompM B; --- letRecM lrts B F body = lrtApply lrts (CompM B) body (multiFixM lrts F); - --- This is let rec with exactly one binding -letRecM1 : (a b c : sort 0) -> ((a -> CompM b) -> (a -> CompM b)) -> - ((a -> CompM b) -> CompM c) -> CompM c; -letRecM1 a b c fn body = - letRecM - (LRT_Cons (LRT_Fun a (\ (_:a) -> LRT_Ret b)) LRT_Nil) c - (\ (f:a -> CompM b) -> (fn f, ())) - (\ (f:a -> CompM b) -> body f); - --- A single-argument fixed-point function -fixM : (a:sort 0) -> (b:a -> sort 0) -> - (((x:a) -> CompM (b x)) -> ((x:a) -> CompM (b x))) -> - (x:a) -> CompM (b x); -fixM a b f x = - letRecM (LRT_Cons (LRT_Fun a (\ (y:a) -> LRT_Ret (b y))) LRT_Nil) - (b x) - (\ (g: (y:a) -> CompM (b y)) -> (f g, ())) - (\ (g: (y:a) -> CompM (b y)) -> g x); - - --- The following commented block allows multiFixM to be defined in terms of and --- to reduce to letRecM, which is useful if we want to define all our automated --- reasoning in terms of letRecM instead of multiFixM - --- Apply a function the the body of a multi-arity lrtPi function -{- -lrtPiMap : (a b : sort 0) -> (f : a -> b) -> (lrts : LetRecTypes) -> - lrtPi lrts a -> lrtPi lrts b; -lrtPiMap a b f lrts_top = - LetRecTypes#rec - (\ (lrts:LetRecTypes) -> lrtPi lrts a -> lrtPi lrts b) - (\ (x:a) -> f x) - (\ (lrt:LetRecType) (lrts:LetRecTypes) (rec:lrtPi lrts a -> lrtPi lrts b) - (f:lrtToType lrt -> lrtPi lrts a) (g:lrtToType lrt) -> - rec (f g)) - lrts_top; - --- Convert a multi-arity lrtPi that returns a pair to a pair of lrtPi functions --- that return the individual arguments -lrtPiPair : (a b:sort 0) -> (lrts : LetRecTypes) -> lrtPi lrts #(a,b) -> - #(lrtPi lrts a, lrtPi lrts b); -lrtPiPair a b lrts f = - (lrtPiMap #(a,b) a (\ (tup:#(a,b)) -> tup.(1)) lrts f, - lrtPiMap #(a,b) b (\ (tup:#(a,b)) -> tup.(2)) lrts f); - --- Build a monadic function that takes in its arguments and then calls letRecM. --- That is, build a function --- --- \x1 ... xn -> letRecM lrts F (\f1 ... fm -> body f1 ... fm x1 ... xn) --- --- where F recursively defines the fi functions and body defines the computation --- for the function we are defining in terms of the fi and the xj arguments. -letRecFun : (lrts : LetRecTypes) -> lrtPi lrts (lrtTupleType lrts) -> - (lrt : LetRecType) -> lrtPi lrts (lrtToType lrt) -> lrtToType lrt; -letRecFun lrts F lrt_top = - LetRecType#rec - (\ (lrt:LetRecType) -> lrtPi lrts (lrtToType lrt) -> lrtToType lrt) - (\ (b:sort 0) (body:lrtPi lrts (CompM b)) -> - letRecM lrts b F body) - (\ (a:sort 0) (lrtF: a -> LetRecType) - (rec: (x:a) -> lrtPi lrts (lrtToType (lrtF x)) -> lrtToType (lrtF x)) - (body:lrtPi lrts ((x:a) -> lrtToType (lrtF x))) - (x:a) -> - rec x (lrtPiMap ((y:a) -> lrtToType (lrtF y)) - (lrtToType (lrtF x)) - (\ (g:(y:a) -> lrtToType (lrtF y)) -> g x) - lrts - body)) - lrt_top; - --- Build a multi-argument fixed-point of type A1 -> ... -> An -> CompM B -multiArgFixM : (lrt:LetRecType) -> (lrtToType lrt -> lrtToType lrt) -> - lrtToType lrt; -multiArgFixM lrt F = - letRecFun (LRT_Cons lrt LRT_Nil) - (\ (f:lrtToType lrt) -> (F f, ())) - lrt - (\ (f:lrtToType lrt) -> f); - --- Construct a fixed-point for a tuple of mutually-recursive functions -multiFixM : (lrts:LetRecTypes) -> lrtPi lrts (lrtTupleType lrts) -> - lrtTupleType lrts; -multiFixM lrts_top F_top = - LetRecTypes#rec - (\ (lrts:LetRecTypes) -> lrtPi lrts_top (lrtTupleType lrts) -> - lrtTupleType lrts) - (\ (_:lrtPi lrts_top #()) -> ()) - (\ (lrt:LetRecType) (lrts:LetRecTypes) - (rec: lrtPi lrts_top (lrtTupleType lrts) -> lrtTupleType lrts) - (F: lrtPi lrts_top #(lrtToType lrt, lrtTupleType lrts)) -> - (letRecFun - lrts_top F_top lrt - (lrtPiPair (lrtToType lrt) (lrtTupleType lrts) lrts_top F).(1) - , - rec (lrtPiPair (lrtToType lrt) (lrtTupleType lrts) lrts_top F).(2))) - lrts_top - F_top; --} - --- Construct a fixed-point for a tuple of mutually-recursive functions --- --- NOTE: Currently, Mr Solver actually works better with a primitive multiFixM, --- so that's what we are going to do for now... -primitive -multiFixM : (lrts:LetRecTypes) -> lrtPi lrts (lrtTupleType lrts) -> - lrtTupleType lrts; - --- Build a multi-argument fixed-point of type A1 -> ... -> An -> CompM B -multiArgFixM : (lrt:LetRecType) -> (lrtToType lrt -> lrtToType lrt) -> - lrtToType lrt; -multiArgFixM lrt F = - (multiFixM (LRT_Cons lrt LRT_Nil) (\ (f:lrtToType lrt) -> (F f, ()))).(1); - - --------------------------------------------------------------------------------- --- ITree Specification monad - -- Lists at sort 1 + +-- The type List1 itself data List1 (a:sort 1) : sort 1 where { Nil1 : List1 a; Cons1 : a -> List1 a -> List1 a; } --- 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)); - --- Build the dependent type { a1:A1 & { a2:A2 & ... { an:An & unit } ... }} of --- inputs to the LetRecType (LRT_Fun A1 (\ a1 -> ...)) -LRTInput : LetRecType -> sort 0; -LRTInput lrt = - LetRecType#rec - (\ (lrt:LetRecType) -> sort 0) - (\ (_:sort 0) -> #()) - (\ (a:sort 0) (_: a -> LetRecType) (b: a -> sort 0) -> Sigma a b) - lrt; - --- Build the output type (R a1 ... an) of the application of a LetRecType --- (LRT_Fun A1 (\ a1 -> ... (LRT_Fun An (\ an -> LRT_Ret R a1 ... an)))) --- function to the arguments a1 ... an in an LRTInput -LRTOutput : (lrt:LetRecType) -> LRTInput lrt -> sort 0; -LRTOutput lrt = - LetRecType#rec - (\ (lrt:LetRecType) -> LRTInput lrt -> sort 0) - (\ (R:sort 0) (_:LRTInput (LRT_Ret R)) -> R) - (\ (a:sort 0) (lrtF : a -> LetRecType) - (rec : (x:a) -> LRTInput (lrtF x) -> sort 0) - (args: Sigma a (\ (x:a) -> LRTInput (lrtF x))) -> - rec (Sigma_proj1 a (\ (x:a) -> LRTInput (lrtF x)) args) - (Sigma_proj2 a (\ (x:a) -> LRTInput (lrtF x)) args)) - lrt; - --- Build the function type (a1:A1) -> ... -> (an:An) -> B from the LetRecType --- (LRT_Fun A1 (\ a1 -> ...)) -lrt1Pi : (lrt:LetRecType) -> (LRTInput lrt -> sort 0) -> sort 0; -lrt1Pi lrt_top = - LetRecType#rec - (\ (lrt:LetRecType) -> (LRTInput lrt -> sort 0) -> sort 0) - (\ (_:sort 0) (F:#() -> sort 0) -> F ()) - (\ (a:sort 0) (lrtF: a -> LetRecType) - (rec: (x:a) -> (LRTInput (lrtF x) -> sort 0) -> sort 0) - (F : LRTInput (LRT_Fun a lrtF) -> sort 0) -> - (x:a) -> rec x (\ (args : LRTInput (lrtF x)) -> - F (exists a (\ (y:a) -> LRTInput (lrtF y)) x args))) - lrt_top; - --- Build an lrtPi function from a unary function on an LRTInput -lrtLambda : (lrt:LetRecType) -> (F: LRTInput lrt -> sort 0) -> - ((args: LRTInput lrt) -> F args) -> lrt1Pi lrt F; -lrtLambda lrt_top = - LetRecType#rec - (\ (lrt:LetRecType) -> (F: LRTInput lrt -> sort 0) -> - ((args: LRTInput lrt) -> F args) -> lrt1Pi lrt F) - (\ (_:sort 0) -> \ (F: #() -> sort 0) (f : (args:#()) -> F args) -> f ()) - (\ (a:sort 0) (lrtF: a -> LetRecType) - (rec: (x:a) -> (F: LRTInput (lrtF x) -> sort 0) -> - ((args: LRTInput (lrtF x)) -> F args) -> lrt1Pi (lrtF x) F) - (F: LRTInput (LRT_Fun a lrtF) -> sort 0) - (f : (args: LRTInput (LRT_Fun a lrtF)) -> F args) (x:a) -> - rec x (\ (args:LRTInput (lrtF x)) -> - F (exists a (\ (y:a) -> LRTInput (lrtF y)) x args)) - (\ (args:LRTInput (lrtF x)) -> - f (exists a (\ (y:a) -> LRTInput (lrtF y)) x args))) - lrt_top; - --- A recursive frame is a list of types for recursive functions all bound --- same time -RecFrame : sort 1; -RecFrame = (List1 LetRecType); - --- Get the nth element of a RecFrame, or void -> void if n is too big -nthLRT : List1 LetRecType -> Nat -> LetRecType; -nthLRT lrts = +-- The length of a List1 +length1 : (a:sort 1) -> List1 a -> Nat; +length1 a l = + List1#rec a (\ (_:List1 a) -> Nat) 0 + (\ (_:a) (_:List1 a) (rec:Nat) -> Succ rec) l; + +-- Append two List1s +app1 : (a:sort 1) -> List1 a -> List1 a -> List1 a; +app1 a l1 l2 = + List1#rec a (\ (_:List1 a) -> List1 a) l2 + (\ (x:a) (_:List1 a) (rec:List1 a) -> Cons1 a x rec) l1; + +-- Concatenate a List1 of List1s +concat1 : (a:sort 1) -> List1 (List1 a) -> List1 a; +concat1 a ls = + List1#rec (List1 a) (\ (_:List1 (List1 a)) -> List1 a) + (Nil1 a) + (\ (xs:List1 a) (_:List1 (List1 a)) (rec:List1 a) -> app1 a xs rec) + ls; + +-- Map a function across a List1 +map1 : (a b:sort 1) -> (f : a -> b) -> List1 a -> List1 b; +map1 a b f l = List1#rec - LetRecType - (\ (lrts:List1 LetRecType) -> Nat -> LetRecType) - (\ (_:Nat) -> LRT_Fun Void (\ (_:Void) -> LRT_Ret Void)) - (\ (lrt:LetRecType) (_:List1 LetRecType) (rec:Nat -> LetRecType) (n:Nat) -> - Nat#rec (\ (_:Nat) -> LetRecType) lrt (\ (m:Nat) (_:LetRecType) -> rec m) n) - lrts; - --- A recursive call to one of the functions in a RecFrame -data FrameCall (frame : RecFrame) : sort 0 where { - FrameCallOfArgs : (n:Nat) -> LRTInput (nthLRT frame n) -> FrameCall frame; -} - --- Make a recursive call from its individual arguments -mkFrameCall : (frame:RecFrame) -> (n:Nat) -> - lrt1Pi (nthLRT frame n) (\ (_:LRTInput (nthLRT frame n)) -> - FrameCall frame); -mkFrameCall frame n = - lrtLambda (nthLRT frame n) (\ (_:LRTInput (nthLRT frame n)) -> FrameCall frame) - (\ (args:LRTInput (nthLRT frame n)) -> FrameCallOfArgs frame n args); - --- The return type for calling a recursive function in a RecFrame -FrameCallRet : (frame:RecFrame) -> FrameCall frame -> sort 0; -FrameCallRet frame call = - FrameCall#rec - frame - (\ (_:FrameCall frame) -> sort 0) - (\ (n:Nat) (args:LRTInput (nthLRT frame n)) -> LRTOutput (nthLRT frame n) args) - call; - --- A function stack is a list of values of type LetRecTypes, which intuitively --- represents a stack of bindings of mutually recursive functions -FunStack : sort 1; -FunStack = List1 (List1 LetRecType); - --- The empty FunStack -emptyFunStack : FunStack; -emptyFunStack = Nil1 (List1 LetRecType); - --- Push a frame, represented by a LetRecTypes list, onto the top of a FunStack -pushFunStack : List1 LetRecType -> FunStack -> FunStack; -pushFunStack frame stack = Cons1 (List1 LetRecType) frame stack; - --- The type of FunStackE E stack: either an error (represented as a String), --- an E, or a FrameCall from stack -FunStackE_type : (E:EvType) -> FunStack -> sort 0; -FunStackE_type E stack = - List1#rec - (List1 LetRecType) - (\ (_:FunStack) -> sort 0) - (Either String (evTypeType E)) - (\ (frame:List1 LetRecType) -> \ (_:FunStack) -> \ (E':sort 0) -> - Either (FrameCall frame) E') - stack; - --- The encoding of FunStackE E stack: Void if the event is an error, the --- encoding of E if the event is an E, or the return type of the FrameCall --- if the event is a FrameCall -FunStackE_enc : (E:EvType) -> (stack:FunStack) -> FunStackE_type E stack -> sort 0; -FunStackE_enc E stack = - List1#rec - (List1 LetRecType) - (\ (stack:FunStack) -> FunStackE_type E stack -> sort 0) - (\ (e:Either String (evTypeType E)) -> - Either#rec String (evTypeType E) (\ (_:Either String (evTypeType E)) -> sort 0) - (\ (_:String) -> Void) (evRetType E) e) - (\ (frame:List1 LetRecType) -> \ (stack:FunStack) -> \ (rec:FunStackE_type E stack -> sort 0) -> - \ (e:Either (FrameCall frame) (FunStackE_type E stack)) -> - Either#rec (FrameCall frame) (FunStackE_type E stack) (\ (_:Either (FrameCall frame) (FunStackE_type E stack)) -> sort 0) - (FrameCallRet frame) rec e) - stack; - --- The event type corresponding to a FunStack: either an error (represented as --- a String and encoded as Void), an E, or a FrameCall from stack (encoded as --- the return type of the FrameCall) -FunStackE : (E:EvType) -> FunStack -> EvType; -FunStackE E stack = Build_EvType (FunStackE_type E stack) (FunStackE_enc E stack); - - --- The monad for specifications (FIXME: document this!) -primitive SpecM : (E:EvType) -> FunStack -> sort 0 -> sort 0; - - --- SpecPreRel E1 E2 stack1 stack2 is a relation on FunStackE E1 stack1 and --- FunStackE E2 stack2. This is the type of the postcondition needed for --- refinesS. -SpecPreRel : (E1:EvType) -> (E2:EvType) -> - (stack1:FunStack) -> (stack2:FunStack) -> sort 0; -SpecPreRel E1 E2 stack1 stack2 = - FunStackE_type E1 stack1 -> FunStackE_type E2 stack2 -> Prop; - --- SpecPreRel E1 E2 stack1 stack2 is a relation on the encodings of e1 and e2, --- for all e1 of type FunStackE E1 stack1 and e2 of type FunStackE E2 stack2. --- This is the type of the postcondition needed for refinesS. -SpecPostRel : (E1:EvType) -> (E2:EvType) -> - (stack1:FunStack) -> (stack2:FunStack) -> sort 0; -SpecPostRel E1 E2 stack1 stack2 = - (e1:FunStackE_type E1 stack1) -> (e2:FunStackE_type E2 stack2) -> - FunStackE_enc E1 stack1 e1 -> FunStackE_enc E2 stack2 e2 -> Prop; - --- SpecRetRel R1 R2 is a relation on R1 and R2. This is the type of the return --- relation needed for refinesS. -SpecRetRel : (R1:sort 0) -> (R1:sort 0) -> sort 0; -SpecRetRel R1 R2 = R1 -> R2 -> Prop; - --- The precondition requiring that errors, events, and FrameCalls match up and --- are equal on both sides -eqPreRel : (E:EvType) -> (stack:FunStack) -> SpecPreRel E E stack stack; -eqPreRel E stack e1 e2 = - Eq (FunStackE_type E stack) e1 e2; - --- The postcondition stating that errors, event encodings, and return values --- of FrameCalls match up and are equal on both sides -eqPostRel : (E:EvType) -> (stack:FunStack) -> SpecPostRel E E stack stack; -eqPostRel E stack e1 e2 a1 a2 = - EqDep (FunStackE_type E stack) (FunStackE_enc E stack) e1 a1 e2 a2; - --- The return relation requiring the returned values on both sides to be equal -eqRR : (R:sort 0) -> SpecRetRel R R; -eqRR R r1 r2 = Eq R r1 r2; - --- Refinement of SpecM computations -primitive refinesS : (E1:EvType) -> (E2:EvType) -> - (stack1:FunStack) -> (stack2:FunStack) -> - (RPre:SpecPreRel E1 E2 stack1 stack2) -> - (RPost:SpecPostRel E1 E2 stack1 stack2) -> - (R1:sort 0) -> (R2:sort 0) -> (RR:SpecRetRel R1 R2) -> - SpecM E1 stack1 R1 -> SpecM E2 stack2 R2 -> Prop; - --- Homogeneous refinement of SpecM computations - i.e. refinesS with eqPreRel for --- the precondition, eqPostRel for the postcondition, and eqRR for the return relation -refinesS_eq : (E:EvType) -> (stack:FunStack) -> (R:sort 0) -> - SpecM E stack R -> SpecM E stack R -> Prop; -refinesS_eq E stack R = - refinesS E E stack stack (eqPreRel E stack) (eqPostRel E stack) R R (eqRR R); - - --- Return for SpecM -primitive retS : (E:EvType) -> (stack:FunStack) -> (a:sort 0) -> a -> - SpecM E stack a; - --- Bind for SpecM -primitive bindS : (E:EvType) -> (stack:FunStack) -> - (a b:sort 0) -> SpecM E stack a -> - (a -> SpecM E stack b) -> SpecM E stack b; - --- Trigger an event in type E, returning its return type -primitive triggerS : (E:EvType) -> (stack:FunStack) -> (e:evTypeType E) -> - SpecM E stack (evRetType E e); - --- Signal an error in SpecM -primitive errorS : (E:EvType) -> (stack:FunStack) -> (a:sort 0) -> String -> - SpecM E stack a; - --- The spec that universally quantifies over all return values of type a -primitive forallS : (E:EvType) -> (stack:FunStack) -> (a:qsort 0) -> - SpecM E stack a; - --- The spec that existentially quantifies over all return values of type a -primitive existsS : (E:EvType) -> (stack:FunStack) -> (a:qsort 0) -> - SpecM E stack a; - --- Assume a proposition holds -primitive assumeS : (E:EvType) -> (stack:FunStack) -> - (p:Prop) -> SpecM E stack #(); - --- Assume a Boolean value is true -assumeBoolS : (E:EvType) -> (stack:FunStack) -> Bool -> SpecM E stack #(); -assumeBoolS E stack b = assumeS E stack (EqTrue b); - --- The specification which assumes that the first argument is True and then --- runs the second argument -assumingS : (E:EvType) -> (stack:FunStack) -> (a : sort 0) -> Bool -> - SpecM E stack a -> SpecM E stack a; -assumingS E stack a cond m = - bindS E stack #() a (assumeBoolS E stack cond) (\ (_:#()) -> m); - --- Assert a proposition holds -primitive assertS : (E:EvType) -> (stack:FunStack) -> - (p:Prop) -> SpecM E stack #(); - --- Assert a Boolean value is true -assertBoolS : (E:EvType) -> (stack:FunStack) -> Bool -> SpecM E stack #(); -assertBoolS E stack b = assertS E stack (EqTrue b); - --- The specification which asserts that the first argument is True and then --- runs the second argument -assertingS : (E:EvType) -> (stack:FunStack) -> (a : sort 0) -> Bool -> - SpecM E stack a -> SpecM E stack a; -assertingS E stack a cond m = - bindS E stack #() a (assertBoolS E stack cond) (\ (_:#()) -> m); - --- Lift a computation into a stack with an additional frame -primitive pushStackS : (E:EvType) -> (frame:List1 LetRecType) -> - (stack:FunStack) -> (A:sort 0) -> - SpecM E stack A -> SpecM E (pushFunStack frame stack) A; - --- Lift a computation in the empty stack to an arbitrary stack -liftStackS : (E:EvType) -> (stack:FunStack) -> (A:sort 0) -> - SpecM E emptyFunStack A -> SpecM E stack A; -liftStackS E stack A m0 = - List1#rec - (List1 LetRecType) - (\ (stack:FunStack) -> SpecM E stack A) - m0 - (\ (frame:List1 LetRecType) (stack:FunStack) (m:SpecM E stack A) -> - pushStackS E frame stack A m) - stack; - --- The computation that nondeterministically chooses one computation or another. --- As a specification, represents the disjunction of two specifications. -orS : (E:EvType) -> (stack:FunStack) -> (a : sort 0) -> - SpecM E stack a -> SpecM E stack a -> SpecM E stack a; -orS E stack a m1 m2 = - bindS E stack Bool a (existsS E stack Bool) - (\ (b:Bool) -> ite (SpecM E stack a) b m1 m2); - --- Return the type represented by a LetRecType -LRTType : (E:EvType) -> FunStack -> LetRecType -> sort 0; -LRTType E stack lrt = - lrt1Pi lrt (\ (args:LRTInput lrt) -> SpecM E stack (LRTOutput lrt args)); - --- Build the right-nested tuple type (T1 * (T2 * ... (Tn * #()))) where each Ti --- is the result of calling LRTType on the ith LetRecType in a list -FrameTuple : (E:EvType) -> FunStack -> List1 LetRecType -> sort 0; -FrameTuple E stack lrts = - List1#rec - LetRecType - (\ (_:List1 LetRecType) -> sort 0) - #() - (\ (lrt:LetRecType) (_:List1 LetRecType) (rest:sort 0) -> - (LRTType E stack lrt) * rest) - lrts; - --- A recursive call to a function in the top frame of a function stack -primitive callS : - (E:EvType) -> (stack:FunStack) -> (frame:List1 LetRecType) -> - (call : FrameCall frame) -> - SpecM E (pushFunStack frame stack) (FrameCallRet frame call); - --- Bind a collection of recursive functions whose types are given by a frame of --- LetRecTypes and whose bodies are given by an FrameTuple, and call the nth one -primitive multiFixS : - (E:EvType) -> (stack:FunStack) -> (frame:List1 LetRecType) -> - FrameTuple E (pushFunStack frame stack) frame -> - (call : FrameCall frame) -> - SpecM E stack (FrameCallRet frame call); - --- Build a frame with a single function -singletonFrame : LetRecType -> List1 LetRecType; -singletonFrame lrt = Cons1 LetRecType lrt (Nil1 LetRecType); - --- Build a frame with a single function of a single input type -fixSFrame : (a:sort 0) -> (b:a -> sort 0) -> List1 LetRecType; -fixSFrame a b = singletonFrame (LRT_Fun a (\ (x:a) -> LRT_Ret (b x))); - --- Build a stack with a single fixS frame -fixSStack : (a:sort 0) -> (b:a -> sort 0) -> FunStack; -fixSStack a b = pushFunStack (fixSFrame a b) emptyFunStack; - --- Helper type for fixS -fixSFun : (E:EvType) -> (stack:FunStack) -> - (a:sort 0) -> (b:a -> sort 0) -> sort 0; -fixSFun E stack a b = - (x:a) -> SpecM E (pushFunStack (fixSFrame a b) stack) (b x); - --- Bind a single recursive function with a single input and pass it the given --- input argument -fixS : (E:EvType) -> (stack:FunStack) -> (a:sort 0) -> (b:a -> sort 0) -> - (fixSFun E stack a b -> fixSFun E stack a b) -> - (x:a) -> SpecM E stack (b x); -fixS E stack a b body_f x_top = - multiFixS - E stack (fixSFrame a b) - (body_f (\ (x:a) -> - callS E stack (fixSFrame a b) - (mkFrameCall (fixSFrame a b) 0 x)), ()) - (mkFrameCall (fixSFrame a b) 0 x_top); - --- Build a multi-argument fixed-point of type A1 -> ... -> An -> SpecM B -multiArgFixS : (E:EvType) -> (stack:FunStack) -> (lrt:LetRecType) -> - (LRTType E (pushFunStack (singletonFrame lrt) stack) lrt -> - LRTType E (pushFunStack (singletonFrame lrt) stack) lrt) -> - LRTType E stack lrt; -multiArgFixS E stack lrt body_f = - lrtLambda - lrt (\ (args:LRTInput lrt) -> SpecM E stack (LRTOutput lrt args)) - (\ (top_args:LRTInput lrt) -> - multiFixS - E stack (singletonFrame lrt) - (body_f - (lrtLambda - lrt (\ (args:LRTInput lrt) -> - SpecM E (pushFunStack (singletonFrame lrt) stack) - (LRTOutput lrt args)) - (\ (args:LRTInput lrt) -> - callS E stack (singletonFrame lrt) - (FrameCallOfArgs (singletonFrame lrt) 0 args))), ()) - (FrameCallOfArgs (singletonFrame lrt) 0 top_args)); - --- Apply a pure function to the result of a computation -fmapS : (E:EvType) -> (stack:FunStack) -> (a b:sort 0) -> (a -> b) -> - SpecM E stack a -> - SpecM E stack b; -fmapS E stack a b f m = - bindS E stack a b m (\ (x:a) -> retS E stack b (f x)); - --- Apply a computation of a function to a computation of an argument -applyS : (E:EvType) -> (stack:FunStack) -> (a b:sort 0) -> - SpecM E stack (a -> b) -> - SpecM E stack a -> SpecM E stack b; -applyS E stack a b fm m = - bindS E stack (a -> b) b fm (\ (f:a -> b) -> - bindS E stack a b m (\ (x:a) -> retS E stack b (f x))); - --- Apply a binary pure function to a computation -fmapS2 : (E:EvType) -> (stack:FunStack) -> (a b c:sort 0) -> (a -> b -> c) -> - SpecM E stack a -> SpecM E stack b -> - SpecM E stack c; -fmapS2 E stack a b c f m1 m2 = - applyS E stack b c (fmapS E stack a (b -> c) f m1) m2; - --- Apply a trinary pure function to a computation -fmapS3 : (E:EvType) -> (stack:FunStack) -> - (a b c d:sort 0) -> (a -> b -> c -> d) -> - SpecM E stack a -> SpecM E stack b -> - SpecM E stack c -> SpecM E stack d; -fmapS3 E stack a b c d f m1 m2 m3 = - applyS E stack c d (fmapS2 E stack a b (c -> d) f m1 m2) m3; - --- Bind two values and pass them to a binary function -bindS2 : (E:EvType) -> (stack:FunStack) -> (a b c:sort 0) -> - SpecM E stack a -> - SpecM E stack b -> (a -> b -> SpecM E stack c) -> - SpecM E stack c; -bindS2 E stack a b c m1 m2 k = - bindS E stack a c m1 - (\ (x:a) -> bindS E stack b c m2 (\ (y:b) -> k x y)); - --- Bind three values and pass them to a trinary function -bindS3 : (E:EvType) -> (stack:FunStack) -> - (a b c d:sort 0) -> SpecM E stack a -> - SpecM E stack b -> SpecM E stack c -> - (a -> b -> c -> SpecM E stack d) -> SpecM E stack d; -bindS3 E stack a b c d m1 m2 m3 k = - bindS E stack a d m1 - (\ (x:a) -> bindS2 E stack b c d m2 m3 (k x)); - --- A version of bind that takes the function first -bindApplyS : (E:EvType) -> (stack:FunStack) -> - (a b:sort 0) -> (a -> SpecM E stack b) -> - SpecM E stack a -> SpecM E stack b; -bindApplyS E stack a b k m = - bindS E stack a b m k; - --- A version of bindS2 that takes the function first -bindApplyS2 : (E:EvType) -> (stack:FunStack) -> - (a b c:sort 0) -> (a -> b -> SpecM E stack c) -> - SpecM E stack a -> SpecM E stack b -> - SpecM E stack c; -bindApplyS2 E stack a b c k m1 m2 = - bindS2 E stack a b c m1 m2 k; - --- A version of bindS3 that takes the function first -bindApplyS3 : (E:EvType) -> (stack:FunStack) -> - (a b c d:sort 0) -> (a -> b -> c -> SpecM E stack d) -> - SpecM E stack a -> SpecM E stack b -> - SpecM E stack c -> SpecM E stack d; -bindApplyS3 E stack a b c d k m1 m2 m3 = - bindS3 E stack a b c d m1 m2 m3 k; - --- Compose two monadic functions -composeS : (E:EvType) -> (stack:FunStack) -> - (a b c:sort 0) -> (a -> SpecM E stack b) -> - (b -> SpecM E stack c) -> a -> SpecM E stack c; -composeS E stack a b c k1 k2 x = - bindS E stack b c (k1 x) k2; - --- Tuple a type onto the input and output types of a monadic function -tupleSpecMFunBoth : (E:EvType) -> (stack:FunStack) -> - (a b c:sort 0) -> (a -> SpecM E stack b) -> - (c * a -> SpecM E stack (c * b)); -tupleSpecMFunBoth E stack a b c k = - \ (x: c * a) -> - bindS E stack b (c * b) (k x.(2)) - (\ (y:b) -> retS E stack (c*b) (x.(1), y)); - --- Tuple a value onto the output of a monadic function -tupleSpecMFunOut : (E:EvType) -> (stack:FunStack) -> (a b c:sort 0) -> - c -> (a -> SpecM E stack b) -> (a -> SpecM E stack (c*b)); -tupleSpecMFunOut E stack a b c x f = - \ (y:a) -> bindS E stack b (c*b) (f y) - (\ (z:b) -> retS E stack (c*b) (x,z)); - --- Map a monadic function across a vector -mapS : (E:EvType) -> (stack:FunStack) -> (a:sort 0) -> - (b:isort 0) -> (a -> SpecM E stack b) -> (n:Nat) -> Vec n a -> - SpecM E stack (Vec n b); -mapS E stack a b f = - Nat__rec - (\ (n:Nat) -> Vec n a -> SpecM E stack (Vec n b)) - (\ (_:Vec 0 a) -> retS E stack (Vec 0 b) (EmptyVec b)) - (\ (n:Nat) (rec_f:Vec n a -> SpecM E stack (Vec n b)) - (v:Vec (Succ n) a) -> - fmapS2 E stack 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) -> (stack:FunStack) -> - (a : sort 0) -> (b : isort 0) -> (a -> SpecM E stack b) -> - (n : Nat) -> (len : Vec n Bool) -> BVVec n len a -> - SpecM E stack (BVVec n len b); -mapBVVecS E stack a b f n len = mapS E stack a b f (bvToNat n len); - --- Cast a vector between lengths, testing that those lengths are equal -castVecS : (E:EvType) -> (stack:FunStack) -> (a : sort 0) -> - (n1 : Nat) -> (n2 : Nat) -> Vec n1 a -> - SpecM E stack (Vec n2 a); -castVecS E stack a n1 n2 v = - maybe - (Eq Nat n1 n2) (SpecM E stack (Vec n2 a)) - (errorS E stack (Vec n2 a) "Could not cast Vec") - (\ (pf:Eq Nat n1 n2) -> - retS - E stack (Vec n2 a) - (coerce (Vec n1 a) (Vec n2 a) - (eq_cong Nat n1 n2 pf (sort 0) (\ (n:Nat) -> Vec n a)) - v)) - (proveEqNat n1 n2); - --- Append two BVVecs and cast the resulting size, if possible -appendCastBVVecS : (E:EvType) -> (stack:FunStack) -> - (n : Nat) -> (len1 len2 len3 : Vec n Bool) -> (a : sort 0) -> - BVVec n len1 a -> BVVec n len2 a -> - SpecM E stack (BVVec n len3 a); -appendCastBVVecS E stack n len1 len2 len3 a v1 v2 = - maybe - (Eq (Vec n Bool) (bvAdd n len1 len2) len3) (SpecM E stack (BVVec n len3 a)) - (errorS E stack (BVVec n len3 a) "Could not cast BVVec") - (\ (pf:Eq (Vec n Bool) (bvAdd n len1 len2) len3) -> - retS - E stack (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))) - (bvEqWithProof n (bvAdd n len1 len2) len3); + a (\ (_:List1 a) -> List1 b) (Nil1 b) + (\ (x:a) (_:List1 a) (rec:List1 b) -> Cons1 b (f x) rec) l; + +-- Return the nth element of a List1, or a default value if n is too big +nth_default1 : (a:sort 1) -> a -> List1 a -> Nat -> a; +nth_default1 a d l = + List1#rec a (\ (_:List1 a) -> Nat -> a) + (\ (_:Nat) -> d) + (\ (x:a) (_:List1 a) (rec:Nat -> a) (n:Nat) -> + Nat_cases a x (\ (m:Nat) (_:a) -> rec m) n) + l; -------------------------------------------------------------------------------- diff --git a/saw-core/src/Verifier/SAW.hs b/saw-core/src/Verifier/SAW.hs index 86f61bb115..d322a5a468 100644 --- a/saw-core/src/Verifier/SAW.hs +++ b/saw-core/src/Verifier/SAW.hs @@ -20,7 +20,3 @@ module Verifier.SAW import Verifier.SAW.SharedTerm import Verifier.SAW.Prelude import Verifier.SAW.ExternalFormat - --- The following type-checks the Prelude at compile time, as a sanity check -import Language.Haskell.TH -$(runIO (mkSharedContext >>= \sc -> scLoadPreludeModule sc >> return [])) diff --git a/saw-core/src/Verifier/SAW/Name.hs b/saw-core/src/Verifier/SAW/Name.hs index 442dd129c1..9e3d147818 100644 --- a/saw-core/src/Verifier/SAW/Name.hs +++ b/saw-core/src/Verifier/SAW/Name.hs @@ -24,7 +24,7 @@ module Verifier.SAW.Name , moduleNameText , moduleNamePieces -- * Identifiers - , Ident(identModule, identBaseName), identName, mkIdent + , Ident(identModule, identBaseName), identName, mkIdent, mkSafeIdent , parseIdent , isIdent , identText @@ -51,6 +51,7 @@ module Verifier.SAW.Name , bestAlias ) where +import Numeric (showHex) import Control.Exception (assert) import Data.Char import Data.Hashable @@ -134,6 +135,23 @@ instance Read Ident where mkIdent :: ModuleName -> Text -> Ident mkIdent m s = Ident m s +-- | Make a \"coq-safe\" identifier from a string that might contain +-- non-identifier characters, where we use the SAW core notion of identifier +-- characters as letters, digits, underscore and primes. Any disallowed +-- character is mapped to the string @__xNN@, where @NN@ is the hexadecimal code +-- for that character. Additionally, a SAW core identifier is not allowed to +-- start with a prime, so a leading underscore is added in such a case. +mkSafeIdent :: ModuleName -> String -> Ident +mkSafeIdent _ [] = fromString "_" +mkSafeIdent mnm nm = + let is_safe_char c = isAlphaNum c || c == '_' || c == '\'' in + mkIdent mnm $ Text.pack $ + (if nm!!0 == '\'' then ('_' :) else id) $ + concatMap + (\c -> if is_safe_char c then [c] else + "__x" ++ showHex (ord c) "") + nm + -- | Parse a fully qualified identifier. parseIdent :: String -> Ident parseIdent s0 = diff --git a/saw-core/src/Verifier/SAW/OpenTerm.hs b/saw-core/src/Verifier/SAW/OpenTerm.hs index 2958e86c41..2e5f755dbc 100644 --- a/saw-core/src/Verifier/SAW/OpenTerm.hs +++ b/saw-core/src/Verifier/SAW/OpenTerm.hs @@ -4,6 +4,8 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} {- | Module : Verifier.SAW.OpenTerm @@ -14,7 +16,38 @@ Portability : non-portable (language extensions) This module defines an interface to building SAW core terms in an incrementally type-checked way, meaning that type-checking is performed as the terms are -built. +built. The interface provides a convenient DSL for building terms in a pure way, +where sub-terms can be freely composed and combined into super-terms without +monadic sequencing or 'IO' computations; the 'IO' computation is only run at the +top level when all the term-building is complete. Users of this interface can +also build binding constructs like lambda- and pi-abstractions without worrying +about deBruijn indices, lifting, and free variables. Instead, a key feature of +this interface is that it uses higher-order abstract syntax for lambda- and +pi-abstractions, meaning that the bodies of these term constructs are specified +as Haskell functions that take in terms for the bound variables. The library +takes care of all the deBruijn indices under the hood. + +To use the 'OpenTerm' API, the caller builds up 'OpenTerm's using a variety of +combinators that mirror the SAW core 'Term' structure. As some useful examples +of 'OpenTerm' operations, 'applyOpenTerm' applies one 'OpenTerm' to another, +'globalOpenTerm' builds an 'OpenTerm' for a global identifier, and +'lambdaOpenTerm' builds a lambda-abstraction. For instance, the SAW core term + +> \ (f : Bool -> Bool) (x : Bool) -> f x + +can be built with the 'OpenTerm' expression + +> let bool = globalOpenTerm "Prelude.Bool" in +> lambdaOpenTerm "f" (arrowOpenTerm bool bool) $ \f -> +> lambdaOpenTerm "x" (globalOpenTerm "Prelude.Bool") $ \x -> +> applyOpenTerm f x + +Existing SAW core 'Term's can be used in 'OpenTerm' by applying 'closedOpenTerm' +if the 'Term' is closed (meaning it has no free variables) or 'openOpenTerm' if +it does, where the latter requires the context of free variables to be +specified. At the top level, 'completeOpenTerm' then "completes" an 'OpenTerm' +by running its underlying 'IO' computation to build and type-check the resulting +SAW core 'Term'. -} module Verifier.SAW.OpenTerm ( @@ -34,20 +67,49 @@ module Verifier.SAW.OpenTerm ( recordOpenTerm, recordTypeOpenTerm, projRecordOpenTerm, ctorOpenTerm, dataTypeOpenTerm, globalOpenTerm, identOpenTerm, extCnsOpenTerm, applyOpenTerm, applyOpenTermMulti, applyGlobalOpenTerm, - applyPiOpenTerm, piArgOpenTerm, - lambdaOpenTerm, lambdaOpenTermMulti, piOpenTerm, piOpenTermMulti, - arrowOpenTerm, letOpenTerm, sawLetOpenTerm, list1OpenTerm, - -- * Monadic operations for building terms with binders + applyPiOpenTerm, piArgOpenTerm, lambdaOpenTerm, lambdaOpenTermMulti, + piOpenTerm, piOpenTermMulti, arrowOpenTerm, letOpenTerm, sawLetOpenTerm, + 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, - lambdaOpenTermAuxM, piOpenTermAuxM + lambdaOpenTermAuxM, piOpenTermAuxM, + -- * Types that provide similar operations to 'OpenTerm' + OpenTermLike(..), lambdaTermLikeMulti, applyTermLikeMulti, failTermLike, + globalTermLike, applyGlobalTermLike, + natTermLike, unitTermLike, unitTypeTermLike, + stringLitTermLike, stringTypeTermLike, trueTermLike, falseTermLike, + boolTermLike, boolTypeTermLike, + arrayValueTermLike, bvLitTermLike, vectorTypeTermLike, bvTypeTermLike, + pairTermLike, pairTypeTermLike, pairLeftTermLike, pairRightTermLike, + tupleTermLike, tupleTypeTermLike, projTupleTermLike, + letTermLike, sawLetTermLike, + -- * Other exported helper functions + sawLetMinimize ) where import qualified Data.Vector as V import Control.Monad import Control.Monad.State import Control.Monad.Writer -import Data.Text (Text) +import Control.Monad.Reader +import Data.Text (Text, pack) import Numeric.Natural import Data.IntMap.Strict (IntMap) @@ -65,18 +127,19 @@ import Verifier.SAW.Utils -- SAW core term and its type newtype OpenTerm = OpenTerm { unOpenTerm :: TCM TypedTerm } --- | "Complete" an 'OpenTerm' to a closed term or 'fail' on type-checking error +-- | \"Complete\" an 'OpenTerm' to a closed term or 'fail' on type-checking +-- error completeOpenTerm :: SharedContext -> OpenTerm -> IO Term completeOpenTerm sc (OpenTerm termM) = either (fail . show) return =<< runTCM (typedVal <$> termM) sc Nothing [] --- | "Complete" an 'OpenTerm' to a closed term and 'betaNormalize' the result +-- | \"Complete\" an 'OpenTerm' to a closed term and 'betaNormalize' the result completeNormOpenTerm :: SharedContext -> OpenTerm -> IO Term completeNormOpenTerm sc m = completeOpenTerm sc m >>= sawLetMinimize sc >>= betaNormalize sc --- | "Complete" an 'OpenTerm' to a closed term for its type +-- | \"Complete\" an 'OpenTerm' to a closed term for its type completeOpenTermType :: SharedContext -> OpenTerm -> IO Term completeOpenTermType sc (OpenTerm termM) = either (fail . show) return =<< @@ -102,7 +165,7 @@ failOpenTerm :: String -> OpenTerm failOpenTerm str = OpenTerm $ fail str -- | Bind the result of a type-checking computation in building an 'OpenTerm'. --- NOTE: this operation should be considered "unsafe" because it can create +-- NOTE: this operation should be considered \"unsafe\" because it can create -- malformed 'OpenTerm's if the result of the 'TCM' computation is used as part -- of the resulting 'OpenTerm'. For instance, @a@ should not be 'OpenTerm'. bindTCMOpenTerm :: TCM a -> (a -> OpenTerm) -> OpenTerm @@ -226,20 +289,22 @@ tupleOpenTerm' :: [OpenTerm] -> OpenTerm tupleOpenTerm' [] = unitOpenTerm tupleOpenTerm' ts = foldr1 pairOpenTerm ts --- | Build a right-nested tuple type as an 'OpenTerm' +-- | Build a right-nested tuple type as an 'OpenTerm' but without adding a final +-- unit type as the right-most element tupleTypeOpenTerm' :: [OpenTerm] -> OpenTerm tupleTypeOpenTerm' [] = unitTypeOpenTerm tupleTypeOpenTerm' ts = foldr1 pairTypeOpenTerm ts --- | Given an index and total length, project out of a right-nested tuple --- without unit as the right-most element +-- | 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. projTupleOpenTerm' :: Natural -> Natural -> OpenTerm -> OpenTerm -projTupleOpenTerm' _ 0 _ = panic "projTupleOpenTerm'" ["Projection of 0-tuple"] -projTupleOpenTerm' 0 1 t = t -projTupleOpenTerm' 0 _ t = pairLeftOpenTerm t -projTupleOpenTerm' i n t - | i < n = projTupleOpenTerm' (i - 1) (n - 1) (pairRightOpenTerm t) - | otherwise = panic "projTupleOpenTerm'" ["Index out of bounds"] +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 -- | Build a record value as an 'OpenTerm' recordOpenTerm :: [(FieldName, OpenTerm)] -> OpenTerm @@ -372,7 +437,8 @@ openTermTopVar = -- | Build an open term inside a binder of a variable with the given name and -- type, where the binder is represented as a Haskell function on 'OpenTerm's -bindOpenTerm :: LocalName -> TypedTerm -> (OpenTerm -> OpenTerm) -> TCM TypedTerm +bindOpenTerm :: LocalName -> TypedTerm -> (OpenTerm -> OpenTerm) -> + TCM TypedTerm bindOpenTerm x tp body_f = do tp_whnf <- typeCheckWHNF $ typedVal tp withVar x tp_whnf (openTermTopVar >>= (unOpenTerm . body_f)) @@ -404,7 +470,7 @@ arrowOpenTerm x tp body = piOpenTerm x tp (const body) -- | Build a nested sequence of Pi abstractions as an 'OpenTerm' piOpenTermMulti :: [(LocalName, OpenTerm)] -> ([OpenTerm] -> OpenTerm) -> - OpenTerm + OpenTerm piOpenTermMulti xs_tps body_f = foldr (\(x,tp) rest_f xs -> piOpenTerm x tp (rest_f . (:xs))) (body_f . reverse) xs_tps [] @@ -423,6 +489,22 @@ sawLetOpenTerm x tp tp_ret rhs body_f = applyOpenTermMulti (globalOpenTerm "Prelude.sawLet") [tp, tp_ret, rhs, lambdaOpenTerm x tp body_f] +-- | Build a bitvector type with the given length +bitvectorTypeOpenTerm :: OpenTerm -> OpenTerm +bitvectorTypeOpenTerm w = + applyGlobalOpenTerm "Prelude.Vec" [w, globalOpenTerm "Prelude.Bool"] + +-- | Build the SAW core type @BVVec n len d@ +bvVecTypeOpenTerm :: OpenTerm -> OpenTerm -> OpenTerm -> OpenTerm +bvVecTypeOpenTerm w_term len_term elem_tp = + applyGlobalOpenTerm "Prelude.BVVec" [w_term, len_term, elem_tp] + +-- | Build a SAW core term for a list with the given element type +listOpenTerm :: OpenTerm -> [OpenTerm] -> OpenTerm +listOpenTerm tp elems = + foldr (\x l -> ctorOpenTerm "Prelude.Cons" [tp, x, l]) + (ctorOpenTerm "Prelude.Nil" [tp]) elems + -- | Build an 'OpenTerm' of type @List1 tp@ from 'OpenTerm's of type @tp@ list1OpenTerm :: OpenTerm -> [OpenTerm] -> OpenTerm list1OpenTerm tp xs = @@ -430,6 +512,334 @@ list1OpenTerm tp xs = (ctorOpenTerm "Prelude.Nil1" [tp]) xs +-- | Build the type @Either a b@ from types @a@ and @b@ +eitherTypeOpenTerm :: OpenTerm -> OpenTerm -> OpenTerm +eitherTypeOpenTerm a b = dataTypeOpenTerm "Prelude.Either" [a,b] + +-- | Build the type @Sigma a (\ (x:a) -> b)@ from variable name @x@, type @a@, +-- and type-level function @b@ +sigmaTypeOpenTerm :: LocalName -> OpenTerm -> (OpenTerm -> OpenTerm) -> OpenTerm +sigmaTypeOpenTerm x tp f = + dataTypeOpenTerm "Prelude.Sigma" [tp, lambdaOpenTerm x tp f] + +-- | Build the type @Sigma a1 (\ (x1:a1) -> Sigma a2 (\ (x2:a2) -> ...))@ +sigmaTypeOpenTermMulti :: LocalName -> [OpenTerm] -> ([OpenTerm] -> OpenTerm) -> + OpenTerm +sigmaTypeOpenTermMulti _ [] f = f [] +sigmaTypeOpenTermMulti x (tp:tps) f = + sigmaTypeOpenTerm x tp $ \ t -> + sigmaTypeOpenTermMulti x tps $ \ts -> f (t:ts) + +-- | Build the dependent pair @exists a (\ (x:a) -> b) x y@ whose type is given +-- by 'sigmaTypeOpenTerm' +sigmaOpenTerm :: LocalName -> OpenTerm -> (OpenTerm -> OpenTerm) -> + OpenTerm -> OpenTerm -> OpenTerm +sigmaOpenTerm x tp tp_f trm_l trm_r = + ctorOpenTerm "Prelude.exists" [tp, lambdaOpenTerm x tp tp_f, trm_l, trm_r] + +-- | Build the right-nested dependent pair @(x1, (x2, ...(xn, y)))@ whose type +-- is given by 'sigmaTypeOpenTermMulti' +sigmaOpenTermMulti :: LocalName -> [OpenTerm] -> ([OpenTerm] -> OpenTerm) -> + [OpenTerm] -> OpenTerm -> OpenTerm +sigmaOpenTermMulti _ [] _ [] trm = trm +sigmaOpenTermMulti x (tp:tps) tp_f (trm_l:trms_l) trm_r = + sigmaOpenTerm x tp (\t -> sigmaTypeOpenTermMulti x tps (tp_f . (t:))) trm_l $ + sigmaOpenTermMulti x tps (tp_f . (trm_l:)) trms_l trm_r +sigmaOpenTermMulti _ _ _ _ _ = + panic "sigmaOpenTermMulti" ["The number of types and arguments disagree"] + +-- | Take a nested dependent pair (of the type returned by +-- 'sigmaTypeOpenTermMulti') and apply a function @f@ to all of its projections +sigmaElimOpenTermMulti :: LocalName -> [OpenTerm] -> ([OpenTerm] -> OpenTerm) -> + OpenTerm -> ([OpenTerm] -> OpenTerm) -> OpenTerm +sigmaElimOpenTermMulti _ [] _ t f_elim = f_elim [t] +sigmaElimOpenTermMulti x (tp:tps) tp_f sig f_elim = + let b_fun = lambdaOpenTerm x tp (\t -> sigmaTypeOpenTermMulti x tps (tp_f . (t:))) + proj1 = applyGlobalOpenTerm "Prelude.Sigma_proj1" [tp, b_fun, sig] + proj2 = applyGlobalOpenTerm "Prelude.Sigma_proj2" [tp, b_fun, sig] in + 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 _ _ _ = + panic "substTpDescMulti" ["Mismatched number of kinds versus expressions"] + +-- | 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 (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 + -- | The monad for building 'OpenTerm's if you want to add in 'IO' actions. This -- is just the type-checking monad, but we give it a new name to keep this -- module self-contained. @@ -439,14 +849,17 @@ newtype OpenTermM a = OpenTermM { unOpenTermM :: TCM a } instance MonadIO OpenTermM where liftIO = OpenTermM . liftIO --- | "Complete" an 'OpenTerm' build in 'OpenTermM' to a closed term, or 'fail' +-- | \"Run\" an 'OpenTermM' computation to produce an 'OpenTerm' +runOpenTermM :: OpenTermM OpenTerm -> OpenTerm +runOpenTermM (OpenTermM m) = + OpenTerm $ join $ fmap unOpenTerm m + +-- | \"Complete\" an 'OpenTerm' build in 'OpenTermM' to a closed term, or 'fail' -- on a type-checking error completeOpenTermM :: SharedContext -> OpenTermM OpenTerm -> IO Term -completeOpenTermM sc (OpenTermM termM) = - either (fail . show) return =<< - runTCM (typedVal <$> join (fmap unOpenTerm termM)) sc Nothing [] +completeOpenTermM sc m = completeOpenTerm sc (runOpenTermM m) --- | "De-duplicate" an open term, so that duplicating the returned 'OpenTerm' +-- | \"De-duplicate\" an open term, so that duplicating the returned 'OpenTerm' -- does not lead to duplicated WHNF work dedupOpenTermM :: OpenTerm -> OpenTermM OpenTerm dedupOpenTermM (OpenTerm trmM) = @@ -505,6 +918,185 @@ piOpenTermAuxM x tp body_f = return (OpenTerm (typeInferComplete $ Pi x tp' body), a) +-------------------------------------------------------------------------------- +-- Types that provide similar operations to 'OpenTerm' + +class OpenTermLike t where + -- | Convert an 'OpenTerm' to a @t@ + openTermLike :: OpenTerm -> t + -- | Get the type of a @t@ + typeOfTermLike :: t -> t + -- | Build a @t@ from a 'FlatTermF' + flatTermLike :: FlatTermF t -> t + -- | Apply a @t@ to another @t@ + applyTermLike :: t -> t -> t + -- | Build a lambda abstraction as a @t@ + lambdaTermLike :: LocalName -> t -> (t -> t) -> t + -- | Build a pi abstraction as a @t@ + piTermLike :: LocalName -> t -> (t -> t) -> t + -- | Build a @t@ for a constructor applied to its arguments + ctorTermLike :: Ident -> [t] -> t + -- | Build a @t@ for a datatype applied to its arguments + dataTypeTermLike :: Ident -> [t] -> t + +instance OpenTermLike OpenTerm where + openTermLike = id + typeOfTermLike = openTermType + flatTermLike = flatOpenTerm + applyTermLike = applyOpenTerm + lambdaTermLike = lambdaOpenTerm + piTermLike = piOpenTerm + ctorTermLike = ctorOpenTerm + dataTypeTermLike = dataTypeOpenTerm + +-- Lift an OpenTermLike instance from t to functions from some type a to t, +-- where the OpenTermLike methods pass the same input a argument to all subterms +instance OpenTermLike t => OpenTermLike (a -> t) where + openTermLike t = const $ openTermLike t + typeOfTermLike t = \x -> typeOfTermLike (t x) + flatTermLike ftf = \x -> flatTermLike (fmap ($ x) ftf) + applyTermLike f arg = \x -> applyTermLike (f x) (arg x) + lambdaTermLike nm tp bodyF = + \x -> lambdaTermLike nm (tp x) (\y -> bodyF (const y) x) + piTermLike nm tp bodyF = + \x -> piTermLike nm (tp x) (\y -> bodyF (const y) x) + ctorTermLike c args = \x -> ctorTermLike c (map ($ x) args) + dataTypeTermLike d args = \x -> dataTypeTermLike d (map ($ x) args) + +-- This is the same as the function instance above +instance OpenTermLike t => OpenTermLike (Reader r t) where + openTermLike t = reader $ openTermLike t + typeOfTermLike t = reader $ typeOfTermLike $ runReader t + flatTermLike ftf = reader $ flatTermLike $ fmap runReader ftf + applyTermLike f arg = reader $ applyTermLike (runReader f) (runReader arg) + lambdaTermLike x tp body = + reader $ lambdaTermLike x (runReader tp) (runReader . body . reader) + piTermLike x tp body = + reader $ piTermLike x (runReader tp) (runReader . body . reader) + ctorTermLike c args = reader $ ctorTermLike c $ map runReader args + dataTypeTermLike d args = reader $ dataTypeTermLike d $ map runReader args + +-- | Build a nested sequence of lambda abstractions +lambdaTermLikeMulti :: OpenTermLike t => [(LocalName, t)] -> ([t] -> t) -> t +lambdaTermLikeMulti xs_tps body_f = + foldr (\(x,tp) rest_f xs -> + lambdaTermLike x tp (rest_f . (:xs))) (body_f . reverse) xs_tps [] + +-- | Apply a term to 0 or more arguments +applyTermLikeMulti :: OpenTermLike t => t -> [t] -> t +applyTermLikeMulti = foldl applyTermLike + +-- | Build a term that 'fail's in the underlying monad when completed +failTermLike :: OpenTermLike t => String -> t +failTermLike str = openTermLike $ failOpenTerm str + +-- | Build a term for a global name with a definition +globalTermLike :: OpenTermLike t => Ident -> t +globalTermLike ident = openTermLike $ globalOpenTerm ident + +-- | Apply a named global to 0 or more arguments +applyGlobalTermLike :: OpenTermLike t => Ident -> [t] -> t +applyGlobalTermLike ident = applyTermLikeMulti (globalTermLike ident) + +-- | Build a term for a natural number literal +natTermLike :: OpenTermLike t => Natural -> t +natTermLike = flatTermLike . NatLit + +-- | The term for the unit value +unitTermLike :: OpenTermLike t => t +unitTermLike = flatTermLike UnitValue + +-- | The term for the unit type +unitTypeTermLike :: OpenTermLike t => t +unitTypeTermLike = flatTermLike UnitType + +-- | Build a SAW core string literal. +stringLitTermLike :: OpenTermLike t => Text -> t +stringLitTermLike = flatTermLike . StringLit + +-- | Return the SAW core type @String@ of strings. +stringTypeTermLike :: OpenTermLike t => t +stringTypeTermLike = globalTermLike "Prelude.String" + +-- | The 'True' value as a SAW core term +trueTermLike :: OpenTermLike t => t +trueTermLike = globalTermLike "Prelude.True" + +-- | The 'False' value as a SAW core term +falseTermLike :: OpenTermLike t => t +falseTermLike = globalTermLike "Prelude.False" + +-- | Convert a 'Bool' to a SAW core term +boolTermLike :: OpenTermLike t => Bool -> t +boolTermLike True = globalTermLike "Prelude.True" +boolTermLike False = globalTermLike "Prelude.False" + +-- | The 'Bool' type as a SAW core term +boolTypeTermLike :: OpenTermLike t => t +boolTypeTermLike = globalTermLike "Prelude.Bool" + +-- | Build an term for an array literal +arrayValueTermLike :: OpenTermLike t => t -> [t] -> t +arrayValueTermLike tp elems = + flatTermLike $ ArrayValue tp $ V.fromList elems + +-- | Create a SAW core term for a bitvector literal +bvLitTermLike :: OpenTermLike t => [Bool] -> t +bvLitTermLike bits = + arrayValueTermLike boolTypeTermLike $ map boolTermLike bits + +-- | Create a SAW core term for a vector type +vectorTypeTermLike :: OpenTermLike t => t -> t -> t +vectorTypeTermLike n a = applyGlobalTermLike "Prelude.Vec" [n,a] + +-- | Create a SAW core term for the type of a bitvector +bvTypeTermLike :: OpenTermLike t => Integral n => n -> t +bvTypeTermLike n = + applyTermLikeMulti (globalTermLike "Prelude.Vec") + [natTermLike (fromIntegral n), boolTypeTermLike] + +-- | Build a term for a pair +pairTermLike :: OpenTermLike t => t -> t -> t +pairTermLike t1 t2 = flatTermLike $ PairValue t1 t2 + +-- | Build a term for a pair type +pairTypeTermLike :: OpenTermLike t => t -> t -> t +pairTypeTermLike t1 t2 = flatTermLike $ PairType t1 t2 + +-- | Build a term for the left projection of a pair +pairLeftTermLike :: OpenTermLike t => t -> t +pairLeftTermLike t = flatTermLike $ PairLeft t + +-- | Build a term for the right projection of a pair +pairRightTermLike :: OpenTermLike t => t -> t +pairRightTermLike t = flatTermLike $ PairRight t + +-- | Build a right-nested tuple as a term +tupleTermLike :: OpenTermLike t => [t] -> t +tupleTermLike = foldr pairTermLike unitTermLike + +-- | Build a right-nested tuple type as a term +tupleTypeTermLike :: OpenTermLike t => [t] -> t +tupleTypeTermLike = foldr pairTypeTermLike unitTypeTermLike + +-- | Project the @n@th element of a right-nested tuple type +projTupleTermLike :: OpenTermLike t => Integer -> t -> t +projTupleTermLike 0 t = pairLeftTermLike t +projTupleTermLike i t = projTupleTermLike (i-1) (pairRightTermLike t) + +-- | Build a let expression as a term. This is equivalent to +-- > 'applyTermLike' ('lambdaTermLike' x tp body) rhs +letTermLike :: OpenTermLike t => LocalName -> t -> t -> (t -> t) -> t +letTermLike x tp rhs body_f = applyTermLike (lambdaTermLike x tp body_f) rhs + +-- | Build a let expression as a term using the @sawLet@ combinator. This +-- is equivalent to the term @sawLet tp tp_ret rhs (\ (x : tp) -> body_f)@ +sawLetTermLike :: OpenTermLike t => LocalName -> t -> t -> t -> (t -> t) -> t +sawLetTermLike x tp tp_ret rhs body_f = + applyTermLikeMulti (globalTermLike "Prelude.sawLet") + [tp, tp_ret, rhs, lambdaTermLike x tp body_f] + + -------------------------------------------------------------------------------- -- sawLet-minimization diff --git a/saw-core/src/Verifier/SAW/Recognizer.hs b/saw-core/src/Verifier/SAW/Recognizer.hs index 54f4746ae8..30e95f0bdd 100644 --- a/saw-core/src/Verifier/SAW/Recognizer.hs +++ b/saw-core/src/Verifier/SAW/Recognizer.hs @@ -46,6 +46,8 @@ module Verifier.SAW.Recognizer , asNat , asBvNat , asUnsignedConcreteBv + , asBvToNat + , asUnsignedConcreteBvToNat , asArrayValue , asStringLit , asLambda @@ -75,6 +77,7 @@ module Verifier.SAW.Recognizer import Control.Lens import Control.Monad +import Data.List (foldl') import Data.Map (Map) import qualified Data.Map as Map import qualified Data.Vector as V @@ -93,6 +96,9 @@ instance Field1 (a :*: b) (a' :*: b) a a' where instance Field2 (a :*: b) (a :*: b') b b' where _2 k (a :*: b) = (a :*:) <$> indexed k (1 :: Int) b +toPair :: a :*: b -> (a, b) +toPair (a :*: b) = (a, b) + type Recognizer t a = t -> Maybe a -- | Recognizes the head and tail of a list, and returns head. @@ -282,13 +288,47 @@ asNat (asCtor -> Just (c, [asNat -> Just i])) | primName c == preludeSuccIdent = return (i+1) asNat _ = Nothing -asBvNat :: Recognizer Term (Natural :*: Natural) -asBvNat = (isGlobalDef "Prelude.bvNat" @> asNat) <@> asNat +-- | Recognize an application of @bvNat@ +asBvNat :: Recognizer Term (Term, Term) +asBvNat = fmap toPair . ((isGlobalDef "Prelude.bvNat" @> return) <@> return) +-- | Try to convert the given term of type @Vec w Bool@ to a concrete 'Natural', +-- taking into account nat, bitvector and integer conversions (treating all +-- bitvectors as unsigned) asUnsignedConcreteBv :: Recognizer Term Natural -asUnsignedConcreteBv term = do - (n :*: v) <- asBvNat term - return $ mod v (2 ^ n) +asUnsignedConcreteBv (asApplyAll -> (asGlobalDef -> Just "Prelude.bvNat", + [asNat -> Just n, v])) = + (`mod` (2 ^ n)) <$> asUnsignedConcreteBvToNat v +asUnsignedConcreteBv (asArrayValue -> Just (asBoolType -> Just _, + mapM asBool -> Just bits)) = + return $ foldl' (\n bit -> if bit then 2*n+1 else 2*n) 0 bits +asUnsignedConcreteBv (asApplyAll -> (asGlobalDef -> Just "Prelude.intToBv", + [asNat -> Just n, i])) = case i of + (asApplyAll -> (asGlobalDef -> Just "Prelude.natToInt", [v])) -> + (`mod` (2 ^ n)) <$> asUnsignedConcreteBvToNat v + (asApplyAll -> (asGlobalDef -> Just "Prelude.bvToInt", [_, bv])) -> + asUnsignedConcreteBv bv + _ -> Nothing +asUnsignedConcreteBv _ = Nothing + +-- | Recognize an application of @bvToNat@ +asBvToNat :: Recognizer Term (Term, Term) +asBvToNat = fmap toPair . ((isGlobalDef "Prelude.bvToNat" @> return) <@> return) + +-- | Try to convert the given term of type @Nat@ to a concrete 'Natural', +-- taking into account nat, bitvector and integer conversions (treating all +-- bitvectors as unsigned) +asUnsignedConcreteBvToNat :: Recognizer Term Natural +asUnsignedConcreteBvToNat (asNat -> Just v) = return v +asUnsignedConcreteBvToNat (asBvToNat -> Just (_, bv)) = asUnsignedConcreteBv bv +asUnsignedConcreteBvToNat (asApplyAll -> (asGlobalDef -> Just "Prelude.intToNat", + [i])) = case i of + (asApplyAll -> (asGlobalDef -> Just "Prelude.natToInt", [v])) -> + asUnsignedConcreteBvToNat v + (asApplyAll -> (asGlobalDef -> Just "Prelude.bvToInt", [_, bv])) -> + asUnsignedConcreteBv bv + _ -> Nothing +asUnsignedConcreteBvToNat _ = Nothing asArrayValue :: Recognizer Term (Term, [Term]) asArrayValue (unwrapTermF -> FTermF (ArrayValue tp tms)) = @@ -370,10 +410,7 @@ asIntModType :: Recognizer Term Natural asIntModType = isGlobalDef "Prelude.IntMod" @> asNat asVectorType :: Recognizer Term (Term, Term) -asVectorType = helper ((isGlobalDef "Prelude.Vec" @> return) <@> return) where - helper r t = - do (n :*: a) <- r t - return (n, a) +asVectorType = fmap toPair . ((isGlobalDef "Prelude.Vec" @> return) <@> return) isVecType :: Recognizer Term a -> Recognizer Term (Natural :*: a) isVecType tp = (isGlobalDef "Prelude.Vec" @> asNat) <@> tp diff --git a/saw-core/src/Verifier/SAW/SharedTerm.hs b/saw-core/src/Verifier/SAW/SharedTerm.hs index b7a439dbdc..675fc55d7a 100644 --- a/saw-core/src/Verifier/SAW/SharedTerm.hs +++ b/saw-core/src/Verifier/SAW/SharedTerm.hs @@ -87,6 +87,7 @@ module Verifier.SAW.SharedTerm , scLoadModule , scUnloadModule , scModifyModule + , scInsertDef , scModuleIsLoaded , scFindModule , scFindDef @@ -581,6 +582,17 @@ scModifyModule sc mnm f = modifyIORef' (scModuleMap sc) $ HMap.alter (\case { Just m -> Just (f m); _ -> error err_msg }) mnm +-- | Insert a definition into a SAW core module +scInsertDef :: SharedContext -> ModuleName -> Ident -> Term -> Term -> IO () +scInsertDef sc mnm ident def_tp def_tm = + do t <- scConstant' sc (ModuleIdentifier ident) def_tm def_tp + scRegisterGlobal sc ident t + scModifyModule sc mnm $ \m -> + insDef m $ Def { defIdent = ident, + defQualifier = NoQualifier, + defType = def_tp, + defBody = Just def_tm } + -- | Look up a module by name, raising an error if it is not loaded scFindModule :: SharedContext -> ModuleName -> IO Module scFindModule sc name = diff --git a/saw-core/src/Verifier/SAW/Simulator/Prims.hs b/saw-core/src/Verifier/SAW/Simulator/Prims.hs index 6755757e53..6511c76cdb 100644 --- a/saw-core/src/Verifier/SAW/Simulator/Prims.hs +++ b/saw-core/src/Verifier/SAW/Simulator/Prims.hs @@ -548,7 +548,7 @@ natSize val = fromMaybe (panic $ "natSize: expected Nat, got: " ++ show val) -- 'Value', if 'natSizeMaybe' returns 'Just' natSizeFun :: (HasCallStack, VMonad l) => (Either (Natural, Value l) Natural -> Prim l) -> Prim l -natSizeFun = PrimFilterFun "expected Nat" r +natSizeFun = PrimFilterFun "expected Nat with a known size" r where r (VNat n) = pure (Right n) r (VCtorApp (primName -> "Prelude.Zero") [] []) = pure (Right 0) r v@(VCtorApp (primName -> "Prelude.Succ") [] [x]) = diff --git a/saw-core/src/Verifier/SAW/Simulator/TermModel.hs b/saw-core/src/Verifier/SAW/Simulator/TermModel.hs index c92fe468fe..a7b933ffc2 100644 --- a/saw-core/src/Verifier/SAW/Simulator/TermModel.hs +++ b/saw-core/src/Verifier/SAW/Simulator/TermModel.hs @@ -18,7 +18,7 @@ module Verifier.SAW.Simulator.TermModel ( TmValue, TermModel, Value(..), TValue(..) , VExtra(..) , readBackValue, readBackTValue - , normalizeSharedTerm + , normalizeSharedTerm, normalizeSharedTerm' , extractUninterp ) where @@ -66,7 +66,7 @@ extractUninterp :: IO (Term, ReplaceUninterpMap) extractUninterp sc m addlPrims ecVals unintSet opaqueSet t = do mapref <- newIORef mempty - cfg <- mfix (\cfg -> Sim.evalGlobal' m (Map.union (constMap sc cfg) addlPrims) + cfg <- mfix (\cfg -> Sim.evalGlobal' m (Map.union addlPrims (constMap sc cfg)) (extcns cfg mapref) (uninterpreted cfg mapref) (neutral cfg) (primHandler cfg)) v <- Sim.evalSharedTerm cfg t tv <- evalType cfg =<< scTypeOf sc t @@ -135,9 +135,21 @@ normalizeSharedTerm :: Set VarIndex {- ^ opaque constants -} -> Term -> IO Term -normalizeSharedTerm sc m addlPrims ecVals opaqueSet t = +normalizeSharedTerm sc m addlPrims = + normalizeSharedTerm' sc m (const $ Map.union addlPrims) + +normalizeSharedTerm' :: + SharedContext -> + ModuleMap -> + (Sim.SimulatorConfig TermModel -> Map Ident TmPrim -> Map Ident TmPrim) + {- ^ function which adds additional primitives -} -> + Map VarIndex TmValue {- ^ ExtCns values -} -> + Set VarIndex {- ^ opaque constants -} -> + Term -> + IO Term +normalizeSharedTerm' sc m primsFn ecVals opaqueSet t = do let ?recordEC = \_ec -> return () - cfg <- mfix (\cfg -> Sim.evalGlobal' m (Map.union (constMap sc cfg) addlPrims) + cfg <- mfix (\cfg -> Sim.evalGlobal' m (primsFn cfg (constMap sc cfg)) (extcns cfg) (constants cfg) (neutral cfg) (primHandler cfg)) v <- Sim.evalSharedTerm cfg t tv <- evalType cfg =<< scTypeOf sc t @@ -420,7 +432,9 @@ readBackValue sc cfg = loop vs' <- Map.fromList <$> traverse build vs scRecord sc vs' - loop tv _v = panic "readBackValue" ["type mismatch", show tv] + loop tv v = panic "readBackValue" ["Type mismatch", + "Expected type: " ++ show tv, + "For value: " ++ show v] readBackCtorArgs cnm (VPiType _nm tv body) (v:vs) = do v' <- force v diff --git a/src/SAWScript/Builtins.hs b/src/SAWScript/Builtins.hs index a3de996e63..f262c70629 100644 --- a/src/SAWScript/Builtins.hs +++ b/src/SAWScript/Builtins.hs @@ -785,7 +785,7 @@ congruence_for tt = -- represents a congruence law for that term. -- This term will be a Curry-Howard style theorem statement -- that can be dispatched to solvers, and should have --- type "Prop". +-- type \"Prop\". -- -- This will only work for terms that represent non-dependent -- functions. @@ -2272,11 +2272,11 @@ mrSolverGetResultOrFail :: TopLevel a mrSolverGetResultOrFail env errStr succStr res = case res of Left err | Prover.mreDebugLevel env == 0 -> - fail (Prover.showMRFailure err ++ "\n[MRSolver] " ++ errStr) + 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 err ++ "\n[MRSolver] " ++ errStr) + fail (Prover.showMRFailureNoCtx env err ++ "\n[MRSolver] " ++ errStr) Right a | Just s <- succStr -> printOutLnTop Info s >> return a Right a -> return a @@ -2291,11 +2291,10 @@ mrSolver rs = execTactic $ Tactic $ \goal -> lift $ 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 ev1 ev2 - stack1 stack2 rtp1 rtp2 - t1 t2)) _ -> - do tp1 <- liftIO $ scGlobalApply sc "Prelude.SpecM" [ev1, stack1, rtp1] - tp2 <- liftIO $ scGlobalApply sc "Prelude.SpecM" [ev2, stack2, rtp2] + 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 @@ -2327,10 +2326,17 @@ 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)) { + 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 (@Prelude.refinesS@) of the given terms, with the given +-- 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 = diff --git a/src/SAWScript/Crucible/LLVM/FFI.hs b/src/SAWScript/Crucible/LLVM/FFI.hs index e6950602a8..0f387f0f76 100644 --- a/src/SAWScript/Crucible/LLVM/FFI.hs +++ b/src/SAWScript/Crucible/LLVM/FFI.hs @@ -282,7 +282,7 @@ setupOutArg tenv = go "out" (outArgss, posts) <- unzip <$> setupTupleArgs go name ffiTypes let len = fromIntegral $ length ffiTypes post ret = zipWithM_ - (\i p -> p (projTupleOpenTerm' i len ret)) + (\i p -> p (projTupleOpenTerm' len i ret)) [0..] posts pure (concat outArgss, post) @@ -299,7 +299,7 @@ setupOutArg tenv = go "out" Just i -> i Nothing -> panic "setupOutArg" ["Bad record field access"] - p (projTupleOpenTerm' ix len ret)) + p (projTupleOpenTerm' len ix ret)) (displayOrder ffiTypeMap) posts pure (concat outArgss, post) diff --git a/src/SAWScript/HeapsterBuiltins.hs b/src/SAWScript/HeapsterBuiltins.hs index cfc1508c78..d3511c5895 100644 --- a/src/SAWScript/HeapsterBuiltins.hs +++ b/src/SAWScript/HeapsterBuiltins.hs @@ -29,9 +29,8 @@ module SAWScript.HeapsterBuiltins -- , heapster_typecheck_fun_rename_rs , heapster_define_opaque_perm , heapster_define_recursive_perm - , heapster_define_irt_recursive_perm - , heapster_define_irt_recursive_shape , heapster_define_reachability_perm + , heapster_define_recursive_shape , heapster_define_perm , heapster_define_llvmshape , heapster_define_opaque_llvmshape @@ -70,16 +69,15 @@ import Data.Functor.Constant (getConstant) import Control.Applicative ( (<|>) ) import Control.Lens import Control.Monad -import Control.Monad.IO.Class +import Control.Monad.Reader import qualified Control.Monad.Fail as Fail import System.Directory import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy.UTF8 as BL -import GHC.TypeLits (KnownNat) import Data.Text (Text) +import qualified Data.Text as T import Data.Binding.Hobbits hiding (sym) -import qualified Data.Type.RList as RL import Data.Parameterized.BoolRepr import qualified Data.Parameterized.Context as Ctx @@ -87,9 +85,11 @@ import Data.Parameterized.TraversableF import Data.Parameterized.TraversableFC import Verifier.SAW.Term.Functor +import Verifier.SAW.Name import Verifier.SAW.Module as Mod -import Verifier.SAW.Prelude +import Verifier.SAW.Cryptol.Monadify import Verifier.SAW.SharedTerm +import Verifier.SAW.Recognizer import Verifier.SAW.OpenTerm import Verifier.SAW.Typechecker import Verifier.SAW.SCTypeCheck @@ -119,11 +119,12 @@ import SAWScript.Builtins import SAWScript.Crucible.LLVM.Builtins import SAWScript.Crucible.LLVM.MethodSpecIR +import Verifier.SAW.Utils (panic) +import qualified Verifier.SAW.Term.Pretty as Pretty import Verifier.SAW.Heapster.CruUtil import Verifier.SAW.Heapster.HintExtract import Verifier.SAW.Heapster.Permissions import Verifier.SAW.Heapster.SAWTranslation -import Verifier.SAW.Heapster.IRTTranslation import Verifier.SAW.Heapster.PermParser import Verifier.SAW.Heapster.RustTypes (parseSome3FunPermFromRust, Some3FunPerm(..)) import Verifier.SAW.Heapster.ParsedCtx @@ -134,6 +135,37 @@ import SAWScript.Prover.Exporter import Verifier.SAW.Translation.Coq import Prettyprinter +-- | 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 ++ + scPrettyTerm pp_opts trm) (return ()) + +-- | Check that a type equals the type described by a type description in a ctx +checkTypeAgreesWithDesc :: SharedContext -> PermEnv -> String -> 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 ("Type description for " ++ nm ++ + " does not match user-supplied type\n" ++ + "Type for description:\n" ++ + scPrettyTermInCtx Pretty.defaultPPOpts [] d_tp_norm ++ "\n" ++ + "User-supplied type:\n" ++ + scPrettyTermInCtx Pretty.defaultPPOpts [] 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'. @@ -265,6 +297,16 @@ findUnusedIdent m str = 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 + let mnm = heapsterEnvSAWModule henv + liftIO $ scInsertDef sc mnm 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 @@ -283,7 +325,7 @@ parseAndInsDef henv nm term_tp term_string = term -> do m <- liftIO $ scFindModule sc mnm let term_ident = findUnusedIdent m nm - liftIO $ scInsertDef sc mnm term_ident term_tp term + heapsterInsertDef henv term_ident term_tp term return term_ident -- | Build a 'HeapsterEnv' associated with the given SAW core module and the @@ -335,13 +377,15 @@ heapster_init_env_gen :: BuiltinContext -> Options -> DebugLevel -> heapster_init_env_gen _bic _opts 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 Prelude by default - preludeMod <- liftIO $ scFindModule sc preludeModuleName + -- 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] @@ -349,29 +393,21 @@ heapster_init_env_gen _bic _opts dlevel mod_str llvm_filename = load_sawcore_from_file :: BuiltinContext -> Options -> String -> 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 :: BuiltinContext -> Options -> String -> String -> TopLevel HeapsterEnv heapster_init_env_from_file bic opts mod_filename llvm_filename = - heapster_init_env_from_file_gen - bic opts noDebugLevel mod_filename llvm_filename + heapster_init_env_for_files_gen + bic opts noDebugLevel mod_filename [llvm_filename] heapster_init_env_from_file_debug :: BuiltinContext -> Options -> String -> String -> TopLevel HeapsterEnv heapster_init_env_from_file_debug bic opts mod_filename llvm_filename = - heapster_init_env_from_file_gen - bic opts traceDebugLevel mod_filename llvm_filename - -heapster_init_env_from_file_gen :: BuiltinContext -> Options -> DebugLevel -> - String -> String -> TopLevel HeapsterEnv -heapster_init_env_from_file_gen _bic _opts dlevel mod_filename llvm_filename = - do llvm_mod <- llvm_load_module llvm_filename - sc <- getSharedContext - (saw_mod, saw_mod_name) <- readModuleFromFile mod_filename - liftIO $ tcInsertModule sc saw_mod - mkHeapsterEnv dlevel saw_mod_name [llvm_mod] + heapster_init_env_for_files_gen + bic opts traceDebugLevel mod_filename [llvm_filename] heapster_init_env_for_files_gen :: BuiltinContext -> Options -> DebugLevel -> String -> [String] -> @@ -379,6 +415,7 @@ heapster_init_env_for_files_gen :: BuiltinContext -> Options -> DebugLevel -> heapster_init_env_for_files_gen _bic _opts 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 @@ -404,291 +441,125 @@ heapster_get_cfg _ _ henv nm = Just (Some lm) -> llvm_cfg (Some lm) nm Nothing -> fail ("Could not find CFG for symbol: " ++ nm) + -- | Define a new opaque named permission with the given name, arguments, and --- type, that translates to the given named SAW core definition +-- Crucible type that translates to the given SAW core type with the supplied +-- type description heapster_define_opaque_perm :: BuiltinContext -> Options -> HeapsterEnv -> String -> String -> String -> String -> - TopLevel () -heapster_define_opaque_perm _bic _opts henv nm args_str tp_str term_string = + String -> 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 args_str Some tp_perm <- parseTypeString "permission type" env tp_str sc <- getSharedContext - term_tp <- liftIO $ - translateCompleteTypeInCtx sc env args (nus (cruCtxProxies args) $ - const $ ValuePermRepr tp_perm) - term_ident <- parseAndInsDef henv nm term_tp term_string - let env' = permEnvAddOpaquePerm env nm args tp_perm term_ident + term_tp <- liftIO $ translateExprTypeFunType sc env args + term_ident <- parseAndInsDef henv nm term_tp term_str + d_tp <- tpDescTypeM sc + d_ident <- parseAndInsDef henv (nm ++ "__desc") d_tp d_str + liftIO $ checkTypeAgreesWithDesc sc env nm term_ident args d_ident + let env' = permEnvAddOpaquePerm env 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, that translates to the given named SAW core definition. +-- type, and permission that it unfolds to heapster_define_recursive_perm :: BuiltinContext -> Options -> HeapsterEnv -> - String -> String -> String -> [String] -> - String -> String -> String -> + String -> String -> String -> String -> TopLevel () -heapster_define_recursive_perm _bic _opts henv - nm args_str tp_str p_strs trans_str fold_fun_str unfold_fun_str = - do env <- liftIO $ readIORef $ heapsterEnvPermEnvRef henv - sc <- getSharedContext - - -- Parse the arguments, the type, and the translation type - Some args_ctx <- parseParsedCtxString "argument types" env args_str - let args = parsedCtxCtx args_ctx - Some tp <- parseTypeString "permission type" env tp_str - trans_tp <- liftIO $ - translateCompleteTypeInCtx sc env args (nus (cruCtxProxies args) $ - const $ ValuePermRepr tp) - trans_ident <- parseAndInsDef henv nm trans_tp trans_str - - -- Use permEnvAddRecPermM to tie the knot of adding a recursive - -- permission whose cases and fold/unfold identifiers depend on that - -- recursive permission being defined - env' <- - permEnvAddRecPermM env nm args tp trans_ident NameNonReachConstr - (\_ tmp_env -> - forM p_strs $ - parsePermInCtxString "disjunctive perm" tmp_env args_ctx tp) - (\npn cases tmp_env -> - do let or_tp = foldr1 (mbMap2 ValPerm_Or) cases - nm_tp = nus (cruCtxProxies args) - (\ns -> ValPerm_Named npn (namesToExprs ns) NoPermOffset) - fold_fun_tp <- liftIO $ - translateCompletePureFun sc tmp_env args (singletonValuePerms - <$> or_tp) nm_tp - unfold_fun_tp <- liftIO $ - translateCompletePureFun sc tmp_env args (singletonValuePerms - <$> nm_tp) or_tp - fold_ident <- parseAndInsDef henv ("fold" ++ nm) fold_fun_tp fold_fun_str - unfold_ident <- parseAndInsDef henv ("unfold" ++ nm) unfold_fun_tp unfold_fun_str - return (fold_ident, unfold_ident)) - (\_ _ -> return NoReachMethods) - liftIO $ writeIORef (heapsterEnvPermEnvRef henv) env' - --- | Define a new recursive named permission with the given name, arguments, --- and type, auto-generating SAWCore definitions using `IRT` -heapster_define_irt_recursive_perm :: BuiltinContext -> Options -> HeapsterEnv -> - String -> String -> String -> [String] -> - TopLevel () -heapster_define_irt_recursive_perm _bic _opts henv nm args_str tp_str p_strs = +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 and type + -- Parse the arguments, the type, and the body Some args_ctx <- parseParsedCtxString "argument types" env args_str - let args = parsedCtxCtx args_ctx Some tp <- parseTypeString "permission type" env tp_str - let mnm = heapsterEnvSAWModule henv - trans_ident = mkSafeIdent mnm (nm ++ "_IRT") - - -- Use permEnvAddRecPermM to tie the knot of adding a recursive - -- permission whose cases and fold/unfold identifiers depend on that - -- recursive permission being defined + let args = parsedCtxCtx args_ctx + args_p = CruCtxCons args (ValuePermRepr tp) + mb_p <- parsePermInCtxString "permission" env + (consParsedCtx nm (ValuePermRepr tp) args_ctx) tp p_str + + -- Generate the type description for the body of the recursive perm + d_tp <- tpDescTypeM sc + let d_ident = mkSafeIdent mnm (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 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 nm args tp trans_ident NameNonReachConstr - (\_ tmp_env -> - forM p_strs $ - parsePermInCtxString "disjunctive perm" tmp_env args_ctx tp) - (\npn cases tmp_env -> liftIO $ - do let or_tp = foldr1 (mbMap2 ValPerm_Or) cases - nm_tp = nus (cruCtxProxies args) - (\ns -> ValPerm_Named npn (namesToExprs ns) NoPermOffset) - -- translate the list of type variables - (TypedTerm ls_tm ls_tp, ixs) <- - translateCompletePermIRTTyVars sc tmp_env npn args or_tp - let ls_ident = mkSafeIdent mnm (nm ++ "_IRTTyVars") - scInsertDef sc mnm ls_ident ls_tp ls_tm - -- translate the type description - (TypedTerm d_tm d_tp) <- - translateCompleteIRTDesc sc tmp_env ls_ident args or_tp ixs - let d_ident = mkSafeIdent mnm (nm ++ "_IRTDesc") - scInsertDef sc mnm d_ident d_tp d_tm - -- translate the final definition - (TypedTerm tp_tm tp_tp) <- - translateCompleteIRTDef sc tmp_env ls_ident d_ident args - scInsertDef sc mnm trans_ident tp_tp tp_tm - -- translate the fold and unfold functions - fold_fun_tp <- - translateCompletePureFun sc tmp_env args (singletonValuePerms - <$> or_tp) nm_tp - unfold_fun_tp <- - translateCompletePureFun sc tmp_env args (singletonValuePerms - <$> nm_tp) or_tp - fold_fun_tm <- - translateCompleteIRTFoldFun sc tmp_env ls_ident d_ident - trans_ident args - unfold_fun_tm <- - translateCompleteIRTUnfoldFun sc tmp_env ls_ident d_ident - trans_ident args - let fold_ident = mkSafeIdent mnm ("fold" ++ nm ++ "_IRT") - let unfold_ident = mkSafeIdent mnm ("unfold" ++ nm ++ "_IRT") - scInsertDef sc mnm fold_ident fold_fun_tp fold_fun_tm - scInsertDef sc mnm unfold_ident unfold_fun_tp unfold_fun_tm - return (fold_ident, unfold_ident)) + permEnvAddRecPermM env nm args tp transf_ident d_ident mb_p + NameNonReachConstr (\_ _ -> return NoReachMethods) liftIO $ writeIORef (heapsterEnvPermEnvRef henv) env' --- | Define a new recursive named shape with the given name, arguments, and --- body, auto-generating SAWCore definitions using `IRT` -heapster_define_irt_recursive_shape :: BuiltinContext -> Options -> HeapsterEnv -> - String -> Int -> String -> String -> - TopLevel () -heapster_define_irt_recursive_shape _bic _opts henv nm w_int args_str body_str = + +-- | 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. +heapster_define_reachability_perm :: BuiltinContext -> Options -> HeapsterEnv -> + String -> String -> String -> String -> + String -> TopLevel () +heapster_define_reachability_perm _bic _opts henv nm args_str tp_str p_str trans_fun_str = do env <- liftIO $ readIORef $ heapsterEnvPermEnvRef henv - SomeKnownNatGeq1 w <- - failOnNothing "Shape width must be positive" $ someKnownNatGeq1 w_int + let mnm = heapsterEnvSAWModule henv sc <- getSharedContext - -- Parse the arguments - Some args_ctx <- parseParsedCtxString "argument types" env args_str + -- Parse the arguments, the type, and the translation type + Some (tp :: TypeRepr tp) <- parseTypeString "permission type" env tp_str + (Some pre_args_ctx, + last_args_ctx :: ParsedCtx (RNil :> tp)) <- + do some_args_ctx <- parseParsedCtxString "argument types" env 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 - mnm = heapsterEnvSAWModule henv - trans_ident = mkSafeIdent mnm (nm ++ "_IRT") - - -- Parse the body - let tmp_nsh = partialRecShape w nm args Nothing trans_ident - tmp_env = permEnvAddNamedShape env tmp_nsh - mb_args = nus (cruCtxProxies args) namesToExprs - body <- parseExprInCtxString tmp_env (LLVMShapeRepr w) args_ctx body_str - abs_body <- - failOnNothing "recursive shape applied to different arguments in its body" $ - fmap (mbCombine RL.typeCtxProxies) . mbMaybe $ - mbMap2 (abstractNS nm args) mb_args body - - -- Add the named shape to scope using the functions from IRTTranslation.hs - env' <- liftIO $ addIRTRecShape sc mnm env nm args abs_body trans_ident - liftIO $ writeIORef (heapsterEnvPermEnvRef henv) env' - --- | A temporary named recursive shape with `error`s for `fold_ident`, --- `unfold_ident`, and optionally `body`. -partialRecShape :: NatRepr w -> String -> CruCtx args -> - Maybe (Mb (args :> LLVMShapeType w) (PermExpr (LLVMShapeType w))) -> - Ident -> NamedShape 'True args w -partialRecShape _ nm args mb_body trans_ident = - let body_err = - error "Analyzing recursive shape cases before it is defined!" in - NamedShape nm args $ - RecShapeBody (fromMaybe body_err mb_body) trans_ident Nothing - --- | Given a named recursive shape name, arguments, body, and `trans_ident`, --- insert its definition and definitions for its fold and unfold functions --- using the functions in `IRTTranslation.hs`. Returns a modified --- `PermEnv` with the new named shape added. -addIRTRecShape :: (1 <= w, KnownNat w) => SharedContext -> ModuleName -> - PermEnv -> String -> CruCtx args -> - Mb (args :> LLVMShapeType w) (PermExpr (LLVMShapeType w)) -> - Ident -> IO PermEnv -addIRTRecShape sc mnm env nm args body trans_ident = - do let tmp_nsh = partialRecShape knownNat nm args (Just body) trans_ident - tmp_env = permEnvAddNamedShape env tmp_nsh - nsh_unf = unfoldNamedShape tmp_nsh <$> - nus (cruCtxProxies args) namesToExprs - nsh_fld = nus (cruCtxProxies args) $ \ns -> - PExpr_NamedShape Nothing Nothing tmp_nsh (namesToExprs ns) - -- translate the list of type variables - (TypedTerm ls_tm ls_tp, ixs) <- - translateCompleteShapeIRTTyVars sc tmp_env tmp_nsh - let ls_ident = mkSafeIdent mnm (nm ++ "_IRTTyVars") - scInsertDef sc mnm ls_ident ls_tp ls_tm - -- translate the type description - (TypedTerm d_tm d_tp) <- - translateCompleteIRTDesc sc tmp_env ls_ident args nsh_unf ixs - let d_ident = mkSafeIdent mnm (nm ++ "_IRTDesc") - scInsertDef sc mnm d_ident d_tp d_tm - -- translate the final definition - (TypedTerm tp_tm tp_tp) <- - translateCompleteIRTDef sc tmp_env ls_ident d_ident args - scInsertDef sc mnm trans_ident tp_tp tp_tm - -- translate the fold and unfold functions - fold_fun_tp <- - translateCompletePureFun sc tmp_env args - (singletonValuePerms . ValPerm_LLVMBlockShape <$> nsh_unf) - (ValPerm_LLVMBlockShape <$> nsh_fld) - unfold_fun_tp <- - translateCompletePureFun sc tmp_env args - (singletonValuePerms . ValPerm_LLVMBlockShape <$> nsh_fld) - (ValPerm_LLVMBlockShape <$> nsh_unf) - fold_fun_tm <- - translateCompleteIRTFoldFun sc tmp_env ls_ident d_ident - trans_ident args - unfold_fun_tm <- - translateCompleteIRTUnfoldFun sc tmp_env ls_ident d_ident - trans_ident args - let fold_ident = mkSafeIdent mnm ("fold" ++ nm ++ "_IRT") - let unfold_ident = mkSafeIdent mnm ("unfold" ++ nm ++ "_IRT") - scInsertDef sc mnm fold_ident fold_fun_tp fold_fun_tm - scInsertDef sc mnm unfold_ident unfold_fun_tp unfold_fun_tm - let nsh = NamedShape nm args $ - RecShapeBody body trans_ident (Just (fold_ident, unfold_ident)) - return $ permEnvAddNamedShape env nsh - --- | Define a new reachability permission -heapster_define_reachability_perm :: BuiltinContext -> Options -> HeapsterEnv -> - String -> String -> String -> String -> - String -> String -> String -> String -> - TopLevel () -heapster_define_reachability_perm _bic _opts henv - nm args_str tp_str p_str trans_tp_str fold_fun_str unfold_fun_str trans_fun_str = - do env <- liftIO $ readIORef $ heapsterEnvPermEnvRef henv - sc <- getSharedContext - - -- Parse the arguments, the type, and the translation type - Some (tp :: TypeRepr tp) <- parseTypeString "permission type" env tp_str - (Some pre_args_ctx, - last_args_ctx :: ParsedCtx (RNil :> tp)) <- - do some_args_ctx <- parseParsedCtxString "argument types" env 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 - trans_tp <- liftIO $ - translateCompleteTypeInCtx sc env args $ - nus (cruCtxProxies args) $ const $ ValuePermRepr tp - trans_tp_ident <- parseAndInsDef henv nm trans_tp trans_tp_str - - -- Use permEnvAddRecPermM to tie the knot of adding a recursive - -- permission whose cases and fold/unfold identifiers depend on that - -- recursive permission being defined - env' <- - permEnvAddRecPermM env nm args tp trans_tp_ident NameReachConstr - (\_ tmp_env -> - -- Return the disjunctive cases, which for P are eq(e) and p - do p <- parsePermInCtxString "disjunctive perm" tmp_env args_ctx tp p_str - return [nus (cruCtxProxies args) (\(_ :>: n) -> - ValPerm_Eq $ PExpr_Var n), - p]) - (\npn cases tmp_env -> - -- Return the Idents for the fold and unfold functions, which - -- includes type-checking them, using or_tp = \args. rec perm body, - -- where the body = the or of all the cases, and nm_tp = - -- \args.P - do let or_tp = foldr1 (mbMap2 ValPerm_Or) cases - nm_tp = nus (cruCtxProxies args) - (\ns -> ValPerm_Named npn (namesToExprs ns) NoPermOffset) - -- Typecheck fold against body -o P - fold_fun_tp <- liftIO $ - translateCompletePureFun sc tmp_env args (singletonValuePerms <$> - or_tp) nm_tp - -- Typecheck fold against P -o body - unfold_fun_tp <- liftIO $ - translateCompletePureFun sc tmp_env args (singletonValuePerms <$> - nm_tp) or_tp - -- Build identifiers foldXXX and unfoldXXX - fold_ident <- - parseAndInsDef henv ("fold" ++ nm) fold_fun_tp fold_fun_str - unfold_ident <- - parseAndInsDef henv ("unfold" ++ nm) unfold_fun_tp unfold_fun_str - return (fold_ident, unfold_ident)) - (\npn tmp_env -> + args_p = CruCtxCons args (ValuePermRepr tp) + mb_p <- parsePermInCtxString "permission" env + (consParsedCtx nm (ValuePermRepr tp) args_ctx) tp p_str + + -- Generate the type description for the body of the recursive perm + d_tp <- tpDescTypeM sc + let d_ident = mkSafeIdent mnm (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 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 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 $ - translateCompletePureFun sc tmp_env (CruCtxCons args tp) + translateCompletePureFunType sc tmp_env (CruCtxCons args tp) (nus (cruCtxProxies args :>: Proxy) $ \(ns :>: y :>: z) -> MNil :>: ValPerm_Named npn (namesToExprs (ns :>: y)) NoPermOffset :>: @@ -696,9 +567,61 @@ heapster_define_reachability_perm _bic _opts henv (nus (cruCtxProxies args :>: Proxy) $ \(ns :>: _ :>: z) -> ValPerm_Named npn (namesToExprs (ns :>: z)) NoPermOffset) trans_ident <- - parseAndInsDef henv ("trans" ++ nm) trans_fun_tp trans_fun_str + parseAndInsDef henv ("trans_" ++ nm) trans_fun_tp trans_fun_str return (ReachMethods trans_ident)) - liftIO $ writeIORef (heapsterEnvPermEnvRef henv) env' + 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 +heapster_define_recursive_shape :: BuiltinContext -> Options -> HeapsterEnv -> + String -> Int -> String -> String -> + 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 args_str + let args = parsedCtxCtx args_ctx + mb_sh <- parseExprInCtxString env (LLVMShapeRepr w) + (consParsedCtx nm (LLVMShapeRepr w) args_ctx) body_str + + -- Add the shape to the current environment + env' <- addRecNamedShape henv 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. @@ -710,11 +633,12 @@ heapster_define_perm _bic _opts henv nm args_str tp_str perm_string = Some args_ctx <- parseParsedCtxString "argument types" env args_str let args = parsedCtxCtx args_ctx Some tp_perm <- parseTypeString "permission type" env tp_str - perm <- parsePermInCtxString "disjunctive perm" env + perm <- parsePermInCtxString "permission body" env args_ctx tp_perm perm_string let env' = permEnvAddDefinedPerm env 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 heapster_define_llvmshape :: BuiltinContext -> Options -> HeapsterEnv -> @@ -730,14 +654,15 @@ heapster_define_llvmshape _bic _opts henv nm w_int args_str sh_str = let env' = withKnownNat w $ permEnvAddDefinedShape env 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, and SAW core expression for a +-- 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 +-- SAW core type, and SAW core expression for a type description of that type heapster_define_opaque_llvmshape :: BuiltinContext -> Options -> HeapsterEnv -> - String -> Int -> String -> String -> String -> - TopLevel () -heapster_define_opaque_llvmshape _bic _opts henv nm w_int args_str len_str tp_str = + String -> Int -> String -> String -> + String -> String -> 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 @@ -745,17 +670,20 @@ heapster_define_opaque_llvmshape _bic _opts henv nm w_int args_str len_str tp_st let args = parsedCtxCtx args_ctx mb_len <- parseExprInCtxString env (BVRepr w) args_ctx len_str sc <- getSharedContext - tp_tp <- liftIO $ - translateCompleteTypeInCtx sc env args $ - nus (cruCtxProxies args) $ const $ ValuePermRepr $ LLVMShapeRepr w + d_tp <- tpDescTypeM sc + d_id <- parseAndInsDef henv (nm ++ "__desc") d_tp d_str + tp_tp <- liftIO $ translateExprTypeFunType sc env args tp_id <- parseAndInsDef henv nm tp_tp tp_str - let env' = withKnownNat w $ permEnvAddOpaqueShape env nm args mb_len tp_id + liftIO $ checkTypeAgreesWithDesc sc env nm tp_id args d_id + let env' = + withKnownNat w $ permEnvAddOpaqueShape env 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 heapster_define_rust_type_qual_opt :: BuiltinContext -> Options -> HeapsterEnv -> - Maybe String -> String -> TopLevel () + Maybe String -> String -> 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 @@ -779,13 +707,9 @@ heapster_define_rust_type_qual_opt _bic _opts henv maybe_crate str = } env' = permEnvAddNamedShape env nsh liftIO $ writeIORef (heapsterEnvPermEnvRef henv) env' - RecShape nm ctx sh -> - do sc <- getSharedContext - let mnm = heapsterEnvSAWModule henv - nm' = crated_nm nm - trans_ident = mkSafeIdent mnm (nm' ++ "_IRT") - env' <- - liftIO $ addIRTRecShape sc mnm env nm' ctx sh trans_ident + RecShape nm ctx mb_sh -> + do let nm' = crated_nm nm + env' <- addRecNamedShape henv nm' ctx w mb_sh liftIO $ writeIORef (heapsterEnvPermEnvRef henv) env' @@ -989,7 +913,7 @@ heapster_find_symbol_commands _bic _opts henv str = -- | 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. +-- @"trait::method"@. Fails if there is not exactly one such symbol. heapster_find_trait_method_symbol :: BuiltinContext -> Options -> HeapsterEnv -> String -> TopLevel String heapster_find_trait_method_symbol bic opts henv str = @@ -1013,6 +937,7 @@ heapster_find_trait_method_symbol bic opts henv str = trait = intercalate ".." $ splitOn "::" colonTrait + -- | Assume that the given named function has the supplied type and translates -- to a SAW core definition given by the second name heapster_assume_fun_rename :: BuiltinContext -> Options -> HeapsterEnv -> @@ -1042,19 +967,6 @@ heapster_assume_fun_rename _bic _opts henv nm nm_to perms_string term_string = (globalOpenTerm term_ident) liftIO $ writeIORef (heapsterEnvPermEnvRef henv) env'' -heapster_translate_rust_type :: BuiltinContext -> Options -> HeapsterEnv -> - String -> 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 perms_string - liftIO $ putStrLn $ permPrettyString emptyPPInfo fun_perm - -- | 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 -> String -> Term -> TopLevel Ident @@ -1077,7 +989,7 @@ insPrimitive henv nm tp = -- | Assume that the given named function has the supplied type and translates -- to a SAW core definition given by the second name heapster_assume_fun_rename_prim :: BuiltinContext -> Options -> HeapsterEnv -> - String -> String -> String -> TopLevel () + String -> String -> String -> 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) @@ -1145,16 +1057,25 @@ heapster_assume_fun_multi _bic _opts henv nm perms_terms_strings = 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 'String' representation of its permission heapster_typecheck_mut_funs :: BuiltinContext -> Options -> HeapsterEnv -> [(String, String)] -> 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 'String' heapster_typecheck_mut_funs_rename :: BuiltinContext -> Options -> HeapsterEnv -> [(String, String, String)] -> TopLevel () -heapster_typecheck_mut_funs_rename _bic _opts henv fn_names_and_perms = +heapster_typecheck_mut_funs_rename _bic opts henv fn_names_and_perms = do let (fst_nm, _, _) = head fn_names_and_perms Some lm <- failOnNothing ("Could not find symbol definition: " ++ fst_nm) (lookupModDefiningSym henv fst_nm) @@ -1169,7 +1090,7 @@ heapster_typecheck_mut_funs_rename _bic _opts henv fn_names_and_perms = Right _ -> fail "LLVM arch width is < 16!" LeqProof <- case decideLeq (knownNat @1) w of Left pf -> return pf - Right _ -> fail "PANIC: 1 > 16!" + Right _ -> panic "heapster_typecheck_mut_funs_rename" ["1 > 16!"] some_cfgs_and_perms <- forM fn_names_and_perms $ \(nm, nm_to, perms_string) -> do AnyCFG cfg <- failOnNothing ("Could not find symbol definition: " ++ nm) =<< @@ -1199,13 +1120,34 @@ heapster_typecheck_mut_funs_rename _bic _opts henv fn_names_and_perms = 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 :: String -> Term -> TopLevel () + warnErrs nm (asApplyAll -> (asGlobalDef -> Just "SpecM.errorS", + [_ev, _a, asStringLit -> Just msg])) + | Just msg_body <- stripPrefix implicationFailurePrefix (T.unpack msg) + = let pref = "WARNING: Heapster implication failure while typechecking " + in io $ printOutLn opts Warn (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 (asCtor -> Just (_, args)) = mapM_ (warnErrs nm) args + 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 -> String -> String -> 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 -> String -> String -> String -> TopLevel () heapster_typecheck_fun_rename bic opts henv fn_name fn_name_to perms_string = @@ -1231,22 +1173,35 @@ heapster_set_event_type :: BuiltinContext -> Options -> HeapsterEnv -> heapster_set_event_type _bic _opts henv term_string = do sc <- getSharedContext ev_tp <- - liftIO $ completeOpenTerm sc $ dataTypeOpenTerm "Prelude.EvType" [] + liftIO $ completeOpenTerm sc $ dataTypeOpenTerm "SpecM.EvType" [] ev_id <- parseAndInsDef henv "HeapsterEv" ev_tp term_string liftIO $ modifyIORef' (heapsterEnvPermEnvRef henv) $ \env -> - env { permEnvSpecMEventType = ev_id } + env { permEnvEventType = EventType (globalOpenTerm ev_id) } -heapster_print_fun_trans :: BuiltinContext -> Options -> HeapsterEnv -> - String -> TopLevel () -heapster_print_fun_trans _bic _opts henv fn_name = - do pp_opts <- getTopLevelPPOpts - sc <- getSharedContext +-- | Fetch the SAW core definition associated with a name +heapsterFunTrans :: HeapsterEnv -> String -> 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 fn_name + bodies <- + fmap (fmap fst) $ + liftIO $ scResolveName sc $ T.pack $ 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 +heapster_print_fun_trans :: BuiltinContext -> Options -> HeapsterEnv -> + String -> TopLevel () +heapster_print_fun_trans _bic _opts henv fn_name = + do pp_opts <- getTopLevelPPOpts + fun_term <- heapsterFunTrans henv fn_name liftIO $ putStrLn $ 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 :: BuiltinContext -> Options -> HeapsterEnv -> String -> TopLevel () heapster_export_coq _bic _opts henv filename = @@ -1256,24 +1211,43 @@ heapster_export_coq _bic _opts henv filename = let coq_doc = vcat [preamble coq_trans_conf { postPreamble = - "From CryptolToCoq Require Import SAWCorePrelude.\n" ++ - "From CryptolToCoq Require Import SAWCoreBitvectors.\n" ++ - "From CryptolToCoq Require Import SpecMExtra.\n" }, + "From CryptolToCoq Require Import " ++ + "SAWCorePrelude SpecMPrimitivesForSAWCore SAWCoreBitvectors.\n" }, translateSAWModule coq_trans_conf 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 +heapster_translate_rust_type :: BuiltinContext -> Options -> HeapsterEnv -> + String -> 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 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 heapster_parse_test :: BuiltinContext -> Options -> Some LLVMModule -> - String -> String -> TopLevel () + String -> String -> 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 @@ -1286,7 +1260,9 @@ heapster_parse_test _bic _opts _some_lm@(Some lm) fn_name perms_string = ret perms_string liftIO $ putStrLn $ permPrettyString emptyPPInfo fun_perm -heapster_dump_ide_info :: BuiltinContext -> Options -> HeapsterEnv -> String -> TopLevel () +-- | Dump the IDE information contained in a Heapster environment to a JSON file +heapster_dump_ide_info :: BuiltinContext -> Options -> HeapsterEnv -> String -> + TopLevel () heapster_dump_ide_info _bic _opts henv filename = do -- heapster_typecheck_mut_funs bic opts henv [(fnName, perms)] penv <- io $ readIORef (heapsterEnvPermEnvRef henv) diff --git a/src/SAWScript/Interpreter.hs b/src/SAWScript/Interpreter.hs index d366f94490..701dc1475a 100644 --- a/src/SAWScript/Interpreter.hs +++ b/src/SAWScript/Interpreter.hs @@ -1595,18 +1595,18 @@ primitives = Map.fromList ] , prim "write_coq_cryptol_primitives_for_sawcore" - "String -> String -> [(String, String)] -> [String] -> TopLevel ()" + "String -> String -> String -> [(String, String)] -> [String] -> TopLevel ()" (pureVal writeCoqCryptolPrimitivesForSAWCore) Experimental [ "Write out a representation of cryptol-saw-core's Cryptol.sawcore and " , "CryptolM.sawcore in Gallina syntax for Coq." - , "The first two arguments are the names of the output files for translating " - , "Cryptol.sawcore and CryptolM.sawcore, respectively." + , "The first three arguments are the names of the output files for translating " + , "Cryptol.sawcore, SpecM.sawcore, and CryptolM.sawcore, respectively." , "Use an empty string to output to standard output." - , "The third argument is a list of pairs of notation substitutions:" + , "The fourth 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." + , "The fifth argument is a list of identifiers to skip translating." ] , prim "offline_coq" "String -> ProofScript ()" @@ -4313,6 +4313,12 @@ primitives = Map.fromList , " 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 @@ -4347,7 +4353,7 @@ primitives = Map.fromList [ "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 (`Prelude.refinesS`) of the" + , " SAWCore term which is the refinement (`SpecM.refinesS`) of the" , " given terms, with the given variables generalized with a Pi type." ] --------------------------------------------------------------------- @@ -4432,59 +4438,45 @@ primitives = Map.fromList ] , prim "heapster_define_opaque_perm" - "HeapsterEnv -> String -> String -> String -> String -> TopLevel HeapsterEnv" + "HeapsterEnv -> String -> String -> String -> String -> String -> TopLevel HeapsterEnv" (bicVal heapster_define_opaque_perm) Experimental - [ "heapster_define_opaque_perm nm args tp trans defines an opaque named" + [ "heapster_define_opaque_perm nm args tp trans d defines an opaque named" , " Heapster permission named nm with arguments parsed from args and type" - , " parsed from tp that translates to the named type trans" + , " tp that translates to the SAW core type trans with type description d" ] , prim "heapster_define_recursive_perm" - "HeapsterEnv -> String -> String -> String -> [String] -> String -> String -> String -> TopLevel HeapsterEnv" + "HeapsterEnv -> String -> String -> String -> String -> TopLevel HeapsterEnv" (bicVal heapster_define_recursive_perm) Experimental - [ "heapster_define_recursive_perm env name arg_ctx value_type" - , " [ p1, ..., pn ] trans_tp fold_fun unfold_fun defines an recursive named" + [ "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 value_type that translates to the named type" - , " trans_tp. The resulting permission is equivalent to the permission" - , " p1 \\/ ... \\/ pn, where the pi can contain name." + , " type parsed from tp that translates to permissions p, which can" + , " resurively use nm (with no arguments) in those permissions" ] - , prim "heapster_define_irt_recursive_perm" - "HeapsterEnv -> String -> String -> String -> [String] -> TopLevel HeapsterEnv" - (bicVal heapster_define_irt_recursive_perm) + , prim "heapster_define_reachability_perm" + "HeapsterEnv -> String -> String -> String -> String -> String -> TopLevel HeapsterEnv" + (bicVal heapster_define_reachability_perm) Experimental - [ "heapster_define_irt_recursive_perm env name arg_ctx value_type" - , " [ p1, ..., pn ] defines an recursive named Heapster permission named" - , " nm with arguments parsed from args_ctx and type parsed from value_type" - , " that translates to the appropriate IRT type. The resulting permission" - , " is equivalent to the permission p1 \\/ ... \\/ pn, where the pi can" - , " contain name." + [ "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_irt_recursive_shape" + , prim "heapster_define_recursive_shape" "HeapsterEnv -> String -> Int -> String -> String -> TopLevel HeapsterEnv" - (bicVal heapster_define_irt_recursive_shape) + (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 translates to the appropriate" - , " IRT type. The resulting shape is equivalent to the shape body_sh," - , " where body_sh can contain name." - ] - - , prim "heapster_define_reachability_perm" - "HeapsterEnv -> String -> String -> String -> String -> String -> String -> String -> String -> TopLevel HeapsterEnv" - (bicVal heapster_define_reachability_perm) - Experimental - [ "heapster_define_recursive_perm env name arg_ctx value_type" - , " [ p1, ..., pn ] trans_tp fold_fun unfold_fun defines an recursive named" - , " Heapster permission named nm with arguments parsed from args_ctx and" - , " type parsed from value_type that translates to the named type" - , " trans_tp. The resulting permission is equivalent to he permission" - , " p1 \\/ ... \\/ pn, where the pi can contain name." + , " 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" @@ -4506,10 +4498,10 @@ primitives = Map.fromList ] , prim "heapster_define_opaque_llvmshape" - "HeapsterEnv -> String -> Int -> String -> String -> String -> TopLevel HeapsterEnv" + "HeapsterEnv -> String -> Int -> String -> String -> String -> String -> TopLevel HeapsterEnv" (bicVal heapster_define_opaque_llvmshape) Experimental - [ "heapster_define_opaque_llvmshape henv nm w args len tp defines a Heapster" + [ "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" @@ -4518,8 +4510,9 @@ primitives = Map.fromList , " 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," - , " and tp gives the translation of the shape as a SAW core type over the" - , " translation of the arguments to SAW core variables." + , " 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" diff --git a/src/SAWScript/Prover/Exporter.hs b/src/SAWScript/Prover/Exporter.hs index a4d858ee55..12c4ed2293 100644 --- a/src/SAWScript/Prover/Exporter.hs +++ b/src/SAWScript/Prover/Exporter.hs @@ -71,7 +71,8 @@ import Lang.JVM.ProcessUtils (readProcessExitIfFailure) import Verifier.SAW.CryptolEnv (initCryptolEnv, loadCryptolModule, ImportPrimitiveOptions(..), mkCryEnv) import Verifier.SAW.Cryptol.Prelude (cryptolModule, scLoadPreludeModule, scLoadCryptolModule) -import Verifier.SAW.Cryptol.PreludeM (cryptolMModule, scLoadCryptolMModule) +import Verifier.SAW.Cryptol.PreludeM (cryptolMModule, specMModule, + scLoadSpecMModule, scLoadCryptolMModule) import Verifier.SAW.Cryptol.Monadify (defaultMonEnv, monadifyCryptolModule) import Verifier.SAW.ExternalFormat(scWriteExternal) import Verifier.SAW.FiniteValue @@ -441,6 +442,22 @@ 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 @@ -543,32 +560,41 @@ writeCoqSAWCorePrelude outputFile notations skips = do writeFile outputFile (show . vcat $ [ Coq.preamble configuration, doc ]) writeCoqCryptolPrimitivesForSAWCore :: - FilePath -> FilePath -> + FilePath -> FilePath -> FilePath -> [(String, String)] -> [String] -> IO () -writeCoqCryptolPrimitivesForSAWCore outputFile outputFileM notations skips = do +writeCoqCryptolPrimitivesForSAWCore cryFile specMFile cryMFile 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) let configuration = withImportSAWCorePreludeExtra $ withImportSAWCorePrelude $ coqTranslationConfiguration notations skips + let configuration_spec = + withImportCryptolPrimitivesForSAWCore $ + withImportSpecM configuration let configuration_mon = - withImportCryptolPrimitivesForSAWCore configuration + withImportSpecMPrimitivesForSAWCore configuration let doc = Coq.translateSAWModule configuration m - writeFile outputFile (show . vcat $ [ Coq.preamble configuration - , doc - ]) + writeFile cryFile (show . vcat $ [ Coq.preamble configuration + , doc + ]) + let doc_spec = Coq.translateSAWModule configuration_spec m_spec + writeFile specMFile (show . vcat $ [ Coq.preamble configuration_spec + , doc_spec + ]) let doc_mon = Coq.translateSAWModule configuration_mon m_mon - writeFile outputFileM (show . vcat $ [ Coq.preamble configuration_mon - , doc_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/src/SAWScript/Prover/MRSolver/Evidence.hs b/src/SAWScript/Prover/MRSolver/Evidence.hs index bc627954f5..c265d32e1e 100644 --- a/src/SAWScript/Prover/MRSolver/Evidence.hs +++ b/src/SAWScript/Prover/MRSolver/Evidence.hs @@ -36,6 +36,7 @@ import Data.Set (Set) import qualified Data.Set as Set import Verifier.SAW.Term.Functor +import Verifier.SAW.Term.Pretty import Verifier.SAW.Recognizer import Verifier.SAW.Cryptol.Monadify import SAWScript.Prover.SolverStats @@ -47,20 +48,14 @@ import SAWScript.Prover.MRSolver.Term -- * Function Refinement Assumptions ---------------------------------------------------------------------- --- | A representation of a term of the form: --- @(a1:A1) -> ... -> (an:An) -> refinesS ev1 ev2 stack1 stack2 rtp1 rtp2 t1 t2@ +-- | 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 LHS event type of the refinement, i.e. @ev1@ above - refnEv1 :: Term, - -- | The RHS event type of the refinement, i.e. @ev2@ above - refnEv2 :: Term, - -- | The LHS stack type of the refinement, i.e. @stack1@ above - refnStack1 :: Term, - -- | The RHS stack type of the refinement, i.e. @stack2@ above - refnStack2 :: 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 @@ -77,20 +72,13 @@ data RefinesS = RefinesS { -- @RefinesS [(a1,A1), ..., (an,An)] ev1 ev2 stack1 stack2 rtp1 rtp2 t1 t2@ asRefinesS :: Recognizer Term RefinesS asRefinesS (asPiList -> (args, asApplyAll -> - (asGlobalDef -> Just "Prelude.refinesS", - [ev1, ev2, stack1, stack2, - asApplyAll -> (asGlobalDef -> Just "Prelude.eqPreRel", _), - asApplyAll -> (asGlobalDef -> Just "Prelude.eqPostRel", _), - rtp1, rtp2, - asApplyAll -> (asGlobalDef -> Just "Prelude.eqRR", _), + (asGlobalDef -> Just "SpecM.refinesS", + [ev, rtp1, rtp2, + asApplyAll -> (asGlobalDef -> Just "SpecM.eqRR", _), t1, t2]))) = - Just $ RefinesS args ev1 ev2 stack1 stack2 rtp1 rtp2 t1 t2 -asRefinesS (asPiList -> (args, asApplyAll -> - (asGlobalDef -> Just "Prelude.refinesS_eq", - [ev, stack, rtp, t1, t2]))) = - Just $ RefinesS args ev ev stack stack rtp rtp t1 t2 -asRefinesS (asPiList -> (_, asApplyAll -> (asGlobalDef -> Just "Prelude.refinesS", _))) = - error "FIXME: MRSolver does not yet accept refinesS goals with non-trivial RPre/RPost/RR" + 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 @@ -121,17 +109,14 @@ data FunAssump t = FunAssump { } -- | Recognizes a term of the form: --- @(a1:A1) -> ... -> (an:An) -> refinesS_eq ev stack rtp (f b1 ... bm) t2@, +-- @(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 :: Maybe t -> Recognizer Term (FunAssump t) asFunAssump ann (asRefinesS -> Just (RefinesS args - (asGlobalDef -> Just "Prelude.VoidEv") - (asGlobalDef -> Just "Prelude.VoidEv") - (asGlobalDef -> Just "Prelude.emptyFunStack") - (asGlobalDef -> Just "Prelude.emptyFunStack") + (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 @@ -181,12 +166,15 @@ listFunAssumps = concatMap Map.elems . HashMap.elems -- | A global MR Solver environment data MREnv = MREnv { -- | The debug level, which controls debug printing - mreDebugLevel :: Int + mreDebugLevel :: Int, + -- | The options for pretty-printing to be used by MRSolver in error messages + -- and debug printing + mrePPOpts :: PPOpts } -- | The empty 'MREnv' emptyMREnv :: MREnv -emptyMREnv = MREnv { mreDebugLevel = 0 } +emptyMREnv = MREnv { mreDebugLevel = 0, mrePPOpts = defaultPPOpts } -- | Set the debug level of a Mr Solver environment mrEnvSetDebugLevel :: Int -> MREnv -> MREnv diff --git a/src/SAWScript/Prover/MRSolver/Monad.hs b/src/SAWScript/Prover/MRSolver/Monad.hs index 72cc2a0aab..303a9fb8d7 100644 --- a/src/SAWScript/Prover/MRSolver/Monad.hs +++ b/src/SAWScript/Prover/MRSolver/Monad.hs @@ -24,7 +24,9 @@ monadic combinators for operating on terms. module SAWScript.Prover.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) @@ -48,11 +50,13 @@ import qualified Data.Set as Set import Prettyprinter +import Verifier.SAW.Utils (panic) import Verifier.SAW.Term.Functor import Verifier.SAW.Term.CtxTerm (MonadTerm(..)) import Verifier.SAW.Term.Pretty import Verifier.SAW.SCTypeCheck import Verifier.SAW.SharedTerm +import Verifier.SAW.Module (Def(..)) import Verifier.SAW.Recognizer import Verifier.SAW.Cryptol.Monadify import SAWScript.Prover.SolverStats @@ -72,21 +76,26 @@ data FailCtx = FailCtxRefines NormComp NormComp | FailCtxCoIndHyp CoIndHyp | FailCtxMNF Term + | FailCtxProveRel Term Term deriving Show -- | That's MR. Failure to you data MRFailure - = TermsNotRel Bool Term Term - | TypesNotRel Bool Type Type + = TermsNotEq Term Term + | TypesNotEq Type Type + | TypesNotUnifiable Type Type + | BindTypesNotUnifiable Type Type + | ReturnTypesNotEq Type Type + | FunNamesDoNotRefine FunName [Term] FunName [Term] | CompsDoNotRefine NormComp NormComp - | ReturnNotError Term + | ReturnNotError (Either Term Term) Term | FunsNotEq FunName FunName | CannotLookupFunDef FunName | RecursiveUnfold FunName - | MalformedLetRecTypes Term + | MalformedTpDescList Term | MalformedDefs Term | MalformedComp Term - | NotCompFunType Term + | NotCompFunType Term Term | AssertionNotProvable Term | AssumptionNotProvable Term | InvariantNotProvable FunName FunName Term @@ -98,12 +107,6 @@ data MRFailure | MRFailureDisj MRFailure MRFailure deriving Show -pattern TermsNotEq :: Term -> Term -> MRFailure -pattern TermsNotEq t1 t2 = TermsNotRel False t1 t2 - -pattern TypesNotEq :: Type -> Type -> MRFailure -pattern TypesNotEq t1 t2 = TypesNotRel False t1 t2 - -- | Remove the context from a 'MRFailure', i.e. remove all applications of the -- 'MRFailureLocalVar' and 'MRFailureCtx' constructors mrFailureWithoutCtx :: MRFailure -> MRFailure @@ -115,13 +118,14 @@ mrFailureWithoutCtx (MRFailureDisj err1 err2) = mrFailureWithoutCtx err = err -- | Pretty-print an object prefixed with a 'String' that describes it -ppWithPrefix :: PrettyInCtx a => String -> a -> PPInCtxM SawDoc -ppWithPrefix str a = (pretty str <>) <$> nest 2 <$> (line <>) <$> prettyInCtx a +prettyPrefix :: PrettyInCtx a => String -> a -> PPInCtxM SawDoc +prettyPrefix str a = + (pretty str <>) <$> nest 2 <$> (line <>) <$> prettyInCtx a -- | Pretty-print two objects, prefixed with a 'String' and with a separator -ppWithPrefixSep :: (PrettyInCtx a, PrettyInCtx b) => +prettyPrefixSep :: (PrettyInCtx a, PrettyInCtx b) => String -> a -> String -> b -> PPInCtxM SawDoc -ppWithPrefixSep d1 t2 d3 t4 = +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)) @@ -133,67 +137,83 @@ vsepM = fmap vsep . sequence instance PrettyInCtx FailCtx where prettyInCtx (FailCtxRefines m1 m2) = group <$> nest 2 <$> - ppWithPrefixSep "When proving refinement:" m1 "|=" m2 + prettyPrefixSep "When proving refinement:" m1 "|=" m2 prettyInCtx (FailCtxCoIndHyp hyp) = group <$> nest 2 <$> - ppWithPrefix "When doing co-induction with hypothesis:" hyp + 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 (TermsNotRel False t1 t2) = - ppWithPrefixSep "Could not prove terms equal:" t1 "and" t2 - prettyInCtx (TermsNotRel True t1 t2) = - ppWithPrefixSep "Could not prove terms heterogeneously related:" t1 "and" t2 - prettyInCtx (TypesNotRel False tp1 tp2) = - ppWithPrefixSep "Types not equal:" tp1 "and" tp2 - prettyInCtx (TypesNotRel True tp1 tp2) = - ppWithPrefixSep "Types not heterogeneously related:" tp1 "and" tp2 + 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) = - ppWithPrefixSep "Could not prove refinement: " m1 "|=" m2 - prettyInCtx (ReturnNotError t) = - ppWithPrefix "errorS computation not equal to:" (RetS t) + 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) = - ppWithPrefix "Could not find definition for function:" nm + prettyPrefix "Could not find definition for function:" nm prettyInCtx (RecursiveUnfold nm) = - ppWithPrefix "Recursive unfolding of function inside its own body:" nm - prettyInCtx (MalformedLetRecTypes t) = - ppWithPrefix "Not a ground LetRecTypes list:" t + prettyPrefix "Recursive unfolding of function inside its own body:" nm + prettyInCtx (MalformedTpDescList t) = + prettyPrefix "Not a list of type descriptions:" t prettyInCtx (MalformedDefs t) = - ppWithPrefix "Cannot handle multiFixS recursive definitions term:" t + prettyPrefix "Cannot handle multiFixS recursive definitions term:" t prettyInCtx (MalformedComp t) = - ppWithPrefix "Could not handle computation:" t - prettyInCtx (NotCompFunType tp) = - ppWithPrefix "Not a computation or computational function type:" tp + 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) = - ppWithPrefix "Failed to prove assertion:" cond + prettyPrefix "Failed to prove assertion:" cond prettyInCtx (AssumptionNotProvable cond) = - ppWithPrefix "Failed to prove condition for `assuming`:" 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 (x:) $ prettyInCtx 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) = - ppWithPrefixSep "Tried two comparisons:" err1 "Backtracking..." err2 + prettyPrefixSep "Tried two comparisons:" err1 "Backtracking..." err2 -- | Render a 'MRFailure' to a 'String' -showMRFailure :: MRFailure -> String -showMRFailure = showInCtx emptyMRVarCtx +showMRFailure :: MREnv -> MRFailure -> String +showMRFailure env = showInCtx (mrePPOpts env) emptyMRVarCtx -- | Render a 'MRFailure' to a 'String' without its context (see -- 'mrFailureWithoutCtx') -showMRFailureNoCtx :: MRFailure -> String -showMRFailureNoCtx = showMRFailure . mrFailureWithoutCtx +showMRFailureNoCtx :: MREnv -> MRFailure -> String +showMRFailureNoCtx env = showMRFailure env . mrFailureWithoutCtx ---------------------------------------------------------------------- @@ -202,13 +222,16 @@ showMRFailureNoCtx = showMRFailure . mrFailureWithoutCtx -- | Classification info for what sort of variable an 'MRVar' is data MRVarInfo - -- | An existential variable, that might be instantiated - = EVarInfo (Maybe Term) + -- | 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) = + prettyInCtx (EVarInfo _ maybe_t) = prettyAppList [ return "EVar", parens <$> prettyInCtx maybe_t] prettyInCtx (CallVarInfo t) = prettyAppList [ return "CallVar", parens <$> prettyInCtx t] @@ -223,11 +246,11 @@ asExtCnsApp (asApplyAll -> (asExtCns -> Just ec, args)) = asExtCnsApp _ = Nothing -- | Recognize an evar applied to 0 or more arguments relative to a 'MRVarMap' --- along with its instantiation, if any -asEVarApp :: MRVarMap -> Recognizer Term (MRVar, [Term], Maybe Term) +-- along with its uvar context length and its instantiation, if any +asEVarApp :: MRVarMap -> Recognizer Term (MRVar, Int, [Term], Maybe Term) asEVarApp var_map (asExtCnsApp -> Just (ec, args)) - | Just (EVarInfo maybe_inst) <- Map.lookup (MRVar ec) var_map = - Just (MRVar ec, args, maybe_inst) + | 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: @@ -284,8 +307,7 @@ type CoIndHyps = Map (FunName, FunName) CoIndHyp instance PrettyInCtx CoIndHyp where prettyInCtx (CoIndHyp ctx f1 f2 args1 args2 invar1 invar2) = - -- ignore whatever context we're in and use `ctx` instead - return $ flip runPPInCtxM ctx $ + prettyWithCtx ctx $ -- ignore whatever context we're in and use `ctx` instead prettyAppList [prettyInCtx ctx, return ".", (case invar1 of Just f -> prettyTermApp f args1 @@ -304,9 +326,9 @@ data DataTypeAssump deriving (Generic, Show, TermLike) instance PrettyInCtx DataTypeAssump where - prettyInCtx (IsLeft x) = prettyInCtx x >>= ppWithPrefix "Left _ _" - prettyInCtx (IsRight x) = prettyInCtx x >>= ppWithPrefix "Right _ _" - prettyInCtx (IsNum x) = prettyInCtx x >>= ppWithPrefix "TCNum" + 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 @@ -350,6 +372,11 @@ data MRState t = MRState { -- | 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 @@ -407,6 +434,10 @@ mrAskSMT unints goal = do mrDebugLevel :: MRM t Int mrDebugLevel = mreDebugLevel <$> mriEnv <$> ask +-- | Get the current pretty-printing options +mrPPOpts :: MRM t PPOpts +mrPPOpts = mrePPOpts <$> mriEnv <$> ask + -- | Get the current value of 'mriEnv' mrEnv :: MRM t MREnv mrEnv = mriEnv <$> ask @@ -423,6 +454,24 @@ mrEvidence = mrsEvidence <$> get 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 SawDoc +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 :: @@ -569,6 +618,58 @@ 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 @@ -613,6 +714,13 @@ mrApplyAll f args = liftSC2 scApplyAllBeta f args 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 @@ -625,6 +733,34 @@ mrCtorApp = liftSC2 scCtorApp 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 " ++ show 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 scDataTypeApp "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 @@ -633,15 +769,48 @@ mrBvToNat _ (asArrayValue -> Just (asBoolType -> Just _, 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" +-- 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" +-- the order as seen \"from the inside\" mrUVarsInnerToOuter :: MRM t [(LocalName,Term)] mrUVarsInnerToOuter = mrVarCtxInnerToOuter <$> mrUVars @@ -658,16 +827,14 @@ 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 parameters. -mrFunOutType :: FunName -> [Term] -> MRM t (SpecMParams Term, Term) +-- type @[args/vars]a@ that @SpecM@ is applied to, along with its event type. +mrFunOutType :: FunName -> [Term] -> MRM t (EvTerm, Term) mrFunOutType fname args = - mrApplyAll (funNameTerm fname) args >>= mrTypeOf >>= \case - (asSpecM -> Just (params, tp)) -> (params,) <$> liftSC1 scWhnf tp - _ -> do pp_ftype <- funNameType fname >>= mrPPInCtx - pp_fname <- mrPPInCtx fname - debugPrint 0 "mrFunOutType: function does not have SpecM return type" - debugPretty 0 ("Function:" <> pp_fname <> " with type: " <> pp_ftype) - error "mrFunOutType" + 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 @@ -688,6 +855,9 @@ uniquifyNames (nm:nms) 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 @@ -708,20 +878,23 @@ mrLambdaLift ctx t f = -- | Call 'mrLambdaLift' with exactly one 'Term' argument. mrLambdaLift1 :: TermLike tm => (LocalName,Term) -> tm -> (Term -> tm -> MRM t Term) -> MRM t Term -mrLambdaLift1 ctx t f = - mrLambdaLift [ctx] t $ \vars t' -> +mrLambdaLift1 (nm,tp) t f = + mrLambdaLift [(nm,tp)] t $ \vars t' -> case vars of [v] -> f v t' - _ -> error "mrLambdaLift1: Expected exactly one Term argument" + _ -> panic "mrLambdaLift1" ["Expected exactly one Term argument"] --- | Call 'mrLambdaLift' with exactly two 'Term' arguments. +-- | 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 ctx1 ctx2 t f = - mrLambdaLift [ctx1, ctx2] t $ \vars t' -> +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' - _ -> error "mrLambdaLift2: Expected exactly two Term arguments" + _ -> 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 @@ -729,7 +902,7 @@ mrLambdaLift2 ctx1 ctx2 t f = withUVar :: LocalName -> Type -> (Term -> MRM t a) -> MRM t a withUVar nm tp m = withUVars (singletonMRVarCtx nm tp) $ \case [v] -> m v - _ -> error "withUVar: impossible" + _ -> 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 @@ -761,7 +934,8 @@ withUVars ctx f = local (\info -> info { mriUVars = mrVarCtxAppend ctx_u (mriUVars info), mriAssumptions = assumps', mriDataTypeAssumps = dataTypeAssumps' }) $ - mrDebugPPPrefix 3 "withUVars:" ctx_u >> + 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 @@ -794,7 +968,8 @@ 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 :: 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 @@ -831,7 +1006,7 @@ mrVarInfo var = Map.lookup var <$> mrVars -- | Convert an 'ExtCns' to a 'FunName' extCnsToFunName :: ExtCns Term -> MRM t FunName extCnsToFunName ec = let var = MRVar ec in mrVarInfo var >>= \case - Just (EVarInfo _) -> return $ EVarFunName var + Just (EVarInfo _ _) -> return $ EVarFunName var Just (CallVarInfo _) -> return $ CallSName var Nothing | Just glob <- asTypedGlobalDef (Unshared $ FTermF $ ExtCns ec) -> @@ -873,8 +1048,11 @@ mrFunBody f args = mrFunNameBody f >>= \case -- per 'mrCallsFun' mrFunBodyRecInfo :: FunName -> [Term] -> MRM t (Maybe (Term, Bool)) mrFunBodyRecInfo f args = - mrFunBody f args >>= \case - Just f_body -> Just <$> (f_body,) <$> mrCallsFun f f_body + 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 @@ -909,7 +1087,8 @@ 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 = - debugPretty 3 ("mrSetVarInfo" <+> ppInEmptyCtx var <+> "=" <+> ppInEmptyCtx info) >> + mrDebugPPInCtxM 3 (prettyWithCtx emptyMRVarCtx $ + prettyPrefixSep "mrSetVarInfo" var "=" info) >> (modify $ \st -> st { mrsVars = Map.alter (\case @@ -922,7 +1101,8 @@ mrSetVarInfo var info = mrFreshEVar :: LocalName -> Type -> MRM t Term mrFreshEVar nm (Type tp) = do var <- mrFreshVar nm tp - mrSetVarInfo var (EVarInfo Nothing) + ctx_len <- mrVarCtxLength <$> mrUVars + mrSetVarInfo var (EVarInfo ctx_len Nothing) mrVarTerm var -- | Return a fresh sequence of existential variables from a 'MRVarCtx'. @@ -961,8 +1141,8 @@ mrSetEVarClosed var val = st { mrsVars = Map.alter (\case - Just (EVarInfo Nothing) -> Just $ EVarInfo (Just val) - Just (EVarInfo (Just _)) -> + 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) } @@ -974,8 +1154,10 @@ mrSetEVarClosed var val = -- 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 complete list of argument variables of the type of evar - let (evar_vars, _) = asPiList (mrVarType evar) in + -- 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 @@ -1018,11 +1200,53 @@ 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')) -> + (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: " ++ show t] + let cargs_ec = fromMaybe (my_panic ()) $ mapM asExtCns 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) @@ -1031,10 +1255,10 @@ mrSubstEVarsStrict top_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')) -> + (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)) -> + (asEVarApp var_map -> Just (_, _, _, Nothing)) -> mzero -- If t is anything else, recurse on its immediate subterms _ -> traverseSubterms recurse t @@ -1050,7 +1274,8 @@ 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 debugPretty 2 ("withCoIndHyp" <+> ppInEmptyCtx hyp) + do mrDebugPPInCtxM 2 (prettyWithCtx emptyMRVarCtx $ + prettyPrefix "withCoIndHyp" hyp) hyps' <- Map.insert (coIndHypLHSFun hyp, coIndHypRHSFun hyp) hyp <$> mrCoIndHyps local (\info -> info { mriCoIndHyps = hyps' }) m @@ -1093,7 +1318,7 @@ mrGetFunAssump nm = lookupFunAssump nm <$> mrRefnset 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 Unlifted k) + mrDebugPPPrefixSep 1 "withFunAssump" (FunBind fname args k) "|=" rhs ctx <- mrUVars rs <- mrRefnset @@ -1108,7 +1333,7 @@ withFunAssump fname args rhs 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 @bindM ... (assertFiniteM ...)@ applications. +-- any initial @bindS ... (assertFiniteS ...)@ applications. mrGetInvariant :: FunName -> MRM t (Maybe Term) mrGetInvariant nm = mrFunNameBody nm >>= \case @@ -1127,17 +1352,17 @@ mrGetInvariantBody tm = case asApplyAll tm of (f@(asLambda -> Just _), args) -> do tm' <- mrApplyAll f args mrGetInvariantBody tm' - -- go inside any top-level applications of of bindM ... (assertFiniteM ...) - (isGlobalDef "Prelude.bindM" -> Just (), - [_, _, - asApp -> Just (isGlobalDef "CryptolM.assertFiniteM" -> Just (), - asCtor -> Just (primName -> "Cryptol.TCNum", _)), + -- go inside any top-level applications of of bindS ... (assertFiniteS ...) + (isGlobalDef "SpecM.bindS" -> Just (), + [_, _, _, + (asApplyAll -> (isGlobalDef "CryptolM.assertFiniteS" -> Just (), + [_, (asCtor -> Just (primName -> "Cryptol.TCNum", _))])), 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 "Prelude.invariantHint" -> Just (), + (isGlobalDef "SpecM.invariantHint" -> Just (), [_, phi, _]) -> return $ Just phi _ -> return Nothing @@ -1185,38 +1410,42 @@ recordUsedFunAssump _ = return () -- * Functions for Debug Output ---------------------------------------------------------------------- --- | Print a 'String' if the debug level is at least the supplied 'Int' -debugPrint :: Int -> String -> MRM t () -debugPrint i str = +-- | 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 if the debug level is at least the supplied 'Int' -debugPretty :: Int -> SawDoc -> MRM t () -debugPretty i pp = debugPrint i $ renderSawDoc defaultPPOpts pp +-- | Print a document to 'stderr' if the debug level is at least the supplied +-- 'Int' +mrDebugPretty :: Int -> SawDoc -> MRM t () +mrDebugPretty i pp = + mrPPOpts >>= \opts -> + mrDebugPrint i (renderSawDoc opts pp) --- | Pretty-print an object in the current context if the current debug level is +-- | 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' -debugPrettyInCtx :: PrettyInCtx a => Int -> a -> MRM t () -debugPrettyInCtx i a = mrUVars >>= \ctx -> debugPrint i (showInCtx ctx a) +mrDebugPPInCtxM :: Int -> PPInCtxM SawDoc -> MRM t () +mrDebugPPInCtxM i m = mrDebugPretty i =<< mrPPInCtxM m --- | Pretty-print an object relative to the current context -mrPPInCtx :: PrettyInCtx a => a -> MRM t SawDoc -mrPPInCtx a = runPPInCtxM (prettyInCtx a) <$> mrUVars +-- | 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 'ppWithPrefix' relative to the current uvar --- context to 'stderr' if the debug level is at least the 'Int' provided +-- | 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 = - mrUVars >>= \ctx -> - debugPretty i $ - runPPInCtxM (group <$> nest 2 <$> ppWithPrefix pre a) ctx + mrDebugPPInCtxM i $ group <$> nest 2 <$> prettyPrefix pre a --- | Pretty-print the result of 'ppWithPrefixSep' relative to the current uvar --- context to 'stderr' if the debug level is at least the 'Int' provided +-- | 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 = - mrUVars >>= \ctx -> - debugPretty i $ - runPPInCtxM (group <$> nest 2 <$> ppWithPrefixSep pre a1 sp a2) ctx + mrDebugPPInCtxM i $ group <$> nest 2 <$> prettyPrefixSep pre a1 sp a2 diff --git a/src/SAWScript/Prover/MRSolver/SMT.hs b/src/SAWScript/Prover/MRSolver/SMT.hs index e02ddbfd69..02d4afd3ed 100644 --- a/src/SAWScript/Prover/MRSolver/SMT.hs +++ b/src/SAWScript/Prover/MRSolver/SMT.hs @@ -7,6 +7,13 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} {- | Module : SAWScript.Prover.MRSolver.SMT @@ -22,33 +29,37 @@ namely 'mrProvable' and 'mrProveEq'. module SAWScript.Prover.MRSolver.SMT where +import Data.Maybe import qualified Data.Vector as V import Numeric.Natural (Natural) -import Control.Monad (MonadPlus(..), (<=<), join, when, zipWithM) +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 Data.Foldable (foldrM, foldlM) 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 Verifier.SAW.Utils (panic) import Verifier.SAW.Term.Functor import Verifier.SAW.Term.Pretty import Verifier.SAW.SharedTerm import Verifier.SAW.Recognizer -import Verifier.SAW.OpenTerm -import Verifier.SAW.Prim (EvalError(..)) +import Verifier.SAW.Module +import Verifier.SAW.Prim (widthNat, EvalError(..)) import qualified Verifier.SAW.Prim as Prim +import Verifier.SAW.Simulator (SimulatorConfig, evalSharedTerm) import Verifier.SAW.Simulator.Value import Verifier.SAW.Simulator.TermModel import Verifier.SAW.Simulator.Prims -import Verifier.SAW.Module -import Verifier.SAW.Prelude.Constants import Verifier.SAW.FiniteValue import SAWScript.Proof (termToProp, propToTerm, prettyProp, propToSequent, SolveResult(..)) @@ -57,194 +68,63 @@ import SAWScript.Prover.MRSolver.Monad ---------------------------------------------------------------------- --- * Various SMT-specific Functions on Terms +-- * Normalizing terms for SMT ---------------------------------------------------------------------- --- | Apply @genBVVec@ to arguments @n@, @len@, and @a@, along with a function of --- type @Vec n Bool -> a@ -genBVVecTerm :: SharedContext -> Term -> Term -> Term -> Term -> IO Term -genBVVecTerm sc n_tm len_tm a_tm f_tm = - let n = closedOpenTerm n_tm - len = closedOpenTerm len_tm - a = closedOpenTerm a_tm - f = closedOpenTerm f_tm in - completeOpenTerm sc $ - applyOpenTermMulti (globalOpenTerm "Prelude.genBVVec") - [n, len, a, - lambdaOpenTerm "i" (vectorTypeOpenTerm n boolTypeOpenTerm) $ \i -> - lambdaOpenTerm "_" (applyGlobalOpenTerm "Prelude.is_bvult" [n, i, len]) $ \_ -> - applyOpenTerm f i] - --- | Match a term of the form @genBVVec n len a (\ i _ -> e)@, i.e., where @e@ --- does not have the proof variable (the underscore) free -asGenBVVecTerm :: Recognizer Term (Term, Term, Term, Term) -asGenBVVecTerm (asApplyAll -> - (isGlobalDef "Prelude.genBVVec" -> Just _, - [n, len, a, f@(asLambdaList -> ([_,_], e))])) - | not $ inBitSet 0 $ looseVars e - = Just (n, len, a, f) -asGenBVVecTerm _ = Nothing - --- | Match a term of the form @genCryM n a f@ -asGenCryMTerm :: Recognizer Term (Term, Term, Term) -asGenCryMTerm (asApplyAll -> (isGlobalDef "CryptolM.genCryM" -> Just _, - [n, a, f])) - = Just (n, a, f) -asGenCryMTerm _ = Nothing - --- | Match a term of the form @genFromBVVec n len a v def m@ -asGenFromBVVecTerm :: Recognizer Term (Term, Term, Term, Term, Term, Term) -asGenFromBVVecTerm (asApplyAll -> - (isGlobalDef "Prelude.genFromBVVec" -> Just _, - [n, len, a, v, def, m])) - = Just (n, len, a, v, def, m) -asGenFromBVVecTerm _ = Nothing - type TmPrim = Prim TermModel --- | Convert a Boolean value to a 'Term'; like 'readBackValue' but that function --- requires a 'SimulatorConfig' which we cannot easily generate here... +-- | 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) --- | An implementation of a primitive function that expects a term of the form --- @genBVVec n _ a _@ or @genCryM (bvToNat n _) a _@, where @n@ is the second --- argument, and passes to the continuation the associated function of type --- @Vec n Bool -> a@ -primGenBVVec :: SharedContext -> Natural -> (Term -> TmPrim) -> TmPrim -primGenBVVec sc n = - PrimFilterFun "primGenBVVec" $ - \case - VExtra (VExtraTerm _ t) -> primGenBVVecFilter sc n t - _ -> mzero - --- | The filter function for 'primGenBVVec', and one case of 'primGenCryM' -primGenBVVecFilter :: SharedContext -> Natural -> - Term -> MaybeT (EvalM TermModel) Term -primGenBVVecFilter sc n (asGenBVVecTerm -> Just (asNat -> Just n', _, _, f)) | n == n' = lift $ - do i_tp <- join $ scVecType sc <$> scNat sc n <*> scBoolType sc - let err_tm = error "primGenBVVec: unexpected variable occurrence" - i_tm <- scLocalVar sc 0 - body <- scApplyAllBeta sc f [i_tm, err_tm] - scLambda sc "i" i_tp body -primGenBVVecFilter sc n (asGenCryMTerm -> Just (asBvToNat -> Just (asNat -> Just n', _), _, f)) | n == n' = lift $ - do i_tp <- join $ scVecType sc <$> scNat sc n <*> scBoolType sc - i_tm <- scLocalVar sc 0 - body <- scApplyBeta sc f =<< scBvToNat sc n i_tm - scLambda sc "i" i_tp body -primGenBVVecFilter _ _ t = - error $ "primGenBVVec could not handle: " ++ showInCtx emptyMRVarCtx t - --- | An implementation of a primitive function that expects a term of the form --- @genCryM _ a _@, @genFromBVVec ... (genBVVec _ _ a _) ...@, or --- @genFromBVVec ... (genCryM (bvToNat _ _) a _) ...@, and passes to the --- continuation either @Just n@ and the associated function of type --- @Vec n Bool -> a@, or @Nothing@ and the associated function of type --- @Nat -> a@ -primGenCryM :: SharedContext -> (Maybe Natural -> Term -> TmPrim) -> TmPrim -primGenCryM sc = - PrimFilterFun "primGenCryM" - (\case - VExtra (VExtraTerm _ (asGenCryMTerm -> Just (_, _, f))) -> - return (Nothing, f) - VExtra (VExtraTerm _ (asGenFromBVVecTerm -> Just (asNat -> Just n, _, _, - v, _, _))) -> - (Just n,) <$> primGenBVVecFilter sc n v - _ -> mzero - ) . uncurry - --- | An implementation of a primitive function that expects a bitvector term -primBVTermFun :: SharedContext -> (Term -> TmPrim) -> TmPrim -primBVTermFun sc = - PrimFilterFun "primBVTermFun" $ - \case - VExtra (VExtraTerm _ w_tm) -> return w_tm - VWord (Left (_,w_tm)) -> return w_tm - VWord (Right bv) -> - lift $ scBvLit sc (fromIntegral (Prim.width bv)) (Prim.unsigned bv) - VVector vs -> - lift $ - do tms <- traverse (boolValToTerm sc <=< force) (V.toList vs) - tp <- scBoolType sc - scVectorReduced sc tp tms - v -> lift (putStrLn ("primBVTermFun: unhandled value: " ++ show v)) >> mzero - --- | A datatype representing the arguments to @genBVVecFromVec@ which can be --- normalized: a @genFromBVVec n len _ v _ _@ term, a @genCryM _ _ body@ term, --- or a vector literal, the lattermost being represented as a list of 'Term's -data BVVecFromVecArg = FromBVVec { fromBVVec_n :: Natural - , fromBVVec_len :: Term - , fromBVVec_vec :: Term } - | GenCryM Term - | BVVecLit [Term] - --- | An implementation of a primitive function that expects a @genFromBVVec@ --- term, a @genCryM@ term, or a vector literal -primBVVecFromVecArg :: SharedContext -> TValue TermModel -> - (BVVecFromVecArg -> TmPrim) -> TmPrim -primBVVecFromVecArg sc a = - PrimFilterFun "primFromBVVecOrLit" $ - \case - VExtra (VExtraTerm _ (asGenFromBVVecTerm -> Just (asNat -> Just n, len, _, - v, _, _))) -> - return $ FromBVVec n len v - VExtra (VExtraTerm _ (asGenCryMTerm -> Just (_, _, body))) -> - return $ GenCryM body - VVector vs -> - lift $ BVVecLit <$> - traverse (readBackValueNoConfig "primFromBVVecOrLit" sc a <=< force) - (V.toList vs) - _ -> mzero - --- | Turn a 'BVVecFromVecArg' into a BVVec term, assuming it has the given --- bit-width (given as both a 'Natural' and a 'Term'), length, and element type --- FIXME: Properly handle empty vector literals -bvVecBVVecFromVecArg :: SharedContext -> Natural -> Term -> Term -> Term -> - BVVecFromVecArg -> IO Term -bvVecBVVecFromVecArg sc n _ len _ (FromBVVec n' len' v) = - do len_cvt_len' <- scConvertible sc True len len' - if n == n' && len_cvt_len' then return v - else error "bvVecBVVecFromVecArg: genFromBVVec type mismatch" -bvVecBVVecFromVecArg sc n _ len a (GenCryM body) = - do len' <- scBvToNat sc n len - scGlobalApply sc "CryptolM.genCryM" [len', a, body] -bvVecBVVecFromVecArg sc n n' len a (BVVecLit vs) = - do body <- mkBody 0 vs - i_tp <- scBitvector sc n - var0 <- scLocalVar sc 0 - pf_tp <- scGlobalApply sc "Prelude.is_bvult" [n', var0, len] - f <- scLambdaList sc [("i", i_tp), ("pf", pf_tp)] body - scGlobalApply sc "Prelude.genBVVec" [n', len, a, f] - where mkBody :: Integer -> [Term] -> IO Term - mkBody _ [] = error "bvVecBVVecFromVecArg: empty vector" - mkBody _ [x] = return $ x - mkBody i (x:xs) = - do var1 <- scLocalVar sc 1 - i' <- scBvConst sc n i - cond <- scBvEq sc n' var1 i' - body' <- mkBody (i+1) xs - scIte sc a cond x body' - --- | A version of 'readBackTValue' which uses 'error' as the simulator config --- Q: Is there every a case where this will actually error? -readBackTValueNoConfig :: String -> SharedContext -> - TValue TermModel -> IO Term -readBackTValueNoConfig err_str sc tv = - let ?recordEC = \_ec -> return () in - let cfg = error $ "FIXME: need the simulator config in " ++ err_str - in readBackTValue sc cfg tv - --- | A version of 'readBackValue' which uses 'error' as the simulator config --- Q: Is there every a case where this will actually error? -readBackValueNoConfig :: String -> SharedContext -> - TValue TermModel -> Value TermModel -> IO Term -readBackValueNoConfig err_str sc tv v = - let ?recordEC = \_ec -> return () in - let cfg = error $ "FIXME: need the simulator config in " ++ err_str - in readBackValue sc cfg tv 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 @@ -256,103 +136,96 @@ primGlobal sc glob = 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 <- scCtorApp sc "Prelude.Refl" [bool_tp, b_trm] + eq_tp <- scDataTypeApp sc "Prelude.Eq" [bool_tp, b_trm, b_trm] + return $ VExtra $ VExtraTerm (VTyTerm propSort eq_tp) refl_trm + +mkDummyProofValue :: String -> 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" + x <- apply x_fun eq_true + x_trm <- readBackValue sc cfg tp x + eq_false <- mkDummyProofValue "iteWithProofOp" + 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 -> Map Ident TmPrim -smtNormPrims sc = Map.fromList - [ -- Don't unfold @genBVVec@ or @genCryM when normalizing - ("Prelude.genBVVec", - Prim (do tp <- scTypeOfGlobal sc "Prelude.genBVVec" - VExtra <$> VExtraTerm (VTyTerm (mkSort 1) tp) <$> - scGlobalDef sc "Prelude.genBVVec") - ), - ("CryptolM.genCryM", - Prim (do tp <- scTypeOfGlobal sc "CryptolM.genCryM" - VExtra <$> VExtraTerm (VTyTerm (mkSort 1) tp) <$> - scGlobalDef sc "CryptolM.genCryM") - ), - -- Normalize applications of @genBVVecFromVec@ to a @genFromBVVec@ term - -- into the body of the @genFromBVVec@ term, a @genCryM@ term into a - -- @genCryM@ term of the new length, or vector literal into a sequence - -- of @ite@s defined by the literal - ("Prelude.genBVVecFromVec", - PrimFun $ \_m -> tvalFun $ \a -> primBVVecFromVecArg sc a $ \eith -> - PrimFun $ \_def -> natFun $ \n -> primBVTermFun sc $ \len -> - Prim (do n' <- scNat sc n - a' <- readBackTValueNoConfig "smtNormPrims (genBVVecFromVec)" sc a - tp <- scGlobalApply sc "Prelude.BVVec" [n', len, a'] - VExtra <$> VExtraTerm (VTyTerm (mkSort 0) tp) <$> - bvVecBVVecFromVecArg sc n n' len a' eith) - ), - -- Don't normalize applications of @genFromBVVec@ - ("Prelude.genFromBVVec", - natFun $ \n -> PrimStrict $ \len -> tvalFun $ \a -> PrimStrict $ \v -> - PrimStrict $ \def -> natFun $ \m -> - Prim (do n' <- scNat sc n - let len_tp = VVecType n VBoolType - len' <- readBackValueNoConfig "smtNormPrims (genFromBVVec)" sc len_tp len - a' <- readBackTValueNoConfig "smtNormPrims (genFromBVVec)" sc a - bvToNat_len <- scGlobalApply sc "Prelude.bvToNat" [n', len'] - v_tp <- VTyTerm (mkSort 0) <$> scVecType sc bvToNat_len a' - v' <- readBackValueNoConfig "smtNormPrims (genFromBVVec)" sc v_tp v - def' <- readBackValueNoConfig "smtNormPrims (genFromBVVec)" sc a def - m' <- scNat sc m - tm <- scGlobalApply sc "Prelude.genFromBVVec" [n', len', a', v', def', m'] - return $ VExtra $ VExtraTerm (VVecType m a) tm) - ), - -- Normalize applications of @atBVVec@ or @atCryM@ to a @genBVVec@ or - -- @genCryM@ term into an application of the body of the term to the index - ("Prelude.atBVVec", - natFun $ \n -> PrimFun $ \_len -> tvalFun $ \a -> - primGenBVVec sc n $ \f -> primBVTermFun sc $ \ix -> PrimFun $ \_pf -> +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') ), - ("CryptolM.atCryM", - PrimFun $ \_n -> tvalFun $ \a -> - primGenCryM sc $ \nMb f -> PrimStrict $ \ix -> - Prim (do natDT <- scRequireDataType sc preludeNatIdent - let natPN = fmap (const $ VSort (mkSort 0)) (dtPrimName natDT) - let nat_tp = VDataType natPN [] [] - ix' <- readBackValueNoConfig "smtNormPrims (atCryM)" sc nat_tp ix - ix'' <- case nMb of - Nothing -> return ix' - Just n -> scNat sc n >>= \n' -> scBvNat sc n' ix' - tm <- scApplyBeta sc f ix'' + + -- 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') ), - -- Don't normalize applications of @SpecM@ and its arguments - ("Prelude.SpecM", - PrimStrict $ \ev -> PrimStrict $ \stack -> PrimStrict $ \tp -> - Prim $ - do ev_tp <- VTyTerm (mkSort 1) <$> scDataTypeApp sc "Prelude.EvType" [] - ev_tm <- readBackValueNoConfig "smtNormPrims (SpecM)" sc ev_tp ev - stack_tp <- VTyTerm (mkSort 1) <$> scGlobalDef sc "Prelude.FunStack" - stack_tm <- - readBackValueNoConfig "smtNormPrims (SpecM)" sc stack_tp stack - tp_tm <- readBackValueNoConfig "smtNormPrims (SpecM)" sc (VSort $ - mkSort 0) tp - ret_tm <- scGlobalApply sc "Prelude.SpecM" [ev_tm,stack_tm,tp_tm] - return $ TValue $ VTyTerm (mkSort 0) ret_tm), - ("Prelude.VoidEv", primGlobal sc "Prelude.VoidEv"), - ("Prelude.emptyFunStack", primGlobal sc "Prelude.emptyFunStack"), - ("Prelude.pushFunStack", primGlobal sc "Prelude.pushFunStack") + + -- 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 +-- 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 + 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 = - debugPrint 2 "Normalizing term:" >> - debugPrettyInCtx 2 t >> + mrDebugPrint 2 "Normalizing term:" >> + mrDebugPPInCtx 2 t >> liftSC1 smtNorm t -- | Normalize an open term by wrapping it in lambdas, normalizing, and then @@ -374,8 +247,8 @@ mrNormOpenTerm body = -- * 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 +-- | 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! @@ -385,8 +258,9 @@ mrProvableRaw prop_term = prop <- liftSC1 termToProp prop_term unints <- Set.map ecVarIndex <$> getAllExtSet <$> liftSC1 propToTerm prop nenv <- liftIO (scGetNamingEnv sc) - debugPrint 2 ("Calling SMT solver with proposition: " ++ - prettyProp defaultPPOpts nenv prop) + 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 @@ -397,19 +271,19 @@ mrProvableRaw prop_term = e -> throwM e case smt_res of Left msg -> - debugPrint 2 ("SMT solver encountered a saw-core error term: " ++ msg) + mrDebugPrint 2 ("SMT solver encountered a saw-core error term: " ++ msg) >> return False Right (stats, SolveUnknown) -> - debugPrint 2 "SMT solver response: unknown" >> + mrDebugPrint 2 "SMT solver response: unknown" >> recordUsedSolver stats prop_term >> return False Right (stats, SolveCounterexample cex) -> - debugPrint 2 "SMT solver response: not provable" >> - debugPrint 3 ("Counterexample:" ++ concatMap (\(x,v) -> - "\n - " ++ renderSawDoc defaultPPOpts (ppTerm defaultPPOpts (Unshared (FTermF (ExtCns x)))) ++ - " = " ++ renderSawDoc defaultPPOpts (ppFirstOrderValue defaultPPOpts v)) cex) >> + mrDebugPrint 2 "SMT solver response: not provable" >> + mrDebugPrint 3 ("Counterexample:" ++ concatMap (\(x,v) -> + "\n - " ++ show (ppName $ ecName x) ++ + " = " ++ renderSawDoc opts (ppFirstOrderValue opts v)) cex) >> recordUsedSolver stats prop_term >> return False Right (stats, SolveSuccess _) -> - debugPrint 2 "SMT solver response: provable" >> + 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 @@ -420,302 +294,499 @@ mrProvable bool_tm = do mrUVars >>= mrDebugPPPrefix 3 "mrProvable uvars:" assumps <- mrAssumptions prop <- liftSC2 scImplies assumps bool_tm >>= liftSC1 scEqTrue - prop_inst <- mrSubstEVars prop >>= instantiateUVarsM instUVar + prop_inst <- instantiateUVarsM instUVar prop >>= mrSubstLowerEVars mrNormTerm prop_inst >>= mrProvableRaw - where -- | Given a UVar name and type, generate a 'Term' to be passed to - -- SMT, with special cases for BVVec and pair types + where -- | Create a new global variable of the given name and type instUVar :: LocalName -> Term -> MRM t Term - instUVar nm tp = mrDebugPPPrefix 3 "instUVar" (nm, tp) >> - liftSC1 scWhnf tp >>= \case - (asNonBVVecVectorType -> Just (m, a)) -> - liftSC1 smtNorm m >>= \m' -> case asBvToNat m' of - -- For variables of type Vec of length which normalizes to - -- a bvToNat term, recurse and wrap the result in genFromBVVec - Just (n, len) -> do - tp' <- liftSC2 scVecType m' a - tm' <- instUVar nm tp' - mrGenFromBVVec n len a tm' "instUVar" m - -- Otherwise for variables of type Vec, create a @Nat -> a@ - -- function as an ExtCns and apply genBVVec to it - Nothing -> do - nat_tp <- liftSC0 scNatType - tp' <- liftSC3 scPi "_" nat_tp =<< liftTermLike 0 1 a - tm' <- instUVar nm tp' - liftSC2 scGlobalApply "CryptolM.genCryM" [m, a, tm'] - -- For variables of type BVVec, create a @Vec n Bool -> a@ function - -- as an ExtCns and apply genBVVec to it - (asBVVecType -> Just (n, len, a)) -> do - ec_tp <- - liftSC1 completeOpenTerm $ - arrowOpenTerm "_" (applyOpenTermMulti (globalOpenTerm "Prelude.Vec") - [closedOpenTerm n, boolTypeOpenTerm]) - (closedOpenTerm a) - ec <- instUVar nm ec_tp - liftSC4 genBVVecTerm n len a ec - -- For pairs, recurse on both sides and combine the result as a pair - (asPairType -> Just (tp1, tp2)) -> do - e1 <- instUVar nm tp1 - e2 <- instUVar nm tp2 - liftSC2 scPairValue e1 e2 - -- Otherwise, create a global variable with the given name and type - tp' -> liftSC2 scFreshEC nm tp' >>= liftSC1 scExtCns + instUVar nm = + liftSC1 scWhnf >=> liftSC2 scFreshEC nm >=> liftSC1 scExtCns + + +---------------------------------------------------------------------- +-- * 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 ---------------------------------------------------------------------- --- * Finding injective conversions +-- * SMT-Friendly Representations ---------------------------------------------------------------------- --- | An injection from @Nat@ to @Num@ ('NatToNum'), @Vec n Bool@ to @Nat@ --- ('BVToNat'), @BVVec n len a@ to @Vec m a@ ('BVVecToVec'), from one pair --- type to another ('PairToPair'), or any composition of these using '(<>)' --- (including the composition of none of them, the identity 'NoConv'). This --- type is primarily used as one of the returns of 'findInjConvs'. --- NOTE: Do not use the constructors of this type or 'SingleInjConversion' --- directly, instead use the pattern synonyms mentioned above and '(<>)' to --- create and compose 'InjConversion's. This ensures elements of this type --- are always in a normal form w.r.t. 'PairToPair' injections. -newtype InjConversion = ConvComp [SingleInjConversion] - deriving (Generic, Show) - --- | Used in the implementation of 'InjConversion'. --- NOTE: Do not use the constructors of this type or 'InjConversion' --- directly, instead use the pattern synonyms mentioned in the documentation of --- 'InjConversion' and '(<>)' to create and compose 'InjConversion's. This --- ensures elements of this type are always in a normal form w.r.t. --- 'PairToPair' injections. -data SingleInjConversion = SingleNatToNum - | SingleBVToNat Natural - | SingleBVVecToVec Term Term Term Term - | SinglePairToPair InjConversion InjConversion - deriving (Generic, Show) - -deriving instance TermLike SingleInjConversion -deriving instance TermLike InjConversion - --- | The identity 'InjConversion' -pattern NoConv :: InjConversion -pattern NoConv = ConvComp [] - --- | The injective conversion from @Nat@ to @Num@ -pattern NatToNum :: InjConversion -pattern NatToNum = ConvComp [SingleNatToNum] - --- | The injective conversion from @Vec n Bool@ to @Nat@ for a given @n@ -pattern BVToNat :: Natural -> InjConversion -pattern BVToNat n = ConvComp [SingleBVToNat n] - --- | The injective conversion from @BVVec n len a@ to @Vec m a@ for given --- @n@, @len@, @a@, and @m@ (in that order), assuming @m >= bvToNat n len@ -pattern BVVecToVec :: Term -> Term -> Term -> Term -> InjConversion -pattern BVVecToVec n len a m = ConvComp [SingleBVVecToVec n len a m] - --- | An injective conversion from one pair type to another, using the given --- 'InjConversion's for the first and second projections, respectively -pattern PairToPair :: InjConversion -> InjConversion -> InjConversion -pattern PairToPair c1 c2 <- ConvComp [SinglePairToPair c1 c2] - where PairToPair NoConv NoConv = NoConv - PairToPair c1 c2 = ConvComp [SinglePairToPair c1 c2] - -instance Semigroup InjConversion where - (ConvComp cs1) <> (ConvComp cs2) = ConvComp (cbnPairs $ cs1 ++ cs2) - where cbnPairs :: [SingleInjConversion] -> [SingleInjConversion] - cbnPairs (SinglePairToPair cL1 cR1 : SinglePairToPair cL2 cR2 : cs) = - cbnPairs (SinglePairToPair (cL1 <> cL2) (cR1 <> cR2) : cs) - cbnPairs (s : cs) = s : cbnPairs cs - cbnPairs [] = [] - -instance Monoid InjConversion where - mempty = NoConv - --- | Return 'True' iff the given 'InjConversion' is not 'NoConv' -nonTrivialConv :: InjConversion -> Bool -nonTrivialConv (ConvComp cs) = not (null cs) - --- | Return 'True' iff the given 'InjConversion's are convertible, i.e. if --- the two injective conversions are the compositions of the same constructors, --- and the arguments to those constructors are convertible via 'mrConvertible' -mrConvsConvertible :: InjConversion -> InjConversion -> MRM t Bool -mrConvsConvertible (ConvComp cs1) (ConvComp cs2) = - if length cs1 /= length cs2 then return False - else and <$> zipWithM mrSingleConvsConvertible cs1 cs2 - --- | Used in the definition of 'mrConvsConvertible' -mrSingleConvsConvertible :: SingleInjConversion -> SingleInjConversion -> MRM t Bool -mrSingleConvsConvertible SingleNatToNum SingleNatToNum = return True -mrSingleConvsConvertible (SingleBVToNat n1) (SingleBVToNat n2) = return $ n1 == n2 -mrSingleConvsConvertible (SingleBVVecToVec n1 len1 a1 m1) - (SingleBVVecToVec n2 len2 a2 m2) = - do ns_are_eq <- mrConvertible n1 n2 - lens_are_eq <- mrConvertible len1 len2 - as_are_eq <- mrConvertible a1 a2 - ms_are_eq <- mrConvertible m1 m2 - return $ ns_are_eq && lens_are_eq && as_are_eq && ms_are_eq -mrSingleConvsConvertible (SinglePairToPair cL1 cR1) - (SinglePairToPair cL2 cR2) = - do cLs_are_eq <- mrConvsConvertible cL1 cL2 - cRs_are_eq <- mrConvsConvertible cR1 cR2 - return $ cLs_are_eq && cRs_are_eq -mrSingleConvsConvertible _ _ = return False - --- | Apply the given 'InjConversion' to the given term, where compositions --- @c1 <> c2 <> ... <> cn@ are applied from right to left as in function --- composition (i.e. @mrApplyConv (c1 <> c2 <> ... <> cn) t@ is equivalent to --- @mrApplyConv c1 (mrApplyConv c2 (... mrApplyConv cn t ...))@) -mrApplyConv :: InjConversion -> Term -> MRM t Term -mrApplyConv (ConvComp cs) = flip (foldrM go) cs - where go :: SingleInjConversion -> Term -> MRM t Term - go SingleNatToNum t = liftSC2 scCtorApp "Cryptol.TCNum" [t] - go (SingleBVToNat n) t = liftSC2 scBvToNat n t - go (SingleBVVecToVec n len a m) t = mrGenFromBVVec n len a t "mrApplyConv" m - go (SinglePairToPair c1 c2) t = - do t1 <- mrApplyConv c1 =<< doTermProj t TermProjLeft - t2 <- mrApplyConv c2 =<< doTermProj t TermProjRight - liftSC2 scPairValueReduced t1 t2 - --- | Try to apply the inverse of the given the conversion to the given term, --- raising an error if this is not possible - see also 'mrApplyConv' -mrApplyInvConv :: InjConversion -> Term -> MRM t Term -mrApplyInvConv (ConvComp cs) = flip (foldlM go) cs - where go :: Term -> SingleInjConversion -> MRM t Term - go t SingleNatToNum = case asNum t of - Just (Left t') -> return t' - _ -> error "mrApplyInvConv: Num term does not normalize to TCNum constructor" - go t (SingleBVToNat n) = case asBvToNat t of - Just (asNat -> Just n', t') | n == n' -> return t' - _ -> do n_tm <- liftSC1 scNat n - liftSC2 scGlobalApply "Prelude.bvNat" [n_tm, t] - go t c@(SingleBVVecToVec n len a m) = case asGenFromBVVecTerm t of - Just (n', len', a', t', _, m') -> - do eq <- mrSingleConvsConvertible c (SingleBVVecToVec n' len' a' m') - if eq then return t' - else mrGenBVVecFromVec m a t "mrApplyInvConv" n len - _ -> mrGenBVVecFromVec m a t "mrApplyInvConv" n len - go t (SinglePairToPair c1 c2) = - do t1 <- mrApplyInvConv c1 =<< doTermProj t TermProjLeft - t2 <- mrApplyInvConv c2 =<< doTermProj t TermProjRight - liftSC2 scPairValueReduced t1 t2 - --- | If the given term can be expressed as @mrApplyInvConv c t@ for some @c@ --- and @t@, return @c@ - otherwise return @NoConv@ -mrConvOfTerm :: Term -> InjConversion -mrConvOfTerm (asNum -> Just (Left t')) = - NatToNum <> mrConvOfTerm t' -mrConvOfTerm (asBvToNat -> Just (asNat -> Just n, t')) = - BVToNat n <> mrConvOfTerm t' -mrConvOfTerm (asGenFromBVVecTerm -> Just (n, len, a, v, _, m)) = - BVVecToVec n len a m <> mrConvOfTerm v -mrConvOfTerm (asPairValue -> Just (t1, t2)) = - PairToPair (mrConvOfTerm t1) (mrConvOfTerm t2) -mrConvOfTerm _ = NoConv - --- | For two types @tp1@ and @tp2@, and optionally two terms @t1 :: tp1@ and --- @t2 :: tp2@, tries to find a type @tp@ and 'InjConversion's @c1@ and @c2@ --- such that @c1@ is an injective conversion from @tp@ to @tp1@ and @c2@ is a --- injective conversion from @tp@ to @tp2@. This tries to make @c1@ and @c2@ --- as large as possible, using information from the given terms (i.e. using --- 'mrConvOfTerm') where possible. In pictorial form, this function finds --- a @tp@, @c1@, and @c2@ which satisfy the following diagram: +-- | 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: " ++ + show r1 ++ " and " ++ 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 scCtorApp "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 -- > ^ ^ --- > c1 \ / c2 +-- > r1 \ / r2 -- > \ / -- > tp -- --- Since adding a 'NatToNum' conversion does not require any choice (i.e. --- unlike 'BVToNat', which requires choosing a bit width), if either @tp1@ or --- @tp2@ is @Num@, a 'NatToNum' conversion will be included on the respective --- side. Another subtlety worth noting is the difference between returning --- @Just (tp, NoConv, NoConv)@ and @Nothing@ - the former indicates that the --- types @tp1@ and @tp2@ are convertible, but the latter indicates that no --- 'InjConversion' could be found. -findInjConvs :: Term -> Maybe Term -> Term -> Maybe Term -> - MRM t (Maybe (Term, InjConversion, InjConversion)) --- always add 'NatToNum' conversions -findInjConvs (asDataType -> Just (primName -> "Cryptol.Num", _)) t1 tp2 t2 = - do tp1' <- liftSC0 scNatType - t1' <- mapM (mrApplyInvConv NatToNum) t1 - mb_cs <- findInjConvs tp1' t1' tp2 t2 - return $ fmap (\(tp, c1, c2) -> (tp, NatToNum <> c1, c2)) mb_cs -findInjConvs tp1 t1 (asDataType -> Just (primName -> "Cryptol.Num", _)) t2 = - do tp2' <- liftSC0 scNatType - t2' <- mapM (mrApplyInvConv NatToNum) t2 - mb_cs <- findInjConvs tp1 t1 tp2' t2' - return $ fmap (\(tp, c1, c2) -> (tp, c1, NatToNum <> c2)) mb_cs --- add a 'BVToNat' conversion if the (optional) given term has a 'BVToNat' --- conversion -findInjConvs (asNatType -> Just ()) - (Just (asBvToNat -> Just (asNat -> Just n, t1'))) tp2 t2 = - do tp1' <- liftSC1 scBitvector n - mb_cs <- findInjConvs tp1' (Just t1') tp2 t2 - return $ fmap (\(tp, c1, c2) -> (tp, BVToNat n <> c1, c2)) mb_cs -findInjConvs tp1 t1 (asNatType -> Just ()) - (Just (asBvToNat -> Just (asNat -> Just n, t2'))) = - do tp2' <- liftSC1 scBitvector n - mb_cs <- findInjConvs tp1 t1 tp2' (Just t2') - return $ fmap (\(tp, c1, c2) -> (tp, c1, BVToNat n <> c2)) mb_cs --- add a 'BVToNat' conversion we have a BV on the other side, using the --- bit-width from the other side -findInjConvs (asNatType -> Just ()) _ (asBitvectorType -> Just n) _ = - do bv_tp <- liftSC1 scBitvector n - return $ Just (bv_tp, BVToNat n, NoConv) -findInjConvs (asBitvectorType -> Just n) _ (asNatType -> Just ()) _ = - do bv_tp <- liftSC1 scBitvector n - return $ Just (bv_tp, NoConv, BVToNat n) --- add a 'BVVecToVec' conversion if the (optional) given term has a --- 'BVVecToVec' conversion -findInjConvs (asNonBVVecVectorType -> Just (m, _)) - (Just (asGenFromBVVecTerm -> Just (n, len, a, t1', _, _))) tp2 t2 = - do len' <- liftSC2 scGlobalApply "Prelude.bvToNat" [n, len] - tp1' <- liftSC2 scVecType len' a - mb_cs <- findInjConvs tp1' (Just t1') tp2 t2 - return $ fmap (\(tp, c1, c2) -> (tp, BVVecToVec n len a m <> c1, c2)) mb_cs -findInjConvs tp1 t1 (asNonBVVecVectorType -> Just (m, _)) - (Just (asGenFromBVVecTerm -> Just (n, len, a, t2', _, _))) = - do len' <- liftSC2 scGlobalApply "Prelude.bvToNat" [n, len] - tp2' <- liftSC2 scVecType len' a - mb_cs <- findInjConvs tp1 t1 tp2' (Just t2') - return $ fmap (\(tp, c1, c2) -> (tp, c1, BVVecToVec n len a m <> c2)) mb_cs --- add a 'BVVecToVec' conversion we have a BVVec on the other side, using the --- bit-width from the other side -findInjConvs (asNonBVVecVectorType -> Just (m, a')) _ - (asBVVecType -> Just (n, len, a)) _ = - do len_nat <- liftSC2 scGlobalApply "Prelude.bvToNat" [n, len] - bvvec_tp <- liftSC2 scVecType len_nat a - lens_are_eq <- mrProveEq m len_nat - as_are_eq <- mrConvertible a a' - if lens_are_eq && as_are_eq - then return $ Just (bvvec_tp, BVVecToVec n len a m, NoConv) - else return $ Nothing -findInjConvs (asBVVecType -> Just (n, len, a)) _ - (asNonBVVecVectorType -> Just (m, a')) _ = - do len_nat <- liftSC2 scGlobalApply "Prelude.bvToNat" [n, len] - bvvec_tp <- liftSC2 scVecType len_nat a - lens_are_eq <- mrProveEq m len_nat - as_are_eq <- mrConvertible a a' - if lens_are_eq && as_are_eq - then return $ Just (bvvec_tp, NoConv, BVVecToVec n len a m) - else return $ Nothing --- add a 'pairToPair' conversion if we have pair types on both sides -findInjConvs (asPairType -> Just (tpL1, tpR1)) t1 - (asPairType -> Just (tpL2, tpR2)) t2 = - do tL1 <- mapM (flip doTermProj TermProjLeft ) t1 - tR1 <- mapM (flip doTermProj TermProjRight) t1 - tL2 <- mapM (flip doTermProj TermProjLeft ) t2 - tR2 <- mapM (flip doTermProj TermProjRight) t2 - mb_cLs <- findInjConvs tpL1 tL1 tpL2 tL2 - mb_cRs <- findInjConvs tpR1 tR1 tpR2 tR2 - case (mb_cLs, mb_cRs) of - (Just (tpL, cL1, cL2), Just (tpR, cR1, cR2)) -> - do pair_tp <- liftSC2 scPairType tpL tpR - return $ Just (pair_tp, PairToPair cL1 cR1, PairToPair cL2 cR2) - _ -> return $ Nothing --- otherwise, just check that the types are convertible -findInjConvs tp1 _ tp2 _ = - do tps_are_eq <- mrConvertible tp1 tp2 - if tps_are_eq - then return $ Just (tp1, NoConv, NoConv) - else return $ Nothing +-- 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 ---------------------------------------------------------------------- @@ -725,29 +796,23 @@ findInjConvs tp1 _ tp2 _ = -- | 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 >>= \tp -> mrEq' tp t1 t2 - --- | Build a Boolean 'Term' stating that the second and third 'Term' arguments --- are equal, where the first 'Term' gives their type (which we assume is the --- same for both). This is like 'scEq' except that it works on open terms. -mrEq' :: Term -> Term -> Term -> MRM t Term --- FIXME: For this Nat case, the definition of 'equalNat' in @Prims.hs@ means --- that if both sides do not have immediately clear bit-widths (e.g. either --- side is is an application of @mulNat@) this will 'error'... -mrEq' (asNatType -> Just _) t1 t2 = liftSC2 scEqualNat t1 t2 -mrEq' (asBoolType -> Just _) t1 t2 = liftSC2 scBoolEq t1 t2 -mrEq' (asIntegerType -> Just _) t1 t2 = liftSC2 scIntEq t1 t2 -mrEq' (asVectorType -> Just (n, asBoolType -> Just ())) t1 t2 = - liftSC3 scBvEq n t1 t2 -mrEq' (asDataType -> Just (primName -> "Cryptol.Num", _)) t1 t2 = - (,) <$> liftSC1 scWhnf t1 <*> liftSC1 scWhnf t2 >>= \case - (asNum -> Just (Left t1'), asNum -> Just (Left t2')) -> - liftSC0 scNatType >>= \nat_tp -> mrEq' nat_tp t1' t2' - _ -> error "mrEq': Num terms do not normalize to TCNum constructors" -mrEq' _ _ _ = error "mrEq': unsupported type" +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 +-- \"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 @@ -765,7 +830,7 @@ liftTermInCtx2 op (TermInCtx ctx1 t1) (TermInCtx ctx2 t2) = TermInCtx (ctx1++ctx2) <$> liftSC2 op t1' t2' -- | Extend the context of a 'TermInCtx' with additional universal variables --- bound "outside" the 'TermInCtx' +-- bound \"outside\" the 'TermInCtx' extTermInCtx :: [(LocalName,Term)] -> TermInCtx -> TermInCtx extTermInCtx ctx (TermInCtx ctx' t) = TermInCtx (ctx++ctx') t @@ -776,176 +841,157 @@ withTermInCtx (TermInCtx [] tm) f = f tm withTermInCtx (TermInCtx ((nm,tp):ctx) tm) f = withUVar nm (Type tp) $ const $ withTermInCtx (TermInCtx ctx tm) f --- | A "simple" strategy for proving equality between two terms, which we assume --- are of the same type, which builds an equality proposition by applying the --- supplied function to both sides and passes this proposition to an SMT solver. -mrProveEqSimple :: (Term -> Term -> MRM t Term) -> Term -> Term -> - MRM t TermInCtx --- NOTE: The use of mrSubstEVars instead of mrSubstEVarsStrict means that we --- allow evars in the terms we send to the SMT solver, but we treat them as --- uvars. -mrProveEqSimple eqf t1 t2 = - do t1' <- mrSubstEVars t1 - t2' <- mrSubstEVars t2 - TermInCtx [] <$> eqf t1' t2' - --- | Prove that two terms are equal, instantiating evars if necessary, --- returning true on success - the same as @mrProveRel False@ +-- | 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 False +mrProveEq = mrProveRel Nothing --- | Prove that two terms are equal, instantiating evars if necessary, or --- throwing an error if this is not possible - the same as --- @mrAssertProveRel False@ +-- | 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 False - --- | Prove that two terms are related, heterogeneously iff the first argument --- is true, instantiating evars if necessary, returning true on success -mrProveRel :: Bool -> Term -> Term -> MRM t Bool -mrProveRel het t1 t2 = - do let nm = if het then "mrProveRel" else "mrProveEq" - mrDebugPPPrefixSep 2 nm t1 (if het then "~=" else "==") t2 +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 - tps_eq <- mrConvertible tp1 tp2 - if not het && not tps_eq - then do mrDebugPPPrefixSep 2 (nm ++ ": Failure, types not equal:") - tp1 "and" tp2 - return False - else do cond_in_ctx <- mrProveRelH het tp1 tp2 t1 t2 - res <- withTermInCtx cond_in_ctx mrProvable - debugPrint 2 $ nm ++ ": " ++ if res then "Success" else "Failure" - return res - --- | Prove that two terms are related, heterogeneously iff the first argument, --- is true, instantiating evars if necessary, or throwing an error if this is --- not possible -mrAssertProveRel :: Bool -> Term -> Term -> MRM t () -mrAssertProveRel het t1 t2 = - do success <- mrProveRel het t1 t2 - if success then return () else - throwMRFailure (TermsNotRel het t1 t2) - --- | The main workhorse for 'mrProveEq' and 'mrProveRel'. Build a Boolean term --- expressing that the fourth and fifth arguments are related, heterogeneously --- iff the first argument is true, whose types are given by the second and --- third arguments, respectively -mrProveRelH :: Bool -> Term -> Term -> Term -> Term -> MRM t TermInCtx -mrProveRelH het tp1 tp2 t1 t2 = + 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 - mrProveRelH' varmap het tp1' tp2' t1 t2 + mrRelTerm' varmap piRel tp1' t1 tp2' t2 --- | The body of 'mrProveRelH' --- NOTE: Don't call this function recursively, call 'mrProveRelH' -mrProveRelH' :: Map MRVar MRVarInfo -> Bool -> - Term -> Term -> Term -> Term -> MRM t TermInCtx +-- | 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 -mrProveRelH' var_map het tp1 tp2 (asEVarApp var_map -> Just (_, args, Just f)) t2 = - mrApplyAll f args >>= \t1' -> mrProveRelH het tp1 tp2 t1' t2 +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 -mrProveRelH' var_map _ tp1 tp2 (asEVarApp var_map -> Just (evar, args, Nothing)) t2 = +mrRelTerm' var_map _ tp1 (asEVarApp var_map -> Just (evar, _, args, Nothing)) tp2 t2 = do tps_are_eq <- mrConvertible tp1 tp2 - if tps_are_eq then return () else - throwMRFailure (TypesNotEq (Type tp1) (Type 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 - TermInCtx [] <$> liftSC1 scBool success + Right <$> TermInCtx [] <$> liftSC1 scBool success -- If t2 is an instantiated evar, substitute and recurse -mrProveRelH' var_map het tp1 tp2 t1 (asEVarApp var_map -> Just (_, args, Just f)) = - mrApplyAll f args >>= \t2' -> mrProveRelH het tp1 tp2 t1 t2' +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 -mrProveRelH' var_map _ tp1 tp2 t1 (asEVarApp var_map -> Just (evar, args, Nothing)) = +mrRelTerm' var_map _ tp1 t1 tp2 (asEVarApp var_map -> Just (evar, _, args, Nothing)) = do tps_are_eq <- mrConvertible tp1 tp2 - if tps_are_eq then return () else - throwMRFailure (TypesNotEq (Type tp1) (Type 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 - TermInCtx [] <$> liftSC1 scBool success + Right <$> TermInCtx [] <$> liftSC1 scBool success -- For unit types, always return true -mrProveRelH' _ _ (asTupleType -> Just []) (asTupleType -> Just []) _ _ = - TermInCtx [] <$> liftSC1 scBool True - --- For Num, nat, bitvector, Boolean, and integer types, call mrProveEqSimple -mrProveRelH' _ _ _ _ (asNum -> Just (Left t1)) (asNum -> Just (Left t2)) = - mrProveEqSimple (liftSC2 scEqualNat) t1 t2 -mrProveRelH' _ _ (asNatType -> Just _) (asNatType -> Just _) t1 t2 = - mrProveEqSimple (liftSC2 scEqualNat) t1 t2 -mrProveRelH' _ _ tp1@(asVectorType -> Just (n1, asBoolType -> Just ())) - tp2@(asVectorType -> Just (n2, asBoolType -> Just ())) t1 t2 = - do ns_are_eq <- mrConvertible n1 n2 - if ns_are_eq then return () else - throwMRFailure (TypesNotEq (Type tp1) (Type tp2)) - mrProveEqSimple (liftSC3 scBvEq n1) t1 t2 -mrProveRelH' _ _ (asBoolType -> Just _) (asBoolType -> Just _) t1 t2 = - mrProveEqSimple (liftSC2 scBoolEq) t1 t2 -mrProveRelH' _ _ (asIntegerType -> Just _) (asIntegerType -> Just _) t1 t2 = - mrProveEqSimple (liftSC2 scIntEq) t1 t2 +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 -mrProveRelH' _ het tp1@(asBVVecType -> Just (n1, len1, tpA1)) - tp2@(asBVVecType -> Just (n2, len2, tpA2)) t1 t2 = - mrConvertible n1 n2 >>= \ns_are_eq -> - mrConvertible len1 len2 >>= \lens_are_eq -> - (if ns_are_eq && lens_are_eq then return () else - throwMRFailure (TypesNotEq (Type tp1) (Type tp2))) >> - liftSC0 scBoolType >>= \bool_tp -> - liftSC2 scVecType n1 bool_tp >>= \ix_tp -> - withUVarLift "ix" (Type ix_tp) (n1,(len1,(tpA1,(tpA2,(t1,t2))))) $ - \ix (n1',(len1',(tpA1',(tpA2',(t1',t2'))))) -> - do ix_bound <- liftSC2 scGlobalApply "Prelude.bvult" [n1', ix, len1'] - pf_tp <- liftSC1 scEqTrue ix_bound - pf <- mrErrorTerm pf_tp "FIXME" -- FIXME replace this with the below? - -- pf <- liftSC2 scGlobalApply "Prelude.unsafeAssertBVULt" [n1', ix, len1'] - t1_prj <- liftSC2 scGlobalApply "Prelude.atBVVec" [n1', len1', tpA1', - t1', ix, pf] - t2_prj <- liftSC2 scGlobalApply "Prelude.atBVVec" [n1', len1', tpA2', - t2', ix, pf] - cond <- mrProveRelH het tpA1' tpA2' t1_prj t2_prj - extTermInCtx [("ix",ix_tp)] <$> - liftTermInCtx2 scImplies (TermInCtx [] ix_bound) cond +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 -mrProveRelH' _ het (asPairType -> Just (tpL1, tpR1)) - (asPairType -> Just (tpL2, tpR2)) t1 t2 = +-- FIXME: Don't re-associate tuples +mrRelTerm' _ piRel (asPairType -> Just (asPairType -> Just (tp1a, tp1b), tp1c)) t1 + tp2 t2 = + do tp1' <- liftSC2 scPairType tp1a =<< liftSC2 scPairType tp1b tp1c + mrRelTerm piRel tp1' t1 tp2 t2 +mrRelTerm' _ piRel tp1 t1 + (asPairType -> Just (asPairType -> Just (tp2a, tp2b), tp2c)) t2 = + do tp2' <- liftSC2 scPairType tp2a =<< liftSC2 scPairType tp2b tp2c + mrRelTerm piRel tp1 t1 tp2' t2 +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 - condL <- mrProveRelH het tpL1 tpL2 t1L t2L - condR <- mrProveRelH het tpR1 tpR2 t1R t2R - liftTermInCtx2 scAnd condL condR - -mrProveRelH' _ het tp1 tp2 t1 t2 = findInjConvs tp1 (Just t1) tp2 (Just t2) >>= \case - -- If we are allowing heterogeneous equality and we can find non-trivial - -- injective conversions from a type @tp@ to @tp1@ and @tp2@, apply the - -- inverses of these conversions to @t1@ and @t2@ and continue checking - -- equality on the results - Just (tp, c1, c2) | nonTrivialConv c1 || nonTrivialConv c2 -> do - t1' <- mrApplyInvConv c1 t1 - t2' <- mrApplyInvConv c2 t2 - mrProveRelH True tp tp t1' t2' - -- Otherwise, just check convertibility - _ -> do - success <- mrConvertible t1 t2 - tps_eq <- mrConvertible tp1 tp2 - if success then return () else - if het || not tps_eq - then mrDebugPPPrefixSep 2 "mrProveRelH' could not match types: " tp1 "and" tp2 >> - mrDebugPPPrefixSep 2 "and could not prove convertible: " t1 "and" t2 - else mrDebugPPPrefixSep 2 "mrProveEq could not prove convertible: " t1 "and" t2 - TermInCtx [] <$> liftSC1 scBool success + 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/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index ec4a6795b2..b57c22db86 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -2,6 +2,7 @@ {-# 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' @@ -20,9 +21,8 @@ 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 and calls to -@liftStackS@ in computations, where @either@ is the sum elimination function -defined in the SAW core prelude: +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 @@ -34,33 +34,18 @@ defined in the SAW core prelude: > (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 -> (multiFixS funs body) >>= k = multiFixS funs (\F1 ... Fn -> body F1 ... Fn >>= k) -> -> liftStackS (retS x) = retS x -> liftStackS (errorS str) = errorS str -> liftStackS (m >>= k) = liftStackS m >>= \x -> liftStackS (k x) -> liftStackS (existsS f) = existsM (\x -> liftStackS (f x)) -> liftStackS (forallS f) = forallM (\x -> liftStackS (f x)) -> liftStackS (assumingS b m) = assumingM b (liftStackS m) -> liftStackS (assertingS b m) = assertingM b (liftStackS m) -> liftStackS (orS m1 m2) = orM (liftStackS m1) (liftStackS m2) -> liftStackS (if b then m1 else m2) = if b then liftStackS m1 else liftStackS m2 -> liftStackS (either f1 f2 e) = either (\x -> liftStackS f1 x) (\x -> liftStackS f2 x) e -> liftStackS (multiFixS funs body) = multiFixS funs (\F1 ... Fn -> liftStackS (body F1 ... Fn)) 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 | liftStackS (F e1 ... en) | -> F e1 ... en >>= k | liftStackS (F e1 ... en) >>= k | -> multiFixS (\F1 ... Fn -> (f1, ..., fn)) (\F1 ... Fn -> m) +> 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 @multiFixS@. Either way, monadic +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: @multiFixS@-bound +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 @@ -68,7 +53,7 @@ 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 @multiFixS@-bound variables. +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: @@ -101,12 +86,10 @@ we are trying to prove @m1@ refines @m2@ in context @C@. This proceeds by cases: > > C |- orS m1 m2 |= m: prove both C |- m1 |= m and C |- m2 |= m > -> C |- multiFixS (\F1 ... Fn -> (f1, ..., fn)) (\F1 ... Fn -> body) |= m: create -> multiFixS-bound variables F1 through Fn in the context bound to their unfoldings -> f1 through fn, respectively, and recurse on body |= 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 |= multiFixS (\F1 ... Fn -> (f1, ..., fn)) (\F1 ... Fn -> body): similar to -> previous case +> 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 @@ -125,8 +108,8 @@ we are trying to prove @m1@ refines @m2@ in context @C@. This proceeds by cases: > 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 multiFixS, or -> any related operations, unfold it +> * 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 @@ -135,36 +118,25 @@ we are trying to prove @m1@ refines @m2@ in context @C@. This proceeds by cases: > > * 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 - -Note that if either side of the final case is wrapped in a @liftStackS@, the -behavior is identical, just with a @liftStackS@ wrapped around the appropriate -unfolded function body or bodies. The only exception is the second to final case, -which also requires the both functions either be lifted or unlifted. -} module SAWScript.Prover.MRSolver.Solver where import Data.Maybe -import Data.Either -import Numeric.Natural (Natural) +import qualified Data.Text as T import Data.List (find, findIndices) import Data.Foldable (foldlM) import Data.Bits (shiftL) -import Control.Monad ((>=>), forM, zipWithM, zipWithM_) +import Control.Monad (void, foldM, forM, zipWithM, zipWithM_, (>=>)) import Control.Monad.Except (MonadError(..)) -import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.Reader (MonadReader(..), ReaderT(..)) -import Control.Monad.Trans.Class (MonadTrans(..)) import qualified Data.Map as Map import qualified Data.Text as Text import Data.Set (Set) -import Prettyprinter - +import Verifier.SAW.Utils (panic) import Verifier.SAW.Term.Functor import Verifier.SAW.SharedTerm import Verifier.SAW.Recognizer -import Verifier.SAW.Cryptol.Monadify import SAWScript.Prover.SolverStats import SAWScript.Proof (Sequent, SolveResult) import SAWScript.Value (TopLevel) @@ -179,6 +151,13 @@ import SAWScript.Prover.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] @@ -186,92 +165,49 @@ asNestedPairs (asPairValue -> Just (x, asNestedPairs -> Just xs)) = Just (x:xs) asNestedPairs (asFTermF -> Just UnitValue) = Just [] asNestedPairs _ = Nothing --- | Recognize a term of the form @Cons1 _ x1 (Cons1 _ x2 (... (Nil1 _)))@ -asList1 :: Recognizer Term [Term] -asList1 (asCtor -> Just (nm, [_])) - | primName nm == "Prelude.Nil1" = return [] -asList1 (asCtor -> Just (nm, [_, hd, tl])) - | primName nm == "Prelude.Cons1" = (hd:) <$> asList1 tl -asList1 _ = Nothing - --- | Recognize a term of the form @mkFrameCall frame n arg1 ... argn@ -asMkFrameCall :: Recognizer Term (Term, Natural, [Term]) -asMkFrameCall (asApplyAll -> ((isGlobalDef "Prelude.mkFrameCall" -> Just ()), - (frame : (asNat -> Just n) : args))) = - Just (frame, n, args) -asMkFrameCall _ = Nothing - --- | Recognize a term of the form @CallS _ _ _ (mkFrameCall frame n args)@ -asCallS :: Recognizer Term (Term, Natural, [Term]) -asCallS (asApplyAll -> - ((isGlobalDef "Prelude.callS" -> Just ()), - [_, _, _, - (asMkFrameCall -> Just (frame, n, args))])) = - Just (frame, n, args) -asCallS _ = Nothing - --- | Recursively traverse a 'Term' and replace each term of the form --- --- > CallS _ _ _ (mkFrameCall _ i arg1 ... argn) +-- | Recognize a term of the form @Cons _ x1 (Cons _ x2 (... (Nil _)))@ +asList :: Recognizer Term [Term] +asList (asCtor -> Just (nm, [_])) + | primName nm == "Prelude.Nil" = return [] +asList (asCtor -> Just (nm, [_, hd, tl])) + | primName nm == "Prelude.Cons" = (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 -- --- with the term @tmi arg1 ... argn@, where @tmi@ is the @i@th term in the list +-- > \F1 F2 ... Fn -> (f1, (f2, ... (fn, ()))) -- --- FIXME: what we /actually/ want here is to only replace recursive calls as --- they get normalized; that is, it would be more correct to only recurse inside --- lambdas, to the left and right of binds, and into the computational subterms --- of our variable monadic operations (including, e.g., if-then-else and the --- either and maybe eliminators). But the implementation here should give the --- correct result for any code we are actually going to see... -mrReplaceCallsWithTerms :: [Term] -> Term -> MRM t Term -mrReplaceCallsWithTerms top_tms top_t = - flip runReaderT top_tms $ - flip memoFixTermFun top_t $ \recurse t -> case t of - (asCallS -> Just (_, i, args)) -> - -- Replace a CallS with its corresponding term - ask >>= \tms -> lift $ mrApplyAll (tms!!(fromIntegral i)) args - (asApplyAll -> - (isGlobalDef "Prelude.multiFixS" -> Just (), _)) -> - -- Don't recurse inside another multiFixS, since it binds new calls - return t - (asLambda -> Just (x, tp, body)) -> - -- Lift our terms when we recurse inside a binder; also, not that we don't - -- expect to lift types, so we leave tp alone - do tms <- ask - tms' <- liftTermLike 0 1 tms - body' <- local (const tms') $ recurse body - lift $ liftSC3 scLambda x tp body' - (asPi -> Just _) -> - -- We don't expect to lift types, so we leave them alone - return t - _ -> traverseSubterms recurse t - - --- | Bind fresh function variables for a @multiFixS@ with the given list of --- @LetRecType@s and tuple of definitions for the function bodies -mrFreshCallVars :: Term -> Term -> Term -> Term -> MRM t [MRVar] -mrFreshCallVars ev stack frame defs_tm = +-- 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 (asConstant -> Just (_, Just defs_tm)) fun_tms = + -- If defs is a constant, unfold it + mrApplyMFixBodies defs_tm fun_tms +mrApplyMFixBodies defs_tm fun_tms = + 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 - -- First, make fresh function constants for all the recursive functions, - -- noting that each constant must abstract out the current uvar context - -- (see mrFreshVar) - new_stack <- liftSC2 scGlobalApply "Prelude.pushFunStack" [frame, stack] - lrts <- liftSC1 scWhnf frame >>= \case - (asList1 -> Just lrts) -> return lrts - _ -> throwMRFailure (MalformedLetRecTypes frame) - fun_tps <- forM lrts $ \lrt -> - liftSC2 scGlobalApply "Prelude.LRTType" [ev, new_stack, lrt] + -- Bind fresh function variables with the types given by fun_tps fun_vars <- mapM (mrFreshVar "F") fun_tps - - -- Next, match on the tuple of recursive function definitions and convert - -- each definition to a function body, by replacing all recursive calls in - -- each function body with our new variable terms (which are applied to the - -- current uvars; see mrVarTerm) and then lambda-abstracting all the - -- current uvars fun_tms <- mapM mrVarTerm fun_vars - defs_tm' <- liftSC1 scWhnf defs_tm - bodies <- case asNestedPairs defs_tm' of - Just defs -> mapM (mrReplaceCallsWithTerms fun_tms >=> lambdaUVarsM) defs - Nothing -> throwMRFailure (MalformedDefs defs_tm) + + -- 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 @@ -280,6 +216,19 @@ mrFreshCallVars ev stack frame defs_tm = 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 @@ -298,26 +247,33 @@ normComp (CompTerm t) = case asApplyAll t of (f@(asLambda -> Just _), args@(_:_)) -> mrApplyAll f args >>= normCompTerm - (isGlobalDef "Prelude.retS" -> Just (), [_, _, _, x]) -> + (isGlobalDef "SpecM.retS" -> Just (), [_, _, x]) -> return $ RetS x - (isGlobalDef "Prelude.bindS" -> Just (), [e, stack, _, _, m, f]) -> + (isGlobalDef "SpecM.bindS" -> Just (), [ev, _, _, m, f]) -> do norm <- normCompTerm m - normBind norm (CompFunTerm (SpecMParams e stack) f) - (isGlobalDef "Prelude.errorS" -> Just (), [_, _, _, str]) -> + normBind norm (CompFunTerm (EvTerm ev) f) + (isGlobalDef "SpecM.errorS" -> Just (), [_, _, str]) -> return (ErrorS str) - (isGlobalDef "Prelude.liftStackS" -> Just (), [ev, stk, _, t']) -> - normCompTerm t' >>= liftStackNormComp (SpecMParams ev stk) (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 (params, _)), f, g, eith]) -> - return $ Eithers [(Type ltp, CompFunTerm params f), - (Type rtp, CompFunTerm params g)] eith + [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 (params, _)), m, f, mayb]) -> + [tp, (asSpecM -> Just (ev, _)), m, f, mayb]) -> do tp' <- case asApplyAll tp of -- Always unfold: is_bvult, is_bvule (tpf@(asGlobalDef -> Just ident), args) @@ -325,59 +281,100 @@ normComp (CompTerm t) = , Just (_, Just body) <- asConstant tpf -> mrApplyAll body args _ -> return tp - return $ MaybeElim (Type tp') (CompTerm m) (CompFunTerm params f) mayb - (isGlobalDef "Prelude.orS" -> Just (), [_, _, _, m1, m2]) -> + return $ MaybeElim (Type tp') (CompTerm m) (CompFunTerm ev f) mayb + (isGlobalDef "SpecM.orS" -> Just (), [_, _, m1, m2]) -> return $ OrS (CompTerm m1) (CompTerm m2) - (isGlobalDef "Prelude.assertBoolS" -> Just (), [ev, stack, cond]) -> + (isGlobalDef "SpecM.assertBoolS" -> Just (), [ev, cond]) -> do unit_tp <- mrUnitType - return $ AssertBoolBind cond (CompFunReturn - (SpecMParams ev stack) unit_tp) - (isGlobalDef "Prelude.assumeBoolS" -> Just (), [ev, stack, cond]) -> + return $ AssertBoolBind cond (CompFunReturn (EvTerm ev) unit_tp) + (isGlobalDef "SpecM.assumeBoolS" -> Just (), [ev, cond]) -> do unit_tp <- mrUnitType - return $ AssumeBoolBind cond (CompFunReturn - (SpecMParams ev stack) unit_tp) - (isGlobalDef "Prelude.existsS" -> Just (), [ev, stack, tp]) -> + return $ AssumeBoolBind cond (CompFunReturn (EvTerm ev) unit_tp) + (isGlobalDef "SpecM.existsS" -> Just (), [ev, tp]) -> do unit_tp <- mrUnitType - return $ ExistsBind (Type tp) (CompFunReturn - (SpecMParams ev stack) unit_tp) - (isGlobalDef "Prelude.forallS" -> Just (), [ev, stack, tp]) -> + return $ ExistsBind (Type tp) (CompFunReturn (EvTerm ev) unit_tp) + (isGlobalDef "SpecM.forallS" -> Just (), [ev, tp]) -> do unit_tp <- mrUnitType - return $ ForallBind (Type tp) (CompFunReturn - (SpecMParams ev stack) unit_tp) - (isGlobalDef "Prelude.multiFixS" -> Just (), - [ev, stack, frame, defs, (asMkFrameCall -> Just (_, i, args))]) -> + 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 stack frame defs + 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 Unlifted <$> mkCompFunReturn <$> - mrFunOutType var all_args + FunBind var all_args <$> mkCompFunReturn <$> + mrFunOutType var all_args -} - (isGlobalDef "Prelude.multiArgFixS" -> Just (), _ev:_stack:_lrt:body:args) -> + (isGlobalDef "SpecM.LetRecS" -> Just (), [ev,tp_ds,_,defs,body]) -> do - -- Bind a fresh function var for the new recursive function - body_tp <- mrTypeOf body - fun_tp <- case asPi body_tp of - Just (_, tp_in, _) -> return tp_in - Nothing -> throwMRFailure (MalformedDefs body) - fun_var <- mrFreshVar "F" fun_tp - fun_tm <- mrVarTerm fun_var + -- 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 - -- Set the new function var to have body applied to it - body_app <- mrApply body fun_tm >>= lambdaUVarsM - mrSetVarInfo fun_var (CallVarInfo body_app) + -- Continue normalizing body applied to those fresh function vars + body_app <- mrApplyAll body fun_tms + normCompTerm body_app - -- Return the function variable applied to args as a normalized + -- 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 - all_args <- (++ args) <$> getAllUVarTerms - FunBind var all_args Unlifted <$> mkCompFunReturn <$> + 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)), @@ -391,20 +388,19 @@ normComp (CompTerm t) = -- Convert `atM (bvToNat ...) ... (bvToNat ...)` into the unfolding of -- `bvVecAtM` - (asGlobalDef -> Just "CryptolM.atM", [ev, stack, - (asBvToNat -> Just (w1, n)), a, xs, - (asBvToNat -> Just (w2, i))]) -> + (asGlobalDef -> Just "CryptolM.atM", [ev, (asBvToNat -> Just (w, n)), + a, xs, i_nat]) -> do body <- mrGlobalDefBody "CryptolM.bvVecAtM" - ws_are_eq <- mrConvertible w1 w2 - if ws_are_eq then - mrApplyAll body [ev, stack, w1, n, a, xs, i] >>= normCompTerm - else throwMRFailure (MalformedComp t) + 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, stack, - n_tm@(asNat -> Just n), a, xs, + (asGlobalDef -> Just "CryptolM.atM", [ev, n_tm@(asNat -> Just n), + a@(asBoolType -> Nothing), xs, (asBvToNat -> Just (w_tm@(asNat -> Just w), i))]) -> @@ -412,25 +408,24 @@ normComp (CompTerm t) = 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, stack, w_tm, n', a, xs', i] >>= normCompTerm - else throwMRFailure (MalformedComp t) + 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, stack, - (asBvToNat -> Just (w1, n)), a, xs, - (asBvToNat -> Just (w2, i)), x]) -> + (asGlobalDef -> Just "CryptolM.updateM", [ev, (asBvToNat -> Just (w, n)), + a, xs, i_nat, x]) -> do body <- mrGlobalDefBody "CryptolM.bvVecUpdateM" - ws_are_eq <- mrConvertible w1 w2 - if ws_are_eq then - mrApplyAll body [ev, stack, w1, n, a, xs, i, x] >>= normCompTerm - else throwMRFailure (MalformedComp t) + 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, stack, - n_tm@(asNat -> Just n), a, xs, + (asGlobalDef -> Just "CryptolM.updateM", [ev, n_tm@(asNat -> Just n), + a@(asBoolType -> Nothing), xs, (asBvToNat -> Just (w_tm@(asNat -> Just w), i)), x]) -> @@ -439,15 +434,18 @@ normComp (CompTerm t) = 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, stack, w_tm, n', a, xs', i, x, err_tm, n_tm] + mrApplyAll body [ev, w_tm, n', a, xs', i, x, err_tm, n_tm] >>= normCompTerm - else throwMRFailure (MalformedComp t) + else throwMRFailure (MalformedComp t) - -- Always unfold: sawLet, multiArgFixM, invariantHint, Num_rec + -- Always unfold: sawLet, Num_rec, invariantHint, assumingS, assertingS, + -- forNatLtThenSBody, vecMapM, vecMapBindM, seqMapM (f@(asGlobalDef -> Just ident), args) - | ident `elem` ["Prelude.sawLet", "Prelude.invariantHint", - "Cryptol.Num_rec", "Prelude.multiArgFixS", - "Prelude.lrtLambda"] + | 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 (_, Just body) <- asConstant f -> mrApplyAll body args >>= normCompTerm @@ -471,11 +469,11 @@ normComp (CompTerm t) = -- FIXME: substitute for evars if they have been instantiated ((asExtCns -> Just ec), args) -> do fun_name <- extCnsToFunName ec - FunBind fun_name args Unlifted <$> mkCompFunReturn <$> + FunBind fun_name args <$> mkCompFunReturn <$> mrFunOutType fun_name args ((asGlobalFunName -> Just f), args) -> - FunBind f args Unlifted <$> mkCompFunReturn <$> mrFunOutType f args + FunBind f args <$> mkCompFunReturn <$> mrFunOutType f args _ -> throwMRFailure (MalformedComp t) @@ -498,7 +496,7 @@ 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 isLifted k1) k2 +normBind (FunBind f args k1) k2 -- Turn `bvVecMapInvarM ... >>= k` into `bvVecMapInvarBindM ... k` {- | GlobalName (globalDefString -> "CryptolM.bvVecMapInvarM") [] <- f @@ -515,73 +513,11 @@ normBind (FunBind f args isLifted k1) k2 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 isLifted (compFunComp k1 k2) - --- | Bind a computation in whnf with a function, normalize, and then call --- 'liftStackNormComp' if the first argument is 'Lifted'. If the first argument --- is 'Unlifted', this function is the same as 'normBind'. -normBindLiftStack :: IsLifted -> NormComp -> CompFun -> MRM t NormComp -normBindLiftStack Unlifted t f = normBind t f -normBindLiftStack Lifted t f = - liftStackNormComp (compFunSpecMParams f) t >>= \t' -> normBind t' f - --- | Bind a 'Term' for a computation with with a function, normalize, and then --- call 'liftStackNormComp' if the first argument is 'Lifted'. See: --- 'normBindLiftStack'. -normBindTermLiftStack :: IsLifted -> Term -> CompFun -> MRM t NormComp -normBindTermLiftStack isLifted t f = - normCompTerm t >>= \m -> normBindLiftStack isLifted m f - - --- | Apply @liftStackS@ to a computation in whnf, and normalize -liftStackNormComp :: SpecMParams Term -> NormComp -> MRM t NormComp -liftStackNormComp _ (RetS t) = return (RetS t) -liftStackNormComp _ (ErrorS msg) = return (ErrorS msg) -liftStackNormComp params (Ite cond comp1 comp2) = - Ite cond <$> liftStackComp params comp1 <*> liftStackComp params comp2 -liftStackNormComp params (Eithers elims t) = - Eithers <$> mapM (\(tp,f) -> (tp,) <$> liftStackCompFun params f) elims - <*> return t -liftStackNormComp params (MaybeElim tp m f t) = - MaybeElim tp <$> liftStackComp params m - <*> liftStackCompFun params f <*> return t -liftStackNormComp params (OrS comp1 comp2) = - OrS <$> liftStackComp params comp1 <*> liftStackComp params comp2 -liftStackNormComp params (AssertBoolBind cond f) = - AssertBoolBind cond <$> liftStackCompFun params f -liftStackNormComp params (AssumeBoolBind cond f) = - AssumeBoolBind cond <$> liftStackCompFun params f -liftStackNormComp params (ExistsBind tp f) = - ExistsBind tp <$> liftStackCompFun params f -liftStackNormComp params (ForallBind tp f) = - ForallBind tp <$> liftStackCompFun params f -liftStackNormComp params (FunBind f args _ k) = - FunBind f args Lifted <$> liftStackCompFun params k - --- | Apply @liftStackS@ to a computation -liftStackComp :: SpecMParams Term -> Comp -> MRM t Comp -liftStackComp (SpecMParams ev stk) (CompTerm t) = mrTypeOf t >>= \case - (asSpecM -> Just (_, tp)) -> - CompTerm <$> liftSC2 scGlobalApply "Prelude.liftStackS" [ev, stk, tp, t] - _ -> error "liftStackComp: type not of the form: SpecM a" -liftStackComp _ (CompReturn t) = return $ CompReturn t -liftStackComp params (CompBind c f) = - CompBind <$> liftStackComp params c <*> liftStackCompFun params f - --- | Apply @liftStackS@ to the bodies of a composition of functions -liftStackCompFun :: SpecMParams Term -> CompFun -> MRM t CompFun -liftStackCompFun params@(SpecMParams ev stk) (CompFunTerm _ f) = mrTypeOf f >>= \case - (asPi -> Just (_, _, asSpecM -> Just (_, tp))) -> - let nm = maybe "ret_val" id (asLambdaName f) in - CompFunTerm params <$> - mrLambdaLift1 (nm, tp) (ev, stk, tp, f) (\arg (ev', stk', tp', f') -> - do app <- mrApplyAll f' [arg] - liftSC2 scGlobalApply "Prelude.liftStackS" [ev', stk', tp', app]) - _ -> error "liftStackCompFun: type not of the form: a -> SpecM b" -liftStackCompFun params (CompFunReturn _ tp) = return $ CompFunReturn params tp -liftStackCompFun params (CompFunComp f g) = - CompFunComp <$> liftStackCompFun params f <*> liftStackCompFun params g + | 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' @@ -610,19 +546,19 @@ compFunToTerm (CompFunComp f g) = f_tp <- mrTypeOf f' g_tp <- mrTypeOf g' case (f_tp, g_tp) of - (asPi -> Just (_, a, asSpecM -> Just (params, b)), + (asPi -> Just (_, a, asSpecM -> Just (ev, b)), asPi -> Just (_, _, asSpecM -> Just (_, c))) -> - -- we explicitly unfold @Prelude.composeM@ here so @mrApplyAll@ will + -- 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 "Prelude.bindS" (specMParamsArgs params ++ - [b', c', app, g'']) + liftSC2 scGlobalApply "SpecM.bindS" [unEvTerm ev, + b', c', app, g''] _ -> error "compFunToTerm: type(s) not of the form: a -> SpecM b" -compFunToTerm (CompFunReturn params (Type a)) = +compFunToTerm (CompFunReturn ev (Type a)) = mrLambdaLift1 ("ret_val", a) a $ \ret_val a' -> - liftSC2 scGlobalApply "Prelude.retS" (specMParamsArgs params ++ [a', ret_val]) + liftSC2 scGlobalApply "SpecM.retS" [unEvTerm ev, a', ret_val] {- -- | Convert a 'Comp' into a 'Term' @@ -630,14 +566,14 @@ compToTerm :: Comp -> MRM t Term compToTerm (CompTerm t) = return t compToTerm (CompReturn t) = do tp <- mrTypeOf t - liftSC2 scGlobalApply "Prelude.returnM" [tp, 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 "Prelude.bindM" [a, b, m', f'] + liftSC2 scGlobalApply "SpecM.bindS" [a, b, m', f'] _ -> error "compToTerm: type not of the form: a -> SpecM b" -} @@ -649,7 +585,7 @@ 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 Unlifted <$> mkCompFunReturn <$> mrFunOutType f args + FunBind f args <$> mkCompFunReturn <$> mrFunOutType f args mrFunAssumpRHSAsNormComp (RewriteFunAssump rhs) = normCompTerm rhs @@ -658,8 +594,8 @@ matchEitherElims :: Term -> Maybe [EitherElim] matchEitherElims (asCtor -> Just (primName -> "Prelude.FunsTo_Nil", [_])) = Just [] matchEitherElims (asCtor -> Just (primName -> "Prelude.FunsTo_Cons", - [asSpecM -> Just (params, _), tp, f, rest])) = - ((Type tp, CompFunTerm params f):) <$> + [asSpecM -> Just (ev, _), tp, f, rest])) = + ((Type tp, CompFunTerm ev f):) <$> matchEitherElims rest matchEitherElims _ = Nothing @@ -701,7 +637,7 @@ mrUnfoldFunBind f args mark g = -} {- -FIXME HERE NOW: maybe each FunName should stipulate whether it is recursive or +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 -} @@ -743,17 +679,18 @@ mrRefinesCoInd f1 args1 f2 args2 = preF2 <- mrGetInvariant f2 let hyp = CoIndHyp ctx f1 f2 args1 args2 preF1 preF2 proveCoIndHypInvariant hyp - proveCoIndHyp hyp + proveCoIndHyp [] hyp -- | Prove the refinement represented by a 'CoIndHyp' coinductively. This is the -- main loop implementing 'mrRefinesCoInd'. See that function for documentation. -proveCoIndHyp :: CoIndHyp -> MRM t () -proveCoIndHyp hyp = withFailureCtx (FailCtxCoIndHyp hyp) $ +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 - debugPretty 1 ("proveCoIndHyp" <+> ppInEmptyCtx 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 @@ -761,12 +698,17 @@ proveCoIndHyp hyp = withFailureCtx (FailCtxCoIndHyp hyp) $ (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 hyp' + proveCoIndHyp (new_vars:prev_specs) hyp' e -> throwError e -- | Test that a coinductive hypothesis for the given function names matches the @@ -777,91 +719,143 @@ matchCoIndHyp hyp args1 args2 = (args1', args2') <- instantiateCoIndHyp hyp mrDebugPPPrefixSep 3 "matchCoIndHyp args" args1 "," args2 mrDebugPPPrefixSep 3 "matchCoIndHyp args'" args1' "," args2' - eqs1 <- zipWithM mrProveEq args1' args1 - eqs2 <- zipWithM mrProveEq args2' 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 some of the arguments of a coinductive hypothesis +-- | 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 arg_spec + -- 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 - -- Partition @arg_specs@ into a left list (@eq_specs@) and a right list - -- (@uneq_specs@) where an @arg_spec_i@ is put in the left list if - -- 'findInjConvs' returns 'Just' and @arg_tm_0@ and @arg_tm_i@ are related - -- via 'mrProveRel' - i.e. if there exists a type @tp_i@ and 'InjConversion's - -- @c1_i@ and @c2_i@ such that @c1_i@ is an injective conversion from - -- 'tp_i' to 'arg_tp_0', @c2_i@ is an injective conversion from - -- 'tp_i' to 'arg_tp_i', and @arg_tm_0@ and @arg_tm_i@ are convertible when - -- the inverses of @c1_i@ and @c2_i@ are applied. In other words, @eq_specs@ - -- contains all the specs which are equal to @arg_spec_0@ up to some - -- injective conversions. - (eq_specs, uneq_specs) <- fmap partitionEithers $ forM arg_specs $ \arg_spec_i -> - let arg_tm_i = coIndHypArg hyp arg_spec_i in - mrTypeOf arg_tm_i >>= \arg_tp_i -> - findInjConvs arg_tp_0 (Just arg_tm_0) arg_tp_i (Just arg_tm_i) >>= \case - Just cvs -> mrProveRel True arg_tm_0 arg_tm_i >>= \case - True -> return $ Left (arg_spec_i, cvs) - _ -> return $ Right arg_spec_i - _ -> return $ Right arg_spec_i - -- What want to do is generalize all the arg_specs in @eq_specs@ into a - -- single variable (with some appropriate conversions applied). So, what - -- we need to do is find a @tp@ (and appropriate conversions) such that the - -- following diagram holds for all @i@ and @j@ (using the names from the - -- previous comment): - -- - -- > arg_tp_i arg_tp_0 arg_tp_j - -- > ^ ^ ^ ^ - -- > \ / \ / - -- > tp_i tp_j - -- > ^ ^ - -- > \ / - -- > tp - -- - -- To do this, we simply need to call 'findInjConvs' iteratively as we fold - -- through @eq_specs@, and compose the injective conversions appropriately. - -- Each step of this iteration is @cbnConvs@, which can be pictured as: - -- - -- > arg_tp_0 arg_tp_i - -- > ^ ^ ^ - -- > c_0 | c1_i \ / c2_i - -- > | \ / - -- > tp tp_i - -- > ^ ^ - -- > c1 \ / c2 - -- > \ / - -- > tp' - -- - -- where @c1@, @c2@, and @tp'@ come from 'findInjConvs' on @tp@ and @tp_i@, - -- and the @tp@ and @c_0@ to use for the next (@i+1@th) iteration are @tp'@ - -- and @c_0 <> c1@. - let cbnConvs :: (Term, InjConversion, [(a, InjConversion)]) -> - (a, (Term, InjConversion, InjConversion)) -> - MRM t (Term, InjConversion, [(a, InjConversion)]) - cbnConvs (tp, c_0, cs) (arg_spec_i, (tp_i, _, c2_i)) = - findInjConvs tp Nothing tp_i Nothing >>= \case - Just (tp', c1, c2) -> - let cs' = fmap (\(spec_j, c_j) -> (spec_j, c_j <> c1)) cs in - return $ (tp', c_0 <> c1, (arg_spec_i, c2_i <> c2) : cs') - Nothing -> error "generalizeCoIndHyp: could not find mutual conversion" - (tp, c_0, eq_specs_cs) <- foldlM cbnConvs (arg_tp_0, NoConv, []) eq_specs - -- Finally we generalize: We add a new variable of type @tp@ and substitute - -- it for all of the arguments in @hyp@ given by @eq_specs@, applying the - -- appropriate conversions from @eq_specs_cs@ - (hyp', var) <- coIndHypWithVar hyp "z" (Type tp) - hyp'' <- foldlM (\hyp_i (arg_spec_i, c_i) -> - coIndHypSetArg hyp_i arg_spec_i <$> mrApplyConv c_i var) - hyp' ((arg_spec_0, c_0) : eq_specs_cs) + 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_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 ---------------------------------------------------------------------- @@ -890,71 +884,39 @@ mrRefines t1 t2 = -- 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) = mrAssertProveRel True e1 e2 +mrRefines' (RetS e1) (RetS e2) = mrAssertProveEqBiRef e1 e2 mrRefines' (ErrorS _) (ErrorS _) = return () -mrRefines' (RetS e) (ErrorS _) = throwMRFailure (ReturnNotError e) -mrRefines' (ErrorS _) (RetS e) = throwMRFailure (ReturnNotError e) - --- maybe elimination on equality types -mrRefines' (MaybeElim (Type cond_tp@(asEq -> Just (tp,e1,e2))) m1 f1 _) m2 = - do cond <- mrEq' tp e1 e2 - not_cond <- liftSC1 scNot cond - cond_pf <- mrDummyProof cond_tp - m1' <- applyNormCompFun f1 cond_pf - cond_holds <- mrProvable cond - not_cond_holds <- mrProvable not_cond - case (cond_holds, not_cond_holds) of - (True, _) -> mrRefines m1' m2 - (_, True) -> mrRefines m1 m2 - _ -> withAssumption cond (mrRefines m1' m2) >> - withAssumption not_cond (mrRefines m1 m2) -mrRefines' m1 (MaybeElim (Type cond_tp@(asEq -> Just (tp,e1,e2))) m2 f2 _) = - do cond <- mrEq' tp e1 e2 - not_cond <- liftSC1 scNot cond - cond_pf <- mrDummyProof cond_tp - m2' <- applyNormCompFun f2 cond_pf - cond_holds <- mrProvable cond - not_cond_holds <- mrProvable not_cond - case (cond_holds, not_cond_holds) of - (True, _) -> mrRefines m1 m2' - (_, True) -> mrRefines m1 m2 - _ -> withAssumption cond (mrRefines m1 m2') >> - withAssumption not_cond (mrRefines m1 m2) - --- maybe elimination on isFinite types -mrRefines' (MaybeElim (Type fin_tp@(asIsFinite -> Just n1)) m1 f1 _) m2 = - do n1_norm <- mrNormOpenTerm n1 - maybe_assump <- mrGetDataTypeAssump n1_norm - fin_pf <- mrDummyProof fin_tp - case (maybe_assump, asNum n1_norm) of - (_, Just (Left _)) -> applyNormCompFun f1 fin_pf >>= flip mrRefines m2 - (_, Just (Right _)) -> mrRefines m1 m2 - (Just (IsNum _), _) -> applyNormCompFun f1 fin_pf >>= flip mrRefines m2 - (Just IsInf, _) -> mrRefines m1 m2 - _ -> - withDataTypeAssump n1_norm IsInf (mrRefines m1 m2) >> - liftSC0 scNatType >>= \nat_tp -> - (withUVarLift "n" (Type nat_tp) (n1_norm, f1, m2) $ \ n (n1', f1', m2') -> - withDataTypeAssump n1' (IsNum n) - (applyNormCompFun f1' n >>= flip mrRefines m2')) -mrRefines' m1 (MaybeElim (Type fin_tp@(asIsFinite -> Just n2)) m2 f2 _) = - do n2_norm <- mrNormOpenTerm n2 - maybe_assump <- mrGetDataTypeAssump n2_norm - fin_pf <- mrDummyProof fin_tp - case (maybe_assump, asNum n2_norm) of - (_, Just (Left _)) -> applyNormCompFun f2 fin_pf >>= mrRefines m1 - (_, Just (Right _)) -> mrRefines m1 m2 - (Just (IsNum _), _) -> applyNormCompFun f2 fin_pf >>= mrRefines m1 - (Just IsInf, _) -> mrRefines m1 m2 - _ -> - withDataTypeAssump n2_norm IsInf (mrRefines m1 m2) >> - liftSC0 scNatType >>= \nat_tp -> - (withUVarLift "n" (Type nat_tp) (n2_norm, f2, m1) $ \ n (n2', f2', m1') -> - withDataTypeAssump n2' (IsNum n) - (applyNormCompFun f2' n >>= mrRefines m1')) +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 -> @@ -1022,20 +984,39 @@ mrRefines' m1 (Eithers ((tp,f2):elims) t2) = mrRefines' m1 (AssumeBoolBind cond2 k2) = do m2 <- liftSC0 scUnitValue >>= applyCompFun k2 - withAssumption cond2 $ mrRefines m1 m2 + 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 - withAssumption cond1 $ mrRefines m1 m2 + 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 - withUVarLift nm tp (m1,f2) $ \x (m1',f2') -> - applyNormCompFun f2' x >>= \m2' -> + 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 - withUVarLift nm tp (f1,m2) $ \x (f1',m2') -> - applyNormCompFun f1' x >>= \m1' -> + 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') = @@ -1045,9 +1026,9 @@ mrRefines' (OrS m1 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 = +mrRefines' m1@(FunBind (EVarFunName _) _ _) m2 = throwMRFailure (CompsDoNotRefine m1 m2) -mrRefines' m1 m2@(FunBind (EVarFunName _) _ _ _) = +mrRefines' m1 m2@(FunBind (EVarFunName _) _ _) = throwMRFailure (CompsDoNotRefine m1 m2) {- mrRefines' (FunBind (EVarFunName evar) args (CompFunReturn _)) m2 = @@ -1058,18 +1039,17 @@ mrRefines' (FunBind (EVarFunName evar) args (CompFunReturn _)) m2 = Nothing -> mrTrySetAppliedEVar evar args m2 -} -mrRefines' (FunBind (CallSName f) args1 isLifted k1) - (FunBind (CallSName f') args2 isLifted' k2) - | f == f' && isLifted == isLifted' && length args1 == length args2 = - zipWithM_ mrAssertProveEq args1 args2 >> - mrFunOutType (CallSName f) args1 >>= \(_, tp) -> +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 isLifted1 k1) - m2@(FunBind f2 args2 isLifted2 k2) = - mrFunOutType f1 args1 >>= \(_, tp1) -> - mrFunOutType f2 args2 >>= \(_, tp2) -> - findInjConvs tp1 Nothing tp2 Nothing >>= \mb_convs -> +mrRefines' m1@(FunBind f1 args1 k1) + m2@(FunBind f2 args2 k2) = + 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 -> @@ -1089,7 +1069,7 @@ mrRefines' m1@(FunBind f1 args1 isLifted1 k1) -- 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 debugPretty 2 $ flip runPPInCtxM ctx $ + do mrDebugPPInCtxM 2 $ prettyWithCtx ctx $ prettyAppList [return "mrRefines using opaque FunAssump:", prettyInCtx ctx, return ".", prettyTermApp (funNameTerm f1) args1', @@ -1097,15 +1077,15 @@ mrRefines' m1@(FunBind f1 args1 isLifted1 k1) prettyTermApp (funNameTerm f2) args2'] evars <- mrFreshEVars ctx (args1'', args2'') <- substTermLike 0 evars (args1', args2') - zipWithM_ mrAssertProveEq args1'' args1 - zipWithM_ mrAssertProveEq args2'' 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 -> - normBindTermLiftStack isLifted2 f2_body k2 >>= \m2' -> + normBindTerm f2_body k2 >>= \m2' -> recordUsedFunAssump fa >> mrRefines m1 m2' -- If we have a rewrite FunAssump, or we have an opaque FunAssump that @@ -1113,8 +1093,12 @@ mrRefines' m1@(FunBind f1 args1 isLifted1 k1) -- 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 debugPretty 2 $ flip runPPInCtxM ctx $ - prettyAppList [return "mrRefines rewriting by FunAssump:", + 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 "|=", @@ -1126,42 +1110,40 @@ mrRefines' m1@(FunBind f1 args1 isLifted1 k1) rhs' <- mrFunAssumpRHSAsNormComp rhs evars <- mrFreshEVars ctx (args1'', rhs'') <- substTermLike 0 evars (args1', rhs') - zipWithM_ mrAssertProveEq args1'' args1 - m1' <- normBindLiftStack isLifted1 rhs'' k1 + 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 -> - normBindTermLiftStack isLifted1 f1_body k1 >>= \m1' -> mrRefines m1' m2 + 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 -> - normBindTermLiftStack isLifted2 f2_body k2 >>= \m2' -> mrRefines m1 m2' + 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 are either lifted or - -- unlifted, and both f1 and f2 are recursive and have return types which are - -- heterogeneously related, 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 _ <- mb_convs - , Just _ <- maybe_f1_body - , Just _ <- maybe_f2_body - , isLifted1 == isLifted2 -> - mrRefinesCoInd f1 args1 f2 args2 >> mrRefinesFun tp1 k1 tp2 k2 + -- 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 - _ -> - do if isLifted1 /= isLifted2 - then debugPrint 1 "mrRefines: isLifted cases do not match" - else mrDebugPPPrefixSep 1 "mrRefines: bind types not equal:" tp1 "/=" tp2 - throwMRFailure (CompsDoNotRefine m1 m2) + _ -> throwMRFailure (FunNamesDoNotRefine f1 args1 f2 args2) -mrRefines' m1@(FunBind f1 args1 isLifted1 k1) m2 = +mrRefines' m1@(FunBind f1 args1 k1) m2 = mrGetFunAssump f1 >>= \case -- If we have an assumption that f1 args' refines some rhs, then prove that @@ -1170,8 +1152,11 @@ mrRefines' m1@(FunBind f1 args1 isLifted1 k1) m2 = do rhs' <- mrFunAssumpRHSAsNormComp rhs evars <- mrFreshEVars ctx (args1'', rhs'') <- substTermLike 0 evars (args1', rhs') - zipWithM_ mrAssertProveEq args1'' args1 - m1' <- normBindLiftStack isLifted1 rhs'' k1 + 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 @@ -1180,19 +1165,19 @@ mrRefines' m1@(FunBind f1 args1 isLifted1 k1) m2 = -- If f1 unfolds and is not recursive in itself, unfold it and recurse Just (f1_body, False) -> - normBindTermLiftStack isLifted1 f1_body k1 >>= \m1' -> mrRefines m1' m2 + 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 isLifted2 k2) = +mrRefines' m1 m2@(FunBind f2 args2 k2) = mrFunBodyRecInfo f2 args2 >>= \case -- If f2 unfolds and is not recursive in itself, unfold it and recurse Just (f2_body, False) -> - normBindTermLiftStack isLifted2 f2_body k2 >>= \m2' -> mrRefines m1 m2' + 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 @@ -1228,13 +1213,21 @@ mrRefines'' (AssumeBoolBind cond1 k1) m2 = mrRefines'' m1 (ExistsBind tp f2) = do let nm = maybe "x" id (compFunVarName f2) - evar <- mrFreshEVar nm tp - m2' <- applyNormCompFun f2 evar + 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) - evar <- mrFreshEVar nm tp - m1' <- applyNormCompFun f1 evar + 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 @@ -1251,35 +1244,80 @@ mrRefinesFun tp1 f1 tp2 f2 = 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'' - piTp2 <- mrTypeOf f2'' + piTp1 <- mrTypeOf f1'' >>= mrNormOpenTerm + piTp2 <- mrTypeOf f2'' >>= mrNormOpenTerm mrRefinesFunH mrRefines [] piTp1 f1'' piTp2 f2'' --- | The main loop of 'mrRefinesFun' and 'askMRSolver': given a continuation, --- two terms of function type, and two equal-length lists representing the --- argument types of the two terms, add a uvar for each corresponding pair of --- types (assuming the types are either equal or are heterogeneously related, --- as in 'HetRelated'), apply the terms to these uvars (modulo possibly some --- wrapper functions determined by how the types are heterogeneously related), --- and call the continuation on the resulting terms. The second argument is --- an accumulator of variables to introduce, innermost first. -mrRefinesFunH :: (Term -> Term -> MRM t a) -> [Term] -> - Term -> Term -> Term -> Term -> MRM t a +-- | 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@(asEq -> Just (asBoolType -> Just (), b1, b2)), _)) t1 piTp2 t2 = +mrRefinesFunH k vars (asPi -> Just (nm1, tp1@(asBoolEq -> + Just (b1, b2)), _)) t1 piTp2 t2 = liftSC2 scBoolEq b1 b2 >>= \eq -> withAssumption eq $ - let nm = maybe "_" id $ find ((/=) '_' . Text.head) + 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@(asEq -> Just (asBoolType -> Just (), b1, b2)), _)) 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 "_" id $ find ((/=) '_' . Text.head) + 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] @@ -1289,6 +1327,7 @@ mrRefinesFunH k vars piTp1 t1 (asPi -> Just (nm2, tp2@(asEq -> Just (asBoolType -- 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' -> @@ -1298,29 +1337,39 @@ mrRefinesFunH k vars (asPi -> Just (nm1, asPairType -> Just (tpL1, tpR1), _)) t1 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 = - findInjConvs tp1 Nothing tp2 Nothing >>= \case + 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, c1, c2) -> + Just (tp, r1, r2) -> mrDebugPPPrefixSep 3 "mrRefinesFunH calling findInjConvs" tp1 "," tp2 >> mrDebugPPPrefix 3 "mrRefinesFunH got type" tp >> - let nm = maybe "_" id $ find ((/=) '_' . Text.head) + let nm = maybe "x" id $ find ((/=) '_' . Text.head) $ [nm1, nm2] ++ catMaybes [ asLambdaName t1 , asLambdaName t2 ] in - withUVarLift nm (Type tp) (vars,c1,c2,t1,t2) $ \var (vars',c1',c2',t1',t2') -> - do tm1 <- mrApplyConv c1' var - tm2 <- mrApplyConv c2' var + 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 (TypesNotRel True (Type tp1) (Type tp2)) + 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 @@ -1332,11 +1381,13 @@ mrRefinesFunH _ _ (asPi -> Nothing) _ (asPi -> Just (_,tp2,_)) _ = throwMRFailure (TypesNotEq (Type utp) (Type tp2)) -- Error if either side's return type is not SpecM -mrRefinesFunH _ _ tp1@(asSpecM -> Nothing) _ _ _ = - throwMRFailure (NotCompFunType tp1) -mrRefinesFunH _ _ _ _ tp2@(asSpecM -> Nothing) _ = - throwMRFailure (NotCompFunType tp2) +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 @@ -1367,35 +1418,36 @@ askMRSolver :: askMRSolver sc env timeout askSMT rs args t1 t2 = execMRM sc env timeout askSMT rs $ withUVars (mrVarCtxFromOuterToInner args) $ \_ -> - do tp1 <- liftIO $ scTypeOf sc t1 >>= scWhnf sc - tp2 <- liftIO $ scTypeOf sc t2 >>= scWhnf sc + do tp1 <- liftSC1 scTypeOf t1 >>= mrNormOpenTerm + tp2 <- liftSC1 scTypeOf t2 >>= mrNormOpenTerm mrDebugPPPrefixSep 1 "mr_solver" t1 "|=" t2 mrRefinesFunH (askMRSolverH mrRefines) [] tp1 t1 tp2 t2 --- | The continuation passed to 'mrRefinesFunH' in 'refinementTerm' - returns --- the 'Term' which is the refinement (@Prelude.refinesS@) of the given --- 'Term's, after quantifying over all current 'mrUVars' with Pi types. Note --- that this assumes both terms have the same event and stack types - if they --- do not a saw-core typechecking error will be raised. +-- | 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 (SpecMParams _ev1 _stack1, tp1) <- fromJust . asSpecM <$> mrTypeOf t1 - (SpecMParams ev2 stack2, tp2) <- fromJust . asSpecM <$> mrTypeOf t2 - rpre <- liftSC2 scGlobalApply "Prelude.eqPreRel" [ev2, stack2] - rpost <- liftSC2 scGlobalApply "Prelude.eqPostRel" [ev2, stack2] - rr <- liftSC2 scGlobalApply "Prelude.eqRR" [tp2] - -- NB: This will throw a type error if _ev1 /= ev2 or _stack1 /= stack2 - ref_tm <- liftSC2 scGlobalApply "Prelude.refinesS" - [ev2, ev2, stack2, stack2, rpre, rpost, - tp1, tp2, rr, 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 --- | Return the 'Term' which is the refinement (@Prelude.refinesS@) of fully --- applied versions of the given 'Term's, 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 +-- | 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 -} -> @@ -1408,6 +1460,6 @@ refinementTerm :: refinementTerm sc env timeout askSMT rs args t1 t2 = evalMRM sc env timeout askSMT rs $ withUVars (mrVarCtxFromOuterToInner args) $ \_ -> - do tp1 <- liftIO $ scTypeOf sc t1 >>= scWhnf sc - tp2 <- liftIO $ scTypeOf sc t2 >>= scWhnf sc + do tp1 <- liftSC1 scTypeOf t1 >>= mrNormOpenTerm + tp2 <- liftSC1 scTypeOf t2 >>= mrNormOpenTerm mrRefinesFunH refinementTermH [] tp1 t1 tp2 t2 diff --git a/src/SAWScript/Prover/MRSolver/Term.hs b/src/SAWScript/Prover/MRSolver/Term.hs index ccbb3d04af..58ab969352 100644 --- a/src/SAWScript/Prover/MRSolver/Term.hs +++ b/src/SAWScript/Prover/MRSolver/Term.hs @@ -56,6 +56,14 @@ import Verifier.SAW.Cryptol.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) @@ -112,7 +120,7 @@ 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 Term deriving (Generic, Show) +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. @@ -170,15 +178,7 @@ mrVarCtxOuterToInner = reverse . mrVarCtxInnerToOuter mrVarCtxFromOuterToInner :: [(LocalName,Term)] -> MRVarCtx mrVarCtxFromOuterToInner = mrVarCtxFromInnerToOuter . reverse --- | Convert a 'SpecMParams' to a list of arguments -specMParamsArgs :: SpecMParams Term -> [Term] -specMParamsArgs (SpecMParams ev stack) = [ev, stack] - --- | A datatype indicating whether an application of a 'FunName' is wrapped in --- a call to @liftStackS@ - used in the 'FunBind' constructor of 'NormComp' -data IsLifted = Lifted | Unlifted deriving (Generic, Eq, Show) - --- | A Haskell representation of a @SpecM@ in "monadic normal form" +-- | 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@ @@ -190,7 +190,7 @@ data NormComp | 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] IsLifted CompFun + | 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) @@ -199,19 +199,22 @@ data NormComp -- 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 (SpecMParams Term) Term + = CompFunTerm EvTerm Term -- | A special case for the term @\ (x:a) -> returnM a x@ - | CompFunReturn (SpecMParams Term) Type + | CompFunReturn EvTerm Type -- | The monadic composition @f >=> g@ | CompFunComp CompFun CompFun deriving (Generic, Show) --- | Apply 'CompFunReturn' to a pair of a 'SpecMParams' and a 'Term' -mkCompFunReturn :: (SpecMParams Term, Term) -> CompFun -mkCompFunReturn (params, tp) = CompFunReturn params $ Type tp +-- | 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 @@ -234,23 +237,21 @@ compFunInputType (CompFunComp f _) = compFunInputType f compFunInputType (CompFunReturn _ t) = Just t compFunInputType _ = Nothing --- | Get the @SpecM@ non-type parameters from a 'CompFun' -compFunSpecMParams :: CompFun -> SpecMParams Term -compFunSpecMParams (CompFunTerm params _) = params -compFunSpecMParams (CompFunReturn params _) = params -compFunSpecMParams (CompFunComp f _) = compFunSpecMParams f +-- | 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 stack a@ for some @a@ -asSpecM :: Term -> Maybe (SpecMParams Term, Term) -asSpecM (asApplyAll -> (isGlobalDef "Prelude.SpecM" -> Just (), [ev, stack, tp])) = - return (SpecMParams { specMEvType = ev, specMStack = stack }, tp) -asSpecM (asApplyAll -> (isGlobalDef "Prelude.CompM" -> Just (), _)) = - error "CompM found instead of SpecM" -asSpecM _ = fail "not a SpecM type!" +-- | 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 @@ -263,11 +264,11 @@ isSpecFunType sc t = scWhnf sc t >>= \case -- * Useful 'Recognizer's for 'Term's ---------------------------------------------------------------------- --- | Recognize a 'Term' as an application of `bvToNat` -asBvToNat :: Recognizer Term (Term, Term) -asBvToNat (asApplyAll -> ((isGlobalDef "Prelude.bvToNat" -> Just ()), - [n, x])) = Just (n, x) -asBvToNat _ = Nothing +-- | 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) @@ -276,6 +277,11 @@ asEither (asCtor -> Just (c, [_, _, x])) | primName c == "Prelude.Right" = return $ Right x asEither _ = Nothing +-- | Recognize the @Num@ type +asNumType :: Recognizer Term () +asNumType (asDataType -> Just (primName -> "Cryptol.Num", _)) = Just () +asNumType _ = Nothing + -- | Recognize a term as a @TCNum n@ or @TCInf@ asNum :: Recognizer Term (Either Term ()) asNum (asCtor -> Just (c, [n])) @@ -290,24 +296,16 @@ asIsFinite (asApp -> Just (isGlobalDef "CryptolM.isFinite" -> Just (), n)) = Just n asIsFinite _ = Nothing --- | Test if a 'Term' is a 'BVVec' type, excluding bitvectors -asBVVecType :: Recognizer Term (Term, Term, Term) -asBVVecType (asApplyAll -> - (isGlobalDef "Prelude.Vec" -> Just _, - [(asApplyAll -> - (isGlobalDef "Prelude.bvToNat" -> Just _, [n, len])), a])) - | Just _ <- asBoolType a = Nothing - | otherwise = Just (n, len, a) -asBVVecType _ = Nothing - --- | Like 'asVectorType', but returns 'Nothing' if 'asBVVecType' returns --- 'Just' or if the given 'Term' is a bitvector type -asNonBVVecVectorType :: Recognizer Term (Term, Term) -asNonBVVecVectorType (asBVVecType -> Just _) = Nothing -asNonBVVecVectorType (asVectorType -> Just (n, a)) - | Just _ <- asBoolType a = Nothing - | otherwise = Just (n, a) -asNonBVVecVectorType _ = 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 @@ -352,57 +350,57 @@ memoFixTermFun f = memoFixTermFunAccum (f .) () -- * Lifting MR Solver Terms ---------------------------------------------------------------------- --- | A term-like object is one that supports lifting and substitution. This --- class can be derived using @DeriveAnyClass@. +-- | 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 - liftTermLike :: MonadTerm m => DeBruijnIndex -> DeBruijnIndex -> a -> m a - substTermLike :: MonadTerm m => DeBruijnIndex -> [Term] -> a -> m a + mapTermLike :: MonadTerm m => (Term -> m Term) -> a -> m a - -- Default instances for @DeriveAnyClass@ - default liftTermLike :: (Generic a, GTermLike (Rep a), MonadTerm m) => - DeBruijnIndex -> DeBruijnIndex -> a -> m a - liftTermLike n i = fmap to . gLiftTermLike n i . from - default substTermLike :: (Generic a, GTermLike (Rep a), MonadTerm m) => - DeBruijnIndex -> [Term] -> a -> m a - substTermLike n i = fmap to . gSubstTermLike n i . from + -- 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 - gLiftTermLike :: MonadTerm m => DeBruijnIndex -> DeBruijnIndex -> f p -> m (f p) - gSubstTermLike :: MonadTerm m => DeBruijnIndex -> [Term] -> f p -> m (f p) + gMapTermLike :: MonadTerm m => (Term -> m Term) -> f p -> m (f p) -- | 'TermLike' on empty types instance GTermLike V1 where - gLiftTermLike _ _ = \case {} - gSubstTermLike _ _ = \case {} + gMapTermLike _ = \case {} -- | 'TermLike' on unary types instance GTermLike U1 where - gLiftTermLike _ _ U1 = return U1 - gSubstTermLike _ _ U1 = return U1 + gMapTermLike _ U1 = return U1 -- | 'TermLike' on sums instance (GTermLike f, GTermLike g) => GTermLike (f :+: g) where - gLiftTermLike n i (L1 a) = L1 <$> gLiftTermLike n i a - gLiftTermLike n i (R1 b) = R1 <$> gLiftTermLike n i b - gSubstTermLike n s (L1 a) = L1 <$> gSubstTermLike n s a - gSubstTermLike n s (R1 b) = R1 <$> gSubstTermLike n s b + 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 - gLiftTermLike n i (a :*: b) = (:*:) <$> gLiftTermLike n i a <*> gLiftTermLike n i b - gSubstTermLike n s (a :*: b) = (:*:) <$> gSubstTermLike n s a <*> gSubstTermLike n s b + gMapTermLike f (a :*: b) = (:*:) <$> gMapTermLike f a <*> gMapTermLike f b -- | 'TermLike' on fields instance TermLike a => GTermLike (K1 i a) where - gLiftTermLike n i (K1 a) = K1 <$> liftTermLike n i a - gSubstTermLike n i (K1 a) = K1 <$> substTermLike n i a + gMapTermLike f (K1 a) = K1 <$> mapTermLike f a -- | 'GTermLike' ignores meta-information instance GTermLike a => GTermLike (M1 i c a) where - gLiftTermLike n i (M1 a) = M1 <$> gLiftTermLike n i a - gSubstTermLike n i (M1 a) = M1 <$> gSubstTermLike n i a + gMapTermLike f (M1 a) = M1 <$> gMapTermLike f a deriving instance _ => TermLike (a,b) deriving instance _ => TermLike (a,b,c) @@ -410,25 +408,23 @@ 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 - liftTermLike = liftTerm - substTermLike = substTerm + mapTermLike f = f instance TermLike FunName where - liftTermLike _ _ = return - substTermLike _ _ = return + mapTermLike _ = return instance TermLike LocalName where - liftTermLike _ _ = return - substTermLike _ _ = return + mapTermLike _ = return instance TermLike Natural where - liftTermLike _ _ = return - substTermLike _ _ = return + mapTermLike _ = return deriving anyclass instance TermLike Type -deriving instance TermLike (SpecMParams Term) -deriving instance TermLike IsLifted +deriving anyclass instance TermLike EvTerm deriving instance TermLike NormComp deriving instance TermLike CompFun deriving instance TermLike Comp @@ -441,25 +437,34 @@ deriving instance TermLike Comp -- | 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). -newtype PPInCtxM a = PPInCtxM (Reader [LocalName] a) +-- +-- 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 'SawDoc' have the prefix @pp@ +-- (e.g. 'ppInCtx', 'ppTermAppInCtx'). This latter convention is consistent with +-- the rest of saw-script (e.g. 'ppTerm' defined in @Verifier.SAW.Term.Pretty@, +-- 'ppFirstOrderValue' defined in @Verifier.SAW.FiniteValue@). +newtype PPInCtxM a = PPInCtxM (Reader (PPOpts, [LocalName]) a) deriving newtype (Functor, Applicative, Monad, - MonadReader [LocalName]) + MonadReader (PPOpts, [LocalName])) --- | Run a 'PPInCtxM' computation in the given 'MRVarCtx' context -runPPInCtxM :: PPInCtxM a -> MRVarCtx -> a -runPPInCtxM (PPInCtxM m) = runReader m . map fst . mrVarCtxInnerToOuter +-- | 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) --- | Pretty-print an object in a SAW core context -ppInCtx :: PrettyInCtx a => MRVarCtx -> a -> SawDoc -ppInCtx ctx a = runPPInCtxM (prettyInCtx a) ctx +-- | Run a 'PPInCtxM' computation in the given 'MRVarCtx' context and 'PPOpts' +runPPInCtxM :: PPInCtxM a -> PPOpts -> MRVarCtx -> a +runPPInCtxM (PPInCtxM m) opts ctx = + runReader m (opts, map fst $ mrVarCtxInnerToOuter ctx) --- | Pretty-print an object in a SAW core context and render to a 'String' -showInCtx :: PrettyInCtx a => MRVarCtx -> a -> String -showInCtx ctx a = renderSawDoc defaultPPOpts $ ppInCtx ctx a +-- | Pretty-print an object in a SAW core context with the given 'PPOpts' +ppInCtx :: PrettyInCtx a => PPOpts -> MRVarCtx -> a -> SawDoc +ppInCtx opts ctx a = runPPInCtxM (prettyInCtx a) opts ctx --- | Pretty-print an object in the empty SAW core context -ppInEmptyCtx :: PrettyInCtx a => a -> SawDoc -ppInEmptyCtx = ppInCtx emptyMRVarCtx +-- | Pretty-print an object in a SAW core context and render to a 'String' with +-- the given 'PPOpts' +showInCtx :: PrettyInCtx a => PPOpts -> MRVarCtx -> a -> String +showInCtx opts ctx a = renderSawDoc opts $ runPPInCtxM (prettyInCtx a) opts ctx -- | A generic function for pretty-printing an object in a SAW core context of -- locally-bound names @@ -467,7 +472,8 @@ class PrettyInCtx a where prettyInCtx :: a -> PPInCtxM SawDoc instance PrettyInCtx Term where - prettyInCtx t = flip (ppTermInCtx defaultPPOpts) t <$> ask + prettyInCtx t = do (opts, ctx) <- ask + return $ ppTermInCtx opts ctx t -- | Combine a list of pretty-printed documents like applications are combined prettyAppList :: [PPInCtxM SawDoc] -> PPInCtxM SawDoc @@ -478,20 +484,24 @@ prettyTermApp :: Term -> [Term] -> PPInCtxM SawDoc 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 -ppTermAppInCtx :: MRVarCtx -> Term -> [Term] -> SawDoc -ppTermAppInCtx ctx f_top args = runPPInCtxM (prettyTermApp f_top args) ctx +-- | Pretty-print the application of a 'Term' in a SAW core context with the +-- given 'PPOpts' +ppTermAppInCtx :: PPOpts -> MRVarCtx -> Term -> [Term] -> SawDoc +ppTermAppInCtx opts ctx f_top args = + runPPInCtxM (prettyTermApp f_top args) opts ctx instance PrettyInCtx MRVarCtx where - prettyInCtx = return . align . sep . helper [] . mrVarCtxOuterToInner where - helper :: [LocalName] -> [(LocalName,Term)] -> [SawDoc] - helper _ [] = [] - helper ns [(n, tp)] = - [ppTermInCtx defaultPPOpts (n:ns) (Unshared $ LocalVar 0) <> ":" <> - ppTermInCtx defaultPPOpts ns tp] - helper ns ((n, tp):ctx) = - (ppTermInCtx defaultPPOpts (n:ns) (Unshared $ LocalVar 0) <> ":" <> - ppTermInCtx defaultPPOpts ns tp <> ",") : (helper (n:ns) ctx) + prettyInCtx ctx_top = do + (opts, _) <- ask + return $ align $ sep $ helper opts [] $ mrVarCtxOuterToInner ctx_top + where helper :: PPOpts -> [LocalName] -> [(LocalName,Term)] -> [SawDoc] + 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 SawDoc where prettyInCtx pp = return pp @@ -514,6 +524,9 @@ instance PrettyInCtx Text where 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" @@ -543,66 +556,63 @@ instance PrettyInCtx Comp where prettyInCtx (CompBind c f) = prettyAppList [prettyInCtx c, return ">>=", prettyInCtx f] prettyInCtx (CompReturn t) = - prettyAppList [return "retS", return "_", return "_", + prettyAppList [return "retS", return "_", parens <$> prettyInCtx t] instance PrettyInCtx CompFun where prettyInCtx (CompFunTerm _ t) = prettyInCtx t prettyInCtx (CompFunReturn _ t) = - prettyAppList [return "retS", return "_", return "_", + 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 "_", return "_", + prettyAppList [return "retS", return "_", return "_", parens <$> prettyInCtx t] prettyInCtx (ErrorS str) = - prettyAppList [return "errorS", return "_", return "_", return "_", + 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 _ _ _"), + 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, + return (parens "SpecM _ _"), parens <$> prettyInCtx m, parens <$> prettyInCtx f, parens <$> prettyInCtx mayb] prettyInCtx (OrS t1 t2) = - prettyAppList [return "orS", return "_", return "_", return "_", + prettyAppList [return "orS", return "_", return "_", parens <$> prettyInCtx t1, parens <$> prettyInCtx t2] prettyInCtx (AssertBoolBind cond k) = - prettyAppList [return "assertBoolS", return "_", return "_", + prettyAppList [return "assertBoolS", return "_", parens <$> prettyInCtx cond, return ">>=", parens <$> prettyInCtx k] prettyInCtx (AssumeBoolBind cond k) = - prettyAppList [return "assumeBoolS", return "_", return "_", + prettyAppList [return "assumeBoolS", return "_", parens <$> prettyInCtx cond, return ">>=", parens <$> prettyInCtx k] prettyInCtx (ExistsBind tp k) = - prettyAppList [return "existsS", return "_", return "_", prettyInCtx tp, + prettyAppList [return "existsS", return "_", prettyInCtx tp, return ">>=", parens <$> prettyInCtx k] prettyInCtx (ForallBind tp k) = - prettyAppList [return "forallS", return "_", return "_", prettyInCtx tp, + prettyAppList [return "forallS", return "_", prettyInCtx tp, return ">>=", parens <$> prettyInCtx k] - prettyInCtx (FunBind f args isLifted (CompFunReturn _ _)) = - snd $ prettyInCtxFunBindH f args isLifted - prettyInCtx (FunBind f args isLifted k) - | (g, m) <- prettyInCtxFunBindH f args isLifted = + 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 'SawDoc' function (which is either 'id' or 'parens') to apply in the -- case where the associated 'CompFun' is something else. -prettyInCtxFunBindH :: FunName -> [Term] -> IsLifted -> +prettyInCtxFunBindH :: FunName -> [Term] -> (SawDoc -> SawDoc, PPInCtxM SawDoc) -prettyInCtxFunBindH f [] Unlifted = (id, prettyInCtx f) -prettyInCtxFunBindH f args Unlifted = (parens,) $ +prettyInCtxFunBindH f [] = (id, prettyInCtx f) +prettyInCtxFunBindH f args = (parens,) $ prettyTermApp (funNameTerm f) args -prettyInCtxFunBindH f args Lifted = (parens,) $ - prettyAppList [return "liftStackS", return "_", return "_", return "_", - parens <$> prettyTermApp (funNameTerm f) args] \ No newline at end of file diff --git a/src/SAWScript/Value.hs b/src/SAWScript/Value.hs index c4571bf067..709b422a58 100644 --- a/src/SAWScript/Value.hs +++ b/src/SAWScript/Value.hs @@ -328,10 +328,10 @@ showRefnset opts ss = ppFunAssump (MRSolver.FunAssump ctx f args rhs _) = PP.pretty '*' PP.<+> (PP.nest 2 $ PP.fillSep - [ ppTermAppInCtx ctx (funNameTerm f) args + [ ppTermAppInCtx opts' ctx (funNameTerm f) args , PP.pretty ("|=" :: String) PP.<+> ppFunAssumpRHS ctx rhs ]) ppFunAssumpRHS ctx (OpaqueFunAssump f args) = - ppTermAppInCtx ctx (funNameTerm f) args + ppTermAppInCtx opts' ctx (funNameTerm f) args ppFunAssumpRHS ctx (RewriteFunAssump rhs) = SAWCorePP.ppTermInCtx opts' (map fst $ mrVarCtxInnerToOuter ctx) rhs opts' = sawPPOpts opts