From bc3d29ffec90f731119e0f769f1f0d191aa81b6a Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Tue, 16 May 2023 14:22:30 -0700 Subject: [PATCH 001/305] removed all the old CompM stuff from Prelude.sawcore and from SpecialTreatment.hs; started updating Prelude.sawcore to the new higher-order version of SpecM --- .../SAW/Translation/Coq/SpecialTreatment.hs | 32 - saw-core/prelude/Prelude.sawcore | 853 +++++------------- 2 files changed, 245 insertions(+), 640 deletions(-) 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..c4e7ef53d7 100644 --- a/saw-core-coq/src/Verifier/SAW/Translation/Coq/SpecialTreatment.hs +++ b/saw-core-coq/src/Verifier/SAW/Translation/Coq/SpecialTreatment.hs @@ -494,38 +494,6 @@ sawCorePreludeSpecialTreatmentMap configuration = , ("test_fun6", skip) ] - -- The computation monad - ++ - [ ("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") diff --git a/saw-core/prelude/Prelude.sawcore b/saw-core/prelude/Prelude.sawcore index 997d6d8f77..bc0accee14 100644 --- a/saw-core/prelude/Prelude.sawcore +++ b/saw-core/prelude/Prelude.sawcore @@ -2342,458 +2342,6 @@ foldIRT As Ds D = IRTDesc__rec As (\ (D:IRTDesc As) -> (Ds:IRTSubsts As) -> Unfo (\ (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 @@ -2824,162 +2372,268 @@ evRetType e = VoidEv : EvType; VoidEv = Build_EvType Void (elimVoid (sort 0)); +-- An inductive encoding of monadic function types and their arguments +data LetRecType : sort 1 where { + -- A nullary monadic function, that returns a value of the encoded type + LRT_Ret : LetRecType -> LetRecType; + -- A dependent monadic function type + LRT_FunDep : (a:sort 0) -> (a -> LetRecType) -> LetRecType; + -- A non-dependent monadic function type + LRT_Fun : LetRecType -> LetRecType -> LetRecType; + -- The unit type + LRT_Unit : LetRecType; + -- An application of a binary type function + LRT_BinOp : (sort 0 -> sort 0 -> sort 0) -> + LetRecType -> LetRecType -> LetRecType; + -- A dependent pair type + LRT_Sigma : (a:sort 0) -> (a -> LetRecType) -> LetRecType; +} + +-- Helper definition to build a LetRecType that decodes to a specific type +LRT_Type : sort 0 -> LetRecType; +LRT_Type a = LRT_BinOp (\ (_:sort 0) (_:sort 0) -> a) LRT_Unit LRT_Unit; + +-- A function stack is a list of LetRecTypes, which intuitively +-- represents a stack of bindings of mutually recursive functions +FunStack : sort 1; +FunStack = List1 LetRecType; + +-- The empty FunStack +emptyFunStack : FunStack; +emptyFunStack = Nil1 LetRecType; + +-- A trivially inhabied "default" LetRecType, representing void -> void +default_lrt : LetRecType; +default_lrt = LRT_FunDep Void (\ (_:Void) -> LRT_Ret (LRT_Type Void)); + +-- Get the nth element of a FunStack, or void -> void if n is too big +nthLRT : List1 LetRecType -> Nat -> LetRecType; +nthLRT lrts = + List1#rec + LetRecType + (\ (lrts:List1 LetRecType) -> Nat -> LetRecType) + (\ (_:Nat) -> default_lrt) + (\ (lrt:LetRecType) (_:List1 LetRecType) (rec:Nat -> LetRecType) (n:Nat) -> + Nat#rec (\ (_:Nat) -> LetRecType) lrt (\ (m:Nat) (_:LetRecType) -> rec m) n) + lrts; + +-- A partial application of a function of LetRecType lrt_in to some of its +-- FunDep arguments, resulting in LetRecType lrt_out +LRTDepApp : LetRecType -> LetRecType -> sort 0; +LRTDepApp lrt_in lrt_out = + LetRecType#rec + (\ (_:LetRecType) -> sort 0) + (\ (_:LetRecType) (_:sort 0) -> Eq LetRecType lrt_in lrt_out) + (\ (A:sort 0) (B:A -> LetRecType) (rec:A -> sort 0) -> + Either (Eq LetRecType lrt_in lrt_out) (Sigma A rec)) + (\ (_:LetRecType) (_:sort 0) (_:LetRecType) (_:sort 0) -> + Eq LetRecType lrt_in lrt_out) + (Eq LetRecType lrt_in lrt_out) + (\ (_:sort 0 -> sort 0 -> sort 0) (_:LetRecType) (_:sort 0) + (_:LetRecType) (_:sort 0) -> + Eq LetRecType lrt_in lrt_out) + (\ (a:sort 0) (_:a -> LetRecType) (_:a -> sort 0) -> + Eq LetRecType lrt_in lrt_out) + lrt_in; + +-- An argument to a recursive function call, which is a decoding of a LetRecType +-- to its corresponding SAW core type, except that functions are just natural +-- numbers that choose functions in the current function stack +LRTArg : FunStack -> LetRecType -> sort 0; +LRTArg stack argTp = + LetRecType#rec + (\ (_:LetRecType) -> sort 0) + (\ (R:LetRecType) (_:sort 0) -> + Sigma Nat (\ (n:Nat) -> LRTDepApp (nthLRT stack n) (LRT_Ret R))) + (\ (A:sort 0) (B:A -> LetRecType) (_:A -> sort 0) -> + Sigma Nat (\ (n:Nat) -> LRTDepApp (nthLRT stack n) (LRT_FunDep A B))) + (\ (A:LetRecType) (_:sort 0) (B:LetRecType) (_:sort 0) -> + Sigma Nat (\ (n:Nat) -> LRTDepApp (nthLRT stack n) (LRT_Fun A B))) + #() + (\ (F:sort 0 -> sort 0 -> sort 0) (_:LetRecType) (A:sort 0) + (_:LetRecType) (B:sort 0) -> + F A B) + (\ (A:sort 0) (_:A -> LetRecType) (rec:A -> sort 0) -> + Sigma A rec) + argTp; + -- 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 = +-- inputs to the LetRecType (LRT_Fun A1 (\ a1 -> ...)). Return the Void type for +-- any LetRecType that is not a valid monadic function type. +LRTInput : FunStack -> LetRecType -> sort 0; +LRTInput stack lrt = LetRecType#rec (\ (lrt:LetRecType) -> sort 0) - (\ (_:sort 0) -> #()) - (\ (a:sort 0) (_: a -> LetRecType) (b: a -> sort 0) -> Sigma a b) + (\ (_:LetRecType) (_:sort 0) -> #()) + (\ (A:sort 0) (_:A -> LetRecType) (rec:A -> sort 0) -> + Sigma A (\ (a:A) -> rec a)) + (\ (A:LetRecType) (_:sort 0) (B:LetRecType) (rec:sort 0) -> + LRTArg stack A * rec) + Void + (\ (_:sort 0 -> sort 0 -> sort 0) (_:LetRecType) (_:sort 0) + (_:LetRecType) (_:sort 0) -> + Void) + (\ (A:sort 0) (_:A -> LetRecType) (_:A -> sort 0) -> + Void) 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 = +LRTOutput : (stack:FunStack) -> (lrt:LetRecType) -> LRTInput stack lrt -> sort 0; +LRTOutput stack 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:LetRecType) -> LRTInput stack lrt -> sort 0) + (\ (R:LetRecType) (_:LRTInput stack R -> sort 0) (_:#()) -> LRTArg stack R) + (\ (A:sort 0) (B:A -> LetRecType) + (rec:(a:A) -> LRTInput stack (B a) -> sort 0) + (args:Sigma A (\ (a:A) -> LRTInput stack (B a))) -> + rec (Sigma_proj1 A (\ (a:A) -> LRTInput stack (B a)) args) + (Sigma_proj2 A (\ (a:A) -> LRTInput stack (B a)) args)) + (\ (A:LetRecType) (_:LRTInput stack A -> sort 0) + (B:LetRecType) (rec:LRTInput stack B -> sort 0) + (args:LRTArg stack A * LRTInput stack B) -> + rec (args.(2))) + (\ (v:Void) -> elimVoid (sort 0) v) + (\ (_:sort 0 -> sort 0 -> sort 0) + (A:LetRecType) (_:LRTInput stack A -> sort 0) + (B:LetRecType) (_:LRTInput stack B -> sort 0) (v:Void) -> + elimVoid (sort 0) v) + (\ (A:sort 0) (B:A -> LetRecType) + (_:(a:A) -> LRTInput stack (B a) -> sort 0) (v:Void) -> + elimVoid (sort 0) v) 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 = +-- (LRT_Fun A1 (\ a1 -> ...)). A LetRecType that is not a monadic function type +-- turns into a function from v:void -> F v +lrtPi : (stack:FunStack) -> (lrt:LetRecType) -> + (LRTInput stack lrt -> sort 0) -> sort 0; +lrtPi stack 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:LetRecType) -> (LRTInput stack lrt -> sort 0) -> sort 0) + (\ (R:LetRecType) (_:(LRTInput stack R -> sort 0) -> sort 0) + (F:#() -> sort 0) -> F ()) + (\ (A:sort 0) (B: A -> LetRecType) + (rec: (x:A) -> (LRTInput stack (B x) -> sort 0) -> sort 0) + (F : LRTInput stack (LRT_FunDep A B) -> sort 0) -> + (x:A) -> rec x (\ (args : LRTInput stack (B x)) -> + F (exists A (\ (y:A) -> LRTInput stack (B y)) x args))) + (\ (A:LetRecType) (_:(LRTInput stack A -> sort 0) -> sort 0) + (B:LetRecType) (rec:(LRTInput stack B -> sort 0) -> sort 0) + (F : LRTInput stack (LRT_Fun A B) -> sort 0) -> + (x:LRTArg stack A) -> rec (\ (args : LRTInput stack B) -> F (x, args))) + (\ (F : Void -> sort 0) -> (v:Void) -> F v) + (\ (_:sort 0 -> sort 0 -> sort 0) + (A:LetRecType) (_:(LRTInput stack A -> sort 0) -> sort 0) + (B:LetRecType) (_:(LRTInput stack B -> sort 0) -> sort 0) + (F : Void -> sort 0) -> (v:Void) -> F v) + (\ (A:sort 0) (B:A -> LetRecType) + (_:(a:A) -> (LRTInput stack (B a) -> sort 0) -> sort 0) + (F : Void -> sort 0) -> (v:Void) -> F v) 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 = +lrtLambda : (stack:FunStack) -> (lrt:LetRecType) -> + (F: LRTInput stack lrt -> sort 0) -> + ((args: LRTInput stack lrt) -> F args) -> lrtPi stack lrt F; +lrtLambda stack 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:LetRecType) -> (F: LRTInput stack lrt -> sort 0) -> + ((args: LRTInput stack lrt) -> F args) -> + lrtPi stack lrt F) + (\ (R:LetRecType) (_: (F: LRTInput stack R -> sort 0) -> + ((args: LRTInput stack R) -> F args) -> + lrtPi stack R F) + (F: #() -> sort 0) (f : (args:#()) -> F args) -> f ()) + (\ (A:sort 0) (B: A -> LetRecType) + (rec: (a:A) -> (F: LRTInput stack (B a) -> sort 0) -> + ((args: LRTInput stack (B a)) -> F args) -> + lrtPi stack (B a) F) + (F: LRTInput stack (LRT_FunDep A B) -> sort 0) + (f : (args: LRTInput stack (LRT_FunDep A B)) -> F args) + (a:A) -> + rec a (\ (args:LRTInput stack (B a)) -> + F (exists A (\ (y:A) -> LRTInput stack (B y)) a args)) + (\ (args:LRTInput stack (B a)) -> + f (exists A (\ (y:A) -> LRTInput stack (B y)) a args))) + (\ (A:LetRecType) + (_:(F: LRTInput stack A -> sort 0) -> + ((args: LRTInput stack A) -> F args) -> + lrtPi stack A F) + (B:LetRecType) + (rec:(F: LRTInput stack B -> sort 0) -> + ((args: LRTInput stack B) -> F args) -> + lrtPi stack B F) + (F : LRTInput stack (LRT_Fun A B) -> sort 0) + (f : (args: LRTInput stack (LRT_Fun A B)) -> F args) + (a:LRTArg stack A) -> + rec (\ (args:LRTInput stack B) -> F (a, args)) + (\ (args:LRTInput stack B) -> f (a, args))) + (\ (F : Void -> sort 0) (f: (v:Void) -> F v) (v:Void) -> + elimVoid (F v) v) + (\ (_:sort 0 -> sort 0 -> sort 0) + (A:LetRecType) + (_:(F:LRTInput stack A -> sort 0) -> ((args:LRTInput stack A) -> F args) -> + lrtPi stack A F) + (B:LetRecType) + (_:(F:LRTInput stack B -> sort 0) -> ((args:LRTInput stack B) -> F args) -> + lrtPi stack B F) + (F : Void -> sort 0) (f: (v:Void) -> F v) (v:Void) -> + elimVoid (F v) v) + (\ (A:sort 0) (B:A -> LetRecType) + (_:(a:A) -> (F:LRTInput stack (B a) -> sort 0) -> + ((args:LRTInput stack (B a)) -> F args) -> + lrtPi stack (B a) F) + (F : Void -> sort 0) (f: (v:Void) -> F v) (v:Void) -> + elimVoid (F v) v) 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 = - 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; +-- A recursive call to one of the functions in a FunStack +data StackCall (stack : FunStack) : sort 0 where { + StackCallOfArgs : (n:Nat) -> LRTInput stack (nthLRT stack n) -> StackCall stack; } --- 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) +-- The return type for calling a recursive function in a FunStack +StackCallRet : (stack:FunStack) -> StackCall stack -> sort 0; +StackCallRet stack call = + StackCall#rec + stack + (\ (_:StackCall stack) -> sort 0) + (\ (n:Nat) (args:LRTInput stack (nthLRT stack n)) -> + LRTOutput stack (nthLRT stack 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!) +-- The type of events / effects in a SpecM computation, each of which is either +-- an error (represented as a String), an E, or a StackCall from stack +FunStackE : (E:EvType) -> FunStack -> sort 0; +FunStackE E stack = Either (StackCall stack) (Either String (evTypeType E)); + +-- The return type for a FunStackE effect in a SpecM computation +FunStackERet : (E:EvType) -> (stack:FunStack) -> FunStackE E stack -> sort 0; +FunStackERet E stack eith_top = + Either#rec + (StackCall stack) (Either String (evTypeType E)) + (\ (_:Either (StackCall stack) (Either String (evTypeType E))) -> sort 0) + (StackCallRet stack) + (\ (eith:Either String (evTypeType E)) -> + Either#rec + String (evTypeType E) + (\ (_:Either String (evTypeType E)) -> sort 0) + (\ (_:String) -> Void) (evRetType E) + eith) + eith_top; + +-- The monad for specifications of computations (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; + FunStackE E1 stack1 -> FunStackE 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. @@ -2987,25 +2641,25 @@ SpecPreRel E1 E2 stack1 stack2 = 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; + (e1:FunStackE E1 stack1) -> (e2:FunStackE E2 stack2) -> + FunStackERet E1 stack1 e1 -> FunStackERet 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 +-- The precondition requiring that errors, events, and StackCalls 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; + Eq (FunStackE E stack) e1 e2; -- The postcondition stating that errors, event encodings, and return values --- of FrameCalls match up and are equal on both sides +-- of StackCalls 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; + EqDep (FunStackE E stack) (FunStackERet 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; @@ -3082,23 +2736,6 @@ assertingS : (E:EvType) -> (stack:FunStack) -> (a : sort 0) -> Bool -> 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) -> @@ -3127,16 +2764,16 @@ FrameTuple E stack 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); + (call : StackCall frame) -> + SpecM E (pushFunStack frame stack) (StackCallRet 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); + (call : StackCall frame) -> + SpecM E stack (StackCallRet frame call); -- Build a frame with a single function singletonFrame : LetRecType -> List1 LetRecType; @@ -3166,8 +2803,8 @@ fixS E stack a b body_f x_top = 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); + (mkStackCall (fixSFrame a b) 0 x)), ()) + (mkStackCall (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) -> @@ -3187,8 +2824,8 @@ multiArgFixS E stack lrt body_f = (LRTOutput lrt args)) (\ (args:LRTInput lrt) -> callS E stack (singletonFrame lrt) - (FrameCallOfArgs (singletonFrame lrt) 0 args))), ()) - (FrameCallOfArgs (singletonFrame lrt) 0 top_args)); + (StackCallOfArgs (singletonFrame lrt) 0 args))), ()) + (StackCallOfArgs (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) -> From ef246c9da3fa2e5d0c5435d1bb1198c138208074 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Tue, 16 May 2023 17:59:36 -0700 Subject: [PATCH 002/305] Added the new higher-order version of callS --- saw-core/prelude/Prelude.sawcore | 135 ++++++++++++------------------- 1 file changed, 52 insertions(+), 83 deletions(-) diff --git a/saw-core/prelude/Prelude.sawcore b/saw-core/prelude/Prelude.sawcore index bc0accee14..62944874ed 100644 --- a/saw-core/prelude/Prelude.sawcore +++ b/saw-core/prelude/Prelude.sawcore @@ -2351,6 +2351,12 @@ data List1 (a:sort 1) : sort 1 where { Cons1 : a -> List1 a -> List1 a; } +-- 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; + -- An event type is a type of events plus a mapping from events to their return -- types data EvType : sort 1 where { @@ -2393,6 +2399,10 @@ data LetRecType : sort 1 where { LRT_Type : sort 0 -> LetRecType; LRT_Type a = LRT_BinOp (\ (_:sort 0) (_:sort 0) -> a) LRT_Unit LRT_Unit; +-- A trivially inhabied "default" LetRecType, representing void -> void +default_lrt : LetRecType; +default_lrt = LRT_FunDep Void (\ (_:Void) -> LRT_Ret (LRT_Type Void)); + -- A function stack is a list of LetRecTypes, which intuitively -- represents a stack of bindings of mutually recursive functions FunStack : sort 1; @@ -2402,9 +2412,9 @@ FunStack = List1 LetRecType; emptyFunStack : FunStack; emptyFunStack = Nil1 LetRecType; --- A trivially inhabied "default" LetRecType, representing void -> void -default_lrt : LetRecType; -default_lrt = LRT_FunDep Void (\ (_:Void) -> LRT_Ret (LRT_Type Void)); +-- Get the length of a FunStack +stackLen : FunStack -> Nat; +stackLen = length1 LetRecType; -- Get the nth element of a FunStack, or void -> void if n is too big nthLRT : List1 LetRecType -> Nat -> LetRecType; @@ -2744,88 +2754,47 @@ 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 StackCall to a function in stk1 with args relative to stk2; the idea is +-- that it is being "mapped" from stk1 to stk2 +data MappedCall (stk1 stk2 : FunStack) : sort 0 where { + MappedCallOfArgs : (n:Nat) -> LRTInput stk2 (nthLRT stk1 n) -> + MappedCall stk1 stk2; +} --- A recursive call to a function in the top frame of a function stack +-- The return type for a MappedCall recursive call +MappedCallRet : (stk1 stk2 : FunStack) -> MappedCall stk1 stk2 -> sort 0; +MappedCallRet stk1 stk2 call = + MappedCall#rec + stk1 stk2 + (\ (_:MappedCall stk1 stk2) -> sort 0) + (\ (n:Nat) (args : LRTInput stk2 (nthLRT stk1 n)) -> + LRTOutput stk2 (nthLRT stk1 n) args) + call; + +-- Create a MappedCall in a way where we take in one argument at a time +mkMappedCall : (stk1 stk2 : FunStack) -> (n:Nat) -> + lrtPi stk2 (nthLRT stk1 n) + (\ (_:LRTInput stk2 (nthLRT stk1 n)) -> MappedCall stk1 stk2); +mkMappedCall stk1 stk2 n = + lrtLambda stk2 (nthLRT stk1 n) + (\ (_:LRTInput stk2 (nthLRT stk1 n)) -> MappedCall stk1 stk2) + (\ (args:LRTInput stk2 (nthLRT stk1 n)) -> MappedCallOfArgs stk1 stk2 n args); + +-- A stack inclusion is a mapping from the indices of one stack to those of +-- another that preserves LetRecTypes +stackIncl : (stk1 stk2 : FunStack) -> sort 0; +stackIncl stk1 stk2 = + Sigma (Nat -> Nat) (\ (f : Nat -> Nat) -> + (n : Nat) -> (IsLtNat n (stackLen stk1)) -> + Eq LetRecType (nthLRT stk1 n) (nthLRT stk2 (f n)) * + IsLtNat (f n) (stackLen stk1)); + +-- Make a recursive call using a MappedCall primitive callS : - (E:EvType) -> (stack:FunStack) -> (frame:List1 LetRecType) -> - (call : StackCall frame) -> - SpecM E (pushFunStack frame stack) (StackCallRet 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 : StackCall frame) -> - SpecM E stack (StackCallRet 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) - (mkStackCall (fixSFrame a b) 0 x)), ()) - (mkStackCall (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) - (StackCallOfArgs (singletonFrame lrt) 0 args))), ()) - (StackCallOfArgs (singletonFrame lrt) 0 top_args)); + (E:EvType) -> (stk1 stk2 : FunStack) -> (incl : stackIncl stk1 stk2) -> + (call : MappedCall stk1 stk2) -> SpecM E stk2 (MappedCallRet stk1 stk2 call); + +-- FIXME HERE NOW: SpecDef and defineSpec -- Apply a pure function to the result of a computation fmapS : (E:EvType) -> (stack:FunStack) -> (a b:sort 0) -> (a -> b) -> From d9ffd630f9d2669d32e8e7a9b3479848ae5eb05a Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 19 May 2023 17:44:14 -0700 Subject: [PATCH 003/305] added SpecDef and its associated definitions; reorganized the SpecM section a bit --- saw-core/prelude/Prelude.sawcore | 197 +++++++++++++++++++------------ 1 file changed, 124 insertions(+), 73 deletions(-) diff --git a/saw-core/prelude/Prelude.sawcore b/saw-core/prelude/Prelude.sawcore index 62944874ed..e7d1018445 100644 --- a/saw-core/prelude/Prelude.sawcore +++ b/saw-core/prelude/Prelude.sawcore @@ -2637,60 +2637,6 @@ FunStackERet E stack eith_top = -- The monad for specifications of computations (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 E1 stack1 -> FunStackE 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 E1 stack1) -> (e2:FunStackE E2 stack2) -> - FunStackERet E1 stack1 e1 -> FunStackERet 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 StackCalls 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 E stack) e1 e2; - --- The postcondition stating that errors, event encodings, and return values --- of StackCalls 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 E stack) (FunStackERet 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; @@ -2754,31 +2700,33 @@ 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); --- A StackCall to a function in stk1 with args relative to stk2; the idea is --- that it is being "mapped" from stk1 to stk2 -data MappedCall (stk1 stk2 : FunStack) : sort 0 where { - MappedCallOfArgs : (n:Nat) -> LRTInput stk2 (nthLRT stk1 n) -> - MappedCall stk1 stk2; + +-- A StackCall in a polymorphic context (in the sense of PolySpecFun, below), +-- where the call is into a function in stk1 but where stk1 has been extended to +-- some arbitrary stk2 +data PolyStackCall (stk1 stk2 : FunStack) : sort 0 where { + PolyStackCallOfArgs : (n:Nat) -> LRTInput stk2 (nthLRT stk1 n) -> + PolyStackCall stk1 stk2; } --- The return type for a MappedCall recursive call -MappedCallRet : (stk1 stk2 : FunStack) -> MappedCall stk1 stk2 -> sort 0; -MappedCallRet stk1 stk2 call = - MappedCall#rec +-- The return type for a PolyStackCall recursive call +PolyStackCallRet : (stk1 stk2 : FunStack) -> PolyStackCall stk1 stk2 -> sort 0; +PolyStackCallRet stk1 stk2 call = + PolyStackCall#rec stk1 stk2 - (\ (_:MappedCall stk1 stk2) -> sort 0) + (\ (_:PolyStackCall stk1 stk2) -> sort 0) (\ (n:Nat) (args : LRTInput stk2 (nthLRT stk1 n)) -> LRTOutput stk2 (nthLRT stk1 n) args) call; --- Create a MappedCall in a way where we take in one argument at a time -mkMappedCall : (stk1 stk2 : FunStack) -> (n:Nat) -> +-- Create a PolyStackCall in a way where we take in one argument at a time +mkPolyStackCall : (stk1 stk2 : FunStack) -> (n:Nat) -> lrtPi stk2 (nthLRT stk1 n) - (\ (_:LRTInput stk2 (nthLRT stk1 n)) -> MappedCall stk1 stk2); -mkMappedCall stk1 stk2 n = + (\ (_:LRTInput stk2 (nthLRT stk1 n)) -> PolyStackCall stk1 stk2); +mkPolyStackCall stk1 stk2 n = lrtLambda stk2 (nthLRT stk1 n) - (\ (_:LRTInput stk2 (nthLRT stk1 n)) -> MappedCall stk1 stk2) - (\ (args:LRTInput stk2 (nthLRT stk1 n)) -> MappedCallOfArgs stk1 stk2 n args); + (\ (_:LRTInput stk2 (nthLRT stk1 n)) -> PolyStackCall stk1 stk2) + (\ (args:LRTInput stk2 (nthLRT stk1 n)) -> PolyStackCallOfArgs stk1 stk2 n args); -- A stack inclusion is a mapping from the indices of one stack to those of -- another that preserves LetRecTypes @@ -2789,12 +2737,57 @@ stackIncl stk1 stk2 = Eq LetRecType (nthLRT stk1 n) (nthLRT stk2 (f n)) * IsLtNat (f n) (stackLen stk1)); --- Make a recursive call using a MappedCall +-- Make a recursive call using a PolyStackCall primitive callS : (E:EvType) -> (stk1 stk2 : FunStack) -> (incl : stackIncl stk1 stk2) -> - (call : MappedCall stk1 stk2) -> SpecM E stk2 (MappedCallRet stk1 stk2 call); + (call : PolyStackCall stk1 stk2) -> SpecM E stk2 (PolyStackCallRet stk1 stk2 call); + + +-- +-- Spec definitions +-- + +-- A monadic function whose type is described by the encoding lrt +SpecFun : EvType -> FunStack -> LetRecType -> sort 0; +SpecFun E stk lrt = + lrtPi stk lrt (\ (args:LRTInput stk lrt) -> + SpecM E stk (LRTOutput stk lrt args)); + +-- A monadic function that is polymorphic in its function stack +PolySpecFun : EvType -> FunStack -> LetRecType -> sort 1; +PolySpecFun E stk lrt = + (stk':FunStack) -> stackIncl stk stk' -> SpecFun E stk' lrt; + +-- A right-nested tuple of a list of function definitions for all the +-- LetRecTypes in the defs list, that can make calls into the calls list +StackTuple : EvType -> FunStack -> FunStack -> sort 0; +StackTuple E calls defs = + List1#rec + LetRecType (\ (_:FunStack) -> sort 0) + #() + (\ (lrt:LetRecType) (_:FunStack) (rec:sort 0) -> SpecFun E calls lrt * rec) + defs; + +-- A StackTuple that is polymorphic in its function stack, which defines +-- functions for all the defs that can call all the calls +PolyStackTuple : EvType -> FunStack -> FunStack -> sort 1; +PolyStackTuple E calls defs = + (calls':FunStack) -> stackIncl calls calls' -> StackTuple E calls' defs; + +-- A "spec definition" represents a definition of a SpecM monadic function via +-- (co)recursion over a tuple of recursive function bodies +data SpecDef (E : EvType) : sort 1 where { + MkSpecDef : (stk : FunStack) -> PolyStackTuple E stk stk -> + (lrt : LetRecType) -> PolySpecFun E stk lrt -> + SpecDef E; +} --- FIXME HERE NOW: SpecDef and defineSpec +-- FIXME HERE NOW: defineSpec + + +-- +-- Helper operations on SpecM +-- -- Apply a pure function to the result of a computation fmapS : (E:EvType) -> (stack:FunStack) -> (a b:sort 0) -> (a -> b) -> @@ -2947,6 +2940,64 @@ appendCastBVVecS E stack n len1 len2 len3 a v1 v2 = (bvEqWithProof n (bvAdd n len1 len2) len3); +-- +-- Defining refinement on SpecM computations +-- + +-- 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 E1 stack1 -> FunStackE 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 E1 stack1) -> (e2:FunStackE E2 stack2) -> + FunStackERet E1 stack1 e1 -> FunStackERet 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 StackCalls 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 E stack) e1 e2; + +-- The postcondition stating that errors, event encodings, and return values +-- of StackCalls 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 E stack) (FunStackERet 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); + + -------------------------------------------------------------------------------- -- SMT Array From cb7fda8791a829432798468bfb1671571662f19f Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 5 Jun 2023 18:18:10 -0700 Subject: [PATCH 004/305] updated SpecialTreatment.hs to use the new entreeSpecsModule --- .../SAW/Translation/Coq/SpecialTreatment.hs | 68 +++++++++---------- 1 file changed, 32 insertions(+), 36 deletions(-) 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 c4e7ef53d7..672876b0a6 100644 --- a/saw-core-coq/src/Verifier/SAW/Translation/Coq/SpecialTreatment.hs +++ b/saw-core-coq/src/Verifier/SAW/Translation/Coq/SpecialTreatment.hs @@ -197,12 +197,8 @@ stringModule = sawDefinitionsModule :: ModuleName sawDefinitionsModule = mkModuleName ["SAWCoreScaffolding"] --- | The @CompM@ module -compMModule :: ModuleName -compMModule = mkModuleName ["CompM"] - -specMModule :: ModuleName -specMModule = mkModuleName ["SpecM"] +entreeSpecsModule :: ModuleName +entreeSpecsModule = mkModuleName ["EnTree.EnTreeSpecs"] sawVectorDefinitionsModule :: TranslationConfiguration -> ModuleName sawVectorDefinitionsModule (TranslationConfiguration {..}) = @@ -496,42 +492,42 @@ sawCorePreludeSpecialTreatmentMap configuration = -- 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") + [ ("EvType", mapsTo entreeSpecsModule "EvType") + , ("Build_EvType", mapsTo entreeSpecsModule "Build_EvType") + , ("evTypeType", mapsTo entreeSpecsModule "evTypeType") + , ("evRetType", mapsTo entreeSpecsModule "evRetType") + , ("SpecM", mapsToExpl entreeSpecsModule "SpecM") + , ("retS", mapsToExpl entreeSpecsModule "RetS") + , ("bindS", mapsToExpl entreeSpecsModule "BindS") + , ("errorS", mapsToExpl entreeSpecsModule "ErrorS") + , ("liftStackS", mapsToExpl entreeSpecsModule "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") + , ("FunStack", mapsTo entreeSpecsModule "FunStack") + , ("LRTInput", mapsToExpl entreeSpecsModule "LRTInput") + , ("LRTOutput", mapsToExpl entreeSpecsModule "LRTOutput") + , ("lrt1Pi", mapsToExpl entreeSpecsModule "lrtPi") + , ("lrtLambda", mapsToExpl entreeSpecsModule "lrtLambda") + , ("nthLRT", mapsToExpl entreeSpecsModule "nthLRT") + , ("FrameCall", mapsToExpl entreeSpecsModule "FrameCall") + , ("FrameCallOfArgs", mapsToExpl entreeSpecsModule "FrameCallOfArgs") + , ("mkFrameCall", mapsToExpl entreeSpecsModule "mkFrameCall") + , ("FrameCallRet", mapsToExpl entreeSpecsModule "FrameCallRet") + , ("LRTType", mapsToExpl entreeSpecsModule "LRTType") + , ("FrameTuple", mapsToExpl entreeSpecsModule "FrameTuple") + , ("callS", mapsToExpl entreeSpecsModule "CallS") + , ("multiFixS", mapsToExpl entreeSpecsModule "MultiFixS") + , ("FunStackE_type", mapsToExpl entreeSpecsModule "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") + , ("SpecPreRel", mapsToExpl entreeSpecsModule "SpecPreRel") + , ("SpecPostRel", mapsToExpl entreeSpecsModule "SpecPostRel") + , ("eqPreRel", mapsToExpl entreeSpecsModule "eqPreRel") + , ("eqPostRel", mapsToExpl entreeSpecsModule "eqPostRel") + , ("refinesS", mapsToExpl entreeSpecsModule "spec_refines") + , ("refinesS_eq", mapsToExpl entreeSpecsModule "spec_refines_eq") ] -- Dependent pairs From 6bf3975aa79b768d1d25014094291e65bcbe24fe Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 5 Jun 2023 18:18:56 -0700 Subject: [PATCH 005/305] started adding definitions for stack inclusions --- saw-core/prelude/Prelude.sawcore | 82 ++++++++++++++++++++++++++++---- 1 file changed, 73 insertions(+), 9 deletions(-) diff --git a/saw-core/prelude/Prelude.sawcore b/saw-core/prelude/Prelude.sawcore index e7d1018445..9f2365d0d6 100644 --- a/saw-core/prelude/Prelude.sawcore +++ b/saw-core/prelude/Prelude.sawcore @@ -2357,6 +2357,11 @@ 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# + -- An event type is a type of events plus a mapping from events to their return -- types data EvType : sort 1 where { @@ -2701,6 +2706,74 @@ orS E stack a m1 m2 = (\ (b:Bool) -> ite (SpecM E stack a) b m1 m2); +-- +-- The category of stack inclusions +-- + +-- A proof that a function is a stack inclusion, i.e., is a mapping from the +-- indices of one stack to those of another that preserves LetRecTypes +isStackIncl : (stk1 stk2 : FunStack) -> (Nat -> Nat) -> sort 0; +isStackIncl stk1 stk2 f = + (n : Nat) -> (IsLtNat n (stackLen stk1)) -> + Eq LetRecType (nthLRT stk1 n) (nthLRT stk2 (f n)) * + IsLtNat (f n) (stackLen stk2); + +-- A stack inclusion is a mapping from the indices of one stack to those of +-- another that preserves LetRecTypes +stackIncl : (stk1 stk2 : FunStack) -> sort 0; +stackIncl stk1 stk2 = Sigma (Nat -> Nat) (isStackIncl stk1 stk2); + +-- Helper function to build a stackIncl +mkStackIncl : (stk1 stk2 : FunStack) -> (f:Nat -> Nat) -> + isStackIncl stk1 stk2 f -> stackIncl stk1 stk2; +mkStackIncl stk1 stk2 f pf = + exists (Nat -> Nat) (isStackIncl stk1 stk2) f pf; + +-- Project the function out of a stackIncl +applyStackIncl : (stk1 stk2 : FunStack) -> stackIncl stk1 stk2 -> Nat -> Nat; +applyStackIncl stk1 stk2 = + Sigma_proj1 (Nat -> Nat) (isStackIncl stk1 stk2); + +-- Project the proof out of a stackIncl +stackInclProof : (stk1 stk2 : FunStack) -> (incl : stackIncl stk1 stk2) -> + isStackIncl stk1 stk2 (applyStackIncl stk1 stk2 incl); +stackInclProof stk1 stk2 = + Sigma_proj2 (Nat -> Nat) (isStackIncl stk1 stk2); + +-- The identity function is a stack inclusion for any stack into itself +reflStackIncl : (stk:FunStack) -> stackIncl stk stk; +reflStackIncl stk = + mkStackIncl stk stk + (\ (n:Nat) -> n) + (\ (n:Nat) (lt_pf:IsLtNat n (stackLen stk)) -> + (Refl LetRecType (nthLRT stk n), lt_pf)); + +-- Compose two stack inclusions +compStackIncl : (stk1 stk2 stk3 : FunStack) -> stackIncl stk1 stk2 -> + stackIncl stk2 stk3 -> stackIncl stk1 stk3; +compStackIncl stk1 stk2 stk3 incl12 incl23 = + mkStackIncl stk1 stk3 + (\ (n:Nat) -> + applyStackIncl stk2 stk3 incl23 (applyStackIncl stk1 stk2 incl12 n)) + (\ (n:Nat) (lt_pf:IsLtNat n (stackLen stk1)) -> + (trans LetRecType (nthLRT stk1 n) + (nthLRT stk2 (applyStackIncl stk1 stk2 incl12 n)) + (nthLRT stk2 (applyStackIncl stk2 stk3 incl23 + (applyStackIncl stk1 stk2 incl12 n))) + (stackInclProof stk1 stk2 incl12 n lt_pf).1 + (stackInclProof stk2 stk3 incl23 + (applyStackIncl stk1 stk2 incl12 n) + (stackInclProof stk1 stk2 incl12 n lt_pf).(2)).1) + , + (stackInclProof stk2 stk3 incl23 + (applyStackIncl stk1 stk2 incl12 n) + (stackInclProof stk1 stk2 incl12 n lt_pf).(2)).(2)); + + +-- +-- Recursive calls in SpecM +-- + -- A StackCall in a polymorphic context (in the sense of PolySpecFun, below), -- where the call is into a function in stk1 but where stk1 has been extended to -- some arbitrary stk2 @@ -2728,15 +2801,6 @@ mkPolyStackCall stk1 stk2 n = (\ (_:LRTInput stk2 (nthLRT stk1 n)) -> PolyStackCall stk1 stk2) (\ (args:LRTInput stk2 (nthLRT stk1 n)) -> PolyStackCallOfArgs stk1 stk2 n args); --- A stack inclusion is a mapping from the indices of one stack to those of --- another that preserves LetRecTypes -stackIncl : (stk1 stk2 : FunStack) -> sort 0; -stackIncl stk1 stk2 = - Sigma (Nat -> Nat) (\ (f : Nat -> Nat) -> - (n : Nat) -> (IsLtNat n (stackLen stk1)) -> - Eq LetRecType (nthLRT stk1 n) (nthLRT stk2 (f n)) * - IsLtNat (f n) (stackLen stk1)); - -- Make a recursive call using a PolyStackCall primitive callS : (E:EvType) -> (stk1 stk2 : FunStack) -> (incl : stackIncl stk1 stk2) -> From cdaf34c8139b5516aae42b6982f27dcd48caf233 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Tue, 6 Jun 2023 15:56:43 -0700 Subject: [PATCH 006/305] whoops, fixed the Prelude so it compiles again --- saw-core/prelude/Prelude.sawcore | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/saw-core/prelude/Prelude.sawcore b/saw-core/prelude/Prelude.sawcore index 9f2365d0d6..73eb9cac7a 100644 --- a/saw-core/prelude/Prelude.sawcore +++ b/saw-core/prelude/Prelude.sawcore @@ -2360,7 +2360,8 @@ length1 a l = -- Append two List1s app1 : (a:sort 1) -> List1 a -> List1 a -> List1 a; app1 a l1 l2 = - List1# + List1#rec a (\ (_:List1 a) -> List1 a) l2 + (\ (x:a) (_:List1 a) (rec:List1 a) -> Cons1 a x rec) l1; -- An event type is a type of events plus a mapping from events to their return -- types @@ -2758,16 +2759,18 @@ compStackIncl stk1 stk2 stk3 incl12 incl23 = (\ (n:Nat) (lt_pf:IsLtNat n (stackLen stk1)) -> (trans LetRecType (nthLRT stk1 n) (nthLRT stk2 (applyStackIncl stk1 stk2 incl12 n)) - (nthLRT stk2 (applyStackIncl stk2 stk3 incl23 + (nthLRT stk3 (applyStackIncl stk2 stk3 incl23 (applyStackIncl stk1 stk2 incl12 n))) (stackInclProof stk1 stk2 incl12 n lt_pf).1 (stackInclProof stk2 stk3 incl23 (applyStackIncl stk1 stk2 incl12 n) - (stackInclProof stk1 stk2 incl12 n lt_pf).(2)).1) + (stackInclProof stk1 stk2 incl12 n lt_pf).(2)).1 , - (stackInclProof stk2 stk3 incl23 + (stackInclProof stk2 stk3 incl23 (applyStackIncl stk1 stk2 incl12 n) - (stackInclProof stk1 stk2 incl12 n lt_pf).(2)).(2)); + (stackInclProof stk1 stk2 incl12 n lt_pf).(2)).(2))); + +-- FIXME HERE NOW: weakenLeftStackIncl and weakenRightStackIncl -- From 12d8c7113e70a2e722803036ac454c66fbb8deea Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 8 Jun 2023 19:30:50 -0700 Subject: [PATCH 007/305] finished defining all the helpers for defineSpec in the prelude --- saw-core/prelude/Prelude.sawcore | 174 ++++++++++++++++++++++++++++++- 1 file changed, 170 insertions(+), 4 deletions(-) diff --git a/saw-core/prelude/Prelude.sawcore b/saw-core/prelude/Prelude.sawcore index 73eb9cac7a..a6fc03bac2 100644 --- a/saw-core/prelude/Prelude.sawcore +++ b/saw-core/prelude/Prelude.sawcore @@ -2343,9 +2343,9 @@ foldIRT As Ds D = IRTDesc__rec As (\ (D:IRTDesc As) -> (Ds:IRTSubsts As) -> Unfo -------------------------------------------------------------------------------- --- 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; @@ -2363,6 +2363,25 @@ 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 + a (\ (_:List1 a) -> List1 b) (Nil1 b) + (\ (x:a) (_:List1 a) (rec:List1 b) -> Cons1 b (f x) rec) l; + + +-------------------------------------------------------------------------------- +-- 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 { @@ -2770,7 +2789,41 @@ compStackIncl stk1 stk2 stk3 incl12 incl23 = (applyStackIncl stk1 stk2 incl12 n) (stackInclProof stk1 stk2 incl12 n lt_pf).(2)).(2))); --- FIXME HERE NOW: weakenLeftStackIncl and weakenRightStackIncl +-- The function portion of weakenLeftStackIncl +weakenLeftStackInclFun : FunStack -> Nat -> Nat; +weakenLeftStackInclFun stk1 n = addNat (length1 LetRecType stk1) n; + +-- Proof that weakenLeftStackIncl is a stack inclusion; note that this is +-- provable in SAW core, and in fact the Coq development has the proof, but it's +-- just big and not really necessary to prove in SAW core, so we just assume it +axiom +weakenLeftStackInclProof : (stk1 stk2 : FunStack) -> + isStackIncl stk2 (app1 LetRecType stk1 stk2) + (weakenLeftStackInclFun stk1); + +-- The inclusion from any stack into the append of another stack on the left +weakenLeftStackIncl : (stk1 stk2 : FunStack) -> + stackIncl stk2 (app1 LetRecType stk1 stk2); +weakenLeftStackIncl stk1 stk2 = + mkStackIncl stk2 (app1 LetRecType stk1 stk2) + (weakenLeftStackInclFun stk1) + (weakenLeftStackInclProof stk1 stk2); + +-- Proof that weakenRightStackIncl is a stack inclusion; note that this is +-- provable in SAW core, and in fact the Coq development has the proof, but it's +-- just big and not really necessary to prove in SAW core, so we just assume it +axiom +weakenRightStackInclProof : (stk1 stk2 : FunStack) -> + isStackIncl stk1 (app1 LetRecType stk1 stk2) + (\ (n:Nat) -> n); + +-- The inclusion from any stack into the append of another stack on the right +weakenRightStackIncl : (stk1 stk2 : FunStack) -> + stackIncl stk1 (app1 LetRecType stk1 stk2); +weakenRightStackIncl stk1 stk2 = + mkStackIncl stk1 (app1 LetRecType stk1 stk2) + (\ (n:Nat) -> n) + (weakenRightStackInclProof stk1 stk2); -- @@ -2835,12 +2888,48 @@ StackTuple E calls defs = (\ (lrt:LetRecType) (_:FunStack) (rec:sort 0) -> SpecFun E calls lrt * rec) defs; +-- Append two StackTuples +appStackTuple : (E:EvType) -> (calls defs1 defs2 : FunStack) -> + StackTuple E calls defs1 -> StackTuple E calls defs2 -> + StackTuple E calls (app1 LetRecType defs1 defs2); +appStackTuple E calls defs1_top defs2 = + List1#rec + LetRecType + (\ (defs1:FunStack) -> StackTuple E calls defs1 -> + StackTuple E calls defs2 -> + StackTuple E calls (app1 LetRecType defs1 defs2)) + (\ (_:#()) (tup2:StackTuple E calls defs2) -> tup2) + (\ (lrt:LetRecType) (defs1:FunStack) + (rec:StackTuple E calls defs1 -> StackTuple E calls defs2 -> + StackTuple E calls (app1 LetRecType defs1 defs2)) + (tup1:StackTuple E calls (Cons1 LetRecType lrt defs1)) + (tup2:StackTuple E calls defs2) -> + (tup1.(1), rec tup1.(2) tup2)) + defs1_top; + -- A StackTuple that is polymorphic in its function stack, which defines -- functions for all the defs that can call all the calls PolyStackTuple : EvType -> FunStack -> FunStack -> sort 1; PolyStackTuple E calls defs = (calls':FunStack) -> stackIncl calls calls' -> StackTuple E calls' defs; +-- Append two PolyStackTuples +appPolyStackTuple : (E:EvType) -> (calls defs1 defs2 : FunStack) -> + PolyStackTuple E calls defs1 -> + PolyStackTuple E calls defs2 -> + PolyStackTuple E calls (app1 LetRecType defs1 defs2); +appPolyStackTuple E calls defs1 defs2 ptup1 ptup2 = + \ (calls':FunStack) (incl:stackIncl calls calls') -> + appStackTuple E calls' defs1 defs2 (ptup1 calls' incl) (ptup2 calls' incl); + +-- Apply a stackIncl to a PolySpecFun +inclPolyStackTuple : (E:EvType) -> (calls1 calls2 defs : FunStack) -> + stackIncl calls1 calls2 -> PolyStackTuple E calls1 defs -> + PolyStackTuple E calls2 defs; +inclPolyStackTuple E calls1 calls2 defs incl ptup = + \ (calls' : FunStack) (incl' : stackIncl calls2 calls') -> + ptup calls' (compStackIncl calls1 calls2 calls' incl incl'); + -- A "spec definition" represents a definition of a SpecM monadic function via -- (co)recursion over a tuple of recursive function bodies data SpecDef (E : EvType) : sort 1 where { @@ -2849,7 +2938,84 @@ data SpecDef (E : EvType) : sort 1 where { SpecDef E; } --- FIXME HERE NOW: defineSpec +-- Get the stack of a SpecDef +defStack : (E : EvType) -> SpecDef E -> FunStack; +defStack E d = + SpecDef#rec + E (\ (_:SpecDef E) -> FunStack) + (\ (stk:FunStack) (_:PolyStackTuple E stk stk) + (lrt:LetRecType) (_:PolySpecFun E stk lrt) -> stk) + d; + +-- Get the function definitions of a SpecDef +defFuns : (E : EvType) -> (d:SpecDef E) -> + PolyStackTuple E (defStack E d) (defStack E d); +defFuns E d = + SpecDef#rec + E (\ (d:SpecDef E) -> PolyStackTuple E (defStack E d) (defStack E d)) + (\ (stk:FunStack) (funs:PolyStackTuple E stk stk) + (lrt:LetRecType) (_:PolySpecFun E stk lrt) -> funs) + d; + +-- Get the LetRecType of a SpecDef +defLRT : (E : EvType) -> SpecDef E -> LetRecType; +defLRT E d = + SpecDef#rec + E (\ (_:SpecDef E) -> LetRecType) + (\ (stk:FunStack) (_:PolyStackTuple E stk stk) + (lrt:LetRecType) (_:PolySpecFun E stk lrt) -> lrt) + d; + +-- Get the body of a SpecDef +defBody : (E : EvType) -> (d:SpecDef E) -> + PolySpecFun E (defStack E d) (defLRT E d); +defBody E d = + SpecDef#rec + E (\ (d:SpecDef E) -> PolySpecFun E (defStack E d) (defLRT E d)) + (\ (stk:FunStack) (_:PolyStackTuple E stk stk) + (lrt:LetRecType) (body:PolySpecFun E stk lrt) -> body) + d; + +-- Build the concatenated FunStack for a list of imported spec defs +impsStack : (E:EvType) -> List1 (SpecDef E) -> FunStack; +impsStack E imps = + concat1 LetRecType (map1 (SpecDef E) FunStack (defStack E) imps); + +-- The combined function stack for defineSpec +defineSpecStack : (E:EvType) -> FunStack -> List1 (SpecDef E) -> FunStack; +defineSpecStack E stk imps = app1 LetRecType stk (impsStack E imps); + +-- Build the list of recursive functions for a list of imported spec defs +impsFuns : (E:EvType) -> (imps : List1 (SpecDef E)) -> + PolyStackTuple E (impsStack E imps) (impsStack E imps); +impsFuns E imps_top = + List1#rec (SpecDef E) + (\ (imps : List1 (SpecDef E)) -> + PolyStackTuple E (impsStack E imps) (impsStack E imps)) + (\ (calls' : FunStack) (_ : stackIncl emptyFunStack calls') -> ()) + (\ (d:SpecDef E) (imps:List1 (SpecDef E)) + (rec:PolyStackTuple E (impsStack E imps) (impsStack E imps)) -> + appPolyStackTuple + E (impsStack E (Cons1 (SpecDef E) d imps)) + (defStack E d) (impsStack E imps) + (inclPolyStackTuple + E (defStack E d) (impsStack E (Cons1 (SpecDef E) d imps)) + (defStack E d) + (weakenRightStackIncl (defStack E d) (impsStack E imps)) + (defFuns E d)) + (inclPolyStackTuple + E (impsStack E imps) (impsStack E (Cons1 (SpecDef E) d imps)) + (impsStack E imps) + (weakenLeftStackIncl (defStack E d) (impsStack E imps)) + rec)) + imps_top; + +-- FIXME HERE: define defineSpec +primitive defineSpec : + (E:EvType) -> (stk:FunStack) -> (lrt:LetRecType) -> (imps:List1 (SpecDef E)) -> + PolyStackTuple E (defineSpecStack E stk imps) stk -> + PolySpecFun E (defineSpecStack E stk imps) lrt -> + SpecDef E; -- From 5ba2bb3f383bc50981b458c7c9e1d9ebc49e2547 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 9 Jun 2023 12:21:05 -0700 Subject: [PATCH 008/305] moved mkSafeIdent and scInsertDef from Permissions.hs to the appropriate places in the saw-core sub-project --- .../src/Verifier/SAW/Heapster/Permissions.hs | 29 ------------------- saw-core/src/Verifier/SAW/Name.hs | 20 ++++++++++++- saw-core/src/Verifier/SAW/SharedTerm.hs | 12 ++++++++ 3 files changed, 31 insertions(+), 30 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs index 3925b582a0..5e9b04f314 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs @@ -29,7 +29,6 @@ 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 @@ -1083,34 +1082,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 diff --git a/saw-core/src/Verifier/SAW/Name.hs b/saw-core/src/Verifier/SAW/Name.hs index 442dd129c1..d930cf4985 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/SharedTerm.hs b/saw-core/src/Verifier/SAW/SharedTerm.hs index 0e0eb1cc76..ea4dc96832 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 @@ -576,6 +577,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 = From 9ff2b2182aaaf913ff64cda379d0cd182d347560 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 7 Jul 2023 07:02:28 -0700 Subject: [PATCH 009/305] adapted the Prelude to the most recent Coq model of higher-order recursion in SpecM, making a lot more things primitive that do not need to be defined in SAW --- saw-core/prelude/Prelude.sawcore | 349 +++++++++++++++++-------------- 1 file changed, 188 insertions(+), 161 deletions(-) diff --git a/saw-core/prelude/Prelude.sawcore b/saw-core/prelude/Prelude.sawcore index a6fc03bac2..908325ef6f 100644 --- a/saw-core/prelude/Prelude.sawcore +++ b/saw-core/prelude/Prelude.sawcore @@ -2378,6 +2378,17 @@ map1 a b f l = 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 + LetRecType + (\ (lrts:List1 LetRecType) -> Nat -> LetRecType) + (\ (_:Nat) -> d) + (\ (lrt:LetRecType) (_:List1 LetRecType) (rec:Nat -> LetRecType) (n:Nat) -> + Nat#rec (\ (_:Nat) -> LetRecType) lrt (\ (m:Nat) (_:LetRecType) -> rec m) n) + lrts; + -------------------------------------------------------------------------------- -- ITree Specification monad @@ -2403,27 +2414,34 @@ evRetType e = VoidEv : EvType; VoidEv = Build_EvType Void (elimVoid (sort 0)); +-- Proof that a type-level function is a valid functor for use in a LetRecType; +-- this is defined in the translation to Coq, and is only axiomatized here +primitive ValidLRTFunctor2 : (sort 0 -> sort 0 -> sort 0) -> sort 0; + +-- The pair functor is a valid binary LRT functor +axiom pair_ValidLRTFunctor2 : ValidLRTFunctor2 (\ (A B:sort 0) -> A * B); + +-- The Vec type constructor is a valid LRT functor +axiom Vec_ValidLRTFunctor2 : + (n:nat) -> ValidLRTFunctor2 (\ (A _:sort 0) -> Vec n A); + -- An inductive encoding of monadic function types and their arguments data LetRecType : sort 1 where { -- A nullary monadic function, that returns a value of the encoded type LRT_Ret : LetRecType -> LetRecType; -- A dependent monadic function type LRT_FunDep : (a:sort 0) -> (a -> LetRecType) -> LetRecType; - -- A non-dependent monadic function type - LRT_Fun : LetRecType -> LetRecType -> LetRecType; + -- A non-dependent monadic function type, which can take in closures + LRT_FunClos : LetRecType -> LetRecType -> LetRecType; -- The unit type - LRT_Unit : LetRecType; + LRT_Type : sort 0 -> LetRecType; -- An application of a binary type function - LRT_BinOp : (sort 0 -> sort 0 -> sort 0) -> + LRT_BinOp : (F: sort 0 -> sort 0 -> sort 0) -> ValidLRTFunctor2 F -> LetRecType -> LetRecType -> LetRecType; -- A dependent pair type LRT_Sigma : (a:sort 0) -> (a -> LetRecType) -> LetRecType; } --- Helper definition to build a LetRecType that decodes to a specific type -LRT_Type : sort 0 -> LetRecType; -LRT_Type a = LRT_BinOp (\ (_:sort 0) (_:sort 0) -> a) LRT_Unit LRT_Unit; - -- A trivially inhabied "default" LetRecType, representing void -> void default_lrt : LetRecType; default_lrt = LRT_FunDep Void (\ (_:Void) -> LRT_Ret (LRT_Type Void)); @@ -2443,55 +2461,91 @@ stackLen = length1 LetRecType; -- Get the nth element of a FunStack, or void -> void if n is too big nthLRT : List1 LetRecType -> Nat -> LetRecType; -nthLRT lrts = - List1#rec - LetRecType - (\ (lrts:List1 LetRecType) -> Nat -> LetRecType) - (\ (_:Nat) -> default_lrt) - (\ (lrt:LetRecType) (_:List1 LetRecType) (rec:Nat -> LetRecType) (n:Nat) -> - Nat#rec (\ (_:Nat) -> LetRecType) lrt (\ (m:Nat) (_:LetRecType) -> rec m) n) - lrts; +nthLRT lrts = nth_default1 default_lrt lrts; --- A partial application of a function of LetRecType lrt_in to some of its --- FunDep arguments, resulting in LetRecType lrt_out -LRTDepApp : LetRecType -> LetRecType -> sort 0; -LRTDepApp lrt_in lrt_out = - LetRecType#rec - (\ (_:LetRecType) -> sort 0) - (\ (_:LetRecType) (_:sort 0) -> Eq LetRecType lrt_in lrt_out) - (\ (A:sort 0) (B:A -> LetRecType) (rec:A -> sort 0) -> - Either (Eq LetRecType lrt_in lrt_out) (Sigma A rec)) - (\ (_:LetRecType) (_:sort 0) (_:LetRecType) (_:sort 0) -> - Eq LetRecType lrt_in lrt_out) - (Eq LetRecType lrt_in lrt_out) - (\ (_:sort 0 -> sort 0 -> sort 0) (_:LetRecType) (_:sort 0) - (_:LetRecType) (_:sort 0) -> - Eq LetRecType lrt_in lrt_out) - (\ (a:sort 0) (_:a -> LetRecType) (_:a -> sort 0) -> - Eq LetRecType lrt_in lrt_out) - lrt_in; +-- A monadic function closure, whose type is described be a LetRecType; this is +-- defined in the translation to Coq, and is only axiomatized here +primitive LRTClos : FunStack -> LetRecType -> sort 0; -- An argument to a recursive function call, which is a decoding of a LetRecType --- to its corresponding SAW core type, except that functions are just natural --- numbers that choose functions in the current function stack +-- to its corresponding SAW core type LRTArg : FunStack -> LetRecType -> sort 0; LRTArg stack argTp = LetRecType#rec (\ (_:LetRecType) -> sort 0) - (\ (R:LetRecType) (_:sort 0) -> - Sigma Nat (\ (n:Nat) -> LRTDepApp (nthLRT stack n) (LRT_Ret R))) + (\ (R:LetRecType) (_:sort 0) -> LRTClos stack (LRT_SpecM R)) (\ (A:sort 0) (B:A -> LetRecType) (_:A -> sort 0) -> - Sigma Nat (\ (n:Nat) -> LRTDepApp (nthLRT stack n) (LRT_FunDep A B))) + LRTClos stack (LRT_FunDep A B)) (\ (A:LetRecType) (_:sort 0) (B:LetRecType) (_:sort 0) -> - Sigma Nat (\ (n:Nat) -> LRTDepApp (nthLRT stack n) (LRT_Fun A B))) - #() - (\ (F:sort 0 -> sort 0 -> sort 0) (_:LetRecType) (A:sort 0) - (_:LetRecType) (B:sort 0) -> - F A B) - (\ (A:sort 0) (_:A -> LetRecType) (rec:A -> sort 0) -> - Sigma A rec) + LRTClos stack (LRT_FunClos A B)) + (\ (A:sort 0) -> A) + (\ (F:sort 0 -> sort 0 -> sort 0) (_:ValidLRTFunctor2 F) + (_:LetRecType) (recA:sort 0) (_:LetRecType) (recB:sort 0) -> F recA recB) + (\ (A:sort 0) (_:A -> LetRecType) (rec:A -> sort 0) -> Sigma A rec) argTp; +-- Apply a monadic function closure with a dependent function type +primitive applyLRTClosDep : + (stk:FunStack) -> (A:sort 0) -> (B:A -> LetRecType) -> + LRTClos stk (LRT_FunDep A B) -> (a:A) -> LRTClos stk (B a); + +-- Apply a monadic function closure with a non-dependent function type +primitive applyLRTClosClos : + (stk:FunStack) -> (A B:LetRecType) -> + LRTClos stk (LRT_FunClos A B) -> (a:LRTArg stk A) -> LRTClos stk B; + +-- The return type of applyLRTClosN, which applies an LRTClos to N arguments +applyLRTClosNRet : (stk:FunStack) -> Nat -> LetRecType -> sort 0; +applyLRTClosNRet stk = + Nat__rec + (\ (_:Nat) -> LetRecType -> sort 0) + (LRTClos stk) + (\ (_:Nat) (rec:LetRecType -> sort 0) (lrt:LetRecType) -> + LetRecType#rec + (\ (_:LetRecType) -> sort 0) + (\ (R:LetRecType) (_:sort 0) -> Void -> Void) + (\ (A:sort 0) (B:A -> LetRecType) (rec:A -> sort 0) -> + (a:A) -> rec (B a)) + (\ (A:LetRecType) (_:sort 0) (B:LetRecType) (recB:sort 0) -> + LRTArg stk A -> recB) + (\ (A:sort 0) -> Void -> Void) + (\ (F:sort 0 -> sort 0 -> sort 0) (_:ValidLRTFunctor2 F) + (_:LetRecType) (_:sort 0) (_:LetRecType) (_:sort 0) -> + Void -> Void) + (\ (A:sort 0) (_:A -> LetRecType) (_:A -> sort 0) -> Void -> Void) + lrt); + +-- Apply an LRTClos to N arguments +{- +applyLRTClosN : (stk:FunStack) -> (n:Nat) -> (lrt:LetRecType) -> + LRTClos stk lrt -> applyLRTClosNRet stk n lrt; +applyLRTClosN stk = + Nat__rec + (\ (n:Nat) -> (lrt:LetRecType) -> LRTClos stk lrt -> applyLRTClosNRet stk n lrt) + (\ (lrt:LetRecType) (clos:LRTClos stk lrt) -> clos) + (\ (n':Nat) + (rec:(lrt:LetRecType) -> LRTClos stk lrt -> applyLRTClosNRet stk n' lrt) + (lrt:LetRecType) -> + LetRecType#rec + (\ (lrt:LetRecType) -> LRTClos stk lrt -> applyLRTClosNRet stk n' lrt) + (\ (R:LetRecType) + (_:LRTClos stk (LRT_SpecM R) -> applyLRTClosNRet stk n' (LRT_SpecM R)) + (_:LRTClos stk (LRT_SpecM R)) (v:Void) -> v) + (\ (A:sort 0) (B:A -> LetRecType) (rec:A -> sort 0) -> + FIXME HERE + + (a:A) -> rec (B a)) + (\ (A:LetRecType) (_:sort 0) (B:LetRecType) (recB:sort 0) -> + LRTArg stk A -> recB) + (\ (A:sort 0) -> Void -> Void) + (\ (F:sort 0 -> sort 0 -> sort 0) (_:ValidLRTFunctor2 F) + (_:LetRecType) (_:sort 0) (_:LetRecType) (_:sort 0) -> + Void -> Void) + (\ (A:sort 0) (_:A -> LetRecType) (_:A -> sort 0) -> Void -> Void) + lrt); +-} + + -- Build the dependent type { a1:A1 & { a2:A2 & ... { an:An & unit } ... }} of -- inputs to the LetRecType (LRT_Fun A1 (\ a1 -> ...)). Return the Void type for -- any LetRecType that is not a valid monadic function type. @@ -2504,12 +2558,11 @@ LRTInput stack lrt = Sigma A (\ (a:A) -> rec a)) (\ (A:LetRecType) (_:sort 0) (B:LetRecType) (rec:sort 0) -> LRTArg stack A * rec) - Void - (\ (_:sort 0 -> sort 0 -> sort 0) (_:LetRecType) (_:sort 0) - (_:LetRecType) (_:sort 0) -> - Void) - (\ (A:sort 0) (_:A -> LetRecType) (_:A -> sort 0) -> + (\ (A:sort 0) -> Void) + (\ (F:sort 0 -> sort 0 -> sort 0) (_:ValidLRTFunctor2 F) + (_:LetRecType) (_:sort 0) (_:LetRecType) (_:sort 0) -> Void) + (\ (A:sort 0) (_:A -> LetRecType) (_:A -> sort 0) -> Void) lrt; -- Build the output type (R a1 ... an) of the application of a LetRecType @@ -2529,8 +2582,8 @@ LRTOutput stack lrt = (B:LetRecType) (rec:LRTInput stack B -> sort 0) (args:LRTArg stack A * LRTInput stack B) -> rec (args.(2))) - (\ (v:Void) -> elimVoid (sort 0) v) - (\ (_:sort 0 -> sort 0 -> sort 0) + (\ (A:sort 0) (v:Void) -> elimVoid (sort 0) v) + (\ (F:sort 0 -> sort 0 -> sort 0) (_:ValidLRTFunctor2 F) (A:LetRecType) (_:LRTInput stack A -> sort 0) (B:LetRecType) (_:LRTInput stack B -> sort 0) (v:Void) -> elimVoid (sort 0) v) @@ -2548,81 +2601,26 @@ lrtPi stack lrt_top = LetRecType#rec (\ (lrt:LetRecType) -> (LRTInput stack lrt -> sort 0) -> sort 0) (\ (R:LetRecType) (_:(LRTInput stack R -> sort 0) -> sort 0) - (F:#() -> sort 0) -> F ()) + (rec:#() -> sort 0) -> rec ()) (\ (A:sort 0) (B: A -> LetRecType) (rec: (x:A) -> (LRTInput stack (B x) -> sort 0) -> sort 0) - (F : LRTInput stack (LRT_FunDep A B) -> sort 0) -> + (rec : LRTInput stack (LRT_FunDep A B) -> sort 0) -> (x:A) -> rec x (\ (args : LRTInput stack (B x)) -> - F (exists A (\ (y:A) -> LRTInput stack (B y)) x args))) + rec (exists A (\ (y:A) -> LRTInput stack (B y)) x args))) (\ (A:LetRecType) (_:(LRTInput stack A -> sort 0) -> sort 0) (B:LetRecType) (rec:(LRTInput stack B -> sort 0) -> sort 0) - (F : LRTInput stack (LRT_Fun A B) -> sort 0) -> - (x:LRTArg stack A) -> rec (\ (args : LRTInput stack B) -> F (x, args))) - (\ (F : Void -> sort 0) -> (v:Void) -> F v) - (\ (_:sort 0 -> sort 0 -> sort 0) + (rec : LRTInput stack (LRT_Fun A B) -> sort 0) -> + (x:LRTArg stack A) -> rec (\ (args : LRTInput stack B) -> rec (x, args))) + (\ (A:sort 0) (rec : Void -> sort 0) -> (v:Void) -> rec v) + (\ (F:sort 0 -> sort 0 -> sort 0) (_:ValidLRTFunctor2 F) (A:LetRecType) (_:(LRTInput stack A -> sort 0) -> sort 0) (B:LetRecType) (_:(LRTInput stack B -> sort 0) -> sort 0) - (F : Void -> sort 0) -> (v:Void) -> F v) + (rec : Void -> sort 0) -> (v:Void) -> rec v) (\ (A:sort 0) (B:A -> LetRecType) (_:(a:A) -> (LRTInput stack (B a) -> sort 0) -> sort 0) - (F : Void -> sort 0) -> (v:Void) -> F v) + (rec : Void -> sort 0) -> (v:Void) -> rec v) lrt_top; --- Build an lrtPi function from a unary function on an LRTInput -lrtLambda : (stack:FunStack) -> (lrt:LetRecType) -> - (F: LRTInput stack lrt -> sort 0) -> - ((args: LRTInput stack lrt) -> F args) -> lrtPi stack lrt F; -lrtLambda stack lrt_top = - LetRecType#rec - (\ (lrt:LetRecType) -> (F: LRTInput stack lrt -> sort 0) -> - ((args: LRTInput stack lrt) -> F args) -> - lrtPi stack lrt F) - (\ (R:LetRecType) (_: (F: LRTInput stack R -> sort 0) -> - ((args: LRTInput stack R) -> F args) -> - lrtPi stack R F) - (F: #() -> sort 0) (f : (args:#()) -> F args) -> f ()) - (\ (A:sort 0) (B: A -> LetRecType) - (rec: (a:A) -> (F: LRTInput stack (B a) -> sort 0) -> - ((args: LRTInput stack (B a)) -> F args) -> - lrtPi stack (B a) F) - (F: LRTInput stack (LRT_FunDep A B) -> sort 0) - (f : (args: LRTInput stack (LRT_FunDep A B)) -> F args) - (a:A) -> - rec a (\ (args:LRTInput stack (B a)) -> - F (exists A (\ (y:A) -> LRTInput stack (B y)) a args)) - (\ (args:LRTInput stack (B a)) -> - f (exists A (\ (y:A) -> LRTInput stack (B y)) a args))) - (\ (A:LetRecType) - (_:(F: LRTInput stack A -> sort 0) -> - ((args: LRTInput stack A) -> F args) -> - lrtPi stack A F) - (B:LetRecType) - (rec:(F: LRTInput stack B -> sort 0) -> - ((args: LRTInput stack B) -> F args) -> - lrtPi stack B F) - (F : LRTInput stack (LRT_Fun A B) -> sort 0) - (f : (args: LRTInput stack (LRT_Fun A B)) -> F args) - (a:LRTArg stack A) -> - rec (\ (args:LRTInput stack B) -> F (a, args)) - (\ (args:LRTInput stack B) -> f (a, args))) - (\ (F : Void -> sort 0) (f: (v:Void) -> F v) (v:Void) -> - elimVoid (F v) v) - (\ (_:sort 0 -> sort 0 -> sort 0) - (A:LetRecType) - (_:(F:LRTInput stack A -> sort 0) -> ((args:LRTInput stack A) -> F args) -> - lrtPi stack A F) - (B:LetRecType) - (_:(F:LRTInput stack B -> sort 0) -> ((args:LRTInput stack B) -> F args) -> - lrtPi stack B F) - (F : Void -> sort 0) (f: (v:Void) -> F v) (v:Void) -> - elimVoid (F v) v) - (\ (A:sort 0) (B:A -> LetRecType) - (_:(a:A) -> (F:LRTInput stack (B a) -> sort 0) -> - ((args:LRTInput stack (B a)) -> F args) -> - lrtPi stack (B a) F) - (F : Void -> sort 0) (f: (v:Void) -> F v) (v:Void) -> - elimVoid (F v) v) - lrt_top; -- A recursive call to one of the functions in a FunStack data StackCall (stack : FunStack) : sort 0 where { @@ -2725,11 +2723,24 @@ 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); +-- Call a monadic function closure of monadic type +primitive CallS : (E:vType) -> (stk:FunStack) -> (R:LetRecType) -> + LRTClos stk (LRT_SpecM R) -> SpecM E stk (LRTArg stk R); + -- -- The category of stack inclusions -- +-- A stack inclusion is a mapping from the indices of one stack to those of +-- another that preserves LetRecTypes; however, SAW doesn't need to know +-- anything about how these are defined nor how they are built -- they are +-- defined and their properties are verified in Coq -- so we just axiomatize +-- them here as a primitive +primitive stackIncl : FunStack -> FunStack -> sort 0; + +-- FIXME: keeping the SAW core definition of stackIncls in case we need them... +{- -- A proof that a function is a stack inclusion, i.e., is a mapping from the -- indices of one stack to those of another that preserves LetRecTypes isStackIncl : (stk1 stk2 : FunStack) -> (Nat -> Nat) -> sort 0; @@ -2824,43 +2835,7 @@ weakenRightStackIncl stk1 stk2 = mkStackIncl stk1 (app1 LetRecType stk1 stk2) (\ (n:Nat) -> n) (weakenRightStackInclProof stk1 stk2); - - --- --- Recursive calls in SpecM --- - --- A StackCall in a polymorphic context (in the sense of PolySpecFun, below), --- where the call is into a function in stk1 but where stk1 has been extended to --- some arbitrary stk2 -data PolyStackCall (stk1 stk2 : FunStack) : sort 0 where { - PolyStackCallOfArgs : (n:Nat) -> LRTInput stk2 (nthLRT stk1 n) -> - PolyStackCall stk1 stk2; -} - --- The return type for a PolyStackCall recursive call -PolyStackCallRet : (stk1 stk2 : FunStack) -> PolyStackCall stk1 stk2 -> sort 0; -PolyStackCallRet stk1 stk2 call = - PolyStackCall#rec - stk1 stk2 - (\ (_:PolyStackCall stk1 stk2) -> sort 0) - (\ (n:Nat) (args : LRTInput stk2 (nthLRT stk1 n)) -> - LRTOutput stk2 (nthLRT stk1 n) args) - call; - --- Create a PolyStackCall in a way where we take in one argument at a time -mkPolyStackCall : (stk1 stk2 : FunStack) -> (n:Nat) -> - lrtPi stk2 (nthLRT stk1 n) - (\ (_:LRTInput stk2 (nthLRT stk1 n)) -> PolyStackCall stk1 stk2); -mkPolyStackCall stk1 stk2 n = - lrtLambda stk2 (nthLRT stk1 n) - (\ (_:LRTInput stk2 (nthLRT stk1 n)) -> PolyStackCall stk1 stk2) - (\ (args:LRTInput stk2 (nthLRT stk1 n)) -> PolyStackCallOfArgs stk1 stk2 n args); - --- Make a recursive call using a PolyStackCall -primitive callS : - (E:EvType) -> (stk1 stk2 : FunStack) -> (incl : stackIncl stk1 stk2) -> - (call : PolyStackCall stk1 stk2) -> SpecM E stk2 (PolyStackCallRet stk1 stk2 call); +-} -- @@ -2888,6 +2863,14 @@ StackTuple E calls defs = (\ (lrt:LetRecType) (_:FunStack) (rec:sort 0) -> SpecFun E calls lrt * rec) defs; +-- A StackTuple that is polymorphic in its function stack, which defines +-- functions for all the defs that can call all the calls +PolyStackTuple : EvType -> FunStack -> FunStack -> sort 1; +PolyStackTuple E calls defs = + (calls':FunStack) -> stackIncl calls calls' -> StackTuple E calls' defs; + +-- FIXME: keeping the SAW core definitions for SpecDefs in case we need them... +{- -- Append two StackTuples appStackTuple : (E:EvType) -> (calls defs1 defs2 : FunStack) -> StackTuple E calls defs1 -> StackTuple E calls defs2 -> @@ -2907,12 +2890,6 @@ appStackTuple E calls defs1_top defs2 = (tup1.(1), rec tup1.(2) tup2)) defs1_top; --- A StackTuple that is polymorphic in its function stack, which defines --- functions for all the defs that can call all the calls -PolyStackTuple : EvType -> FunStack -> FunStack -> sort 1; -PolyStackTuple E calls defs = - (calls':FunStack) -> stackIncl calls calls' -> StackTuple E calls' defs; - -- Append two PolyStackTuples appPolyStackTuple : (E:EvType) -> (calls defs1 defs2 : FunStack) -> PolyStackTuple E calls defs1 -> @@ -3010,13 +2987,63 @@ impsFuns E imps_top = rec)) imps_top; +-} + +-- A "spec definition" represents a definition of a SpecM monadic function via +-- corecursion over a tuple of recursive function bodies. However, SAW doesn't +-- need to know anything about how these are defined nor how they are built -- +-- they are defined and their properties are verified in Coq -- so we just +-- axiomatize them here as a primitive +primitive SpecDef : EvType -> LetRecType -> sort 1; + +-- A "spec import" is a spec definition that is imported into another spec +-- definition, represented as a SpecDef with existential LetRecType +data SpecImp (E: EvType) : sort 1 { + Build_SpecImp : (lrt : LetRecType) -> SpecDef E lrt -> SpecImp E; +} + +-- Get the LetRecType of a spec import +SpecImpType : (E:EvType) -> SpecImp E -> LetRecType; +SpecImpType E imp = + SpecImp#rec E (\ (_:SpecImp E) -> LetRecType) + (\ (lrt:LetRecType) (_:Specef E lrt) -> lrt) imp; + +-- The FunStack used by defineSpec; also defined only in Coq, not in SAW +primitive defineSpecStack : + (E:EvType) -> FunStack -> List1 (SpecImp E) -> FunStack; + -- FIXME HERE: define defineSpec primitive defineSpec : - (E:EvType) -> (stk:FunStack) -> (lrt:LetRecType) -> (imps:List1 (SpecDef E)) -> + (E:EvType) -> (stk:FunStack) -> (lrt:LetRecType) -> (imps:List1 (SpecImp E)) -> PolyStackTuple E (defineSpecStack E stk imps) stk -> PolySpecFun E (defineSpecStack E stk imps) lrt -> SpecDef E; +-- Build a closure that calls the nth corecursive function out of those that are +-- defined locally in a SpecDef +primitive mkLocalLRTClos : + (E:EvType) -> (stk: FunStack) -> (imps: List1 (SpecImp E)) -> + (stk': FunStack) -> (incl: stackIncl (defineSpecStack E stk imps) stk') -> + (n: Nat) -> LRTClos stk' (nthLRT stk n); + +-- The "default", trivial spec definition +defaultSpecDef : (E:EvType) -> SpecDef E default_lrt; +defaultSpecDef E = + defineSpec E emptyFunStack default_lrt (Nil1 (SpecImp E)) () + (\ (stk': FunStack) (incl: stackIncl (defineSpecStack E stk imps) stk') + (v:Void) -> elimVoid (SpecM E stk' Void) v); + +-- Get the nth spec import from a list +nthImport : (E:EvType) -> List1 (SpecImp E) -> Nat -> SpecImp E; +nthImport E = + nth_default1 (SpecImp E) (Build_SpecImp default_lrt (defaultSpecDef E)); + +-- Call the body of the nth import from a spec import list +primitive callNthImportS : + (E:EvType) -> (stk:FunStack) -> (imps:List1 (SpecImp E)) -> + (stk':FunStack) -> stackIncl (defineSpecStack E stk imps) stk' -> + (n:Nat) -> SpecFun E stk' (SpecImpType E (nthImport E imps n)); + -- -- Helper operations on SpecM From 1f0ab46076fdb5d8623b913e2ff8b562c176e73b Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 7 Jul 2023 10:01:53 -0700 Subject: [PATCH 010/305] Got Prelude to compile --- saw-core/prelude/Prelude.sawcore | 56 +++++++++++++++++--------------- 1 file changed, 29 insertions(+), 27 deletions(-) diff --git a/saw-core/prelude/Prelude.sawcore b/saw-core/prelude/Prelude.sawcore index 908325ef6f..a7cd08d787 100644 --- a/saw-core/prelude/Prelude.sawcore +++ b/saw-core/prelude/Prelude.sawcore @@ -2381,13 +2381,11 @@ map1 a b f 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 - LetRecType - (\ (lrts:List1 LetRecType) -> Nat -> LetRecType) - (\ (_:Nat) -> d) - (\ (lrt:LetRecType) (_:List1 LetRecType) (rec:Nat -> LetRecType) (n:Nat) -> - Nat#rec (\ (_:Nat) -> LetRecType) lrt (\ (m:Nat) (_:LetRecType) -> rec m) n) - lrts; + 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; -------------------------------------------------------------------------------- @@ -2423,12 +2421,12 @@ axiom pair_ValidLRTFunctor2 : ValidLRTFunctor2 (\ (A B:sort 0) -> A * B); -- The Vec type constructor is a valid LRT functor axiom Vec_ValidLRTFunctor2 : - (n:nat) -> ValidLRTFunctor2 (\ (A _:sort 0) -> Vec n A); + (n:Nat) -> ValidLRTFunctor2 (\ (A _:sort 0) -> Vec n A); -- An inductive encoding of monadic function types and their arguments data LetRecType : sort 1 where { -- A nullary monadic function, that returns a value of the encoded type - LRT_Ret : LetRecType -> LetRecType; + LRT_SpecM : LetRecType -> LetRecType; -- A dependent monadic function type LRT_FunDep : (a:sort 0) -> (a -> LetRecType) -> LetRecType; -- A non-dependent monadic function type, which can take in closures @@ -2444,7 +2442,7 @@ data LetRecType : sort 1 where { -- A trivially inhabied "default" LetRecType, representing void -> void default_lrt : LetRecType; -default_lrt = LRT_FunDep Void (\ (_:Void) -> LRT_Ret (LRT_Type Void)); +default_lrt = LRT_FunDep Void (\ (_:Void) -> LRT_SpecM (LRT_Type Void)); -- A function stack is a list of LetRecTypes, which intuitively -- represents a stack of bindings of mutually recursive functions @@ -2461,7 +2459,7 @@ stackLen = length1 LetRecType; -- Get the nth element of a FunStack, or void -> void if n is too big nthLRT : List1 LetRecType -> Nat -> LetRecType; -nthLRT lrts = nth_default1 default_lrt lrts; +nthLRT lrts = nth_default1 LetRecType default_lrt lrts; -- A monadic function closure, whose type is described be a LetRecType; this is -- defined in the translation to Coq, and is only axiomatized here @@ -2505,7 +2503,7 @@ applyLRTClosNRet stk = (\ (_:LetRecType) -> sort 0) (\ (R:LetRecType) (_:sort 0) -> Void -> Void) (\ (A:sort 0) (B:A -> LetRecType) (rec:A -> sort 0) -> - (a:A) -> rec (B a)) + (a:A) -> rec a) (\ (A:LetRecType) (_:sort 0) (B:LetRecType) (recB:sort 0) -> LRTArg stk A -> recB) (\ (A:sort 0) -> Void -> Void) @@ -2566,7 +2564,7 @@ LRTInput stack lrt = 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)))) +-- (LRT_Fun A1 (\ a1 -> ... (LRT_Fun An (\ an -> LRT_SpecM R a1 ... an)))) -- function to the arguments a1 ... an in an LRTInput LRTOutput : (stack:FunStack) -> (lrt:LetRecType) -> LRTInput stack lrt -> sort 0; LRTOutput stack lrt = @@ -2592,9 +2590,9 @@ LRTOutput stack lrt = elimVoid (sort 0) v) lrt; --- Build the function type (a1:A1) -> ... -> (an:An) -> B from the LetRecType --- (LRT_Fun A1 (\ a1 -> ...)). A LetRecType that is not a monadic function type --- turns into a function from v:void -> F v +-- Build the function type (a1:A1) -> ... -> (an:An) -> B represented by a +-- LetRecType. A LetRecType that is not a monadic function type turns into a +-- function from v:void -> F v lrtPi : (stack:FunStack) -> (lrt:LetRecType) -> (LRTInput stack lrt -> sort 0) -> sort 0; lrtPi stack lrt_top = @@ -2604,13 +2602,13 @@ lrtPi stack lrt_top = (rec:#() -> sort 0) -> rec ()) (\ (A:sort 0) (B: A -> LetRecType) (rec: (x:A) -> (LRTInput stack (B x) -> sort 0) -> sort 0) - (rec : LRTInput stack (LRT_FunDep A B) -> sort 0) -> + (outF : LRTInput stack (LRT_FunDep A B) -> sort 0) -> (x:A) -> rec x (\ (args : LRTInput stack (B x)) -> - rec (exists A (\ (y:A) -> LRTInput stack (B y)) x args))) + outF (exists A (\ (y:A) -> LRTInput stack (B y)) x args))) (\ (A:LetRecType) (_:(LRTInput stack A -> sort 0) -> sort 0) (B:LetRecType) (rec:(LRTInput stack B -> sort 0) -> sort 0) - (rec : LRTInput stack (LRT_Fun A B) -> sort 0) -> - (x:LRTArg stack A) -> rec (\ (args : LRTInput stack B) -> rec (x, args))) + (outF : LRTInput stack (LRT_FunClos A B) -> sort 0) -> + (x:LRTArg stack A) -> rec (\ (args : LRTInput stack B) -> outF (x, args))) (\ (A:sort 0) (rec : Void -> sort 0) -> (v:Void) -> rec v) (\ (F:sort 0 -> sort 0 -> sort 0) (_:ValidLRTFunctor2 F) (A:LetRecType) (_:(LRTInput stack A -> sort 0) -> sort 0) @@ -2724,7 +2722,7 @@ orS E stack a m1 m2 = (\ (b:Bool) -> ite (SpecM E stack a) b m1 m2); -- Call a monadic function closure of monadic type -primitive CallS : (E:vType) -> (stk:FunStack) -> (R:LetRecType) -> +primitive CallS : (E:EvType) -> (stk:FunStack) -> (R:LetRecType) -> LRTClos stk (LRT_SpecM R) -> SpecM E stk (LRTArg stk R); @@ -2998,7 +2996,7 @@ primitive SpecDef : EvType -> LetRecType -> sort 1; -- A "spec import" is a spec definition that is imported into another spec -- definition, represented as a SpecDef with existential LetRecType -data SpecImp (E: EvType) : sort 1 { +data SpecImp (E: EvType) : sort 1 where { Build_SpecImp : (lrt : LetRecType) -> SpecDef E lrt -> SpecImp E; } @@ -3006,7 +3004,7 @@ data SpecImp (E: EvType) : sort 1 { SpecImpType : (E:EvType) -> SpecImp E -> LetRecType; SpecImpType E imp = SpecImp#rec E (\ (_:SpecImp E) -> LetRecType) - (\ (lrt:LetRecType) (_:Specef E lrt) -> lrt) imp; + (\ (lrt:LetRecType) (_:SpecDef E lrt) -> lrt) imp; -- The FunStack used by defineSpec; also defined only in Coq, not in SAW primitive defineSpecStack : @@ -3017,7 +3015,7 @@ primitive defineSpec : (E:EvType) -> (stk:FunStack) -> (lrt:LetRecType) -> (imps:List1 (SpecImp E)) -> PolyStackTuple E (defineSpecStack E stk imps) stk -> PolySpecFun E (defineSpecStack E stk imps) lrt -> - SpecDef E; + SpecDef E lrt; -- Build a closure that calls the nth corecursive function out of those that are -- defined locally in a SpecDef @@ -3029,14 +3027,18 @@ primitive mkLocalLRTClos : -- The "default", trivial spec definition defaultSpecDef : (E:EvType) -> SpecDef E default_lrt; defaultSpecDef E = - defineSpec E emptyFunStack default_lrt (Nil1 (SpecImp E)) () - (\ (stk': FunStack) (incl: stackIncl (defineSpecStack E stk imps) stk') + defineSpec E emptyFunStack default_lrt (Nil1 (SpecImp E)) + (\ (stk': FunStack) + (incl: stackIncl (defineSpecStack E emptyFunStack (Nil1 (SpecImp E))) stk') -> + ()) + (\ (stk': FunStack) + (incl: stackIncl (defineSpecStack E emptyFunStack (Nil1 (SpecImp E))) stk') (v:Void) -> elimVoid (SpecM E stk' Void) v); -- Get the nth spec import from a list nthImport : (E:EvType) -> List1 (SpecImp E) -> Nat -> SpecImp E; nthImport E = - nth_default1 (SpecImp E) (Build_SpecImp default_lrt (defaultSpecDef E)); + nth_default1 (SpecImp E) (Build_SpecImp E default_lrt (defaultSpecDef E)); -- Call the body of the nth import from a spec import list primitive callNthImportS : From 3f39b8636b924d62e39effa6e34ebd209b984033 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 7 Jul 2023 17:02:37 -0700 Subject: [PATCH 011/305] wrote initial versions of defineSpecOpenTerm, mkBaseClosSpec, and mkFreshClosSpec --- saw-core/src/Verifier/SAW/OpenTerm.hs | 223 +++++++++++++++++++++++++- 1 file changed, 219 insertions(+), 4 deletions(-) diff --git a/saw-core/src/Verifier/SAW/OpenTerm.hs b/saw-core/src/Verifier/SAW/OpenTerm.hs index 362cf45f85..18d3734d01 100644 --- a/saw-core/src/Verifier/SAW/OpenTerm.hs +++ b/saw-core/src/Verifier/SAW/OpenTerm.hs @@ -40,19 +40,24 @@ module Verifier.SAW.OpenTerm ( -- * Monadic operations for building terms with binders OpenTermM(..), completeOpenTermM, dedupOpenTermM, lambdaOpenTermM, piOpenTermM, - lambdaOpenTermAuxM, piOpenTermAuxM + lambdaOpenTermAuxM, piOpenTermAuxM, + -- * Building SpecM computations + SpecTerm(), SpecFunTerm(), defineSpecOpenTerm, + mkBaseClosSpec, mkFreshClosSpec, applySpecTerm, applySpecTermMulti ) where import qualified Data.Vector as V import Control.Monad import Control.Monad.State import Control.Monad.Writer +import Control.Monad.Reader import Data.Text (Text) import Numeric.Natural import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap +import Verifier.SAW.Utils (panic) import Verifier.SAW.Term.Functor import Verifier.SAW.Term.Pretty import Verifier.SAW.SharedTerm @@ -428,12 +433,15 @@ newtype OpenTermM a = OpenTermM { unOpenTermM :: TCM a } instance MonadIO OpenTermM where liftIO = OpenTermM . liftIO +-- | "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' -- does not lead to duplicated WHNF work @@ -494,6 +502,213 @@ piOpenTermAuxM x tp body_f = return (OpenTerm (typeInferComplete $ Pi x tp' body), a) +-------------------------------------------------------------------------------- +-- Building SpecM computations + +-- FIXME HERE NOW: improve all the docs below + +-- | When creating a SAW core term of type @PolySpecFun@ or @PolyStackTuple@, +-- the body or bodies are relative to: the "base" @FunStack@ that gives the +-- types of all the corecursive functions defined in the current @SpecDef@; an +-- extension stack that specifies the @FunStack@ of any future @SpecDef@ that +-- this object will be used in; and a stack inclusion between the two. These are +-- captured by the 'SpecTermInfo' type. +-- +-- FIXME: this needs to be all top-level info needed from the SpecDef (local +-- stack plus import list) +data SpecTermInfo = + SpecTermInfo { specInfoEvType :: OpenTerm, + specInfoLocalsStack :: OpenTerm, + specInfoImps :: OpenTerm, + specInfoExtStack :: OpenTerm, + specInfoIncl :: OpenTerm } + +-- | An 'OpenTerm' that depends on a 'SpecTermInfo'. These are used for the +-- bodies of terms of type @PolySpecFun@ or @PolyStackTuple@. +type SpecInfoTerm = Reader SpecTermInfo OpenTerm + +applySpecInfoTerm :: SpecInfoTerm -> SpecInfoTerm -> SpecInfoTerm +applySpecInfoTerm f arg = applyOpenTerm <$> f <*> arg + +-- | Apply a term to all of the 'SpecTermInfo' terms in order +applySpecInfoOp :: Ident -> SpecInfoTerm +applySpecInfoOp f = + do SpecTermInfo { specInfoEvType = ev, specInfoLocalsStack = local_stk, + specInfoImps = imps, specInfoExtStack = stk', + specInfoIncl = incl } <- ask + return $ applyGlobalOpenTerm f [ev, local_stk, imps, stk', incl] + +-- | In order to create a recursive function in a @SpecDef@, we need its +-- @LetRecType@ and its definition as a @PolySpecFun E stk lrt@. The difficulty +-- is that the function stack @stk@ is only known after we have fully processed +-- all the recursive function definitions in the entire @SpecDef@, so we make +-- the body depend on the @stk@ value; that is, 'specRecFunBody' should take in +-- @stk@ and return a SAW core term of type @PolySpecFun E stk lrt@, where @lrt@ +-- is the value of 'specRecFunLRT'. +data SpecRecFun = SpecRecFun { specRecFunLRT :: OpenTerm, + specRecFunBody :: Maybe SpecInfoTerm } + +tempSpecRecFun :: OpenTerm -> SpecRecFun +tempSpecRecFun lrt = SpecRecFun { specRecFunLRT = lrt, + specRecFunBody = Nothing } + +-- | The state that is built up when building a 'SpecTerm' that is needed to +-- make the top-level @defineSpec@ call; all the lists are accumulated in +-- reverse order, so that the final index of elements already in the lists don't +-- change as we add new elements +data SpecTermState = + SpecTermState { specStEvType :: OpenTerm, + specStNumBaseRecs :: Natural, + specStExtraRecsRev :: [SpecRecFun], + specStImportsRev :: [OpenTerm] } + +specStExtraRecs :: SpecTermState -> [SpecRecFun] +specStExtraRecs st = reverse $ specStExtraRecsRev st + +specStImports :: SpecTermState -> [OpenTerm] +specStImports st = reverse (specStImportsRev st) + +specStInsTempClos :: OpenTerm -> SpecTermState -> (Natural, SpecTermState) +specStInsTempClos lrt st = + (specStNumBaseRecs st + fromIntegral (length $ specStExtraRecsRev st), + st { specStExtraRecsRev = tempSpecRecFun lrt : specStExtraRecsRev st }) + +modifyNth :: Int -> (a -> a) -> [a] -> [a] +modifyNth i _ xs | i >= length xs || i < 0 = error "modifyNthNat" +modifyNth i f xs = take i xs ++ (f (xs!!i)) : drop (i+1) xs + +-- | Modify the nth element from the end of a list +modifyNthRev :: Int -> (a -> a) -> [a] -> [a] +modifyNthRev i f xs = modifyNth (length xs - i) f xs + +specStSetClosBody :: Natural -> SpecInfoTerm -> SpecTermState -> SpecTermState +specStSetClosBody clos_ix body st = + st { specStExtraRecsRev = + modifyNthRev (fromIntegral clos_ix) + (\case (SpecRecFun lrt Nothing) -> SpecRecFun lrt (Just body) + _ -> panic "specStSetClosBody" ["Closure body already set"]) + (specStExtraRecsRev st) } + +initSpecTermState :: OpenTerm -> Natural -> SpecTermState +initSpecTermState ev n = + SpecTermState { specStEvType = ev, specStNumBaseRecs = n, + specStExtraRecsRev = [], specStImportsRev = [] } + +-- | High-level idea: while building a @SpecM@ computation, you have to keep +-- track of the imported SpecDefs and the co-recursive functions that are +-- created by defunctionalization, and this is tracked in this monad +type SpecTermM = StateT SpecTermState OpenTermM + +runSpecTermM :: OpenTerm -> Natural -> SpecTermM a -> OpenTermM a +runSpecTermM ev n m = evalStateT m $ initSpecTermState ev n + +-- | A 'SpecTerm' is a term representation used to build @SpecM@ computations to +-- be used in spec definitions, i.e., terms of type @SpecDef E@ for some given +-- @E@. Any monadic functions or calls to functions that have been previously +-- defined are lifted to the top level using the 'SpecTermM' monad. The +-- resulting terms will always be inside a @PolySpecFun@ or @PolyStackTuple@, +-- and so are in the context of the information provided by a 'SpecInfoTerm', +-- thus the use of the 'SpecInfoTerm' type. +newtype SpecTerm = SpecTerm { unSpecTerm :: SpecTermM SpecInfoTerm } + +applySpecTerm :: SpecTerm -> SpecTerm -> SpecTerm +applySpecTerm (SpecTerm f) (SpecTerm arg) = + SpecTerm (applySpecInfoTerm <$> f <*> arg) + +applySpecTermMulti :: SpecTerm -> [SpecTerm] -> SpecTerm +applySpecTermMulti = foldl applySpecTerm + +-- | A 'SpecFunTerm' is a term representation of a monadic function, that is +-- basically the same as 'SpecTerm', except we keep it separate to indicate +-- where lambdas are allowed, as lambdas are only allowed in certain contexts +newtype SpecFunTerm = SpecFunTerm { unSpecFunTerm :: SpecTermM SpecInfoTerm } + +funStackTypeOpenTerm :: OpenTerm +funStackTypeOpenTerm = globalOpenTerm "Prelude.FunStack" + +letRecTypeOpenTerm :: OpenTerm +letRecTypeOpenTerm = dataTypeOpenTerm "Prelude.LetRecType" [] + +specImpOpenTerm :: OpenTerm -> OpenTerm +specImpOpenTerm ev = dataTypeOpenTerm "Prelude.SpecImp" [ev] + +defineSpecStackOpenTerm :: OpenTerm -> OpenTerm -> OpenTerm -> OpenTerm +defineSpecStackOpenTerm ev local_stk imps = + applyGlobalOpenTerm "Prelude.defineSpecStack" [ev, local_stk, imps] + +mkPolySpecLambda :: OpenTerm -> OpenTerm -> OpenTerm -> SpecInfoTerm -> OpenTerm +mkPolySpecLambda ev local_stk imps t = + let stk = defineSpecStackOpenTerm ev local_stk imps in + lambdaOpenTerm "stk'" funStackTypeOpenTerm $ \stk' -> + lambdaOpenTerm "incl" (applyGlobalOpenTerm + "Prelude.stackIncl" [stk, stk']) $ \incl -> + runReader t $ SpecTermInfo { specInfoEvType = ev, + specInfoLocalsStack = local_stk, + specInfoImps = imps, + specInfoExtStack = stk', + specInfoIncl = incl } + +mkSpecRecFunM :: OpenTerm -> SpecFunTerm -> SpecTermM SpecRecFun +mkSpecRecFunM lrt (SpecFunTerm m) = SpecRecFun lrt <$> Just <$> m + +specRecFunsStack :: [SpecRecFun] -> OpenTerm +specRecFunsStack recFuns = + list1OpenTerm letRecTypeOpenTerm $ map specRecFunLRT recFuns + +specRecFunsTuple :: [SpecRecFun] -> SpecInfoTerm +specRecFunsTuple recFuns = + tupleOpenTerm <$> forM recFuns + (\rf -> case specRecFunBody rf of + Just body -> body + Nothing -> panic "specRecFunsTuple" ["Recursive function body not defined"]) + +-- | Build a spec definition, i.e., a term of type @SpecDef E@, given: an event +-- type @E@; a list of corecursive functions that can be called in that spec +-- definition, given as pairs of a @LetRecType@ and a 'SpecFunTerm' of that +-- type; and a @LetRecType@ plus a body for the entire definition. +defineSpecOpenTerm :: OpenTerm -> [(OpenTerm,SpecFunTerm)] -> + OpenTerm -> SpecTerm -> OpenTerm +defineSpecOpenTerm ev base_recs_in lrt body_in = + runOpenTermM $ runSpecTermM ev (fromIntegral $ length base_recs_in) $ + do base_recs <- + forM base_recs_in $ \(fun_lrt,fun_tm) -> mkSpecRecFunM fun_lrt fun_tm + body <- unSpecTerm body_in + final_st <- get + let all_recs = base_recs ++ specStExtraRecs final_st + let local_stk = specRecFunsStack all_recs + let imps = list1OpenTerm (specImpOpenTerm ev) (specStImports final_st) + return $ applyGlobalOpenTerm "Prelude.defineSpec" + [ev, local_stk, lrt, imps, + mkPolySpecLambda ev local_stk imps (specRecFunsTuple all_recs), + mkPolySpecLambda ev local_stk imps body] + +-- | Internal-only helper function +mkClosSpecInfoTerm :: Natural -> SpecInfoTerm +mkClosSpecInfoTerm n = + applySpecInfoTerm (applySpecInfoOp "Prelude.mkLocalLRTClos") + (return $ natOpenTerm n) + +-- | Build a closure that calls one of the "base" recursive functions in the +-- current spec definition +mkBaseClosSpec :: Natural -> SpecTerm +mkBaseClosSpec clos_ix = SpecTerm $ + do st <- get + if clos_ix < specStNumBaseRecs st then return () else + panic "mkBaseClosSpec" ["Closure index out of bounds"] + return $ mkClosSpecInfoTerm clos_ix + +-- | Build a closure that calls a new corecursive function with the given +-- @LetRecType@ and body, that can call itself using the term passed to it +mkFreshClosSpec :: OpenTerm -> (SpecTerm -> SpecFunTerm) -> SpecTerm +mkFreshClosSpec lrt body_f = SpecTerm $ + do (clos_ix, st) <- specStInsTempClos lrt <$> get + put st + body <- unSpecFunTerm $ body_f (SpecTerm $ return $ + mkClosSpecInfoTerm clos_ix) + modify $ specStSetClosBody clos_ix body + return $ mkClosSpecInfoTerm clos_ix + + -------------------------------------------------------------------------------- -- sawLet-minimization From de8b2e20bd7d94ef26a71883415965b1c7460a6f Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Sat, 8 Jul 2023 08:27:06 -0700 Subject: [PATCH 012/305] changed the TCM type synonym to not require an argument --- saw-core/src/Verifier/SAW/SCTypeCheck.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/saw-core/src/Verifier/SAW/SCTypeCheck.hs b/saw-core/src/Verifier/SAW/SCTypeCheck.hs index 9d94d5eef2..dd6320e959 100644 --- a/saw-core/src/Verifier/SAW/SCTypeCheck.hs +++ b/saw-core/src/Verifier/SAW/SCTypeCheck.hs @@ -79,9 +79,9 @@ type TCState = Map TermIndex Term -- * Memoizes the most general type inferred for each expression; AND -- -- * Can throw 'TCError's -type TCM a = +type TCM = ReaderT (SharedContext, Maybe ModuleName, [(LocalName, Term)]) - (StateT TCState (ExceptT TCError IO)) a + (StateT TCState (ExceptT TCError IO)) -- | Run a type-checking computation in a given context, starting from the empty -- memoization table From 1ec5fdfc7d84ccad213128c0832f1b952ab2a9a7 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Sat, 8 Jul 2023 08:27:32 -0700 Subject: [PATCH 013/305] implemented lambdaSpecFun and a number of helper SpecTerm operations --- saw-core/src/Verifier/SAW/OpenTerm.hs | 152 +++++++++++++++++++++----- 1 file changed, 125 insertions(+), 27 deletions(-) diff --git a/saw-core/src/Verifier/SAW/OpenTerm.hs b/saw-core/src/Verifier/SAW/OpenTerm.hs index 18d3734d01..2081a6c94b 100644 --- a/saw-core/src/Verifier/SAW/OpenTerm.hs +++ b/saw-core/src/Verifier/SAW/OpenTerm.hs @@ -42,8 +42,10 @@ module Verifier.SAW.OpenTerm ( dedupOpenTermM, lambdaOpenTermM, piOpenTermM, lambdaOpenTermAuxM, piOpenTermAuxM, -- * Building SpecM computations - SpecTerm(), SpecFunTerm(), defineSpecOpenTerm, - mkBaseClosSpec, mkFreshClosSpec, applySpecTerm, applySpecTermMulti + SpecTerm(), SpecFunTerm(), defineSpecOpenTerm, lambdaSpecFun, baseSpecFun, + applySpecTerm, applySpecTermMulti, lambdaSpec, openTermSpecTerm, + mkBaseClosSpec, mkFreshClosSpec, callClosSpec, callDefSpec, + returnSpec, bindSpec, errorSpec ) where import qualified Data.Vector as V @@ -512,31 +514,39 @@ piOpenTermAuxM x tp body_f = -- types of all the corecursive functions defined in the current @SpecDef@; an -- extension stack that specifies the @FunStack@ of any future @SpecDef@ that -- this object will be used in; and a stack inclusion between the two. These are --- captured by the 'SpecTermInfo' type. +-- captured by the 'SpecInfo' type. -- -- FIXME: this needs to be all top-level info needed from the SpecDef (local -- stack plus import list) -data SpecTermInfo = - SpecTermInfo { specInfoEvType :: OpenTerm, - specInfoLocalsStack :: OpenTerm, - specInfoImps :: OpenTerm, - specInfoExtStack :: OpenTerm, - specInfoIncl :: OpenTerm } +data SpecInfo = + SpecInfo { specInfoEvType :: OpenTerm, + specInfoLocalsStack :: OpenTerm, + specInfoImps :: OpenTerm, + specInfoExtStack :: OpenTerm, + specInfoIncl :: OpenTerm } --- | An 'OpenTerm' that depends on a 'SpecTermInfo'. These are used for the --- bodies of terms of type @PolySpecFun@ or @PolyStackTuple@. -type SpecInfoTerm = Reader SpecTermInfo OpenTerm +-- | An 'OpenTerm' that depends on a 'SpecInfo'. These are used for the bodies +-- of terms of type @PolySpecFun@ or @PolyStackTuple@. +type SpecInfoTerm = Reader SpecInfo OpenTerm applySpecInfoTerm :: SpecInfoTerm -> SpecInfoTerm -> SpecInfoTerm applySpecInfoTerm f arg = applyOpenTerm <$> f <*> arg --- | Apply a term to all of the 'SpecTermInfo' terms in order -applySpecInfoOp :: Ident -> SpecInfoTerm -applySpecInfoOp f = - do SpecTermInfo { specInfoEvType = ev, specInfoLocalsStack = local_stk, - specInfoImps = imps, specInfoExtStack = stk', - specInfoIncl = incl } <- ask - return $ applyGlobalOpenTerm f [ev, local_stk, imps, stk', incl] +-- | Apply an operator to the event type, locals stack, imports, extended +-- function stack, and tsack inclusion in the current 'SpecInfo' +applyStackInclOp :: Ident -> SpecInfoTerm +applyStackInclOp f = + do info <- ask + return $ applyGlobalOpenTerm f + [specInfoEvType info, specInfoLocalsStack info, specInfoImps info, + specInfoExtStack info, specInfoIncl info] + +-- | Apply an operator to the current event type and extended function stack +applyExtStackOp :: Ident -> SpecInfoTerm +applyExtStackOp f = + do info <- ask + return $ applyGlobalOpenTerm f + [specInfoEvType info, specInfoExtStack info] -- | In order to create a recursive function in a @SpecDef@, we need its -- @LetRecType@ and its definition as a @PolySpecFun E stk lrt@. The difficulty @@ -589,6 +599,11 @@ specStSetClosBody clos_ix body st = _ -> panic "specStSetClosBody" ["Closure body already set"]) (specStExtraRecsRev st) } +specStInsImport :: OpenTerm -> SpecTermState -> (Natural, SpecTermState) +specStInsImport def st = + (fromIntegral (length $ specStImportsRev st), + st { specStImportsRev = def : specStImportsRev st }) + initSpecTermState :: OpenTerm -> Natural -> SpecTermState initSpecTermState ev n = SpecTermState { specStEvType = ev, specStNumBaseRecs = n, @@ -597,10 +612,10 @@ initSpecTermState ev n = -- | High-level idea: while building a @SpecM@ computation, you have to keep -- track of the imported SpecDefs and the co-recursive functions that are -- created by defunctionalization, and this is tracked in this monad -type SpecTermM = StateT SpecTermState OpenTermM +type SpecTermM = StateT SpecTermState TCM runSpecTermM :: OpenTerm -> Natural -> SpecTermM a -> OpenTermM a -runSpecTermM ev n m = evalStateT m $ initSpecTermState ev n +runSpecTermM ev n m = OpenTermM $ evalStateT m $ initSpecTermState ev n -- | A 'SpecTerm' is a term representation used to build @SpecM@ computations to -- be used in spec definitions, i.e., terms of type @SpecDef E@ for some given @@ -618,11 +633,55 @@ applySpecTerm (SpecTerm f) (SpecTerm arg) = applySpecTermMulti :: SpecTerm -> [SpecTerm] -> SpecTerm applySpecTermMulti = foldl applySpecTerm +specInfoTermTerm :: SpecInfoTerm -> SpecTerm +specInfoTermTerm t = SpecTerm $ return t + +openTermSpecTerm :: OpenTerm -> SpecTerm +openTermSpecTerm t = SpecTerm $ return $ return t + -- | A 'SpecFunTerm' is a term representation of a monadic function, that is -- basically the same as 'SpecTerm', except we keep it separate to indicate -- where lambdas are allowed, as lambdas are only allowed in certain contexts newtype SpecFunTerm = SpecFunTerm { unSpecFunTerm :: SpecTermM SpecInfoTerm } +-- | Build a lambda abstraction as a 'SpecFunTerm' +lambdaSpecFun :: LocalName -> OpenTerm -> (OpenTerm -> SpecFunTerm) -> + SpecFunTerm +lambdaSpecFun x (OpenTerm tpM) body_f = SpecFunTerm $ + do + -- First we compute the type of the variable by running its underlying TCM + -- computation and normalizing it; normalization is required here because + -- the typeInferComplete instance for TermF TypedTerm, which we use below, + -- assumes that the variable type is normalized + TypedTerm tp tp_tp <- lift tpM + tp_whnf <- lift $ typeCheckWHNF tp + let tp' = TypedTerm tp_whnf tp_tp + + -- Next, we apply body_f to the top-most variable in a context extended with + -- x, run it with the current state, and update to the new state it returns + st <- get + (body_infot, st') <- + lift $ withVar x tp_whnf (openTermTopVar >>= \y -> + runStateT (unSpecFunTerm $ body_f y) st) + put st' + + -- Finally, we map the OpenTerm inside body_infot so its computation also + -- runs in the extended context with x, and then map its return value to + -- lambda-abstract x after the body is computed + return $ flip fmap body_infot $ \(OpenTerm bodyM) -> + OpenTerm $ do body <- withVar x tp_whnf bodyM + typeInferComplete $ Lambda x tp' body + +-- | Build a 'SpecFunTerm' function with no more arguments from a 'SpecTerm' +baseSpecFun :: SpecTerm -> SpecFunTerm +baseSpecFun (SpecTerm m) = SpecFunTerm m + +-- | Build a lambda abstraction as a 'SpecTerm' +lambdaSpec :: LocalName -> OpenTerm -> (OpenTerm -> SpecTerm) -> SpecTerm +lambdaSpec x tp body_f = + SpecTerm $ unSpecFunTerm $ + lambdaSpecFun x tp (SpecFunTerm . unSpecTerm . body_f) + funStackTypeOpenTerm :: OpenTerm funStackTypeOpenTerm = globalOpenTerm "Prelude.FunStack" @@ -642,11 +701,11 @@ mkPolySpecLambda ev local_stk imps t = lambdaOpenTerm "stk'" funStackTypeOpenTerm $ \stk' -> lambdaOpenTerm "incl" (applyGlobalOpenTerm "Prelude.stackIncl" [stk, stk']) $ \incl -> - runReader t $ SpecTermInfo { specInfoEvType = ev, - specInfoLocalsStack = local_stk, - specInfoImps = imps, - specInfoExtStack = stk', - specInfoIncl = incl } + runReader t $ SpecInfo { specInfoEvType = ev, + specInfoLocalsStack = local_stk, + specInfoImps = imps, + specInfoExtStack = stk', + specInfoIncl = incl } mkSpecRecFunM :: OpenTerm -> SpecFunTerm -> SpecTermM SpecRecFun mkSpecRecFunM lrt (SpecFunTerm m) = SpecRecFun lrt <$> Just <$> m @@ -685,7 +744,7 @@ defineSpecOpenTerm ev base_recs_in lrt body_in = -- | Internal-only helper function mkClosSpecInfoTerm :: Natural -> SpecInfoTerm mkClosSpecInfoTerm n = - applySpecInfoTerm (applySpecInfoOp "Prelude.mkLocalLRTClos") + applySpecInfoTerm (applyStackInclOp "Prelude.mkLocalLRTClos") (return $ natOpenTerm n) -- | Build a closure that calls one of the "base" recursive functions in the @@ -708,6 +767,45 @@ mkFreshClosSpec lrt body_f = SpecTerm $ modify $ specStSetClosBody clos_ix body return $ mkClosSpecInfoTerm clos_ix +-- | Build a @SpecM@ computation that calls a closure with the given return +-- type specified as a @LetRecType@ +callClosSpec :: OpenTerm -> SpecTerm -> SpecTerm +callClosSpec tp clos = + applySpecTermMulti (monadicSpecOp "Prelude.CallS") + [openTermSpecTerm tp, clos] + +-- | Call another spec definition inside a spec definition, by importing it +callDefSpec :: OpenTerm -> SpecTerm +callDefSpec def = SpecTerm $ + do (imp_ix, st) <- specStInsImport def <$> get + put st + return $ + applySpecInfoTerm (applyStackInclOp "Prelude.callNthImportS") + (return $ natOpenTerm imp_ix) + +-- | Build a 'SpecTerm' for a monadic operation that takes the current event +-- type and extended function stack +monadicSpecOp :: Ident -> SpecTerm +monadicSpecOp f = specInfoTermTerm $ applyExtStackOp f + +-- | Build a @SpecM@ computation that returns a value of a given type +returnSpec :: OpenTerm -> SpecTerm -> SpecTerm +returnSpec tp val = + applySpecTermMulti (monadicSpecOp "Prelude.retS") [openTermSpecTerm tp, val] + +-- | Build a @SpecM@ computation that does a monadic bind +bindSpec :: OpenTerm -> OpenTerm -> SpecTerm -> + LocalName -> (OpenTerm -> SpecTerm) -> SpecTerm +bindSpec tp1 tp2 m x f = + applySpecTermMulti (monadicSpecOp "Prelude.bindS") + [openTermSpecTerm tp1, openTermSpecTerm tp2, m, lambdaSpec x tp1 f] + +-- | Build a @SpecM@ error computation at the given type with the given message +errorSpec :: OpenTerm -> Text -> SpecTerm +errorSpec tp msg = + applySpecTermMulti (monadicSpecOp "Prelude.errorS") + [openTermSpecTerm tp, openTermSpecTerm (stringLitOpenTerm msg)] + -------------------------------------------------------------------------------- -- sawLet-minimization From 0b055209acf7e462c4c0957afd5385aa29838217 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Sun, 9 Jul 2023 07:10:16 -0700 Subject: [PATCH 014/305] changed SpecTermM to not use TCM, but instead only use a context length component of its state, so that lambdaSpec can use a SpecTerm for the type of the bound variable; renamed lambdaSpec to lambdaSpecTerm; removed the SpecFunTerm type in favor of just SpecTerm everywhere --- saw-core/src/Verifier/SAW/OpenTerm.hs | 140 ++++++++++++++------------ 1 file changed, 77 insertions(+), 63 deletions(-) diff --git a/saw-core/src/Verifier/SAW/OpenTerm.hs b/saw-core/src/Verifier/SAW/OpenTerm.hs index 2081a6c94b..3cf5f47a59 100644 --- a/saw-core/src/Verifier/SAW/OpenTerm.hs +++ b/saw-core/src/Verifier/SAW/OpenTerm.hs @@ -42,8 +42,8 @@ module Verifier.SAW.OpenTerm ( dedupOpenTermM, lambdaOpenTermM, piOpenTermM, lambdaOpenTermAuxM, piOpenTermAuxM, -- * Building SpecM computations - SpecTerm(), SpecFunTerm(), defineSpecOpenTerm, lambdaSpecFun, baseSpecFun, - applySpecTerm, applySpecTermMulti, lambdaSpec, openTermSpecTerm, + SpecTerm(), defineSpecOpenTerm, lambdaSpecTerm, + applySpecTerm, applySpecTermMulti, openTermSpecTerm, mkBaseClosSpec, mkFreshClosSpec, callClosSpec, callDefSpec, returnSpec, bindSpec, errorSpec ) where @@ -548,6 +548,27 @@ applyExtStackOp f = return $ applyGlobalOpenTerm f [specInfoEvType info, specInfoExtStack info] +lambdaSpecInfoTerm :: LocalName -> SpecInfoTerm -> SpecInfoTerm -> SpecInfoTerm +lambdaSpecInfoTerm x tpM bodyM = + do tpOT <- tpM + bodyOT <- bodyM + return $ OpenTerm $ do + -- First we compute the type of the variable by running its underlying TCM + -- computation and normalizing it; normalization is required here because + -- the typeInferComplete instance for TermF TypedTerm, which we use below, + -- assumes that the variable type is normalized + TypedTerm tp tp_tp <- unOpenTerm tpOT + tp_whnf <- typeCheckWHNF tp + let tp' = TypedTerm tp_whnf tp_tp + + -- Next, we run the body TCM computation to get its TypedTerm, making + -- sure to run that computation in an extended typing context with x + body <- withVar x tp_whnf $ unOpenTerm bodyOT + + -- Finally, build and return the required lambda-abstraction + typeInferComplete $ Lambda x tp' body + + -- | In order to create a recursive function in a @SpecDef@, we need its -- @LetRecType@ and its definition as a @PolySpecFun E stk lrt@. The difficulty -- is that the function stack @stk@ is only known after we have fully processed @@ -569,6 +590,7 @@ tempSpecRecFun lrt = SpecRecFun { specRecFunLRT = lrt, data SpecTermState = SpecTermState { specStEvType :: OpenTerm, specStNumBaseRecs :: Natural, + specStCtxLen :: Int, specStExtraRecsRev :: [SpecRecFun], specStImportsRev :: [OpenTerm] } @@ -578,6 +600,12 @@ specStExtraRecs st = reverse $ specStExtraRecsRev st specStImports :: SpecTermState -> [OpenTerm] specStImports st = reverse (specStImportsRev st) +specStIncCtx :: SpecTermState -> SpecTermState +specStIncCtx st = st { specStCtxLen = specStCtxLen st + 1 } + +specStDecCtx :: SpecTermState -> SpecTermState +specStDecCtx st = st { specStCtxLen = specStCtxLen st - 1 } + specStInsTempClos :: OpenTerm -> SpecTermState -> (Natural, SpecTermState) specStInsTempClos lrt st = (specStNumBaseRecs st + fromIntegral (length $ specStExtraRecsRev st), @@ -604,18 +632,21 @@ specStInsImport def st = (fromIntegral (length $ specStImportsRev st), st { specStImportsRev = def : specStImportsRev st }) -initSpecTermState :: OpenTerm -> Natural -> SpecTermState -initSpecTermState ev n = +initSpecTermState :: OpenTerm -> Natural -> Int -> SpecTermState +initSpecTermState ev n ctx_len = SpecTermState { specStEvType = ev, specStNumBaseRecs = n, + specStCtxLen = ctx_len, specStExtraRecsRev = [], specStImportsRev = [] } -- | High-level idea: while building a @SpecM@ computation, you have to keep -- track of the imported SpecDefs and the co-recursive functions that are -- created by defunctionalization, and this is tracked in this monad -type SpecTermM = StateT SpecTermState TCM +type SpecTermM = State SpecTermState -runSpecTermM :: OpenTerm -> Natural -> SpecTermM a -> OpenTermM a -runSpecTermM ev n m = OpenTermM $ evalStateT m $ initSpecTermState ev n +runSpecTermM :: OpenTerm -> Natural -> SpecTermM OpenTerm -> OpenTerm +runSpecTermM ev n m = OpenTerm $ + do ctx_len <- length <$> askCtx + unOpenTerm $ evalState m $ initSpecTermState ev n ctx_len -- | A 'SpecTerm' is a term representation used to build @SpecM@ computations to -- be used in spec definitions, i.e., terms of type @SpecDef E@ for some given @@ -639,48 +670,31 @@ specInfoTermTerm t = SpecTerm $ return t openTermSpecTerm :: OpenTerm -> SpecTerm openTermSpecTerm t = SpecTerm $ return $ return t --- | A 'SpecFunTerm' is a term representation of a monadic function, that is --- basically the same as 'SpecTerm', except we keep it separate to indicate --- where lambdas are allowed, as lambdas are only allowed in certain contexts -newtype SpecFunTerm = SpecFunTerm { unSpecFunTerm :: SpecTermM SpecInfoTerm } - --- | Build a lambda abstraction as a 'SpecFunTerm' -lambdaSpecFun :: LocalName -> OpenTerm -> (OpenTerm -> SpecFunTerm) -> - SpecFunTerm -lambdaSpecFun x (OpenTerm tpM) body_f = SpecFunTerm $ - do - -- First we compute the type of the variable by running its underlying TCM - -- computation and normalizing it; normalization is required here because - -- the typeInferComplete instance for TermF TypedTerm, which we use below, - -- assumes that the variable type is normalized - TypedTerm tp tp_tp <- lift tpM - tp_whnf <- lift $ typeCheckWHNF tp - let tp' = TypedTerm tp_whnf tp_tp - - -- Next, we apply body_f to the top-most variable in a context extended with - -- x, run it with the current state, and update to the new state it returns - st <- get - (body_infot, st') <- - lift $ withVar x tp_whnf (openTermTopVar >>= \y -> - runStateT (unSpecFunTerm $ body_f y) st) - put st' - - -- Finally, we map the OpenTerm inside body_infot so its computation also - -- runs in the extended context with x, and then map its return value to - -- lambda-abstract x after the body is computed - return $ flip fmap body_infot $ \(OpenTerm bodyM) -> - OpenTerm $ do body <- withVar x tp_whnf bodyM - typeInferComplete $ Lambda x tp' body - --- | Build a 'SpecFunTerm' function with no more arguments from a 'SpecTerm' -baseSpecFun :: SpecTerm -> SpecFunTerm -baseSpecFun (SpecTerm m) = SpecFunTerm m +topVarSpecTerm :: SpecTermM SpecTerm +topVarSpecTerm = + do outer_ctx_len <- specStCtxLen <$> get + return $ SpecTerm $ do + inner_ctx_len <- specStCtxLen <$> get + return $ return $ OpenTerm $ + do inner_ctx <- askCtx + if length inner_ctx == inner_ctx_len then return () else + panic "topVarSpecTerm" ["Variable context of unexpected length"] + typeInferComplete (LocalVar (inner_ctx_len + - outer_ctx_len) :: TermF Term) + +withVarSpecTermM :: SpecTermM a -> SpecTermM a +withVarSpecTermM m = + do modify specStIncCtx + a <- m + modify specStDecCtx + return a -- | Build a lambda abstraction as a 'SpecTerm' -lambdaSpec :: LocalName -> OpenTerm -> (OpenTerm -> SpecTerm) -> SpecTerm -lambdaSpec x tp body_f = - SpecTerm $ unSpecFunTerm $ - lambdaSpecFun x tp (SpecFunTerm . unSpecTerm . body_f) +lambdaSpecTerm :: LocalName -> SpecTerm -> (SpecTerm -> SpecTerm) -> SpecTerm +lambdaSpecTerm x (SpecTerm tpM) body_f = SpecTerm $ + do tp <- tpM + body <- withVarSpecTermM (topVarSpecTerm >>= (unSpecTerm . body_f)) + return $ lambdaSpecInfoTerm x tp body funStackTypeOpenTerm :: OpenTerm funStackTypeOpenTerm = globalOpenTerm "Prelude.FunStack" @@ -707,8 +721,8 @@ mkPolySpecLambda ev local_stk imps t = specInfoExtStack = stk', specInfoIncl = incl } -mkSpecRecFunM :: OpenTerm -> SpecFunTerm -> SpecTermM SpecRecFun -mkSpecRecFunM lrt (SpecFunTerm m) = SpecRecFun lrt <$> Just <$> m +mkSpecRecFunM :: OpenTerm -> SpecTerm -> SpecTermM SpecRecFun +mkSpecRecFunM lrt (SpecTerm m) = SpecRecFun lrt <$> Just <$> m specRecFunsStack :: [SpecRecFun] -> OpenTerm specRecFunsStack recFuns = @@ -723,12 +737,12 @@ specRecFunsTuple recFuns = -- | Build a spec definition, i.e., a term of type @SpecDef E@, given: an event -- type @E@; a list of corecursive functions that can be called in that spec --- definition, given as pairs of a @LetRecType@ and a 'SpecFunTerm' of that --- type; and a @LetRecType@ plus a body for the entire definition. -defineSpecOpenTerm :: OpenTerm -> [(OpenTerm,SpecFunTerm)] -> +-- definition, given as pairs of a @LetRecType@ and a 'SpecTerm' of that type; +-- and a @LetRecType@ plus a body for the entire definition. +defineSpecOpenTerm :: OpenTerm -> [(OpenTerm,SpecTerm)] -> OpenTerm -> SpecTerm -> OpenTerm defineSpecOpenTerm ev base_recs_in lrt body_in = - runOpenTermM $ runSpecTermM ev (fromIntegral $ length base_recs_in) $ + runSpecTermM ev (fromIntegral $ length base_recs_in) $ do base_recs <- forM base_recs_in $ \(fun_lrt,fun_tm) -> mkSpecRecFunM fun_lrt fun_tm body <- unSpecTerm body_in @@ -758,12 +772,12 @@ mkBaseClosSpec clos_ix = SpecTerm $ -- | Build a closure that calls a new corecursive function with the given -- @LetRecType@ and body, that can call itself using the term passed to it -mkFreshClosSpec :: OpenTerm -> (SpecTerm -> SpecFunTerm) -> SpecTerm +mkFreshClosSpec :: OpenTerm -> (SpecTerm -> SpecTerm) -> SpecTerm mkFreshClosSpec lrt body_f = SpecTerm $ do (clos_ix, st) <- specStInsTempClos lrt <$> get put st - body <- unSpecFunTerm $ body_f (SpecTerm $ return $ - mkClosSpecInfoTerm clos_ix) + body <- unSpecTerm $ body_f (SpecTerm $ return $ + mkClosSpecInfoTerm clos_ix) modify $ specStSetClosBody clos_ix body return $ mkClosSpecInfoTerm clos_ix @@ -789,22 +803,22 @@ monadicSpecOp :: Ident -> SpecTerm monadicSpecOp f = specInfoTermTerm $ applyExtStackOp f -- | Build a @SpecM@ computation that returns a value of a given type -returnSpec :: OpenTerm -> SpecTerm -> SpecTerm +returnSpec :: SpecTerm -> SpecTerm -> SpecTerm returnSpec tp val = - applySpecTermMulti (monadicSpecOp "Prelude.retS") [openTermSpecTerm tp, val] + applySpecTermMulti (monadicSpecOp "Prelude.retS") [tp, val] -- | Build a @SpecM@ computation that does a monadic bind -bindSpec :: OpenTerm -> OpenTerm -> SpecTerm -> - LocalName -> (OpenTerm -> SpecTerm) -> SpecTerm +bindSpec :: SpecTerm -> SpecTerm -> SpecTerm -> + LocalName -> (SpecTerm -> SpecTerm) -> SpecTerm bindSpec tp1 tp2 m x f = applySpecTermMulti (monadicSpecOp "Prelude.bindS") - [openTermSpecTerm tp1, openTermSpecTerm tp2, m, lambdaSpec x tp1 f] + [tp1, tp2, m, lambdaSpecTerm x tp1 f] -- | Build a @SpecM@ error computation at the given type with the given message -errorSpec :: OpenTerm -> Text -> SpecTerm +errorSpec :: SpecTerm -> Text -> SpecTerm errorSpec tp msg = applySpecTermMulti (monadicSpecOp "Prelude.errorS") - [openTermSpecTerm tp, openTermSpecTerm (stringLitOpenTerm msg)] + [tp, openTermSpecTerm (stringLitOpenTerm msg)] -------------------------------------------------------------------------------- From 30d0dacbf9d2f6aaf0253ddf15a36d0b34421be8 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 10 Jul 2023 07:37:31 -0700 Subject: [PATCH 015/305] wrote module-level documentation for OpenTerm.hs, along with some haddocks for some of the SpecTerm combinators; generalized lambdaSpecTerm so we could also define piSpecTerm --- saw-core/src/Verifier/SAW/OpenTerm.hs | 101 +++++++++++++++++++------- 1 file changed, 74 insertions(+), 27 deletions(-) diff --git a/saw-core/src/Verifier/SAW/OpenTerm.hs b/saw-core/src/Verifier/SAW/OpenTerm.hs index 3cf5f47a59..4884beebbd 100644 --- a/saw-core/src/Verifier/SAW/OpenTerm.hs +++ b/saw-core/src/Verifier/SAW/OpenTerm.hs @@ -14,7 +14,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 ( @@ -42,7 +73,7 @@ module Verifier.SAW.OpenTerm ( dedupOpenTermM, lambdaOpenTermM, piOpenTermM, lambdaOpenTermAuxM, piOpenTermAuxM, -- * Building SpecM computations - SpecTerm(), defineSpecOpenTerm, lambdaSpecTerm, + SpecTerm(), defineSpecOpenTerm, lambdaSpecTerm, piSpecTerm, applySpecTerm, applySpecTermMulti, openTermSpecTerm, mkBaseClosSpec, mkFreshClosSpec, callClosSpec, callDefSpec, returnSpec, bindSpec, errorSpec @@ -507,17 +538,13 @@ piOpenTermAuxM x tp body_f = -------------------------------------------------------------------------------- -- Building SpecM computations --- FIXME HERE NOW: improve all the docs below - -- | When creating a SAW core term of type @PolySpecFun@ or @PolyStackTuple@, --- the body or bodies are relative to: the "base" @FunStack@ that gives the --- types of all the corecursive functions defined in the current @SpecDef@; an --- extension stack that specifies the @FunStack@ of any future @SpecDef@ that --- this object will be used in; and a stack inclusion between the two. These are --- captured by the 'SpecInfo' type. --- --- FIXME: this needs to be all top-level info needed from the SpecDef (local --- stack plus import list) +-- the body or bodies are relative to: the current event type (or @EvType@); the +-- @FunStack@ of @LetRecType@s of the locally-defined corecursive functions; the +-- list of imported spec definitions; an extended stack that specifies the +-- @FunStack@ of any future @SpecDef@ that this object will be used in; and a +-- stack inclusion between the @FunStack@ defined by the local stack plus +-- imports and the extended stack. These are captured by the 'SpecInfo' type. data SpecInfo = SpecInfo { specInfoEvType :: OpenTerm, specInfoLocalsStack :: OpenTerm, @@ -529,6 +556,7 @@ data SpecInfo = -- of terms of type @PolySpecFun@ or @PolyStackTuple@. type SpecInfoTerm = Reader SpecInfo OpenTerm +-- | Apply a 'SpecInfoTerm' to another applySpecInfoTerm :: SpecInfoTerm -> SpecInfoTerm -> SpecInfoTerm applySpecInfoTerm f arg = applyOpenTerm <$> f <*> arg @@ -548,8 +576,10 @@ applyExtStackOp f = return $ applyGlobalOpenTerm f [specInfoEvType info, specInfoExtStack info] -lambdaSpecInfoTerm :: LocalName -> SpecInfoTerm -> SpecInfoTerm -> SpecInfoTerm -lambdaSpecInfoTerm x tpM bodyM = +-- | FIXME: docs +bindSpecInfoTerm :: (LocalName -> TypedTerm -> TypedTerm -> TermF TypedTerm) -> + LocalName -> SpecInfoTerm -> SpecInfoTerm -> SpecInfoTerm +bindSpecInfoTerm f x tpM bodyM = do tpOT <- tpM bodyOT <- bodyM return $ OpenTerm $ do @@ -566,7 +596,7 @@ lambdaSpecInfoTerm x tpM bodyM = body <- withVar x tp_whnf $ unOpenTerm bodyOT -- Finally, build and return the required lambda-abstraction - typeInferComplete $ Lambda x tp' body + typeInferComplete $ f x tp' body -- | In order to create a recursive function in a @SpecDef@, we need its @@ -594,15 +624,21 @@ data SpecTermState = specStExtraRecsRev :: [SpecRecFun], specStImportsRev :: [OpenTerm] } +-- | Return the local corecursive functions in a 'SpecTermState' in the correct +-- order, by reversing the reversed 'specStExtraRecsRev' list specStExtraRecs :: SpecTermState -> [SpecRecFun] specStExtraRecs st = reverse $ specStExtraRecsRev st +-- | Return the spec imports in a 'SpecTermState' in the correct order, by +-- reversing the reversed 'specStImportsRev' list specStImports :: SpecTermState -> [OpenTerm] specStImports st = reverse (specStImportsRev st) +-- | Increment the context length of a 'SpecTermState' specStIncCtx :: SpecTermState -> SpecTermState specStIncCtx st = st { specStCtxLen = specStCtxLen st + 1 } +-- | Decrement the context length of a 'SpecTermState' specStDecCtx :: SpecTermState -> SpecTermState specStDecCtx st = st { specStCtxLen = specStCtxLen st - 1 } @@ -611,21 +647,25 @@ specStInsTempClos lrt st = (specStNumBaseRecs st + fromIntegral (length $ specStExtraRecsRev st), st { specStExtraRecsRev = tempSpecRecFun lrt : specStExtraRecsRev st }) -modifyNth :: Int -> (a -> a) -> [a] -> [a] -modifyNth i _ xs | i >= length xs || i < 0 = error "modifyNthNat" -modifyNth i f xs = take i xs ++ (f (xs!!i)) : drop (i+1) xs - --- | Modify the nth element from the end of a list -modifyNthRev :: Int -> (a -> a) -> [a] -> [a] -modifyNthRev i f xs = modifyNth (length xs - i) f xs +setNthClosBody :: Int -> SpecInfoTerm -> [SpecRecFun] -> [SpecRecFun] +setNthClosBody i _ recFuns + | i >= length recFuns || i < 0 = + panic "setNthClosBody" ["Index out of range"] +setNthClosBody i body recFuns = + let new_recFun = case recFuns!!i of + SpecRecFun lrt Nothing -> SpecRecFun lrt (Just body) + SpecRecFun _ (Just _) -> + panic "setNthClosBody" ["Closure body already set"] in + take i recFuns ++ new_recFun : drop (i+1) recFuns + +setNthClosBodyRev :: Int -> SpecInfoTerm -> [SpecRecFun] -> [SpecRecFun] +setNthClosBodyRev i body recFuns = + setNthClosBody (length recFuns - i) body recFuns specStSetClosBody :: Natural -> SpecInfoTerm -> SpecTermState -> SpecTermState specStSetClosBody clos_ix body st = st { specStExtraRecsRev = - modifyNthRev (fromIntegral clos_ix) - (\case (SpecRecFun lrt Nothing) -> SpecRecFun lrt (Just body) - _ -> panic "specStSetClosBody" ["Closure body already set"]) - (specStExtraRecsRev st) } + setNthClosBodyRev (fromIntegral clos_ix) body (specStExtraRecsRev st) } specStInsImport :: OpenTerm -> SpecTermState -> (Natural, SpecTermState) specStInsImport def st = @@ -694,7 +734,14 @@ lambdaSpecTerm :: LocalName -> SpecTerm -> (SpecTerm -> SpecTerm) -> SpecTerm lambdaSpecTerm x (SpecTerm tpM) body_f = SpecTerm $ do tp <- tpM body <- withVarSpecTermM (topVarSpecTerm >>= (unSpecTerm . body_f)) - return $ lambdaSpecInfoTerm x tp body + return $ bindSpecInfoTerm Lambda x tp body + +-- | Build a pi abstraction as a 'SpecTerm' +piSpecTerm :: LocalName -> SpecTerm -> (SpecTerm -> SpecTerm) -> SpecTerm +piSpecTerm x (SpecTerm tpM) body_f = SpecTerm $ + do tp <- tpM + body <- withVarSpecTermM (topVarSpecTerm >>= (unSpecTerm . body_f)) + return $ bindSpecInfoTerm Pi x tp body funStackTypeOpenTerm :: OpenTerm funStackTypeOpenTerm = globalOpenTerm "Prelude.FunStack" From 92e5a2d9e9fbf5f432b5b1cf088cd15c9c64464a Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 19 Jul 2023 21:34:02 -0700 Subject: [PATCH 016/305] making progress on updating SAWTranslation.hs... --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 1139 +++++++++++------ saw-core/prelude/Prelude.sawcore | 26 + saw-core/src/Verifier/SAW/OpenTerm.hs | 157 ++- 3 files changed, 934 insertions(+), 388 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 7369ccecc6..562a9705ca 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -97,60 +97,88 @@ listSortOpenTerm = ---------------------------------------------------------------------- --- * Translation Monads +-- * Type Translations ---------------------------------------------------------------------- -- | Call 'prettyCallStack' and insert a newline in front nlPrettyCallStack :: CallStack -> String nlPrettyCallStack = ("\n" ++) . prettyCallStack --- | The result of translating a type-like construct such as a 'TypeRepr' or a --- permission, parameterized by the (Haskell) type of the translations of the --- elements of that type. This are translated to 0 or more SAW types, along with --- a (Haskell) function for mapping elements of those types their translation --- construct in Haskell. -data TypeTrans tr = TypeTrans - { typeTransTypes :: [OpenTerm], - typeTransFun :: [OpenTerm] -> tr } - --- | Apply the 'typeTransFun' of a 'TypeTrans' with the call stack -typeTransF :: HasCallStack => TypeTrans tr -> [OpenTerm] -> tr -typeTransF (TypeTrans tps f) ts | length tps == length ts = f ts -typeTransF (TypeTrans tps _) ts = - error ("Type translation expected " ++ show (length tps) ++ - " arguments, but got " ++ show (length ts)) - -instance Functor TypeTrans where - fmap f (TypeTrans ts tp_f) = TypeTrans ts (f . tp_f) - -instance Applicative TypeTrans where - pure = mkTypeTrans0 - liftA2 f (TypeTrans tps1 f1) (TypeTrans tps2 f2) = - TypeTrans (tps1 ++ tps2) - (\ts -> f (f1 $ take (length tps1) ts) (f2 $ drop (length tps1) ts)) - --- | Build a 'TypeTrans' represented by 0 SAW types -mkTypeTrans0 :: tr -> TypeTrans tr -mkTypeTrans0 tr = TypeTrans [] $ \case - [] -> tr - _ -> error "mkTypeTrans0: incorrect number of terms" - --- | Build a 'TypeTrans' represented by 1 SAW type -mkTypeTrans1 :: OpenTerm -> (OpenTerm -> tr) -> TypeTrans tr -mkTypeTrans1 tp f = TypeTrans [tp] $ \case - [t] -> f t - _ -> error "mkTypeTrans1: incorrect number of terms" - --- | Build a 'TypeTrans' for an 'OpenTerm' of a given type -openTermTypeTrans :: OpenTerm -> TypeTrans OpenTerm -openTermTypeTrans tp = mkTypeTrans1 tp id - --- | 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) +-- | A description of a type as either a "pure" type containg no corecursive +-- closure types (i.e., no @LRTClos@ types) or as an 'OpenTerm' of type +-- @LetRecType@ along with the SAW core type it decodes to as a 'SpecTerm' +data TypeDesc + = TypeDescPure OpenTerm + | TypeDescLRT OpenTerm SpecTerm + +-- | Get the type described by a 'TypeDesc' +typeDescType :: TypeDesc -> SpecTerm +typeDescType (TypeDescPure tp) = openTermSpecTerm tp +typeDescType (TypeDescLRT _ tp) = tp + +-- | Get the @LetRecType@ that encodes the type of a 'TypeDesc' +typeDescLRT :: TypeDesc -> OpenTerm +typeDescLRT (TypeDescPure tp) = ctorOpenTerm "Prelude.LRT_Type" [tp] +typeDescLRT (TypeDescLRT lrt _) = lrt + +-- | Return the pair of the type and @LetRecType@ of a 'TypeDesc' +typeDescTypeLRT :: TypeDesc -> (OpenTerm,SpecTerm) +typeDescTypeLRT d = (typeDescType d, typeDescLRT d) + +-- | If all the type descriptions in a list are pure, return their pure types as +-- a list; otherwise, convert them all to impure LRT types +typeDescsPureOrLRT :: [TypeDesc] -> Either [OpenTerm] [(OpenTerm,SpecTerm)] +typeDescsPureOrLRT = + foldr (\d descs -> case d of + TypeDescPure tp | Left tps <- descs -> Left (tp:tps) + _ | Right lrt_tps <- descs -> Right (typeDescTypeLRT d : lrt_tps) + _ -> Right $ map typeDescTypeLRT (d:descs)) (Left []) + +-- | Apply a binary type-forming operation to two type descriptions, using the +-- 'OpenTerm' function if the type descriptions are both pure and otherwise +-- using the supplied 'Ident' to combine @LetRecType@s and the 'SpecTerm' +-- function to combine impure types +typeDescBinOp :: (OpenTerm -> OpenTerm -> OpenTerm) -> Ident -> + (SpecTerm -> SpecTerm -> SpecTerm) -> + TypeDesc -> TypeDesc -> TypeDesc +typeDescBinOp f _ _ (TypeDescPure tp_l) (TypeDescPure tp_r) = + TypeDescPure $ f tp_l tp_r +typeDescBinOp _ lrt_op f d_l d_r = + TypeDescLRT + (applyGlobalOpenTerm lrt_op [typeDescLRT d_l, typeDescLRT d_r]) + (f (typeDescType d_l) (typeDescType d_r)) + +-- | Build a type description for the type @BVVec w len a@ +bvVecTypeDesc :: OpenTerm -> OpenTerm -> TypeDesc -> TypeDesc +bvVecTypeDesc w_term len_term (TypeDescPure elem_tp) = + TypeDescPure (applyGlobalOpenTerm "Prelude.BVVec" + [w_term, len_term, elem_tp]) +bvVecTypeDesc w_term len_term (TypeDescImpure lrt elem_tpx) = + TypeDescLRT + (applyGlobalOpenTerm "Prelude.LRT_BVVec" [w_term, len_term, lrt]) + (applyGlobalOpenTerm "Prelude.BVVec" [w_term, len_term, elem_tp]) + +-- | Build a type description for the pair of two type descriptions +typeDescPair :: TypeDesc -> TypeDesc -> TypeDesc +typeDescPair = + typeDescBinOp pairTypeOpenTerm "Prelude.LRT_Pair" pairTypeSpecTerm + +-- | Build a type description for the @Either@ of two type descriptions +typeDescEither :: TypeDesc -> TypeDesc -> TypeDesc +typeDescEither = + typeDescBinOp + (\tp1 tp2 -> dataTypeOpenTerm "Prelude.Either" [tp1,tp2]) + "Prelude.LRT_Either" + (\tp1 tp2 -> dataTypeSpecTerm "Prelude.Either" [tp1,tp2]) + +-- | Build a type description for a @Sigma@ type as an impure 'TypeDesc' +typeDescSigma :: String -> OpenTerm -> (OpenTerm -> TypeDesc) -> TypeDesc +typeDescSigma x tp_l tp_r_f = + TypeDescLRT + (ctorOpenTerm "Prelude.LRT_Sigma" + [tp_l, lambdaOpenTerm x tp_l (typeDescLRT . tp_r_f)]) + (dataTypeSpecTerm "Prelude.Sigma" + [openTermSpecTerm tp_l, lambdaSpecTerm x tp_l (typeDescType . tp_r_f)]) -- | 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 @@ -161,42 +189,170 @@ tupleOfTypes [] = unitTypeOpenTerm tupleOfTypes [tp] = tp tupleOfTypes (tp:tps) = pairTypeOpenTerm tp $ tupleOfTypes tps +-- | Like 'tupleOfTypes' but applied to type descriptions +tupleOfTypeDescs :: [TypeDesc] -> TypeDesc +tupleOfTypeDescs [] = unitTypeOpenTerm +tupleOfTypeDescs [tp] = tp +tupleOfTypeDescs (TypeDescPure tp_l : ds) + | TypeDescPure tp_r <- tupleOfTypeDescs ds = pairTypeOpenTerm tp_l tp_r +tupleOfTypeDescs (d : ds) = + let d_r = tupleOfTypeDescs ds in + TypeDescLRT + (applyGlobalOpenTerm "Prelude.LRT_Pair" [typeDescLRT d, typeDescLRT d_r]) + (pairTypeSpecTerm (typeDescType d) (typeDescType d_r)) + -- | 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 :: [SpecTerm] -> SpecTerm +tupleOfTerms [] = unitSpecTerm tupleOfTerms [t] = t -tupleOfTerms (t:ts) = pairOpenTerm t $ tupleOfTerms ts +tupleOfTerms (t:ts) = pairSpecTerm 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 [] _ _ = + panic "projTupleOfTypes" ["projection of empty tuple!"] projTupleOfTypes [_] 0 tup = tup projTupleOfTypes (_:_) 0 tup = pairLeftOpenTerm tup projTupleOfTypes (_:tps) i tup = projTupleOfTypes tps (i-1) $ pairRightOpenTerm tup +-- | Impure version of 'projTupleOfTypes' +projTupleOfTypesI :: [SpecTerm] -> Integer -> SpecTerm -> SpecTerm +projTupleOfTypesI [] _ _ = + panic "projTupleOfTypesI" ["projection of empty tuple!"] +projTupleOfTypesI [_] 0 tup = tup +projTupleOfTypesI (_:_) 0 tup = pairLeftSpecTerm tup +projTupleOfTypesI (_:tps) i tup = + projTupleOfTypesI tps (i-1) $ pairRightSpecTerm tup + +-- | The result of translating a type-like construct such as a 'TypeRepr' or a +-- permission, parameterized by the (Haskell) type of the translations of the +-- elements of that type. This are translated to 0 or more type descriptions, +-- along with a (Haskell) function for mapping elements of the types they +-- describe to the corresponding translation construct in Haskell. Type +-- translations can either be pure, meaning they do not depend on the event type +-- and function stack of the current @SpecM@ computation and so are represented +-- with 'OpenTerm's, or impure, meaning they can depend on these objects and so +-- are represented with 'SpecTerm's. The @p@ type parameter is 'True' for pure +-- type translations and 'False' for impure ones. +data TypeTrans p tr where + TypeTransPure :: [OpenTerm] -> ([OpenTerm] -> tr) -> TypeTrans 'True tr + TypeTransImpure :: [TypeDesc] -> ([SpecTerm] -> tr) -> TypeTrans 'False tr + +-- | A pure 'TypeTrans' +type PureTypeTrans = TypeTrans 'True + +-- | An impure 'TypeTrans' +type ImpTypeTrans = TypeTrans 'False + +-- | A term that is either pure, meaning it does not depend on the event type +-- and function stack of the current @SpecM@ computation and so is represented +-- as an 'OpenTerm', or impure, meaning they it depend on these objects and so +-- is represented as a 'SpecTerm' +type family PurityTerm p where + PurityTerm 'True = OpenTerm + PurityTerm 'False = SpecTerm + +-- | Get the types in a 'TypeTrans' +typeTransTypes :: TypeTrans p tr -> [PurityTerm p] +typeTransTypes (TypeTransPure tps _) = tps +typeTransTypes (TypeTransImpure ds _) = map typeDescType ds + +-- | Get the type descriptions of the types in a 'TypeTrans' +typeTransDescs :: TypeTrans p tr -> [TypeDesc] +typeTransDescs (TypeTransPure tps _) = map TypeDescPure tps +typeTransDescs (TypeTransImpure ds _) = ds + +-- | Apply the function of a 'TypeTrans' +typeTransF :: HasCallStack => TypeTrans p tr -> [PurityTerm p] -> tr +typeTransF (TypeTransPure tps f) ts | length tps == length ts = f ts +typeTransF (TypeTransImpure tps f) ts | length tps == length ts = f ts +typeTransF tp_trans ts = + error ("Type translation expected " + ++ show (length $ typeTransTypes tp_trans) ++ + " arguments, but got " ++ show (length ts)) + +instance Functor (TypeTrans p) where + fmap f (TypeTransPure ts tp_f) = TypeTransPure ts (f . tp_f) + fmap f (TypeTransImpure ts tp_f) = TypeTransImpure ts (f . tp_f) + +instance Applicative (TypeTrans 'True) where + pure = mkPureTypeTrans0 + liftA2 f (TypeTransPure tps1 f1) (TypeTransPure tps2 f2) = + TypeTransPure (tps1 ++ tps2) + (\ts -> f (f1 $ take (length tps1) ts) (f2 $ drop (length tps1) ts)) + +instance Applicative (TypeTrans 'False) where + pure = mkImpTypeTrans0 + liftA2 f (TypeTransImpure tps1 f1) (TypeTransImpure tps2 f2) = + TypeTransImpure (tps1 ++ tps2) + (\ts -> f (f1 $ take (length tps1) ts) (f2 $ drop (length tps1) ts)) + +-- | Build a pure 'TypeTrans' represented by 0 SAW types +mkPureTypeTrans0 :: tr -> TypeTrans 'True tr +mkPureTypeTrans0 tr = TypeTransPure [] $ \case + [] -> tr + _ -> panic "mkPureTypeTrans0" ["incorrect number of terms"] + +-- | Build an impure 'TypeTrans' represented by 0 SAW types +mkImpTypeTrans0 :: tr -> TypeTrans 'False tr +mkImpTypeTrans0 tr = TypeTransImpure [] $ \case + [] -> tr + _ -> panic "mkImpTypeTrans0" ["incorrect number of terms"] + +-- | Build a 'TypeTrans' represented by a "pure" (see 'TypeDesc') SAW type +mkPureTypeTrans1 :: OpenTerm -> (OpenTerm -> tr) -> TypeTrans 'True tr +mkPureTypeTrans1 tp f = TypeTransPure [TypeDescPure tp] $ \case + [t] -> f t + _ -> panic "mkPureTypeTrans1" ["incorrect number of terms"] + +-- | Build a 'TypeTrans' represented by a SAW type with the given description +mkImpTypeTrans1 :: TypeDesc -> (SpecTerm -> tr) -> TypeTrans 'False tr +mkImpTypeTrans1 d f = TypeTransImpure [d] $ \case + [t] -> f t + _ -> panic "mkImpTypeTrans1" ["incorrect number of terms"] + +-- | 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 p tr -> PurityTerm p +typeTransType1 (TypeTransPure [] _) = unitTypeOpenTerm +typeTransType1 (TypeTransImpure [] _) = unitTypeSpecTerm +typeTransType1 (TypeTransPure [tp] _) = tp +typeTransType1 (TypeTransImpure [tp] _) = tp +typeTransType1 _ = + panic "typeTransType1" ["More than one type when at most one 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 :: TypeTrans p tr -> PurityTerm p +typeTransTupleType (TypeTransPure tps _) = tupleOfTypes tps +typeTransTupleType (TypeTransImpure tps _) = + typeDescType $ tupleOfTypeDescs tps -- | Convert a 'TypeTrans' over 0 or more types to one over the one type --- returned by 'tupleOfTypes' -tupleTypeTrans :: TypeTrans tr -> TypeTrans tr -tupleTypeTrans ttrans = - let tps = typeTransTypes ttrans in - TypeTrans [tupleOfTypes tps] +-- returned by 'typeTransTupleType' +tupleTypeTrans :: TypeTrans p tr -> TypeTrans p tr +tupleTypeTrans (TypeTransPure tps f) = + TypeTransPure [tupleOfTypes tps] + (\case + [t] -> + f $ map (\i -> projTupleOfTypes tps i t) $ + take (length $ typeTransTypes ttrans) [0..] + _ -> panic "tupleTypeTrans" ["incorrect number of terms"]) +tupleTypeTrans (TypeTransImpure tps f) = + TypeTransLRT [tupleOfTypeDescs tps] (\case [t] -> - typeTransF ttrans $ map (\i -> projTupleOfTypes tps i t) $ + f $ map (\i -> projTupleOfTypesI tps i t) $ take (length $ typeTransTypes ttrans) [0..] - _ -> error "tupleTypeTrans: incorrect number of terms") + _ -> panic "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. @@ -208,13 +364,18 @@ strictTupleTypeTrans ttrans = typeTransF ttrans $ map (\i -> projTupleOpenTerm i t) $ take (length $ typeTransTypes ttrans) [0..] _ -> error "strictTupleTypeTrans: incorrect number of terms") +-} -- | Build a type translation for a list of translations -listTypeTrans :: [TypeTrans tr] -> TypeTrans [tr] +listTypeTrans :: [TypeTrans 'False tr] -> TypeTrans 'False [tr] listTypeTrans [] = pure [] listTypeTrans (trans:transs) = liftA2 (:) trans $ listTypeTrans transs +---------------------------------------------------------------------- +-- * Translation Monads +---------------------------------------------------------------------- + -- | The result of translating a 'PermExpr' at 'CrucibleType' @a@. This is a -- form of partially static data in the sense of partial evaluation. data ExprTrans (a :: CrucibleType) where @@ -247,6 +408,12 @@ 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 a type description + ETrans_Shape :: TypeDesc -> ExprTrans (LLVMShapeType w) + + -- | The translation of a permission is a type description + ETrans_Perm :: TypeDesc -> 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 @@ -254,20 +421,31 @@ data ExprTrans (a :: CrucibleType) where -- | A context mapping bound names to their type-level SAW translations type ExprTransCtx = RAssign ExprTrans +-- | A 'TypeTrans' that is relative to an expression context +type RelTypeTrans ectx tp = ExprTransCtx ectx -> TypeTrans tp + -- | Describes a Haskell type that represents the translation of a term-like -- construct that corresponds to 0 or more SAW terms class IsTermTrans tr where - transTerms :: HasCallStack => tr -> [OpenTerm] + transTerms :: HasCallStack => tr -> [SpecTerm] + +-- | Describes a Haskell type that represents the translation of a term-like +-- construct that corresponds to 0 or more SAW terms that are "pure", meaning +-- they are 'OpenTerm's instead of 'SpecTerm's, i.e., they do not depend on the +-- function stack or event type +class IsPureTrans tr where + transPureTerms :: HasCallStack => tr -> [OpenTerm] -- | Build a tuple of the terms contained in a translation, with 0 terms mapping -- to the unit term and one term mapping to itself. If @ttrans@ is a 'TypeTrans' -- describing the SAW types associated with a @tr@ translation, then this -- function returns an element of the type @'tupleTypeTrans' ttrans@. -transTupleTerm :: IsTermTrans tr => tr -> OpenTerm +transTupleTerm :: IsTermTrans tr => tr -> SpecTerm transTupleTerm (transTerms -> [t]) = t transTupleTerm tr = tupleOfTerms $ transTerms tr +{- -- | 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 @@ -275,40 +453,49 @@ transTupleTerm tr = tupleOfTerms $ transTerms tr -- the type @'strictTupleTypeTrans' ttrans@. strictTransTupleTerm :: IsTermTrans tr => tr -> OpenTerm strictTransTupleTerm tr = tupleOpenTerm $ transTerms tr +-} -- | Like 'transTupleTerm' but raise an error if there are more than 1 terms -transTerm1 :: HasCallStack => IsTermTrans tr => tr -> OpenTerm -transTerm1 (transTerms -> []) = unitOpenTerm +transTerm1 :: HasCallStack => IsTermTrans tr => tr -> SpecTerm +transTerm1 (transTerms -> []) = unitSpecTerm transTerm1 (transTerms -> [t]) = t -transTerm1 _ = error ("transTerm1" ++ nlPrettyCallStack callStack) - +transTerm1 tr = panic "transTerm1" ["Expected at most one term, but found " + ++ length (transTerms tr)] instance IsTermTrans tr => IsTermTrans [tr] where transTerms = concatMap transTerms +instance IsPureTrans tr => IsPureTrans [tr] where + transPureTerms = concatMap transPureTerms + instance IsTermTrans (TypeTrans tr) where transTerms = typeTransTypes +instance IsPureTrans (ExprTrans tp) where + transPureTerms ETrans_LLVM = [] + transPureTerms ETrans_LLVMBlock = [] + transPureTerms ETrans_LLVMFrame = [] + transPureTerms ETrans_Lifetime = [] + transPureTerms ETrans_RWModality = [] + transPureTerms (ETrans_Struct etranss) = + concat $ RL.mapToList transPureTerms etranss + transPureTerms ETrans_Fun = [] + transPureTerms ETrans_Unit = [] + transPureTerms ETrans_AnyVector = [] + transPureTerms (ETrans_Term t) = [t] + instance IsTermTrans (ExprTrans tp) where - transTerms ETrans_LLVM = [] - transTerms ETrans_LLVMBlock = [] - transTerms ETrans_LLVMFrame = [] - transTerms ETrans_Lifetime = [] - transTerms ETrans_RWModality = [] - transTerms (ETrans_Struct etranss) = - concat $ RL.mapToList transTerms etranss - transTerms ETrans_Fun = [] - transTerms ETrans_Unit = [] - transTerms ETrans_AnyVector = [] - transTerms (ETrans_Term t) = [t] + transTerms = map openTermSpecTerm . transPureTerms -instance IsTermTrans (ExprTransCtx ctx) where - transTerms MNil = [] - transTerms (ctx :>: etrans) = transTerms ctx ++ transTerms etrans +instance IsPureTrans (ExprTransCtx ctx) where + transPureTerms MNil = [] + transPureTerms (ctx :>: etrans) = transPureTerms ctx ++ transPureTerms etrans +instance IsTermTrans (ExprTransCtx ctx) where + transTerms = map openTermSpecTerm . transPureTerms --- | Map a context of expression translations to a list of 'OpenTerm's -exprCtxToTerms :: ExprTransCtx tps -> [OpenTerm] +-- | Map a context of expression translations to a list of 'SpecTerm's +exprCtxToTerms :: ExprTransCtx tps -> [SpecTerm] exprCtxToTerms = concat . RL.mapToList transTerms @@ -356,11 +543,13 @@ inExtMultiTransM (ctx :>: etrans) m = -- | Run a translation computation in an extended context, where we sawLet-bind any -- term in the supplied expression translation -inExtTransSAWLetBindM :: TransInfo info => TypeTrans (ExprTrans tp) -> OpenTerm -> - ExprTrans tp -> TransM info (ctx :> tp) OpenTerm -> - TransM info ctx OpenTerm +inExtTransSAWLetBindM :: TransInfo info => TypeTrans 'True (ExprTrans tp) -> + SpecTerm -> ExprTrans tp -> + TransM info (ctx :> tp) SpecTerm -> + TransM info ctx SpecTerm inExtTransSAWLetBindM tp_trans tp_ret etrans m = - sawLetTransMultiM "z" (typeTransTypes tp_trans) tp_ret (transTerms etrans) $ + sawLetTransMultiM "z" (map openTermSpecTerm $ + 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 @@ -386,17 +575,29 @@ nuMultiTransM f = do info <- ask return $ nuMulti (RL.map (\_ -> Proxy) (infoCtx info)) f --- | Apply the result of a translation to that of another -applyTransM :: TransM info ctx OpenTerm -> TransM info ctx OpenTerm -> - TransM info ctx OpenTerm -applyTransM m1 m2 = applyOpenTerm <$> m1 <*> m2 +-- | Apply the result of a pure translation to that of another +applyPureTransM :: TransM info ctx OpenTerm -> TransM info ctx OpenTerm -> + TransM info ctx OpenTerm +applyPureTransM m1 m2 = applyOpenTerm <$> m1 <*> m2 --- | Apply the result of a translation to the results of multiple translations -applyMultiTransM :: TransM info ctx OpenTerm -> [TransM info ctx OpenTerm] -> - TransM info ctx OpenTerm -applyMultiTransM m ms = foldl applyTransM m ms +-- | Apply the result of an impure translation to that of another +applyImpTransM :: TransM info ctx SpecTerm -> TransM info ctx SpecTerm -> + TransM info ctx SpecTerm +applyImpTransM m1 m2 = applySpecTerm <$> m1 <*> m2 + +-- | Apply the result of a pure translation to that of multiple translations +applyMultiPureTransM :: TransM info ctx OpenTerm -> + [TransM info ctx OpenTerm] -> + TransM info ctx OpenTerm +applyMultiPureTransM m ms = foldl applyPureTransM m ms + +-- | Apply the result of an impure translation to that of multiple translations +applyMultiImpTransM :: TransM info ctx SpecTerm -> + [TransM info ctx SpecTerm] -> + TransM info ctx SpecTerm +applyMultiImpTransM m ms = foldl applyImpTransM m ms --- | Build a lambda-abstraction inside the 'TransM' monad +-- | Build a lambda-abstraction as an 'OpenTerm' inside the 'TransM' monad lambdaOpenTermTransM :: String -> OpenTerm -> (OpenTerm -> TransM info ctx OpenTerm) -> TransM info ctx OpenTerm @@ -404,17 +605,30 @@ lambdaOpenTermTransM x tp body_f = ask >>= \info -> return (lambdaOpenTerm (pack x) tp $ \t -> runTransM (body_f t) info) +-- | Build a lambda-abstraction as a 'SpecTerm' inside the 'TransM' monad +lambdaSpecTermTransM :: String -> SpecTerm -> + (SpecTerm -> TransM info ctx SpecTerm) -> + TransM info ctx SpecTerm +lambdaSpecTermTransM x tp body_f = + ask >>= \info -> + return (lambdaSpecTerm (pack x) tp $ \t -> runTransM (body_f t) info) + -- | 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 -lambdaTrans :: String -> TypeTrans tr -> (tr -> OpenTerm) -> OpenTerm -lambdaTrans x tps body_f = - lambdaOpenTermMulti - (zipWith (\i tp -> (pack (x ++ show (i :: Integer)), tp)) [0..] $ typeTransTypes tps) - (body_f . typeTransF tps) +-- over the types in a 'TypeTrans', using the 'String' as a variable name prefix +-- for the @xi@ variables +lambdaTrans :: String -> TypeTrans p tr -> (tr -> SpecTerm) -> SpecTerm +lambdaTrans x (TypeTransPure tps tr_f) body_f = + lambdaPureSpecTermMulti + (zipWith (\i tp -> (pack (x ++ show (i :: Integer)), tp)) [0..] $ + map openTermSpecTerm tps) + (body_f . tr_f) +lambdaTrans x (TypeTransImpure tps tr_f) body_f = + lambdaSpecTermMulti + (zipWith (\i tp -> (pack (x ++ show (i :: Integer)), tp)) [0..] tps) + (body_f . tr_f) -- | Build a nested lambda-abstraction -- @@ -422,13 +636,10 @@ lambdaTrans x tps body_f = -- -- over the types in a 'TypeTrans' inside a translation monad, using the -- 'String' as a variable name prefix for the @xi@ variables -lambdaTransM :: String -> TypeTrans tr -> (tr -> TransM info ctx OpenTerm) -> - TransM info ctx OpenTerm -lambdaTransM x 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 :: String -> TypeTrans p tr -> (tr -> TransM info ctx SpecTerm) -> + TransM info ctx SpecTerm +lambdaTransM x tp body_f = + ask >>= \info -> return (lambdaTrans x tp (flip runTransM info . body_f)) -- | Build a lambda-abstraction -- @@ -436,11 +647,43 @@ lambdaTransM x tps body_f = -- -- over a tuple of the types in a 'TypeTrans'. Note that this always builds -- exactly one lambda-abstraction, even if there are 0 types. -lambdaTupleTransM :: String -> TypeTrans tr -> (tr -> TransM info ctx OpenTerm) -> - TransM info ctx OpenTerm +lambdaTupleTransM :: String -> TypeTrans p tr -> (tr -> TransM info ctx SpecTerm) -> + TransM info ctx SpecTerm lambdaTupleTransM x ttrans body_f = lambdaTransM x (tupleTypeTrans ttrans) body_f +-- | Construct a @LetRecType@ inductive description +-- +-- > LRT_FunDep tp1 \(x1 : tp1) -> ... -> LRT_FunDep tpn \(xn : tpn) -> +-- > body x1 ... xn +-- +-- of a pi abstraction over the types @tpi@ in a pure 'TypeTrans', passing the +-- abstracted variables to the supplied @body@ function, which should itself +-- return a @LetRecType@ +piLRTTransM :: String -> TypeTrans 'True 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_FunDep" [tp, t]) <$> + lambdaOpenTermTransM (x ++ show (i :: Integer)) tp + (\var -> rest_f (vars ++ [var]))) + (body_f . typeTransF tps) (zip [0..] $ typeTransTypes tps) [] + +-- | Construct a @LetRecType@ inductive description +-- +-- > LRT_FunClos lrt1 (LRT_FunClos lrt2 (... body ...)) +-- +-- of monadic arrow types over the @LetRecType@ type descriptions @lrti@ in a +-- 'TypeTrans' +arrowLRTTransM :: String -> TypeTrans 'False tr -> + TransM info ctx OpenTerm -> TransM info ctx OpenTerm +arrowLRTTransM x tps body_top = + foldr (\(i,d) body -> + ctorOpenTerm "Prelude.LRT_FunClos" [typeDescLRT d, body]) + body_top (zip [0..] $ typeTransDescs tps) [] + +-- FIXME: should only need to build pi-abstractions as LetRecTypes... right? +{- -- | Build a pi-abstraction over the types in a 'TypeTrans' inside a -- translation monad, using the 'String' as a variable name prefix piTransM :: String -> TypeTrans tr -> (tr -> TransM info ctx OpenTerm) -> @@ -458,20 +701,21 @@ 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 -> - (OpenTerm -> TransM info ctx OpenTerm) -> - TransM info ctx OpenTerm +letTransM :: String -> SpecTerm -> TransM info ctx SpecTerm -> + (SpecTerm -> TransM info ctx SpecTerm) -> + TransM info ctx SpecTerm 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) + letSpecTerm (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 :: String -> SpecTerm -> SpecTerm -> TransM info ctx SpecTerm -> + (SpecTerm -> TransM info ctx SpecTerm) -> + TransM info ctx SpecTerm sawLetTransM x tp tp_ret rhs_m body_m = do r <- ask return $ @@ -480,9 +724,9 @@ sawLetTransM x tp tp_ret rhs_m body_m = -- | 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 :: String -> [SpecTerm] -> SpecTerm -> [SpecTerm] -> + ([SpecTerm] -> TransM info ctx SpecTerm) -> + TransM info ctx SpecTerm sawLetTransMultiM _ [] _ [] f = f [] sawLetTransMultiM x (tp:tps) ret_tp (rhs:rhss) f = sawLetTransM x tp ret_tp (return rhs) $ \var_tm -> @@ -493,41 +737,41 @@ sawLetTransMultiM _ _ _ _ _ = -- | Build a bitvector type in a translation monad bitvectorTransM :: TransM info ctx OpenTerm -> TransM info ctx OpenTerm bitvectorTransM m = - applyMultiTransM (return $ globalOpenTerm "Prelude.Vec") + applyPureMultiTransM (return $ globalOpenTerm "Prelude.Vec") [m, return $ globalOpenTerm "Prelude.Bool"] -- | Build an @Either@ type in SAW from the 'typeTransTupleType's of the left -- and right types -eitherTypeTrans :: TypeTrans trL -> TypeTrans trR -> OpenTerm +eitherTypeTrans :: ImpTypeTrans trL -> ImpTypeTrans trR -> TypeDesc eitherTypeTrans tp_l tp_r = - dataTypeOpenTerm "Prelude.Either" - [typeTransTupleType tp_l, typeTransTupleType tp_r] + typeDescEither (tupleOfTypeDescs $ typeTransDescs tp_l) (tupleOfTypeDescs $ + typeTransDescs 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 :: IsTermTrans trL => ImpTypeTrans trL -> ImpTypeTrans trR -> trL -> + SpecTerm leftTrans tp_l tp_r tr = - ctorOpenTerm "Prelude.Left" + ctorSpecTerm "Prelude.Left" [typeTransTupleType tp_l, typeTransTupleType tp_r, transTupleTerm tr] -- | 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 :: IsTermTrans trR => ImpTypeTrans trL -> ImpTypeTrans trR -> trR -> + SpecTerm rightTrans tp_l tp_r tr = - ctorOpenTerm "Prelude.Right" + ctorSpecTerm "Prelude.Right" [typeTransTupleType tp_l, typeTransTupleType tp_r, transTupleTerm tr] -- | Eliminate a SAW @Either@ type -eitherElimTransM :: TypeTrans trL -> TypeTrans trR -> - TypeTrans tr -> (trL -> TransM info ctx OpenTerm) -> - (trR -> TransM info ctx OpenTerm) -> OpenTerm -> - TransM info ctx OpenTerm +eitherElimTransM :: ImpTypeTrans trL -> ImpTypeTrans trR -> + TypeTrans tr -> (trL -> TransM info ctx SpecTerm) -> + (trR -> TransM info ctx SpecTerm) -> SpecTerm -> + TransM info ctx SpecTerm 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 $ applySpecTermMulti (globalSpecTerm "Prelude.either") [ typeTransTupleType tp_l, typeTransTupleType tp_r, typeTransTupleType tp_ret, fl_trans, fr_trans, eith ] @@ -535,79 +779,91 @@ eitherElimTransM tp_l tp_r tp_ret fl fr eith = -- translations of the types in the @Eithers@ type; the translation of the -- output type; a list of functions for the branches of the @Eithers@ -- elimination; and the term of @Eithers@ type being eliminated -eithersElimTransM :: [TypeTrans tr_in] -> TypeTrans tr_out -> - [tr_in -> TransM info ctx OpenTerm] -> OpenTerm -> - TransM info ctx OpenTerm +eithersElimTransM :: [ImpTypeTrans tr_in] -> ImpTypeTrans tr_out -> + [tr_in -> TransM info ctx SpecTerm] -> SpecTerm -> + TransM info ctx SpecTerm eithersElimTransM tps tp_ret fs eith = foldr (\(tp,f) restM -> do f_trans <- lambdaTupleTransM "x_eith_elim" tp f rest <- restM - return (ctorOpenTerm "Prelude.FunsTo_Cons" + return (ctorSpecTerm "Prelude.FunsTo_Cons" [typeTransTupleType tp_ret, typeTransTupleType tp, f_trans, rest])) - (return $ ctorOpenTerm "Prelude.FunsTo_Nil" [typeTransTupleType tp_ret]) + (return $ ctorSpecTerm "Prelude.FunsTo_Nil" [typeTransTupleType tp_ret]) (zip tps fs) >>= \elims_trans -> - return (applyOpenTermMulti (globalOpenTerm "Prelude.eithers") + return (applyGlobalSpecTerm "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 -> - (trL -> TransM info ctx (TypeTrans trR)) -> - TransM info ctx OpenTerm -sigmaTypeTransM _ ttrans@(typeTransTypes -> []) tp_f = +-- is given by the type translation returned by the supplied monadic function. +-- The Boolean flag indicates whether this monadic function is expected to +-- return a pure type, in which case the returned dependent pair type is pure, +-- or not, in which case it isn't. It is an error if the Boolean flag is 'True' +-- but the monadic function returns an impure type description. +sigmaTypeTransM :: String -> PureTypeTrans trL -> Bool -> + (trL -> TransM info ctx (ImpTypeTrans trR)) -> + TransM info ctx TypeDesc +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]) +sigmaTypeTransM x ttrans True tp_f = + do tp_f_trm <- lambdaTupleTransM x ttrans $ \tr -> tp_f tr >>= \case + TypeDescPure tp_r -> tp_r + TypeDescLRT _ _ -> + panic "sigmaTypeTransM" + ["Expected a pure type description but got an impure one"] + return $ TypeDescPure $ + dataTypeOpenTerm "Prelude.Sigma" [typeTransTupleType ttrans, tp_f_trm] +sigmaTypeTransM x ttrans False tp_f = + do info <- ask + return $ typeDescSigma x (typeTransTupleType ttrans) $ \e_tup -> + tupleOfTypeDescs $ typeTransDescs $ + runTransM (tp_f $ typeTransF (tupleTypeTrans ttrans) [e_tup]) info -- | Like `sigmaTypeTransM`, but translates `exists x.eq(y)` into just `x` -sigmaTypePermTransM :: TransInfo info => String -> TypeTrans (ExprTrans trL) -> +sigmaTypePermTransM :: TransInfo info => String -> + PureTypeTrans (ExprTrans trL) -> Mb (ctx :> trL) (ValuePerm trR) -> - TransM info ctx OpenTerm -sigmaTypePermTransM x ttrans p_cbn = case mbMatch p_cbn of - [nuMP| ValPerm_Eq _ |] -> return $ typeTransTupleType ttrans - _ -> sigmaTypeTransM x ttrans (flip inExtTransM $ translate p_cbn) + TransM info ctx TypeDesc +sigmaTypePermTransM x ttrans mb_p = case mbMatch mb_p of + [nuMP| ValPerm_Eq _ |] -> return $ TypeDescPure $ typeTransTupleType ttrans + _ -> sigmaTypeTransM x ttrans (isPurePerm mb_p) (flip inExtTransM $ + translate mb_p) -- | 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 -> - (trL -> TransM info ctx (TypeTrans trR1)) -> +sigmaTransM :: (IsTermTrans trL, IsTermTrans trR2) => + String -> PureTypeTrans trL -> + (trL -> TransM info ctx (ImpTypeTrans trR1)) -> trL -> TransM info ctx trR2 -> - TransM info ctx OpenTerm + TransM info ctx SpecTerm 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" + return (ctorSpecTerm "Prelude.exists" [typeTransTupleType tp_l, tp_r_trm, transTupleTerm lhs, rhs]) -- | Like `sigmaTransM`, but translates `exists x.eq(y)` into just `x` -sigmaPermTransM :: (TransInfo info, IsTermTrans trR2) => - String -> 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 - [nuMP| ValPerm_Eq _ |] -> return $ transTupleTerm etrans - _ -> sigmaTransM x ttrans (flip inExtTransM $ translate p_cbn) - etrans rhs_m +sigmaPermTransM :: TransInfo info => String -> TypeTrans (ExprTrans a) -> + Mb (ctx :> a) (ValuePerm b) -> ExprTrans a -> + TransM info ctx (PermTrans ctx b) -> + TransM info ctx SpecTerm +sigmaPermTransM x ttrans mb_p etrans rhs_m = case mbMatch mb_p of + [nuMP| ValPerm_Eq _ |] -> return $ openTermSpecTerm $ transTupleTerm etrans + _ -> 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 -> - (trL -> TransM info ctx (TypeTrans trR)) -> - TransM info ctx (TypeTrans trRet) -> - (trL -> trR -> TransM info ctx OpenTerm) -> - OpenTerm -> - TransM info ctx OpenTerm + String -> PureTypeTrans trL -> + (trL -> TransM info ctx (ImpTypeTrans trR)) -> + TransM info ctx (ImpTypeTrans trRet) -> + (trL -> trR -> TransM info ctx SpecTerm) -> + SpecTerm -> + TransM info ctx SpecTerm sigmaElimTransM _ tp_l@(typeTransTypes -> []) tp_r _ f sigma = do let proj1 = typeTransF tp_l [] proj2 <- flip (typeTransF . tupleTypeTrans) [sigma] <$> tp_r proj1 @@ -644,19 +900,27 @@ sigmaElimTransM x tp_l tp_r tp_ret_m f sigma = -- | Like `sigmaElimTransM`, but translates `exists x.eq(y)` into just `x` sigmaElimPermTransM :: (TransInfo info) => - String -> TypeTrans (ExprTrans trL) -> + String -> PureTypeTrans (ExprTrans trL) -> Mb (ctx :> trL) (ValuePerm trR) -> - TransM info ctx (TypeTrans trRet) -> + TransM info ctx (ImpTypeTrans trRet) -> (ExprTrans trL -> PermTrans (ctx :> trL) trR -> - TransM info ctx OpenTerm) -> - OpenTerm -> - TransM info ctx OpenTerm + TransM info ctx SpecTerm) -> + SpecTerm -> + TransM info ctx SpecTerm 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 +NOWNOW: +- change uses of TypeTrans to include the purity flag +- NOTE: PermExprs translate to pure terms / OpenTerms +- eitherTypeTrans and sigmaTypeTrans should build TypeDescs +- compReturnTypeM should return a TypeDesc +- need a variant of piTransM that builds TypeDescs + + -- | Apply an 'OpenTerm' to the current event type @E@ and to a -- list of other arguments applyEventOpM :: TransInfo info => OpenTerm -> [OpenTerm] -> @@ -775,6 +1039,13 @@ type TypeTransM = TransM TypeTransInfo 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 = @@ -783,19 +1054,19 @@ 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 +-- | Return a pure type translation that uses a single term of the given type +returnType1 :: OpenTerm -> TransM info ctx (TypeTrans 'True (ExprTrans a)) +returnType1 tp = return $ mkPureTypeTrans1 tp ETrans_Term -- FIXME: explain this translation instance TransInfo info => - Translate info ctx (TypeRepr a) (TypeTrans (ExprTrans a)) where + Translate info ctx (TypeRepr a) (TypeTrans 'True (ExprTrans a)) where translate mb_tp = case mbMatch mb_tp of [nuMP| AnyRepr |] -> return $ error "Translate: Any" [nuMP| UnitRepr |] -> - return $ mkTypeTrans0 ETrans_Unit + return $ mkPureTypeTrans0 ETrans_Unit [nuMP| BoolRepr |] -> returnType1 $ globalOpenTerm "Prelude.Bool" [nuMP| NatRepr |] -> @@ -811,28 +1082,30 @@ instance TransInfo info => [nuMP| BVRepr w |] -> returnType1 =<< bitvectorTransM (translate w) [nuMP| VectorRepr AnyRepr |] -> - return $ mkTypeTrans0 ETrans_AnyVector + return $ mkPureTypeTrans0 ETrans_AnyVector -- Our special-purpose intrinsic types, whose translations do not have -- computational content [nuMP| LLVMPointerRepr _ |] -> - return $ mkTypeTrans0 ETrans_LLVM + return $ mkPureTypeTrans0 ETrans_LLVM [nuMP| LLVMBlockRepr _ |] -> - return $ mkTypeTrans0 ETrans_LLVMBlock + return $ mkPureTypeTrans0 ETrans_LLVMBlock [nuMP| LLVMFrameRepr _ |] -> - return $ mkTypeTrans0 ETrans_LLVMFrame + return $ mkPureTypeTrans0 ETrans_LLVMFrame [nuMP| LifetimeRepr |] -> - return $ mkTypeTrans0 ETrans_Lifetime + return $ mkPureTypeTrans0 ETrans_Lifetime [nuMP| PermListRepr |] -> returnType1 (sortOpenTerm $ mkSort 0) [nuMP| RWModalityRepr |] -> - return $ mkTypeTrans0 ETrans_RWModality + return $ mkPureTypeTrans0 ETrans_RWModality -- Permissions and LLVM shapes translate to types [nuMP| ValuePermRepr _ |] -> - returnType1 (sortOpenTerm $ mkSort 0) + return $ mkPureTypeTrans1 (dataTypeOpenTerm + "Prelude.LetRecType" []) ETrans_Perm [nuMP| LLVMShapeRepr _ |] -> - returnType1 (sortOpenTerm $ mkSort 0) + return $ mkPureTypeTrans1 (dataTypeOpenTerm + "Prelude.LetRecType" []) ETrans_Shape -- We can't handle any other special-purpose types [nuMP| IntrinsicRepr _ _ |] -> @@ -853,7 +1126,7 @@ instance TransInfo info => [nuMP| FunctionHandleRepr _ _ |] -> -- NOTE: function permissions translate to the SAW function, but the -- function handle itself has no SAW translation - return $ mkTypeTrans0 ETrans_Fun + return $ mkPureTypeTrans0 ETrans_Fun [nuMP| MaybeRepr _ |] -> return $ error "translate: MaybeRepr" [nuMP| VectorRepr _ |] -> @@ -877,7 +1150,7 @@ instance TransInfo info => 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| CruCtxNil |] -> return $ mkPureTypeTrans0 MNil [nuMP| CruCtxCons ctx tp |] -> liftA2 (:>:) <$> translate ctx <*> translate tp @@ -888,22 +1161,23 @@ lambdaExprCtx ctx m = translateClosed ctx >>= \tptrans -> lambdaTransM "e" tptrans (\ectx -> inCtxTransM ectx m) --- | Translate all types in a Crucible context and pi-abstract over them -piExprCtx :: TransInfo info => CruCtx ctx -> - TransM info ctx OpenTerm -> - TransM info RNil OpenTerm -piExprCtx ctx m = +-- | Translate all types in a Crucible context and pi-abstract over them, +-- building the resulting type as a @LetRecType@ +piLRTExprCtx :: TransInfo info => CruCtx ctx -> + TransM info ctx OpenTerm -> + TransM info RNil OpenTerm +piLRTExprCtx ctx m = translateClosed ctx >>= \tptrans -> - piTransM "e" tptrans (\ectx -> inCtxTransM ectx m) + piLRTTransM "e" tptrans (\ectx -> inCtxTransM ectx m) -- | Like 'piExprCtx' but append the newly bound variables to the current -- context, rather than running in the empty context -piExprCtxApp :: TransInfo info => CruCtx ctx2 -> - TransM info (ctx :++: ctx2) OpenTerm -> - TransM info ctx OpenTerm -piExprCtxApp ctx m = +piLRTExprCtxApp :: TransInfo info => CruCtx ctx2 -> + TransM info (ctx :++: ctx2) OpenTerm -> + TransM info ctx OpenTerm +piLRTExprCtxApp ctx m = translateClosed ctx >>= \tptrans -> - piTransM "e" tptrans (\ectx -> inExtMultiTransM ectx m) + piLRTTransM "e" tptrans (\ectx -> inExtMultiTransM ectx m) ---------------------------------------------------------------------- @@ -983,6 +1257,8 @@ instance TransInfo info => [nuMP| ns :>: n |] -> (:>:) <$> translate ns <*> translate n +NOWNOW: update the translation of shapes and perms to use ETrans_Shape and ETrans_Perm + instance TransInfo info => Translate info ctx (PermExpr a) (ExprTrans a) where translate mb_tr = case mbMatch mb_tr of @@ -1052,11 +1328,13 @@ instance TransInfo info => ((\t1 t2 -> dataTypeOpenTerm "Prelude.Either" [t1,t2]) <$> translate1 sh1 <*> translate1 sh2) [nuMP| PExpr_ExShape mb_sh |] -> + error "FIXME HERE NOWNOW" + {- 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]) + [typeTransTupleType tp_trans, tp_f_trm]) -} [nuMP| PExpr_FalseShape |] -> return $ ETrans_Term $ globalOpenTerm "Prelude.FalseProp" @@ -1181,11 +1459,16 @@ 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) -> + ExprTransCtx ctx -> PermTransCtx ctx ps_extra -> + RAssign (Member ctx) ps_extra -> + RelTypeTrans ctx (PermTransCtx ctx ps_in) -> + RelTypeTrans ctx (PermTransCtx ctx ps_out) -> + RelTypeTrans ctx (PermTransCtx ctx ps_extra) -> + LOwnedTransTerm 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 @@ -1220,7 +1503,7 @@ data AtomicPermTrans ctx a where -- | The translation of a proof of a 'BVProp' -data BVPropTrans ctx w = BVPropTrans (Mb ctx (BVProp w)) OpenTerm +data BVPropTrans ctx w = BVPropTrans (Mb ctx (BVProp w)) SpecTerm -- | Build the translation of a 'BVProp' permission from a proof of it bvPropPerm :: (1 <= w, KnownNat w) => BVPropTrans ctx w -> @@ -1247,13 +1530,14 @@ bvRangeTransLen (BVRangeTrans _ _ len) = len data LLVMArrayPermTrans ctx w = LLVMArrayPermTrans { llvmArrayTransPerm :: Mb ctx (LLVMArrayPerm w), llvmArrayTransLen :: OpenTerm, - llvmArrayTransHeadCell :: TypeTrans (AtomicPermTrans ctx (LLVMPointerType w)), + llvmArrayTransHeadCell :: + TypeTrans 'False (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 :: LLVMArrayPermTrans ctx w -> SpecTerm llvmArrayTransCellType = typeTransType1 . llvmArrayTransHeadCell @@ -1266,15 +1550,116 @@ data LLVMArrayBorrowTrans ctx w = llvmArrayBorrowTransProps :: [BVPropTrans ctx w] } -} +newtype PermTransInfo ps ctx = + PermTransInfo { ptransInfoECtx :: ExprTransCtx ctx, + ptransInfoPCtx :: PermTransCtx ctx ps, + ptransInfoVars :: RAssign (Member ctx) ps, + ptransInfoRetType :: SpecTerm } + +ptInfoSetPerms :: PermTransCtx ctx ps' -> RAssign (Member ctx) ps' -> + PermTransInfo ps ctx -> PermTransInfo ps' ctx +ptInfoSetPerms ps' vars' (PermTransInfo {..}) = + PermTransInfo { ptransInfoPCtx = ps', ptransInfoVars = vars', ..} + +ptInfoSplit :: RAssign any ps2 -> PermTransInfo (ps1 :++: ps2) ctx -> + (PermTransInfo ps1 ctx, PermTransInfo ps2 ctx) +ptInfoSplit = error "FIXME HERE NOWNOW" + +ptInfoAppend :: PermTransInfo ps1 ctx -> PermTransInfo ps2 ctx -> + PermTransInfo (ps1 :++: ps2) ctx +ptInfoAppend = error "FIXME HERE NOWNOW" + +type PermTransM ps ctx = TransM (PermTransInfo ps) + +newtype LOwnedTransTerm ctx ps_extra ps_in ps_out = + LOwnedTransTerm { + unLOwnedTransTerm :: + forall ctx'. ExprTransCtx ctx' -> + PermTransM ps_out (ctx :++: ctx') SpecTerm -> + PermTransM (ps_extra :++: ps_in) (ctx :++: ctx') SpecTerm } + +lownedTransTermTerm :: TypeTrans (ExprTransCtx ctx) -> + RelTypeTrans ctx (PermTransCtx ctx ps_extra) -> + RAssign (Member ctx) ps_extra -> + RelTypeTrans ctx (PermTransCtx ctx ps_in) -> + RAssign (Member ctx) ps_in -> + RelTypeTrans ctx (PermTransCtx ctx ps_out) -> + LOwnedTransTerm ctx ps_extra ps_in ps_out -> SpecTerm +lownedTransTermTerm ectx ps_extraF vars_extra ps_inF vars_in ps_outF f = + lambdaTrans "e" ectx $ \exprs -> + lambdaTrans "p" (ps_extraF exprs) $ \ps_extra -> + lambdaTrans "p" (ps_inF exprs) $ \ps_in -> + flip runTransM (PermTransInfo + { ptransInfoECtx = exprs, + ptransInfoPCtx = RL.append ps_extra ps_in, + ptransInfoVars = RL.append vars_extra vars_in, + ptransInfoRetType = typeTransTupleType (ps_outF exprs) }) $ + unLOwnedTransTerm f MNil $ + do PermTransInfo {..} <- ask + return $ returnSpecTerm ptransInfoRetType $ transTupleTerm ptransInfoPCtx + +extLOwnedTransTerm' :: prx1 ctx -> ExprTrans tp -> + LOwnedTransTerm ctx ps_extra ps_in ps_out -> + LOwnedTransTerm (ctx :> tp) ps_extra ps_in ps_out +extLOwnedTransTerm' ctx tp (LOwnedTransTerm f) = + LOwnedTransTerm $ \ ctx' -> case appendRNilConsEq ctx tp ctx' of + Refl -> f (RL.append (MNil :>: tp) ctx') + +extLOwnedTransTerm :: ExprTrans tp -> + LOwnedTransTerm ctx ps_extra ps_in ps_out -> + LOwnedTransTerm (ctx :> tp) ps_extra ps_in ps_out +extLOwnedTransTerm = extLOwnedTransTerm' Proxy + +emptyLOwnedTransTerm :: LOwnedTransTerm ctx RNil RNil RNil +emptyLOwnedTransTerm = LOwnedTransTerm $ \_ m -> m + +elimSimplLOwnedTransTerm :: (forall ctx'. ExprTransCtx ctx' -> + TypeTrans (PermTransCtx (ctx :++: ctx') ps)) -> + LOwnedTransTerm ctx RNil ps ps +elimSimplLOwnedTransTerm ps = + LOwnedTransTerm $ \ctx' m -> + local (\info -> info { ptransInfoPCtx = + typeTransF (ps ctx') (transTerms $ + ptransInfoPCtx info) }) + m + +weakenLOwnedTransTerm :: + (forall ctx'. ExprTransCtx ctx' -> + TypeTrans (PermTrans (ctx :++: ctx') tp)) -> + LOwnedTransTerm ctx ps_extra ps_in ps_out -> + LOwnedTransTerm ctx ps_extra (ps_in :> tp) (ps_out :> tp) +weakenLOwnedTransTerm tp f = + LOwnedTransTerm $ \ectx' k -> + do (info_ps, info_tp) <- ptInfoSplit (MNil :>: Proxy) <$> ask + withInfoM (const info_ps) $ + unLOwnedTransTerm f ectx' $ + withInfoM (flip ptInfoAppend info_tp) k + +bindLOwnedTransTerm :: + RAssign any ps_extra2 -> RAssign any ps_in -> + LOwnedTransTerm ctx ps_extra1 ps_in ps_int -> + LOwnedTransTerm ctx ps_extra2 ps_int ps_out -> + LOwnedTransTerm ctx (ps_extra1 :++: ps_extra2) ps_in ps_out +bindLOwnedTransTerm prx_extra2 prx_in f1 f2 = + LOwnedTransTerm $ \ectx' k -> + do (info_extra, info_in) <- ptInfoSplit prx_in <$> ask + let (info_extra1, info_extra2) = ptInfoSplit prx_extra2 <$> ask + withInfoM (const $ ptInfoAppend info_extra1 info_in) $ + unLOwnedTransTerm f1 ectx' $ + withInfoM (ptInfoAppend info_extra2) $ + unLOwnedTransTerm f2 ectx' k + + + -- | The translation of the vacuously true permission pattern PTrans_True :: PermTrans ctx a pattern PTrans_True = PTrans_Conj [] -- | Build a type translation for a disjunctive, existential, or named -- permission that uses the 'PTrans_Term' constructor -mkPermTypeTrans1 :: Mb ctx (ValuePerm a) -> OpenTerm -> +mkPermTypeTrans1 :: Mb ctx (ValuePerm a) -> TypeDesc -> TypeTrans (PermTrans ctx a) -mkPermTypeTrans1 mb_p tp = mkTypeTrans1 tp (PTrans_Term mb_p) +mkPermTypeTrans1 mb_p tp = mkImpTypeTrans1 tp (PTrans_Term mb_p) -- | Extract the body of a conjunction or raise an error unPTransConj :: String -> PermTrans ctx a -> [AtomicPermTrans ctx a] @@ -1356,7 +1741,13 @@ instance IsTermTrans (AtomicPermTrans ctx a) where transTerms (APTrans_NamedConj _ _ _ t) = [t] transTerms (APTrans_DefinedNamedConj _ _ _ ptrans) = transTerms ptrans transTerms (APTrans_LLVMFrame _) = [] - transTerms (APTrans_LOwned _ _ _ _ _ t) = [t] + transTerms (APTrans_LOwned _ _ _ _ _ ectx ps_in ps_out ps_extra args_extra f) = + let etps = exprCtxTypes ectx + ps_extra_in = RL.append <$> ps_extra <*> ps_in + lrt = piExprPermLRT etps ps_extra_in ps_out + fun_tm = error "FIXME HERE NOWNOW" in + applyClosSpecTerm lrt (mkFreshClosSpec lrt (const fun_tm)) + (transTerms ectx ++ transTerms args_extra) transTerms (APTrans_LOwnedSimple _ _) = [] transTerms (APTrans_LCurrent _) = [] transTerms APTrans_LFinished = [] @@ -1769,62 +2160,65 @@ weakenLifetimeFun tp_trans ps_in_trans ps_out_trans f = tp_trans) (transTerms ps_in_trans) (transTerms ps_out_trans) f +-- | Make a type translation of a 'BVProp' from it and its pure type +mkBVPropTrans :: Mb ctx (BVProp w) -> OpenTerm -> + TypeTrans 'False (BVPropTrans ctx w) +mkBVPropTrans prop tp = + mkImpTypeTrans1 (TypeDescPure tp) $ BVPropTrans prop instance (1 <= w, KnownNat w, TransInfo info) => - Translate info ctx (BVProp w) (TypeTrans (BVPropTrans ctx w)) where + Translate info ctx (BVProp w) (TypeTrans 'False + (BVPropTrans ctx w)) where translate prop = case mbMatch prop of [nuMP| BVProp_Eq e1 e2 |] -> do let w = natVal4 e1 t1 <- translate1 e1 t2 <- translate1 e2 - return $ 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 @@ -1835,9 +2229,10 @@ instance (1 <= w, KnownNat w, TransInfo info) => -- [| p :: ValuePerm |] = type of the impl translation of reg with perms p instance TransInfo info => - Translate info ctx (ValuePerm a) (TypeTrans (PermTrans ctx a)) where + Translate info ctx (ValuePerm a) (TypeTrans 'False + (PermTrans ctx a)) where translate p = case mbMatch p of - [nuMP| ValPerm_Eq e |] -> return $ mkTypeTrans0 $ PTrans_Eq e + [nuMP| ValPerm_Eq e |] -> return $ mkImpTypeTrans0 $ PTrans_Eq e [nuMP| ValPerm_Or p1 p2 |] -> do tp1 <- translate p1 tp2 <- translate p2 @@ -1871,7 +2266,7 @@ instance TransInfo info => return $ mkPermTypeTrans1 p $ globalOpenTerm "Prelude.FalseProp" instance TransInfo info => - Translate info ctx (AtomicPerm a) (TypeTrans + Translate info ctx (AtomicPerm a) (TypeTrans 'False (AtomicPermTrans ctx a)) where translate mb_p = case mbMatch mb_p of [nuMP| Perm_LLVMField fld |] -> @@ -1882,18 +2277,18 @@ instance TransInfo info => [nuMP| Perm_LLVMBlock bp |] -> do tp <- translate1 (fmap llvmBlockShape bp) - return $ mkTypeTrans1 tp (APTrans_LLVMBlock bp) + return $ mkImpTypeTrans1 tp (APTrans_LLVMBlock bp) [nuMP| Perm_LLVMFree e |] -> - return $ mkTypeTrans0 $ APTrans_LLVMFree e + return $ mkImpTypeTrans0 $ APTrans_LLVMFree e [nuMP| Perm_LLVMFunPtr tp p |] -> translate p >>= \tp_ptrans -> return $ fmap (APTrans_LLVMFunPtr $ mbLift tp) tp_ptrans [nuMP| Perm_IsLLVMPtr |] -> - return $ mkTypeTrans0 APTrans_IsLLVMPtr + return $ mkImpTypeTrans0 APTrans_IsLLVMPtr [nuMP| Perm_LLVMBlockShape sh |] -> - do tp <- translate1 sh - return $ mkTypeTrans1 tp (APTrans_LLVMBlockShape sh) + do tp <- translateSh sh + return $ mkImpTypeTrans1 tp (APTrans_LLVMBlockShape sh) [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 @@ -1909,28 +2304,30 @@ instance TransInfo info => APTrans_NamedConj (mbLift npn) args off t _ -> error "translateSimplImpl: Perm_NamedConj") ptrans [nuMP| Perm_LLVMFrame fp |] -> - return $ mkTypeTrans0 $ APTrans_LLVMFrame fp + return $ mkLRTTypeTrans0 $ APTrans_LLVMFrame fp [nuMP| Perm_LOwned ls tps_in tps_out ps_in ps_out |] -> + error "FIXME HERE NOWNOW" + {- 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) + return $ mkImpTypeTrans1 tp (APTrans_LOwned ls + (mbLift tps_in) (mbLift tps_out) ps_in ps_out) -} [nuMP| Perm_LOwnedSimple tps lops |] -> - return $ mkTypeTrans0 $ APTrans_LOwnedSimple (mbLift tps) lops + return $ mkImpTypeTrans0 $ APTrans_LOwnedSimple (mbLift tps) lops [nuMP| Perm_LCurrent l |] -> - return $ mkTypeTrans0 $ APTrans_LCurrent l + return $ mkImpTypeTrans0 $ APTrans_LCurrent l [nuMP| Perm_LFinished |] -> - return $ mkTypeTrans0 APTrans_LFinished + return $ mkImpTypeTrans0 APTrans_LFinished [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) + translate fun_perm >>= \tp_desc -> + return $ mkImpTypeTrans1 tp_desc (APTrans_Fun fun_perm . Right) [nuMP| Perm_BVProp prop |] -> fmap APTrans_BVProp <$> translate prop - [nuMP| Perm_Any |] -> return $ mkTypeTrans0 APTrans_Any + [nuMP| Perm_Any |] -> return $ mkImpTypeTrans0 APTrans_Any -- | Translate an array permission to a 'TypeTrans' for an array permission -- translation, also returning the translations of the bitvector width as a @@ -1950,13 +2347,11 @@ translateLLVMArrayPerm 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 = bvVecTypeDesc 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 -} ) + mkImpTypeTrans1 arr_tp + ({- flip $ -} LLVMArrayPermTrans mb_ap len_term sh_trans + {- <*> bs_trans -})) instance (1 <= w, KnownNat w, TransInfo info) => Translate info ctx (LLVMArrayPerm w) (TypeTrans @@ -1980,10 +2375,10 @@ translateLLVMArrayBorrow mb_ap mb_b = -} instance TransInfo info => - Translate info ctx (ValuePerms ps) (TypeTrans + Translate info ctx (ValuePerms ps) (TypeTrans 'False (PermTransCtx ctx ps)) where translate mb_ps = case mbMatch mb_ps of - [nuMP| ValPerms_Nil |] -> return $ mkTypeTrans0 MNil + [nuMP| ValPerms_Nil |] -> return $ mkImpTypeTrans0 MNil [nuMP| ValPerms_Cons ps p |] -> liftA2 (:>:) <$> translate ps <*> translate p @@ -2022,9 +2417,8 @@ instance TransInfo info => (infoCtx <$> ask) >>= \ctx -> case RL.appendAssoc ctx tops_prxs rets_prxs of Refl -> - piExprCtxApp tops $ - piPermCtx (mbCombine tops_prxs perms_in) $ \_ -> - specMTypeTransM emptyStackOpenTerm =<< + piLRTExprCtxApp tops $ + arrowLRTPermCtx (mbCombine tops_prxs perms_in) $ translateRetType rets (mbCombine (RL.append tops_prxs rets_prxs) perms_out) @@ -2042,18 +2436,31 @@ 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 a @LetRecType@ that abstracts the SAW terms for a sequence of value +-- permissions +arrowLRTPermCtx :: TransInfo info => Mb ctx (ValuePerms ps) -> + TransM info ctx OpenTerm -> + TransM info ctx OpenTerm +arrowLRTPermCtx ps body = + translate ps >>= \tptrans -> arrowLRTTransM "p" tptrans body + +-- | Build a @LetRecType@ describing a monadic SAW core function that takes in: +-- values for all the expression types in an 'ExprTransCtx' as dependent +-- arguments using @LRT_FunDep@; and values for all the permissions described by +-- a 'PermTransCtx' relative to the expressions using @LRT_FunClos@. The return +-- type is described by a 'PermTransCtx' as well. +piExprPermLRT :: TypeTrans (ExprTransCtx ctx) -> + RelTypeTrans ctx (PermTransCtx ctx ps_in) -> + RelTypeTrans ctx (PermTransCtx ctx ps_out) -> + OpenTerm +piExprPermLRT ectx pctx_in_F pctx_out_F = + error "FIXME HERE NOWNOW" -- | Build the return type for a function; FIXME: documentation translateRetType :: TransInfo info => CruCtx rets -> Mb (ctx :++: rets) (ValuePerms ps) -> - TransM info ctx OpenTerm + TransM info ctx TypeDesc translateRetType rets ret_perms = do tptrans <- translateClosed rets sigmaTypeTransM "ret" tptrans (flip inExtMultiTransM @@ -2095,6 +2502,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 -> @@ -2220,6 +2631,13 @@ impTransM pvars pctx mapTrans stack retType = itiFunStack = stack } +-- | Run an inner 'ImpTransM' computation that does not use the block map +emptyBlocksImpTransM :: ImpTransM () RNil RNil RNil ps ctx a -> + ImpTransM ext blocks tops rets ps ctx a +emptyBlocksImpTransM = + withInfoM (\(ImpTransInfo {..}) -> + ImpTransInfo { itiBlockMapTrans = emptyTypedBlockMapTrans, .. }) + -- | 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 @@ -2419,13 +2837,13 @@ returnTypeM = itiReturnType <$> ask -- | 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 +compReturnTypeM :: ImpTransM ext blocks tops rets ps_out ctx TypeDesc +compReturnTypeM = error "FIXME HERE NOWNOW" -- returnTypeM >>= specMImpTransM -- | Like 'compReturnTypeM' but build a 'TypeTrans' compReturnTypeTransM :: - ImpTransM ext blocks tops rets ps_out ctx (TypeTrans OpenTerm) -compReturnTypeTransM = flip mkTypeTrans1 id <$> compReturnTypeM + ImpTransM ext blocks tops rets ps_out ctx (TypeTrans 'False SpecTerm) +compReturnTypeTransM = flip mkImpTypeTrans1 id <$> compReturnTypeM -- | Build an @errorS@ computation with the given error message mkErrorComp :: String -> ImpTransM ext blocks tops rets ps_out ctx OpenTerm @@ -3772,7 +4190,7 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl do mb_false <- nuMultiTransM $ const ValPerm_False () <- assertTopPermM "Impl1_ElimFalse" mb_x mb_false top_ptrans <- getTopPermM - applyMultiTransM (return $ globalOpenTerm "Prelude.efq") + applyImpMultiTransM (return $ globalOpenTerm "Prelude.efq") [compReturnTypeM, return $ transTerm1 top_ptrans] -- A SimplImpl is translated using translateSimplImpl @@ -3972,14 +4390,14 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl translatePermImpl prx (mbCombine RL.typeCtxProxies mb_impl') >>= \trans -> return $ \k -> do prop_tp_trans <- translate prop - applyMultiTransM (return $ globalOpenTerm "Prelude.maybe") + applyImpMultiTransM (return $ globalOpenTerm "Prelude.maybe") [ return (typeTransType1 prop_tp_trans), compReturnTypeM , implTransAltErr (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") + , applyImpMultiTransM (return $ globalOpenTerm "Prelude.bvEqWithProof") [ return (natOpenTerm $ natVal2 prop) , translate1 e1, translate1 e2]] -- If e1 and e2 are already unequal, short-circuit and do nothing @@ -3995,9 +4413,9 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl translatePermImpl prx (mbCombine RL.typeCtxProxies mb_impl') >>= \trans -> return $ \k -> let w = natVal2 prop in - applyMultiTransM (return $ globalOpenTerm "Prelude.ite") + applyImpMultiTransM (return $ globalOpenTerm "Prelude.ite") [ compReturnTypeM - , applyMultiTransM (return $ globalOpenTerm "Prelude.bvEq") + , applyImpMultiTransM (return $ globalOpenTerm "Prelude.bvEq") [ return (natOpenTerm w), translate1 e1, translate1 e2 ] , implTransAltErr (mbLift prop_str) k , withPermStackM (:>: translateVar x) @@ -4026,14 +4444,14 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl translatePermImpl prx (mbCombine RL.typeCtxProxies mb_impl') >>= \trans -> return $ \k -> do prop_tp_trans <- translate prop - applyMultiTransM (return $ globalOpenTerm "Prelude.maybe") + applyImpMultiTransM (return $ globalOpenTerm "Prelude.maybe") [ return (typeTransType1 prop_tp_trans), compReturnTypeM , implTransAltErr (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") + , applyImpMultiTransM (return $ globalOpenTerm "Prelude.bvultWithProof") [ return (natOpenTerm $ natVal2 prop), translate1 e1, translate1 e2] ] @@ -4059,14 +4477,14 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl translatePermImpl prx (mbCombine RL.typeCtxProxies mb_impl') >>= \trans -> return $ \k -> do prop_tp_trans <- translate prop - applyMultiTransM (return $ globalOpenTerm "Prelude.maybe") + applyImpMultiTransM (return $ globalOpenTerm "Prelude.maybe") [ return (typeTransType1 prop_tp_trans), compReturnTypeM , implTransAltErr (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") + , applyImpMultiTransM (return $ globalOpenTerm "Prelude.bvuleWithProof") [ return (natOpenTerm $ natVal2 prop), translate1 e1, translate1 e2] ] @@ -4095,16 +4513,16 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl translatePermImpl prx (mbCombine RL.typeCtxProxies mb_impl') >>= \trans -> return $ \k -> do prop_tp_trans <- translate prop - applyMultiTransM (return $ globalOpenTerm "Prelude.maybe") + applyImpMultiTransM (return $ globalOpenTerm "Prelude.maybe") [ return (typeTransType1 prop_tp_trans), compReturnTypeM , implTransAltErr (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") + , applyImpMultiTransM (return $ globalOpenTerm "Prelude.bvuleWithProof") [ return (natOpenTerm $ natVal2 prop), translate1 e1, - applyMultiTransM (return $ globalOpenTerm "Prelude.bvSub") + applyImpMultiTransM (return $ globalOpenTerm "Prelude.bvSub") [return (natOpenTerm $ natVal2 prop), translate1 e2, translate1 e3]] ] @@ -4205,15 +4623,15 @@ instance (PermCheckExtC ext exprExt, TransInfo info) => translate mb_e = case mbMatch mb_e of [nuMP| BaseIsEq BaseBoolRepr e1 e2 |] -> ETrans_Term <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.boolEq") + applyPureMultiTransM (return $ globalOpenTerm "Prelude.boolEq") [translateRWV e1, translateRWV e2] -- [nuMP| BaseIsEq BaseNatRepr e1 e2 |] -> -- ETrans_Term <$> - -- applyMultiTransM (return $ globalOpenTerm "Prelude.equalNat") + -- applyPureMultiTransM (return $ globalOpenTerm "Prelude.equalNat") -- [translateRWV e1, translateRWV e2] [nuMP| BaseIsEq (BaseBVRepr w) e1 e2 |] -> ETrans_Term <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvEq") + applyPureMultiTransM (return $ globalOpenTerm "Prelude.bvEq") [translate w, translateRWV e1, translateRWV e2] [nuMP| EmptyApp |] -> return ETrans_Unit @@ -4225,19 +4643,19 @@ instance (PermCheckExtC ext exprExt, TransInfo info) => return $ ETrans_Term $ globalOpenTerm "Prelude.False" [nuMP| Not e |] -> ETrans_Term <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.not") + applyPureMultiTransM (return $ globalOpenTerm "Prelude.not") [translateRWV e] [nuMP| And e1 e2 |] -> ETrans_Term <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.and") + applyPureMultiTransM (return $ globalOpenTerm "Prelude.and") [translateRWV e1, translateRWV e2] [nuMP| Or e1 e2 |] -> ETrans_Term <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.or") + applyPureMultiTransM (return $ globalOpenTerm "Prelude.or") [translateRWV e1, translateRWV e2] [nuMP| BoolXor e1 e2 |] -> ETrans_Term <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.xor") + applyPureMultiTransM (return $ globalOpenTerm "Prelude.xor") [translateRWV e1, translateRWV e2] -- Natural numbers @@ -4245,32 +4663,32 @@ instance (PermCheckExtC ext exprExt, TransInfo info) => return $ ETrans_Term $ natOpenTerm $ mbLift n [nuMP| NatLt e1 e2 |] -> ETrans_Term <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.ltNat") + applyPureMultiTransM (return $ globalOpenTerm "Prelude.ltNat") [translateRWV e1, translateRWV e2] -- [nuMP| NatLe _ _ |] -> [nuMP| NatEq e1 e2 |] -> ETrans_Term <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.equalNat") + applyPureMultiTransM (return $ globalOpenTerm "Prelude.equalNat") [translateRWV e1, translateRWV e2] [nuMP| NatAdd e1 e2 |] -> ETrans_Term <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.addNat") + applyPureMultiTransM (return $ globalOpenTerm "Prelude.addNat") [translateRWV e1, translateRWV e2] [nuMP| NatSub e1 e2 |] -> ETrans_Term <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.subNat") + applyPureMultiTransM (return $ globalOpenTerm "Prelude.subNat") [translateRWV e1, translateRWV e2] [nuMP| NatMul e1 e2 |] -> ETrans_Term <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.mulNat") + applyPureMultiTransM (return $ globalOpenTerm "Prelude.mulNat") [translateRWV e1, translateRWV e2] [nuMP| NatDiv e1 e2 |] -> ETrans_Term <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.divNat") + applyPureMultiTransM (return $ globalOpenTerm "Prelude.divNat") [translateRWV e1, translateRWV e2] [nuMP| NatMod e1 e2 |] -> ETrans_Term <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.modNat") + applyPureMultiTransM (return $ globalOpenTerm "Prelude.modNat") [translateRWV e1, translateRWV e2] -- Function handles: the expression part of a function handle has no @@ -4286,126 +4704,126 @@ instance (PermCheckExtC ext exprExt, TransInfo info) => return $ ETrans_Term $ bvBVOpenTerm (mbLift w) $ mbLift mb_bv [nuMP| BVConcat w1 w2 e1 e2 |] -> ETrans_Term <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.join") + applyPureMultiTransM (return $ globalOpenTerm "Prelude.join") [translate w1, translate w2, translateRWV e1, translateRWV e2] [nuMP| BVTrunc w1 w2 e |] -> ETrans_Term <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvTrunc") + applyPureMultiTransM (return $ globalOpenTerm "Prelude.bvTrunc") [return (natOpenTerm (natValue (mbLift w2) - natValue (mbLift w1))), translate w1, translateRWV e] [nuMP| BVZext w1 w2 e |] -> ETrans_Term <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvUExt") + applyPureMultiTransM (return $ globalOpenTerm "Prelude.bvUExt") [return (natOpenTerm (natValue (mbLift w1) - natValue (mbLift w2))), translate w2, translateRWV e] [nuMP| BVSext w1 w2 e |] -> ETrans_Term <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvSExt") + applyPureMultiTransM (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 <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvNot") + applyPureMultiTransM (return $ globalOpenTerm "Prelude.bvNot") [translate w, translateRWV e] [nuMP| BVAnd w e1 e2 |] -> ETrans_Term <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvAnd") + applyPureMultiTransM (return $ globalOpenTerm "Prelude.bvAnd") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVOr w e1 e2 |] -> ETrans_Term <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvOr") + applyPureMultiTransM (return $ globalOpenTerm "Prelude.bvOr") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVXor w e1 e2 |] -> ETrans_Term <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvXor") + applyPureMultiTransM (return $ globalOpenTerm "Prelude.bvXor") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVNeg w e |] -> ETrans_Term <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvNeg") + applyPureMultiTransM (return $ globalOpenTerm "Prelude.bvNeg") [translate w, translateRWV e] [nuMP| BVAdd w e1 e2 |] -> ETrans_Term <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvAdd") + applyPureMultiTransM (return $ globalOpenTerm "Prelude.bvAdd") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVSub w e1 e2 |] -> ETrans_Term <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvSub") + applyPureMultiTransM (return $ globalOpenTerm "Prelude.bvSub") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVMul w e1 e2 |] -> ETrans_Term <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvMul") + applyPureMultiTransM (return $ globalOpenTerm "Prelude.bvMul") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVUdiv w e1 e2 |] -> ETrans_Term <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvUDiv") + applyPureMultiTransM (return $ globalOpenTerm "Prelude.bvUDiv") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVSdiv w e1 e2 |] -> ETrans_Term <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvSDiv") + applyPureMultiTransM (return $ globalOpenTerm "Prelude.bvSDiv") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVUrem w e1 e2 |] -> ETrans_Term <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvURem") + applyPureMultiTransM (return $ globalOpenTerm "Prelude.bvURem") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVSrem w e1 e2 |] -> ETrans_Term <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvSRem") + applyPureMultiTransM (return $ globalOpenTerm "Prelude.bvSRem") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVUle w e1 e2 |] -> ETrans_Term <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvule") + applyPureMultiTransM (return $ globalOpenTerm "Prelude.bvule") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVUlt w e1 e2 |] -> ETrans_Term <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvult") + applyPureMultiTransM (return $ globalOpenTerm "Prelude.bvult") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVSle w e1 e2 |] -> ETrans_Term <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvsle") + applyPureMultiTransM (return $ globalOpenTerm "Prelude.bvsle") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVSlt w e1 e2 |] -> ETrans_Term <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvslt") + applyPureMultiTransM (return $ globalOpenTerm "Prelude.bvslt") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVCarry w e1 e2 |] -> ETrans_Term <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvCarry") + applyPureMultiTransM (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 <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvSCarry") + applyPureMultiTransM (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 <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvSBorrow") + applyPureMultiTransM (return $ globalOpenTerm "Prelude.bvSBorrow") [return w_minus_1, translateRWV e1, translateRWV e2] [nuMP| BVShl w e1 e2 |] -> ETrans_Term <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvShiftL") + applyPureMultiTransM (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 <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvShiftR") + applyPureMultiTransM (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 <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.bvSShiftR") + applyPureMultiTransM (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 <$> - applyMultiTransM (return $ globalOpenTerm "Prelude.ite") + applyPureMultiTransM (return $ globalOpenTerm "Prelude.ite") [bitvectorTransM (translate mb_w), translateRWV e, return (bvBVOpenTerm w (BV.one w)), @@ -4413,8 +4831,8 @@ instance (PermCheckExtC ext exprExt, TransInfo info) => [nuMP| BVNonzero mb_w e |] -> let w = mbLift mb_w in ETrans_Term <$> - applyTransM (return $ globalOpenTerm "Prelude.not") - (applyMultiTransM (return $ globalOpenTerm "Prelude.bvEq") + applyPureTransM (return $ globalOpenTerm "Prelude.not") + (applyPureMultiTransM (return $ globalOpenTerm "Prelude.bvEq") [translate mb_w, translateRWV e, return (bvBVOpenTerm w (BV.zero w))]) @@ -4605,7 +5023,7 @@ translateStmt loc mb_stmt m = case mbMatch mb_stmt of applyCallS ix all_args _ -> error "translateStmt: TypedCall: unexpected function permission" bindSpecMTransM - fret_trm (openTermTypeTrans fret_tp) "call_ret_val" $ \ret_val -> + fret_trm fret_tp "call_ret_val" $ \ret_val -> sigmaElimTransM "elim_call_ret_val" rets_trans (flip inExtMultiTransM (translate perms_out)) compReturnTypeTransM (\rets_ectx pctx -> @@ -4622,7 +5040,7 @@ translateStmt loc mb_stmt m = case mbMatch mb_stmt of -- FIXME HERE: figure out why these asserts always translate to ite True [nuMP| TypedAssert e _ |] -> - applyMultiTransM (return $ globalOpenTerm "Prelude.ite") + applyImpMultiTransM (return $ globalOpenTerm "Prelude.ite") [compReturnTypeM, translate1 e, m, mkErrorComp ("Failed Assert at " ++ renderDoc (ppShortFileName (plSourceLoc loc)))] @@ -4818,7 +5236,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") + applyImpMultiTransM (return $ globalOpenTerm "Prelude.ite") [compReturnTypeM, translate1 reg, translate impl_tgt1, translate impl_tgt2] [nuMP| TypedReturn impl_ret |] -> translate impl_ret @@ -4883,21 +5301,6 @@ mapBlockMapLetRec :: 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 -> @@ -5075,14 +5478,12 @@ lambdaCFGArgs env cfg bodyF = -- | 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) -> + TypeTransM (ghosts :++: inits) OpenTerm -> OpenTerm -piCFGArgs env cfg bodyF = +piCFGArgs env cfg bodyM = runNilTypeTransM env noChecks $ - piExprCtx (typedFnHandleAllArgs (tpcfgHandle cfg)) $ - piPermCtx (funPermIns $ tpcfgFunPerm cfg) $ \pctx -> - do ectx <- infoCtx <$> ask - bodyF (transTerms ectx ++ transTerms pctx) + piLRTExprCtx (typedFnHandleAllArgs (tpcfgHandle cfg)) $ + arrowLRTPermCtx (funPermIns $ tpcfgFunPerm cfg) bodyM -- | Translate a typed CFG to a SAW term (FIXME HERE NOW: explain the term that -- is generated and the fun args) @@ -5247,7 +5648,7 @@ tcTranslateAddCFGs sc mod_name env checks endianness dlevel cfgs_and_perms = zipWithM (\(SomeTypedCFG sym nm cfg) i -> do tp <- - completeNormOpenTerm sc $ piCFGArgs env cfg $ \_ -> + completeNormOpenTerm sc $ piCFGArgs env cfg $ let fun_perm = tpcfgFunPerm cfg in translateRetType (funPermRets fun_perm) (funPermOuts fun_perm) >>= specMTypeTransM emptyStackOpenTerm @@ -5297,5 +5698,5 @@ translateCompletePureFun :: SharedContext -> PermEnv -> IO Term translateCompletePureFun sc env ctx args ret = completeNormOpenTerm sc $ runNilTypeTransM env noChecks $ - piExprCtx ctx $ piPermCtx args $ const $ + piExprCtx ctx $ arrowLRTPermCtx args $ typeTransTupleType <$> translate ret diff --git a/saw-core/prelude/Prelude.sawcore b/saw-core/prelude/Prelude.sawcore index a7cd08d787..f03fdcccdc 100644 --- a/saw-core/prelude/Prelude.sawcore +++ b/saw-core/prelude/Prelude.sawcore @@ -2419,6 +2419,9 @@ primitive ValidLRTFunctor2 : (sort 0 -> sort 0 -> sort 0) -> sort 0; -- The pair functor is a valid binary LRT functor axiom pair_ValidLRTFunctor2 : ValidLRTFunctor2 (\ (A B:sort 0) -> A * B); +-- The either functor is a valid binary LRT functor +axiom either_ValidLRTFunctor2 : ValidLRTFunctor2 (\ (A B:sort 0) -> Either A B); + -- The Vec type constructor is a valid LRT functor axiom Vec_ValidLRTFunctor2 : (n:Nat) -> ValidLRTFunctor2 (\ (A _:sort 0) -> Vec n A); @@ -2444,6 +2447,29 @@ data LetRecType : sort 1 where { default_lrt : LetRecType; default_lrt = LRT_FunDep Void (\ (_:Void) -> LRT_SpecM (LRT_Type Void)); +-- The LetRecType for the unit type +LRT_Unit : LetRecType; +LRT_Unit = LRT_Type #(); + +-- The LetRecType for a pair +LRT_Pair : LetRecType -> LetRecType -> LetRecType; +LRT_Pair lrt_l lrt_r = + LRT_BinOp (\ (A B:sort 0) -> A * B) pair_ValidLRTFunctor2 lrt_l lrt_r; + +-- The LetRecType for the Either type +LRT_Either : LetRecType -> LetRecType -> LetRecType; +LRT_Either lrt_l lrt_r = + LRT_BinOp (\ (A B:sort 0) -> Either A B) either_ValidLRTFunctor2 lrt_l lrt_r; + +-- The LetRecType for the Vec type +LRT_Vec : Nat -> LetRecType -> LetRecType; +LRT_Vec n lrt = + LRT_BinOp (\ (A _:sort 0) -> Vec n A) (Vec_ValidLRTFunctor2 n) lrt LRT_Unit; + +-- The LetRecType for the BVVec type +LRT_BVVec : (n:Nat) -> Vec n Bool -> LetRecType -> LetRecType; +LRT_BVVec n len lrt = LRT_Vec (bvToNat n len) lrt; + -- A function stack is a list of LetRecTypes, which intuitively -- represents a stack of bindings of mutually recursive functions FunStack : sort 1; diff --git a/saw-core/src/Verifier/SAW/OpenTerm.hs b/saw-core/src/Verifier/SAW/OpenTerm.hs index 4884beebbd..6b6ea04202 100644 --- a/saw-core/src/Verifier/SAW/OpenTerm.hs +++ b/saw-core/src/Verifier/SAW/OpenTerm.hs @@ -65,18 +65,24 @@ module Verifier.SAW.OpenTerm ( recordOpenTerm, recordTypeOpenTerm, projRecordOpenTerm, ctorOpenTerm, dataTypeOpenTerm, globalOpenTerm, identOpenTerm, extCnsOpenTerm, applyOpenTerm, applyOpenTermMulti, applyGlobalOpenTerm, - applyPiOpenTerm, piArgOpenTerm, - lambdaOpenTerm, lambdaOpenTermMulti, piOpenTerm, piOpenTermMulti, + applyPiOpenTerm, piArgOpenTerm, lambdaOpenTerm, lambdaOpenTermMulti, + piOpenTerm, piOpenTermMulti, arrowOpenTerm, letOpenTerm, sawLetOpenTerm, list1OpenTerm, - -- * Monadic operations for building terms with binders + -- * Monadic operations for building terms including 'IO' actions OpenTermM(..), completeOpenTermM, dedupOpenTermM, lambdaOpenTermM, piOpenTermM, lambdaOpenTermAuxM, piOpenTermAuxM, -- * Building SpecM computations - SpecTerm(), defineSpecOpenTerm, lambdaSpecTerm, piSpecTerm, + SpecTerm(), defineSpecOpenTerm, + lambdaPureSpecTerm, lambdaPureSpecTermMulti, lambdaSpecTerm, + lambdaSpecTermMulti, piSpecTerm, applySpecTerm, applySpecTermMulti, openTermSpecTerm, - mkBaseClosSpec, mkFreshClosSpec, callClosSpec, callDefSpec, - returnSpec, bindSpec, errorSpec + globalSpecTerm, applyGlobalSpecTerm, + mkBaseClosSpec, mkFreshClosSpec, callClosSpec, applyClosSpecTerm, + callDefSpec, returnSpec, bindSpec, errorSpec, + flatSpecTerm, unitSpecTerm, pairSpecTerm, pairTypeSpecTerm, + pairLeftSpecTerm, pairRightSpecTerm, ctorSpecTerm, dataTypeSpecTerm, + sawLetSpecTerm ) where import qualified Data.Vector as V @@ -399,7 +405,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)) @@ -457,6 +464,7 @@ list1OpenTerm tp xs = (ctorOpenTerm "Prelude.Nil1" [tp]) xs + -- | 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. @@ -576,6 +584,10 @@ applyExtStackOp f = return $ applyGlobalOpenTerm f [specInfoEvType info, specInfoExtStack info] +-- | Build the 'SpecInfoTerm' for the extended function stack +extStackSpecInfoTerm :: SpecInfoTerm +extStackSpecInfoTerm = ask >>= (return . specInfoExtStack) + -- | FIXME: docs bindSpecInfoTerm :: (LocalName -> TypedTerm -> TypedTerm -> TermF TypedTerm) -> LocalName -> SpecInfoTerm -> SpecInfoTerm -> SpecInfoTerm @@ -707,21 +719,40 @@ applySpecTermMulti = foldl applySpecTerm specInfoTermTerm :: SpecInfoTerm -> SpecTerm specInfoTermTerm t = SpecTerm $ return t +-- | Convert an 'OpenTerm' to a 'SpecTerm' openTermSpecTerm :: OpenTerm -> SpecTerm -openTermSpecTerm t = SpecTerm $ return $ return t - -topVarSpecTerm :: SpecTermM SpecTerm +openTermSpecTerm t = + SpecTerm $ + do ctx_len <- specStCtxLen <$> get + return $ return $ + OpenTerm $ + do ctx <- askCtx + if length ctx == ctx_len then unOpenTerm t else + panic "openTermSpecTerm" ["Typing context not of expected length"] + +natSpecTerm :: Natural -> SpecTerm +natSpecTerm n = openTermSpecTerm $ natOpenTerm n + +globalSpecTerm :: Ident -> SpecTerm +globalSpecTerm ident = openTermSpecTerm $ globalOpenTerm ident + +applyGlobalSpecTerm :: Ident -> [SpecTerm] -> SpecTerm +applyGlobalSpecTerm f args = applySpecTermMulti (globalSpecTerm f) args + +-- | Build the 'SpecTerm' for the extended function stack +extStackSpecTerm :: SpecTerm +extStackSpecTerm = specInfoTermTerm extStackSpecInfoTerm + +-- | Build an 'OpenTerm' for the top variable in a 'SpecTermM' computation +topVarSpecTerm :: SpecTermM OpenTerm topVarSpecTerm = do outer_ctx_len <- specStCtxLen <$> get - return $ SpecTerm $ do - inner_ctx_len <- specStCtxLen <$> get - return $ return $ OpenTerm $ - do inner_ctx <- askCtx - if length inner_ctx == inner_ctx_len then return () else - panic "topVarSpecTerm" ["Variable context of unexpected length"] + return $ OpenTerm $ + do inner_ctx_len <- length <$> askCtx typeInferComplete (LocalVar (inner_ctx_len - outer_ctx_len) :: TermF Term) +-- | Run a 'SpecTermM' computation in a context with an extra bound variable withVarSpecTermM :: SpecTermM a -> SpecTermM a withVarSpecTermM m = do modify specStIncCtx @@ -729,13 +760,33 @@ withVarSpecTermM m = modify specStDecCtx return a --- | Build a lambda abstraction as a 'SpecTerm' -lambdaSpecTerm :: LocalName -> SpecTerm -> (SpecTerm -> SpecTerm) -> SpecTerm -lambdaSpecTerm x (SpecTerm tpM) body_f = SpecTerm $ +-- | Build a lambda abstraction as a 'SpecTerm' from a function that takes in a +-- pure 'OpenTerm' +lambdaPureSpecTerm :: LocalName -> SpecTerm -> (OpenTerm -> SpecTerm) -> SpecTerm +lambdaPureSpecTerm x (SpecTerm tpM) body_f = SpecTerm $ do tp <- tpM body <- withVarSpecTermM (topVarSpecTerm >>= (unSpecTerm . body_f)) return $ bindSpecInfoTerm Lambda x tp body +-- | Build a nested sequence of pure lambda abstractions as a 'SpecTerm' +lambdaPureSpecTermMulti :: [(LocalName, SpecTerm)] -> + ([OpenTerm] -> SpecTerm) -> SpecTerm +lambdaPureSpecTermMulti xs_tps body_f = + foldr (\(x,tp) rest_f xs -> + lambdaPureSpecTerm x tp (rest_f . (:xs))) (body_f . reverse) xs_tps [] + +-- | Build a lambda abstraction as a 'SpecTerm' +lambdaSpecTerm :: LocalName -> SpecTerm -> (SpecTerm -> SpecTerm) -> SpecTerm +lambdaSpecTerm x tp body_f = + lambdaPureSpecTerm x tp (body_f . openTermSpecTerm) + +-- | Build a nested sequence of lambda abstractions as a 'SpecTerm' +lambdaSpecTermMulti :: [(LocalName, SpecTerm)] -> + ([SpecTerm] -> SpecTerm) -> SpecTerm +lambdSpecTermMulti xs_tps body_f = + foldr (\(x,tp) rest_f xs -> + lambdaSpecTerm x tp (rest_f . (:xs))) (body_f . reverse) xs_tps [] + -- | Build a pi abstraction as a 'SpecTerm' piSpecTerm :: LocalName -> SpecTerm -> (SpecTerm -> SpecTerm) -> SpecTerm piSpecTerm x (SpecTerm tpM) body_f = SpecTerm $ @@ -828,6 +879,12 @@ mkFreshClosSpec lrt body_f = SpecTerm $ modify $ specStSetClosBody clos_ix body return $ mkClosSpecInfoTerm clos_ix +-- | Apply a closure of a given @LetRecType@ to a list of arguments +applyClosSpecTerm :: OpenTerm -> SpecTerm -> [SpecTerm] -> SpecTerm +applyClosSpecTerm lrt clos args = + applyGlobalSpecTerm "Prelude.applyLRTClosN" + (extStackSpecTerm : natSpecTerm (length args) : args) + -- | Build a @SpecM@ computation that calls a closure with the given return -- type specified as a @LetRecType@ callClosSpec :: OpenTerm -> SpecTerm -> SpecTerm @@ -867,6 +924,68 @@ errorSpec tp msg = applySpecTermMulti (monadicSpecOp "Prelude.errorS") [tp, openTermSpecTerm (stringLitOpenTerm msg)] +-- | Build a 'SpecInfoTerm' from a 'FlatTermF' +flatSpecInfoTerm :: FlatTermF SpecInfoTerm -> SpecInfoTerm +flatSpecInfoTerm ftf = fmap flatOpenTerm $ sequence ftf + +-- | Build a 'SpecTerm' from a 'FlatTermF' +flatSpecTerm :: FlatTermF SpecTerm -> SpecTerm +flatSpecTerm ftf = + SpecTerm $ fmap flatSpecInfoTerm $ sequence (fmap unSpecTerm ftf) + +-- | Build a 'SpecTerm' for a pair +unitSpecTerm :: SpecTerm +unitSpecTerm = flatSpecTerm UnitValue + +-- | Build a 'SpecTerm' for a pair +pairSpecTerm :: SpecTerm -> SpecTerm -> SpecTerm +pairSpecTerm t1 t2 = flatSpecTerm $ PairValue t1 t2 + +-- | Build a 'SpecTerm' for a pair type +pairTypeSpecTerm :: SpecTerm -> SpecTerm -> SpecTerm +pairTypeSpecTerm t1 t2 = flatSpecTerm $ PairType t1 t2 + +-- | Build a 'SpecTerm' for the left projection of a pair +pairLeftSpecTerm :: SpecTerm -> SpecTerm +pairLeftSpecTerm t = flatSpecTerm $ PairLeft t + +-- | Build a 'SpecTerm' for the right projection of a pair +pairRightSpecTerm :: SpecTerm -> SpecTerm +pairRightSpecTerm t = flatSpecTerm $ PairRight t + +-- | Build a 'SpecInfoTerm' for a constructor applied to its arguments +ctorSpecInfoTerm :: Ident -> [SpecInfoTerm] -> SpecInfoTerm +ctorSpecInfoTerm c args = fmap (ctorOpenTerm c) (sequence args) + +-- | Build a 'SpecTerm' for a constructor applied to its arguments +ctorSpecTerm :: Ident -> [SpecTerm] -> SpecTerm +ctorSpecTerm c args = + SpecTerm $ fmap (ctorSpecInfoTerm c) $ sequence $ map unSpecTerm args + +-- | Build a 'SpecInfoTerm' for a datatype applied to its arguments +dataTypeSpecInfoTerm :: Ident -> [SpecInfoTerm] -> SpecInfoTerm +dataTypeSpecInfoTerm d args = fmap (dataTypeOpenTerm d) (sequence args) + +-- | Build a 'SpecTerm' for a datatype applied to its arguments +dataTypeSpecTerm :: Ident -> [SpecTerm] -> SpecTerm +dataTypeSpecTerm d args = + SpecTerm $ fmap (dataTypeSpecInfoTerm c) $ sequence $ map unSpecTerm args + +-- | Build a let expression as an 'SpecTerm'. This is equivalent to +-- > 'applySpecTerm' ('lambdaSpecTerm' x tp body) rhs +letSpecTerm :: LocalName -> SpecTerm -> SpecTerm -> (SpecTerm -> SpecTerm) -> + SpecTerm +letSpecTerm x tp rhs body_f = applySpecTerm (lambdaSpecTerm x tp body_f) rhs + +-- | Build a let expression as an 'SpecTerm'. This is equivalent to +-- > 'applySpecTerm' ('lambdaSpecTerm' x tp body) rhs +sawLetSpecTerm :: LocalName -> SpecTerm -> SpecTerm -> SpecTerm -> + (SpecTerm -> SpecTerm) -> SpecTerm +sawLetSpecTerm x tp tp_ret rhs body_f = + applySpecTermMulti (globalSpecTerm "Prelude.sawLet") + [tp, tp_ret, rhs, lambdaSpecTerm x tp body_f] + + -------------------------------------------------------------------------------- -- sawLet-minimization From 06bc64c884a6e40427d59b86ceb9f335f28933f5 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 20 Jul 2023 17:08:26 -0700 Subject: [PATCH 017/305] updated the names ofthe SpecTerm operations to all use SpecTerm instead of Spec --- saw-core/src/Verifier/SAW/OpenTerm.hs | 49 ++++++++++++++++----------- 1 file changed, 30 insertions(+), 19 deletions(-) diff --git a/saw-core/src/Verifier/SAW/OpenTerm.hs b/saw-core/src/Verifier/SAW/OpenTerm.hs index 6b6ea04202..51d4a34ff8 100644 --- a/saw-core/src/Verifier/SAW/OpenTerm.hs +++ b/saw-core/src/Verifier/SAW/OpenTerm.hs @@ -77,10 +77,10 @@ module Verifier.SAW.OpenTerm ( lambdaPureSpecTerm, lambdaPureSpecTermMulti, lambdaSpecTerm, lambdaSpecTermMulti, piSpecTerm, applySpecTerm, applySpecTermMulti, openTermSpecTerm, - globalSpecTerm, applyGlobalSpecTerm, - mkBaseClosSpec, mkFreshClosSpec, callClosSpec, applyClosSpecTerm, - callDefSpec, returnSpec, bindSpec, errorSpec, - flatSpecTerm, unitSpecTerm, pairSpecTerm, pairTypeSpecTerm, + globalSpecTerm, applyGlobalSpecTerm, lrtToTypeSpecTerm + mkBaseClosSpecTerm, mkFreshClosSpecTerm, callClosSpecTerm, applyClosSpecTerm, + callDefSpecTerm, specMTypeSpecTerm, returnSpecTerm, bindSpecTerm, + errorSpecTerm, flatSpecTerm, unitSpecTerm, pairSpecTerm, pairTypeSpecTerm, pairLeftSpecTerm, pairRightSpecTerm, ctorSpecTerm, dataTypeSpecTerm, sawLetSpecTerm ) where @@ -794,6 +794,13 @@ piSpecTerm x (SpecTerm tpM) body_f = SpecTerm $ body <- withVarSpecTermM (topVarSpecTerm >>= (unSpecTerm . body_f)) return $ bindSpecInfoTerm Pi x tp body +-- | Convert a term @lrt@ of type @LetRecType@ to the type it represents by +-- forming the term @LRTArg stk lrt@ +lrtToTypeSpecTerm :: OpenTerm -> SpecTerm +lrtToTypeSpecTerm lrt = + applyGlobalSpecTerm "Prelude.LRTArg" + [specInfoTermTerm (specInfoExtStack <$> ask), lrt] + funStackTypeOpenTerm :: OpenTerm funStackTypeOpenTerm = globalOpenTerm "Prelude.FunStack" @@ -861,8 +868,8 @@ mkClosSpecInfoTerm n = -- | Build a closure that calls one of the "base" recursive functions in the -- current spec definition -mkBaseClosSpec :: Natural -> SpecTerm -mkBaseClosSpec clos_ix = SpecTerm $ +mkBaseClosSpecTerm :: Natural -> SpecTerm +mkBaseClosSpecTerm clos_ix = SpecTerm $ do st <- get if clos_ix < specStNumBaseRecs st then return () else panic "mkBaseClosSpec" ["Closure index out of bounds"] @@ -870,8 +877,8 @@ mkBaseClosSpec clos_ix = SpecTerm $ -- | Build a closure that calls a new corecursive function with the given -- @LetRecType@ and body, that can call itself using the term passed to it -mkFreshClosSpec :: OpenTerm -> (SpecTerm -> SpecTerm) -> SpecTerm -mkFreshClosSpec lrt body_f = SpecTerm $ +mkFreshClosSpecTerm :: OpenTerm -> (SpecTerm -> SpecTerm) -> SpecTerm +mkFreshClosSpecTerm lrt body_f = SpecTerm $ do (clos_ix, st) <- specStInsTempClos lrt <$> get put st body <- unSpecTerm $ body_f (SpecTerm $ return $ @@ -887,14 +894,14 @@ applyClosSpecTerm lrt clos args = -- | Build a @SpecM@ computation that calls a closure with the given return -- type specified as a @LetRecType@ -callClosSpec :: OpenTerm -> SpecTerm -> SpecTerm -callClosSpec tp clos = +callClosSpecTerm :: OpenTerm -> SpecTerm -> SpecTerm +callClosSpecTerm tp clos = applySpecTermMulti (monadicSpecOp "Prelude.CallS") [openTermSpecTerm tp, clos] -- | Call another spec definition inside a spec definition, by importing it -callDefSpec :: OpenTerm -> SpecTerm -callDefSpec def = SpecTerm $ +callDefSpecTerm :: OpenTerm -> SpecTerm +callDefSpecTerm def = SpecTerm $ do (imp_ix, st) <- specStInsImport def <$> get put st return $ @@ -906,21 +913,25 @@ callDefSpec def = SpecTerm $ monadicSpecOp :: Ident -> SpecTerm monadicSpecOp f = specInfoTermTerm $ applyExtStackOp f +-- | Build the type @SpecM ev stk tp@ from the type @tp@ +specMTypeSpecTerm :: SpecTerm -> SpecTerm +specMTypeSpecTerm = applySpecTerm (monadicSpecOp "Prelude.SpecM") + -- | Build a @SpecM@ computation that returns a value of a given type -returnSpec :: SpecTerm -> SpecTerm -> SpecTerm -returnSpec tp val = +returnSpecTerm :: SpecTerm -> SpecTerm -> SpecTerm +returnSpecTerm tp val = applySpecTermMulti (monadicSpecOp "Prelude.retS") [tp, val] -- | Build a @SpecM@ computation that does a monadic bind -bindSpec :: SpecTerm -> SpecTerm -> SpecTerm -> - LocalName -> (SpecTerm -> SpecTerm) -> SpecTerm -bindSpec tp1 tp2 m x f = +bindSpecTerm :: SpecTerm -> SpecTerm -> SpecTerm -> + LocalName -> (SpecTerm -> SpecTerm) -> SpecTerm +bindSpecTerm tp1 tp2 m x f = applySpecTermMulti (monadicSpecOp "Prelude.bindS") [tp1, tp2, m, lambdaSpecTerm x tp1 f] -- | Build a @SpecM@ error computation at the given type with the given message -errorSpec :: SpecTerm -> Text -> SpecTerm -errorSpec tp msg = +errorSpecTerm :: SpecTerm -> Text -> SpecTerm +errorSpecTerm tp msg = applySpecTermMulti (monadicSpecOp "Prelude.errorS") [tp, openTermSpecTerm (stringLitOpenTerm msg)] From 2cefee92b6a449ff4a611ec39a9a41326d9030b8 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 20 Jul 2023 17:08:59 -0700 Subject: [PATCH 018/305] more work on updating SAWTranslation.hs... --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 235 +++++++++--------- 1 file changed, 119 insertions(+), 116 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 562a9705ca..b5ac6bfa28 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -125,6 +125,10 @@ typeDescLRT (TypeDescLRT lrt _) = lrt typeDescTypeLRT :: TypeDesc -> (OpenTerm,SpecTerm) typeDescTypeLRT d = (typeDescType d, typeDescLRT d) +-- | Build an impure 'TypeDesc' from a term of type @LetRecType@ +typeDescFromLRT :: OpenTerm -> TypeDesc +typeDescFromLRT lrt = TypeDescLRT lrt (lrtToTypeSpecTerm lrt) + -- | If all the type descriptions in a list are pure, return their pure types as -- a list; otherwise, convert them all to impure LRT types typeDescsPureOrLRT :: [TypeDesc] -> Either [OpenTerm] [(OpenTerm,SpecTerm)] @@ -158,6 +162,10 @@ bvVecTypeDesc w_term len_term (TypeDescImpure lrt elem_tpx) = (applyGlobalOpenTerm "Prelude.LRT_BVVec" [w_term, len_term, lrt]) (applyGlobalOpenTerm "Prelude.BVVec" [w_term, len_term, elem_tp]) +-- | The 'TypeDesc' for the unit type +typeDescUnit :: TypeDesc +typeDescUnit = TypeDescPure unitTypeOpenTerm + -- | Build a type description for the pair of two type descriptions typeDescPair :: TypeDesc -> TypeDesc -> TypeDesc typeDescPair = @@ -171,9 +179,23 @@ typeDescEither = "Prelude.LRT_Either" (\tp1 tp2 -> dataTypeSpecTerm "Prelude.Either" [tp1,tp2]) --- | Build a type description for a @Sigma@ type as an impure 'TypeDesc' -typeDescSigma :: String -> OpenTerm -> (OpenTerm -> TypeDesc) -> TypeDesc -typeDescSigma x tp_l tp_r_f = +-- | Build a type description for a @Sigma@ type from a pure type for the first +-- projection and a function to a type description for the second projection. +-- The Boolean flag indicates whether this function is expected to return a pure +-- type, in which case the returned dependent pair type is pure, or not, in +-- which case it isn't. It is an error if the Boolean flag is 'True' but the +-- function returns an impure type description. +typeDescSigma :: String -> OpenTerm -> Bool -> (OpenTerm -> TypeDesc) -> + TypeDesc +typeDescSigma x tp_l True tp_r_f = + do tp_f_trm <- lambdaOpenTerm x tp_l $ \tr -> tp_f tr >>= \case + TypeDescPure tp_r -> tp_r + TypeDescLRT _ _ -> + panic "typeDescSigma" + ["Expected a pure type description but got an impure one"] + return $ TypeDescPure $ + dataTypeOpenTerm "Prelude.Sigma" [typeTransTupleType ttrans, tp_f_trm] +typeDescSigma x tp_l False tp_r_f = TypeDescLRT (ctorOpenTerm "Prelude.LRT_Sigma" [tp_l, lambdaOpenTerm x tp_l (typeDescLRT . tp_r_f)]) @@ -424,6 +446,11 @@ type ExprTransCtx = RAssign ExprTrans -- | A 'TypeTrans' that is relative to an expression context type RelTypeTrans ectx tp = ExprTransCtx ectx -> TypeTrans tp +-- | Destruct an 'ExprTrans' of shape type to a type description +unETransShape :: ExprTrans (LLVMShapeType w) -> TypeDesc +unETransShape (ETrans_Shape d) = d +unETransShape (ETrans_Term _) = + panic "unETransShape" ["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 @@ -482,6 +509,8 @@ instance IsPureTrans (ExprTrans tp) where transPureTerms ETrans_Fun = [] transPureTerms ETrans_Unit = [] transPureTerms ETrans_AnyVector = [] + transPureTerms (ETrans_Shape d) = [typeDescLRT d] + transPureTerms (ETrans_Perm d) = [typeDescLRT d] transPureTerms (ETrans_Term t) = [t] instance IsTermTrans (ExprTrans tp) where @@ -498,6 +527,22 @@ instance IsTermTrans (ExprTransCtx ctx) where exprCtxToTerms :: ExprTransCtx tps -> [SpecTerm] exprCtxToTerms = concat . RL.mapToList transTerms +-- | Map an 'ExprTrans' to the SAW core terms it contains, similarly to +-- 'transPureTerms', except that all type descriptions are mapped to pure types, +-- not terms of type @LetRecType@. Return 'Nothing' if this is not possible. +exprTransPureTypeTerms :: ExprTrans tp -> Maybe [OpenTerm] +exprTransPureTypeTerms (ETrans_Shape (TypeDescPure tp)) = Just [tp] +exprTransPureTypeTerms (ETrans_Shape (TypeDescLRT _ _)) = Nothing +exprTransPureTypeTerms (ETrans_Perm (TypeDescPure tp)) = Just [tp] +exprTransPureTypeTerms (ETrans_Perm (TypeDescLRT _ _)) = Nothing +exprTransPureTypeTerms etrans = transPureTerms etrans + +-- | Map an 'ExprTransCtx' to the SAW core terms it contains, similarly to +-- 'transPureTerms', except that all type descriptions are mapped to pure types, +-- not terms of type @LetRecType@. Return 'Nothing' if this is not possible. +exprTransPureTypeTerms :: ExprTransCtx tps -> Maybe [OpenTerm] +exprTransPureTypeTerms = + fmap concat . sequence . RL.mapToList exprTransPureTypeTerms -- | Class for valid translation info types, which must contain at least a -- context of expression translations @@ -807,17 +852,9 @@ sigmaTypeTransM :: String -> PureTypeTrans trL -> Bool -> TransM info ctx TypeDesc sigmaTypeTransM _ ttrans@(typeTransTypes -> []) _ tp_f = typeTransTupleType <$> tp_f (typeTransF ttrans []) -sigmaTypeTransM x ttrans True tp_f = - do tp_f_trm <- lambdaTupleTransM x ttrans $ \tr -> tp_f tr >>= \case - TypeDescPure tp_r -> tp_r - TypeDescLRT _ _ -> - panic "sigmaTypeTransM" - ["Expected a pure type description but got an impure one"] - return $ TypeDescPure $ - dataTypeOpenTerm "Prelude.Sigma" [typeTransTupleType ttrans, tp_f_trm] -sigmaTypeTransM x ttrans False tp_f = +sigmaTypeTransM x ttrans pure_p tp_f = do info <- ask - return $ typeDescSigma x (typeTransTupleType ttrans) $ \e_tup -> + return $ typeDescSigma x (typeTransTupleType ttrans) pure_p $ \e_tup -> tupleOfTypeDescs $ typeTransDescs $ runTransM (tp_f $ typeTransF (tupleTypeTrans ttrans) [e_tup]) info @@ -913,73 +950,23 @@ sigmaElimPermTransM x tp_l p_cbn tp_ret_m f sigma = case mbMatch p_cbn of _ -> sigmaElimTransM x tp_l (flip inExtTransM $ translate p_cbn) tp_ret_m f sigma -NOWNOW: -- change uses of TypeTrans to include the purity flag -- NOTE: PermExprs translate to pure terms / OpenTerms -- eitherTypeTrans and sigmaTypeTrans should build TypeDescs -- compReturnTypeM should return a TypeDesc -- need a variant of piTransM that builds TypeDescs - - --- | 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 - 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 - --- | 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] - --- | 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 - --- | 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 - --- | Pi-abstract a function stack variable of type @FunStack@ -piFunStackM :: (OpenTerm -> TransM 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] -- | 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 pure SAW term, raising an +-- error if the result has 0 or more than 1 terms +translate1Pure :: (IsPureTrans tr, Translate info ctx a tr, HasCallStack) => + Mb ctx a -> TransM info ctx OpenTerm +translate1Pure a = translate a >>= \tr -> case transPureTerms tr of + [t] -> return t + ts -> panic "translate1" ["expected 1 term, found " ++ show (length ts)] -- | Translate to SAW and then convert to a single SAW term, raising an error if -- the result has 0 or more than 1 terms translate1 :: (IsTermTrans tr, Translate info ctx a tr, HasCallStack) => - Mb ctx a -> TransM info ctx OpenTerm + Mb ctx a -> TransM info ctx SpecTerm translate1 a = translate a >>= \tr -> case transTerms tr of [t] -> return t ts -> error ("translate1: expected 1 term, found " ++ show (length ts) @@ -1055,13 +1042,13 @@ instance TransInfo info => Translate info ctx (NatRepr n) OpenTerm where translate mb_n = return $ natOpenTerm $ mbLift $ fmap natValue mb_n -- | Return a pure type translation that uses a single term of the given type -returnType1 :: OpenTerm -> TransM info ctx (TypeTrans 'True (ExprTrans a)) +returnType1 :: OpenTerm -> TransM info ctx (PureTypeTrans (ExprTrans a)) returnType1 tp = return $ mkPureTypeTrans1 tp ETrans_Term -- FIXME: explain this translation instance TransInfo info => - Translate info ctx (TypeRepr a) (TypeTrans 'True (ExprTrans a)) where + Translate info ctx (TypeRepr a) (PureTypeTrans (ExprTrans a)) where translate mb_tp = case mbMatch mb_tp of [nuMP| AnyRepr |] -> return $ error "Translate: Any" @@ -1101,11 +1088,11 @@ instance TransInfo info => -- Permissions and LLVM shapes translate to types [nuMP| ValuePermRepr _ |] -> - return $ mkPureTypeTrans1 (dataTypeOpenTerm - "Prelude.LetRecType" []) ETrans_Perm + return $ mkPureTypeTrans1 (dataTypeOpenTerm "Prelude.LetRecType" []) + (ETrans_Perm . typeDescFromLRT) [nuMP| LLVMShapeRepr _ |] -> - return $ mkPureTypeTrans1 (dataTypeOpenTerm - "Prelude.LetRecType" []) ETrans_Shape + return $ mkPureTypeTrans1 (dataTypeOpenTerm "Prelude.LetRecType" []) + (ETrans_Shape . typeDescFromLRT) -- We can't handle any other special-purpose types [nuMP| IntrinsicRepr _ _ |] -> @@ -1257,8 +1244,6 @@ instance TransInfo info => [nuMP| ns :>: n |] -> (:>:) <$> translate ns <*> translate n -NOWNOW: update the translation of shapes and perms to use ETrans_Shape and ETrans_Perm - instance TransInfo info => Translate info ctx (PermExpr a) (ExprTrans a) where translate mb_tr = case mbMatch mb_tr of @@ -1294,58 +1279,65 @@ instance TransInfo info => [nuMP| PExpr_PermListCons _ _ p l |] -> ETrans_Term <$> (pairTypeOpenTerm <$> (typeTransTupleType <$> translate p) <*> - (translate1 l)) + (translate1Pure l)) [nuMP| PExpr_RWModality _ |] -> return ETrans_RWModality -- LLVM shapes are translated to types - [nuMP| PExpr_EmptyShape |] -> return $ ETrans_Term unitTypeOpenTerm + [nuMP| PExpr_EmptyShape |] -> return $ ETrans_Shape typeDescUnit [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 + exprTransPureTypeTerms <$> translate args >>= \case + Just args_trans -> + ETrans_Shape $ applyOpenTermMulti (globalOpenTerm $ + mbLift trans_id) args_trans + Nothing -> + panic "translate" + ["Heapster cannot yet handle opaque shapes over impure types"] [nuMP| RecShapeBody _ trans_id _ |] -> - ETrans_Term <$> applyOpenTermMulti (globalOpenTerm $ mbLift trans_id) <$> - transTerms <$> translate args - [nuMP| PExpr_EqShape _ _ |] -> return $ ETrans_Term unitTypeOpenTerm + exprTransPureTypeTerms <$> translate args >>= \case + Just args_trans -> + ETrans_Shape $ applyOpenTermMulti (globalOpenTerm $ + mbLift trans_id) args_trans + Nothing -> + panic "translate" + ["Heapster cannot yet handle recursive shapes over impure types"] + [nuMP| PExpr_EqShape _ _ |] -> return $ ETrans_Shape typeDescUnit [nuMP| PExpr_PtrShape _ _ sh |] -> translate sh [nuMP| PExpr_FieldShape fsh |] -> - ETrans_Term <$> tupleOfTypes <$> translate fsh + ETrans_Shape <$> tupleOfTypeDescs <$> translate fsh [nuMP| PExpr_ArrayShape mb_len _ mb_sh |] -> do let w = natVal4 mb_len let w_term = natOpenTerm w - len_term <- translate1 mb_len - elem_tp <- translate1 mb_sh - return $ ETrans_Term $ - applyOpenTermMulti (globalOpenTerm "Prelude.BVVec") - [w_term, len_term, elem_tp] + len_term <- translate1Pure mb_len + elem_d <- translateShape mb_sh + return $ ETrans_Shape $ bvVecTypeDesc w_term len_term elem_d [nuMP| PExpr_SeqShape sh1 sh2 |] -> - ETrans_Term <$> (pairTypeOpenTerm <$> translate1 sh1 <*> translate1 sh2) + ETrans_Shape <$> (typeDescPair <$> translateShape sh1 + <*> translateShape sh2) [nuMP| PExpr_OrShape sh1 sh2 |] -> - ETrans_Term <$> - ((\t1 t2 -> dataTypeOpenTerm "Prelude.Either" [t1,t2]) - <$> translate1 sh1 <*> translate1 sh2) + ETrans_Shape <$> (typeDescEither + <$> translate1Pure sh1 <*> translate1Pure sh2) [nuMP| PExpr_ExShape mb_sh |] -> - error "FIXME HERE NOWNOW" - {- 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]) -} + ETrans_Shape <$> + sigmaTypeTransM "x_exsh" tp_trans + (isPureShape $ mbCombine RL.typeCtxProxies mb_sh) $ \e -> + inExtTransM e (translateShape $ mbCombine RL.typeCtxProxies mb_sh) [nuMP| PExpr_FalseShape |] -> - return $ ETrans_Term $ globalOpenTerm "Prelude.FalseProp" + return $ ETrans_Shape $ TypeTransPure $ globalOpenTerm "Prelude.FalseProp" [nuMP| PExpr_ValPerm p |] -> - ETrans_Term <$> typeTransTupleType <$> translate p + ETrans_Perm <$> tupleOfTypeDescs <$> typeTransDescs <$> translate p -- LLVM field shapes translate to the types 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 info ctx (LLVMFieldShape w) [TypeDesc] where + translate (mbMatch -> [nuMP| LLVMFieldShape p |]) = + typeTransDescs <$> translate p instance TransInfo info => Translate info ctx (PermExprs as) (ExprTransCtx as) where @@ -1356,11 +1348,24 @@ instance TransInfo info => instance TransInfo info => Translate info ctx (BVFactor w) OpenTerm where translate mb_f = case mbMatch mb_f of - [nuMP| BVFactor (BV.BV 1) x |] -> translate1 (fmap PExpr_Var x) + [nuMP| BVFactor (BV.BV 1) x |] -> translate1Pure (fmap PExpr_Var x) [nuMP| BVFactor i x |] -> let w = natRepr4 x in bvMulOpenTerm (natValue w) (bvBVOpenTerm w $ mbLift i) <$> - translate1 (fmap PExpr_Var x) + translate1Pure (fmap PExpr_Var x) + +translateShape :: (TransInfo info, HasCallStack) => + Mb ctx (PermExpr (LLVMShapeType w)) -> + TransM info ctx TypeDesc +translateShape mb_e = unETransShape <$> translate mb_e + +NOWNOW: +- change uses of TypeTrans to include the purity flag +- NOTE: PermExprs translate to pure terms / OpenTerms +- compReturnTypeM should return a TypeDesc +- need a variant of piTransM that builds TypeDescs +- update the translation of shapes and perms to use ETrans_Shape and ETrans_Perm +- ISSUE: transPureTerms of ETrans_Shape and ETrans_Perm return an LRT, not a type, so recursive and opaque names need to as well ---------------------------------------------------------------------- @@ -2167,8 +2172,7 @@ mkBVPropTrans prop tp = mkImpTypeTrans1 (TypeDescPure tp) $ BVPropTrans prop instance (1 <= w, KnownNat w, TransInfo info) => - Translate info ctx (BVProp w) (TypeTrans 'False - (BVPropTrans ctx w)) where + Translate info ctx (BVProp w) (ImpTypeTrans (BVPropTrans ctx w)) where translate prop = case mbMatch prop of [nuMP| BVProp_Eq e1 e2 |] -> do let w = natVal4 e1 @@ -2229,8 +2233,7 @@ instance (1 <= w, KnownNat w, TransInfo info) => -- [| p :: ValuePerm |] = type of the impl translation of reg with perms p instance TransInfo info => - Translate info ctx (ValuePerm a) (TypeTrans 'False - (PermTrans ctx a)) where + Translate info ctx (ValuePerm a) (ImpTypeTrans (PermTrans ctx a)) where translate p = case mbMatch p of [nuMP| ValPerm_Eq e |] -> return $ mkImpTypeTrans0 $ PTrans_Eq e [nuMP| ValPerm_Or p1 p2 |] -> @@ -4276,7 +4279,7 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl do let mb_e = case mbLLVMFieldContents mb_fp of [nuP| ValPerm_Eq (PExpr_LLVMWord e) |] -> e _ -> error "translatePermImpl1: Impl1_SplitLLVMWordField" - e_tm <- translate1 mb_e + e_tm <- translate1Pure mb_e sz1_tm <- translate mb_sz1 sz2_tm <- translateClosed $ mbLLVMFieldSize mb_fp let sz2m1_tm = @@ -4306,7 +4309,7 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl do let mb_e = case mbLLVMFieldContents mb_fp of [nuP| ValPerm_Eq (PExpr_LLVMWord e) |] -> e _ -> error "translatePermImpl1: Impl1_TruncateLLVMWordField" - e_tm <- translate1 mb_e + e_tm <- translate1Pure mb_e sz1_tm <- translate mb_sz1 sz2_tm <- translateClosed $ mbLLVMFieldSize mb_fp let sz2m1_tm = @@ -4334,8 +4337,8 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl do let mb_e1 = case mbLLVMFieldContents mb_fp1 of [nuP| ValPerm_Eq (PExpr_LLVMWord e1) |] -> e1 _ -> error "translatePermImpl1: Impl1_ConcatLLVMWordFields" - e1_tm <- translate1 mb_e1 - e2_tm <- translate1 mb_e2 + e1_tm <- translate1Pure mb_e1 + e2_tm <- translate1Pure mb_e2 sz1_tm <- translateClosed $ mbLLVMFieldSize mb_fp1 sz2_tm <- translateClosed $ mbExprBVTypeWidth mb_e2 let endianness = mbLift mb_endianness From 6884903567a4823a6838d7f315bddcadfb0bbab2 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 21 Jul 2023 08:50:56 -0700 Subject: [PATCH 019/305] small tweaks to get OpenTerm.hs to compile --- saw-core/src/Verifier/SAW/OpenTerm.hs | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/saw-core/src/Verifier/SAW/OpenTerm.hs b/saw-core/src/Verifier/SAW/OpenTerm.hs index 51d4a34ff8..fd2b911e3b 100644 --- a/saw-core/src/Verifier/SAW/OpenTerm.hs +++ b/saw-core/src/Verifier/SAW/OpenTerm.hs @@ -77,12 +77,12 @@ module Verifier.SAW.OpenTerm ( lambdaPureSpecTerm, lambdaPureSpecTermMulti, lambdaSpecTerm, lambdaSpecTermMulti, piSpecTerm, applySpecTerm, applySpecTermMulti, openTermSpecTerm, - globalSpecTerm, applyGlobalSpecTerm, lrtToTypeSpecTerm + globalSpecTerm, applyGlobalSpecTerm, lrtToTypeSpecTerm, mkBaseClosSpecTerm, mkFreshClosSpecTerm, callClosSpecTerm, applyClosSpecTerm, callDefSpecTerm, specMTypeSpecTerm, returnSpecTerm, bindSpecTerm, errorSpecTerm, flatSpecTerm, unitSpecTerm, pairSpecTerm, pairTypeSpecTerm, pairLeftSpecTerm, pairRightSpecTerm, ctorSpecTerm, dataTypeSpecTerm, - sawLetSpecTerm + letSpecTerm, sawLetSpecTerm ) where import qualified Data.Vector as V @@ -783,7 +783,7 @@ lambdaSpecTerm x tp body_f = -- | Build a nested sequence of lambda abstractions as a 'SpecTerm' lambdaSpecTermMulti :: [(LocalName, SpecTerm)] -> ([SpecTerm] -> SpecTerm) -> SpecTerm -lambdSpecTermMulti xs_tps body_f = +lambdaSpecTermMulti xs_tps body_f = foldr (\(x,tp) rest_f xs -> lambdaSpecTerm x tp (rest_f . (:xs))) (body_f . reverse) xs_tps [] @@ -791,7 +791,8 @@ lambdSpecTermMulti xs_tps body_f = piSpecTerm :: LocalName -> SpecTerm -> (SpecTerm -> SpecTerm) -> SpecTerm piSpecTerm x (SpecTerm tpM) body_f = SpecTerm $ do tp <- tpM - body <- withVarSpecTermM (topVarSpecTerm >>= (unSpecTerm . body_f)) + body <- withVarSpecTermM (fmap openTermSpecTerm topVarSpecTerm >>= + (unSpecTerm . body_f)) return $ bindSpecInfoTerm Pi x tp body -- | Convert a term @lrt@ of type @LetRecType@ to the type it represents by @@ -799,7 +800,7 @@ piSpecTerm x (SpecTerm tpM) body_f = SpecTerm $ lrtToTypeSpecTerm :: OpenTerm -> SpecTerm lrtToTypeSpecTerm lrt = applyGlobalSpecTerm "Prelude.LRTArg" - [specInfoTermTerm (specInfoExtStack <$> ask), lrt] + [specInfoTermTerm (specInfoExtStack <$> ask), openTermSpecTerm lrt] funStackTypeOpenTerm :: OpenTerm funStackTypeOpenTerm = globalOpenTerm "Prelude.FunStack" @@ -890,7 +891,8 @@ mkFreshClosSpecTerm lrt body_f = SpecTerm $ applyClosSpecTerm :: OpenTerm -> SpecTerm -> [SpecTerm] -> SpecTerm applyClosSpecTerm lrt clos args = applyGlobalSpecTerm "Prelude.applyLRTClosN" - (extStackSpecTerm : natSpecTerm (length args) : args) + (extStackSpecTerm : natSpecTerm (fromIntegral $ length args) + : openTermSpecTerm lrt : clos : args) -- | Build a @SpecM@ computation that calls a closure with the given return -- type specified as a @LetRecType@ @@ -980,7 +982,7 @@ dataTypeSpecInfoTerm d args = fmap (dataTypeOpenTerm d) (sequence args) -- | Build a 'SpecTerm' for a datatype applied to its arguments dataTypeSpecTerm :: Ident -> [SpecTerm] -> SpecTerm dataTypeSpecTerm d args = - SpecTerm $ fmap (dataTypeSpecInfoTerm c) $ sequence $ map unSpecTerm args + SpecTerm $ fmap (dataTypeSpecInfoTerm d) $ sequence $ map unSpecTerm args -- | Build a let expression as an 'SpecTerm'. This is equivalent to -- > 'applySpecTerm' ('lambdaSpecTerm' x tp body) rhs From d53790021afe5b778e36a98e5a59ba86802573eb Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 21 Jul 2023 08:51:20 -0700 Subject: [PATCH 020/305] just a little further with SAWTranslation.hs, to try to compile the first part of it... --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 225 +++++++++--------- 1 file changed, 114 insertions(+), 111 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index b5ac6bfa28..9131a047c7 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -1359,14 +1359,6 @@ translateShape :: (TransInfo info, HasCallStack) => TransM info ctx TypeDesc translateShape mb_e = unETransShape <$> translate mb_e -NOWNOW: -- change uses of TypeTrans to include the purity flag -- NOTE: PermExprs translate to pure terms / OpenTerms -- compReturnTypeM should return a TypeDesc -- need a variant of piTransM that builds TypeDescs -- update the translation of shapes and perms to use ETrans_Shape and ETrans_Perm -- ISSUE: transPureTerms of ETrans_Shape and ETrans_Perm return an LRT, not a type, so recursive and opaque names need to as well - ---------------------------------------------------------------------- -- * Translating Permissions to Types @@ -1538,7 +1530,7 @@ data LLVMArrayPermTrans ctx w = LLVMArrayPermTrans { llvmArrayTransHeadCell :: TypeTrans 'False (AtomicPermTrans ctx (LLVMPointerType w)), -- llvmArrayTransBorrows :: [LLVMArrayBorrowTrans ctx w], - llvmArrayTransTerm :: OpenTerm + llvmArrayTransTerm :: SpecTerm } -- | Get the SAW type of the cells of the translation of an array permission @@ -1555,24 +1547,29 @@ data LLVMArrayBorrowTrans ctx w = llvmArrayBorrowTransProps :: [BVPropTrans ctx w] } -} + newtype PermTransInfo ps ctx = PermTransInfo { ptransInfoECtx :: ExprTransCtx ctx, ptransInfoPCtx :: PermTransCtx ctx ps, - ptransInfoVars :: RAssign (Member ctx) ps, ptransInfoRetType :: SpecTerm } -ptInfoSetPerms :: PermTransCtx ctx ps' -> RAssign (Member ctx) ps' -> - PermTransInfo ps ctx -> PermTransInfo ps' ctx -ptInfoSetPerms ps' vars' (PermTransInfo {..}) = - PermTransInfo { ptransInfoPCtx = ps', ptransInfoVars = vars', ..} +ptInfoSetPerms :: PermTransCtx ctx ps' -> PermTransInfo ps ctx -> + PermTransInfo ps' ctx +ptInfoSetPerms ps' (PermTransInfo {..}) = + PermTransInfo { ptransInfoPCtx = ps', ..} ptInfoSplit :: RAssign any ps2 -> PermTransInfo (ps1 :++: ps2) ctx -> (PermTransInfo ps1 ctx, PermTransInfo ps2 ctx) ptInfoSplit = error "FIXME HERE NOWNOW" +ptInfoAppendPerms :: PermTransInfo ps1 ctx -> PermTransCtx ctx ps2 -> + PermTransInfo (ps1 :++: ps2) ctx +ptInfoAppendPerms (PermTransInfo {..}) pctx2 = + PermTransInfo { ptransInfoPCtx = RL.append ptransInfoPCtx pctx2, .. } + ptInfoAppend :: PermTransInfo ps1 ctx -> PermTransInfo ps2 ctx -> PermTransInfo (ps1 :++: ps2) ctx -ptInfoAppend = error "FIXME HERE NOWNOW" +ptInfoAppend info1 info2 = ptInfoAppendPerms info1 (ptransInfoPCtx info2) type PermTransM ps ctx = TransM (PermTransInfo ps) @@ -1580,80 +1577,64 @@ newtype LOwnedTransTerm ctx ps_extra ps_in ps_out = LOwnedTransTerm { unLOwnedTransTerm :: forall ctx'. ExprTransCtx ctx' -> - PermTransM ps_out (ctx :++: ctx') SpecTerm -> - PermTransM (ps_extra :++: ps_in) (ctx :++: ctx') SpecTerm } + PermTransM ps_in (ctx :++: ctx') (PermTransCtx (ctx :++: ctx') ps_out) } lownedTransTermTerm :: TypeTrans (ExprTransCtx ctx) -> - RelTypeTrans ctx (PermTransCtx ctx ps_extra) -> - RAssign (Member ctx) ps_extra -> RelTypeTrans ctx (PermTransCtx ctx ps_in) -> - RAssign (Member ctx) ps_in -> RelTypeTrans ctx (PermTransCtx ctx ps_out) -> - LOwnedTransTerm ctx ps_extra ps_in ps_out -> SpecTerm -lownedTransTermTerm ectx ps_extraF vars_extra ps_inF vars_in ps_outF f = + LOwnedTransTerm ctx ps_in ps_out -> SpecTerm +lownedTransTermTerm ectx ps_inF ps_outF t = lambdaTrans "e" ectx $ \exprs -> - lambdaTrans "p" (ps_extraF exprs) $ \ps_extra -> lambdaTrans "p" (ps_inF exprs) $ \ps_in -> flip runTransM (PermTransInfo - { ptransInfoECtx = exprs, - ptransInfoPCtx = RL.append ps_extra ps_in, - ptransInfoVars = RL.append vars_extra vars_in, + { ptransInfoECtx = exprs, ptransInfoPCtx = ps_in, ptransInfoRetType = typeTransTupleType (ps_outF exprs) }) $ - unLOwnedTransTerm f MNil $ - do PermTransInfo {..} <- ask - return $ returnSpecTerm ptransInfoRetType $ transTupleTerm ptransInfoPCtx + (transTupleTerm <$> unLOwnedTransTerm t MNil) -extLOwnedTransTerm' :: prx1 ctx -> ExprTrans tp -> - LOwnedTransTerm ctx ps_extra ps_in ps_out -> - LOwnedTransTerm (ctx :> tp) ps_extra ps_in ps_out +extLOwnedTransTerm' :: Proxy ctx -> ExprTrans tp -> + LOwnedTransTerm ctx ps_in ps_out -> + LOwnedTransTerm (ctx :> tp) ps_in ps_out extLOwnedTransTerm' ctx tp (LOwnedTransTerm f) = LOwnedTransTerm $ \ ctx' -> case appendRNilConsEq ctx tp ctx' of Refl -> f (RL.append (MNil :>: tp) ctx') extLOwnedTransTerm :: ExprTrans tp -> - LOwnedTransTerm ctx ps_extra ps_in ps_out -> - LOwnedTransTerm (ctx :> tp) ps_extra ps_in ps_out + LOwnedTransTerm ctx ps_in ps_out -> + LOwnedTransTerm (ctx :> tp) ps_in ps_out extLOwnedTransTerm = extLOwnedTransTerm' Proxy -emptyLOwnedTransTerm :: LOwnedTransTerm ctx RNil RNil RNil -emptyLOwnedTransTerm = LOwnedTransTerm $ \_ m -> m +emptyLOwnedTransTerm :: LOwnedTransTerm ctx RNil RNil +emptyLOwnedTransTerm = LOwnedTransTerm $ \_ -> return MNil elimSimplLOwnedTransTerm :: (forall ctx'. ExprTransCtx ctx' -> TypeTrans (PermTransCtx (ctx :++: ctx') ps)) -> - LOwnedTransTerm ctx RNil ps ps + LOwnedTransTerm ctx ps ps elimSimplLOwnedTransTerm ps = - LOwnedTransTerm $ \ctx' m -> - local (\info -> info { ptransInfoPCtx = - typeTransF (ps ctx') (transTerms $ - ptransInfoPCtx info) }) - m + LOwnedTransTerm $ \ctx' -> ptransInfoPCtx <$> ask weakenLOwnedTransTerm :: (forall ctx'. ExprTransCtx ctx' -> TypeTrans (PermTrans (ctx :++: ctx') tp)) -> - LOwnedTransTerm ctx ps_extra ps_in ps_out -> - LOwnedTransTerm ctx ps_extra (ps_in :> tp) (ps_out :> tp) -weakenLOwnedTransTerm tp f = - LOwnedTransTerm $ \ectx' k -> + LOwnedTransTerm ctx ps_in ps_out -> + LOwnedTransTerm ctx (ps_in :> tp) (ps_out :> tp) +weakenLOwnedTransTerm tp t = + LOwnedTransTerm $ \ectx' -> do (info_ps, info_tp) <- ptInfoSplit (MNil :>: Proxy) <$> ask - withInfoM (const info_ps) $ - unLOwnedTransTerm f ectx' $ - withInfoM (flip ptInfoAppend info_tp) k + pctx <- withInfoM (const info_ps) (unLOwnedTransTerm t ectx') + return (RL.append pctx $ ptransInfoPCtx info_tp) bindLOwnedTransTerm :: RAssign any ps_extra2 -> RAssign any ps_in -> - LOwnedTransTerm ctx ps_extra1 ps_in ps_int -> - LOwnedTransTerm ctx ps_extra2 ps_int ps_out -> - LOwnedTransTerm ctx (ps_extra1 :++: ps_extra2) ps_in ps_out -bindLOwnedTransTerm prx_extra2 prx_in f1 f2 = - LOwnedTransTerm $ \ectx' k -> + 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 +bindLOwnedTransTerm prx_extra2 prx_in t1 t2 = + LOwnedTransTerm $ \ectx' -> do (info_extra, info_in) <- ptInfoSplit prx_in <$> ask let (info_extra1, info_extra2) = ptInfoSplit prx_extra2 <$> ask - withInfoM (const $ ptInfoAppend info_extra1 info_in) $ - unLOwnedTransTerm f1 ectx' $ - withInfoM (ptInfoAppend info_extra2) $ - unLOwnedTransTerm f2 ectx' k - + pctx_mid <- + withInfoM (const $ ptInfoAppend info_extra1 info_in) (unLOwnedTransTerm t1) + withInfoM (const $ ptInfoAppendPerms info_extra2 pctx_mid) (unLOwnedTransTerm t2) -- | The translation of the vacuously true permission @@ -1785,6 +1766,7 @@ 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] @@ -1857,48 +1839,53 @@ extsMb ctx = mbCombine proxies . fmap (nus proxies . const) -- | Generic function to extend the context of the translation of a permission class ExtPermTrans f where - extPermTrans :: f ctx a -> f (ctx :> tp) a + extPermTrans :: ExprTrans tp -> f ctx a -> f (ctx :> tp) 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 + extPermTrans _ (PTrans_Eq e) = PTrans_Eq $ extMb e + extPermTrans e (PTrans_Conj aps) = + PTrans_Conj (map (extPermTrans e) aps) + extPermTrans e (PTrans_Defined n args a ptrans) = + PTrans_Defined n (extMb args) (extMb a) (extPermTrans e ptrans) + extPermTrans _ (PTrans_Term p t) = PTrans_Term (extMb 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) = + extPermTrans e (APTrans_LLVMField fld ptrans) = + APTrans_LLVMField (extMb fld) (extPermTrans e ptrans) + extPermTrans e (APTrans_LLVMArray arr_trans) = + APTrans_LLVMArray $ extPermTrans e arr_trans + extPermTrans _ (APTrans_LLVMBlock mb_bp t) = APTrans_LLVMBlock (extMb mb_bp) t + extPermTrans _ (APTrans_LLVMFree e) = APTrans_LLVMFree $ extMb e + extPermTrans e (APTrans_LLVMFunPtr tp ptrans) = + APTrans_LLVMFunPtr tp (extPermTrans e 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) = + 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) = + extPermTrans e (APTrans_DefinedNamedConj npn args off ptrans) = + APTrans_DefinedNamedConj npn (extMb args) (extMb off) (extPermTrans e ptrans) + extPermTrans _ (APTrans_LLVMFrame fp) = APTrans_LLVMFrame $ extMb fp + extPermTrans e (APTrans_LOwned ls tps_in tps_out ps_in ps_out ectx + ps_extra vars_extra ptrans_in ptrans_out ptrans_extra t) = + APTrans_LOwned (extMb ls) tps_in tps_out (extMb ps_in) (extMb ps_out) + (ectx :>: e) (extPermTransCtx ps_extra) (RL.map Member_Step vars_extra) + (extRelTypeTrans ptrans_in) (extRelTypeTrans ptrans_out) + (extRelTypeTrans ptrans_extra) (extLOwnedTransTerm e 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 + extPermTrans _ (APTrans_LCurrent p) = APTrans_LCurrent $ extMb p + extPermTrans _ APTrans_LFinished = APTrans_LFinished + extPermTrans e (APTrans_Struct ps) = + APTrans_Struct $ RL.map (extPermTrans e) ps + extPermTrans _ (APTrans_Fun fp trans) = APTrans_Fun (extMb fp) trans + extPermTrans e (APTrans_BVProp prop_trans) = + APTrans_BVProp $ extPermTrans e prop_trans + extPermTrans _ APTrans_Any = APTrans_Any instance ExtPermTrans LLVMArrayPermTrans where - extPermTrans (LLVMArrayPermTrans ap len sh {- bs -} t) = - LLVMArrayPermTrans (extMb ap) len (fmap extPermTrans sh) + extPermTrans e (LLVMArrayPermTrans ap len sh {- bs -} t) = + LLVMArrayPermTrans (extMb ap) len (fmap (extPermTrans e) sh) {- (map extPermTrans bs) -} t {- @@ -1908,14 +1895,15 @@ instance ExtPermTrans LLVMArrayBorrowTrans where -} instance ExtPermTrans BVPropTrans where - extPermTrans (BVPropTrans prop t) = BVPropTrans (extMb prop) t + extPermTrans _ (BVPropTrans prop t) = BVPropTrans (extMb prop) t instance ExtPermTrans BVRangeTrans where - extPermTrans (BVRangeTrans rng t1 t2) = BVRangeTrans (extMb rng) t1 t2 + extPermTrans _ (BVRangeTrans rng t1 t2) = BVRangeTrans (extMb rng) t1 t2 -- | Extend the context of a permission translation context -extPermTransCtx :: PermTransCtx ctx ps -> PermTransCtx (ctx :> tp) ps -extPermTransCtx = RL.map extPermTrans +extPermTransCtx :: ExprTrans tp -> PermTransCtx ctx ps -> + PermTransCtx (ctx :> tp) ps +extPermTransCtx e = RL.map (extPermTrans e) -- | Add another permission translation to a permission translation context consPermTransCtx :: PermTransCtx ctx ps -> PermTrans ctx a -> @@ -2098,6 +2086,7 @@ setLLVMArrayTransSlice arr_trans sub_arr_trans off_tm = (globalOpenTerm "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' @@ -2164,6 +2153,7 @@ weakenLifetimeFun tp_trans ps_in_trans ps_out_trans f = weakenMonadicFun (transTerms tp_trans) (transTerms ps_in_trans) (transTerms ps_out_trans) f +-} -- | Make a type translation of a 'BVProp' from it and its pure type mkBVPropTrans :: Mb ctx (BVProp w) -> OpenTerm -> @@ -2378,7 +2368,7 @@ translateLLVMArrayBorrow mb_ap mb_b = -} instance TransInfo info => - Translate info ctx (ValuePerms ps) (TypeTrans 'False + Translate info ctx (ValuePerms ps) (ImpTypeTrans (PermTransCtx ctx ps)) where translate mb_ps = case mbMatch mb_ps of [nuMP| ValPerms_Nil |] -> return $ mkImpTypeTrans0 MNil @@ -2392,12 +2382,12 @@ instance TransInfo info => translate = translate . mbDistPermsToValuePerms instance TransInfo info => - Translate info ctx (TypedDistPerms ps) (TypeTrans + Translate info ctx (TypedDistPerms ps) (ImpTypeTrans (PermTransCtx ctx ps)) where translate = translate . mbDistPermsToValuePerms . fmap unTypeDistPerms instance TransInfo info => - Translate info ctx (ExprPerms ps) (TypeTrans + Translate info ctx (ExprPerms ps) (ImpTypeTrans (PermTransCtx ctx ps)) where translate mb_eps | Just mb_ps <- mbExprPermsToValuePerms mb_eps = translate mb_ps @@ -2410,7 +2400,7 @@ emptyStackOpenTerm = globalOpenTerm "Prelude.emptyFunStack" -- Translate a FunPerm to a pi-abstraction (FIXME HERE NOW: document translation) instance TransInfo info => - Translate info ctx (FunPerm ghosts args gouts ret) OpenTerm where + Translate info ctx (FunPerm ghosts args gouts ret) SpecTerm where translate (mbMatch -> [nuMP| FunPerm ghosts args gouts ret perms_in perms_out |]) = let tops = appendCruCtx (mbLift ghosts) (mbLift args) @@ -2427,15 +2417,15 @@ instance TransInfo info => -- | Lambda-abstraction over a permission lambdaPermTrans :: TransInfo info => String -> Mb ctx (ValuePerm a) -> - (PermTrans ctx a -> TransM info ctx OpenTerm) -> - TransM info ctx OpenTerm + (PermTrans ctx a -> TransM info ctx SpecTerm) -> + TransM info ctx SpecTerm lambdaPermTrans str p f = translate p >>= \tptrans -> lambdaTransM str tptrans f -- | Lambda-abstraction over a sequence of permissions lambdaPermCtx :: TransInfo info => Mb ctx (ValuePerms ps) -> - (PermTransCtx ctx ps -> TransM info ctx OpenTerm) -> - TransM info ctx OpenTerm + (PermTransCtx ctx ps -> TransM info ctx SpecTerm) -> + TransM info ctx SpecTerm lambdaPermCtx ps f = translate ps >>= \tptrans -> lambdaTransM "p" tptrans f @@ -2472,7 +2462,7 @@ translateRetType rets ret_perms = -- | Build the return type for the function resulting from an entrypoint translateEntryRetType :: TransInfo info => TypedEntry phase ext blocks tops rets args ghosts -> - TransM info ((tops :++: args) :++: ghosts) OpenTerm + TransM info ((tops :++: args) :++: ghosts) TypeDesc translateEntryRetType (TypedEntry {..} :: TypedEntry phase ext blocks tops rets args ghosts) = let mb_perms_out = @@ -2483,6 +2473,16 @@ translateEntryRetType (TypedEntry {..} translateRetType typedEntryRets mb_perms_out +{- +NOWNOW: +- change uses of TypeTrans to include the purity flag +- NOTE: PermExprs translate to pure terms / OpenTerms +- compReturnTypeM should return a TypeDesc +- need a variant of piTransM that builds TypeDescs +- update the translation of shapes and perms to use ETrans_Shape and ETrans_Perm +- IDEA: change LOwnedTransTerm to have a single PermTransM that returns a + PermTransCtx; also remove the vars input from PermTransInfo + ---------------------------------------------------------------------- -- * The Implication Translation Monad ---------------------------------------------------------------------- @@ -2603,8 +2603,8 @@ instance TransInfo (ImpTransInfo ext blocks tops rets ps) where 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 , .. } @@ -3441,8 +3441,9 @@ 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 @@ -4990,7 +4991,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 @@ -5183,7 +5184,8 @@ translateLLVMStmt mb_stmt m = case mbMatch mb_stmt of let ptrans = PTrans_Conj [APTrans_LLVMFunPtr (mbLift fun_tp) $ PTrans_Conj [APTrans_Fun fun_perm (Left i)]] in - withPermStackM (:>: Member_Base) (:>: extPermTrans ptrans) m + withPermStackM (:>: Member_Base) + (:>: extPermTrans ETrans_LLVM ptrans) m Just (_, Left _) -> error ("translateLLVMStmt: TypedLLVMResolveGlobal: " ++ " unexpected recursive call translation for symbol " @@ -5703,3 +5705,4 @@ translateCompletePureFun sc env ctx args ret = completeNormOpenTerm sc $ runNilTypeTransM env noChecks $ piExprCtx ctx $ arrowLRTPermCtx args $ typeTransTupleType <$> translate ret +-} From 8840f2901debb70193ec570ccec62592ae9d6ac4 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 21 Jul 2023 15:51:49 -0700 Subject: [PATCH 021/305] fixed compile error in LLVMGlobalConst.hs --- heapster-saw/src/Verifier/SAW/Heapster/LLVMGlobalConst.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/LLVMGlobalConst.hs b/heapster-saw/src/Verifier/SAW/Heapster/LLVMGlobalConst.hs index f470783359..c5f2807cc6 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/LLVMGlobalConst.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/LLVMGlobalConst.hs @@ -29,6 +29,7 @@ import Lang.Crucible.Types import Lang.Crucible.LLVM.DataLayout import Lang.Crucible.LLVM.MemModel +import Verifier.SAW.Name (mkSafeIdent) import Verifier.SAW.OpenTerm import Verifier.SAW.Term.Functor (ModuleName) import Verifier.SAW.SharedTerm From 70efba06234907e5a1f3d125a66509bfcfadc269 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 21 Jul 2023 15:52:39 -0700 Subject: [PATCH 022/305] Fixed one compile error --- heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 9131a047c7..f15781eecd 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -540,8 +540,8 @@ exprTransPureTypeTerms etrans = transPureTerms etrans -- | Map an 'ExprTransCtx' to the SAW core terms it contains, similarly to -- 'transPureTerms', except that all type descriptions are mapped to pure types, -- not terms of type @LetRecType@. Return 'Nothing' if this is not possible. -exprTransPureTypeTerms :: ExprTransCtx tps -> Maybe [OpenTerm] -exprTransPureTypeTerms = +exprCtxPureTypeTerms :: ExprTransCtx tps -> Maybe [OpenTerm] +exprCtxPureTypeTerms = fmap concat . sequence . RL.mapToList exprTransPureTypeTerms -- | Class for valid translation info types, which must contain at least a From 2f7150c3e39243160fe464c438f298d39aee168a Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Tue, 25 Jul 2023 18:07:07 -0700 Subject: [PATCH 023/305] added specTermType and failSpecTerm --- saw-core/src/Verifier/SAW/OpenTerm.hs | 20 +++++++++++++++----- 1 file changed, 15 insertions(+), 5 deletions(-) diff --git a/saw-core/src/Verifier/SAW/OpenTerm.hs b/saw-core/src/Verifier/SAW/OpenTerm.hs index fd2b911e3b..f158b26f1b 100644 --- a/saw-core/src/Verifier/SAW/OpenTerm.hs +++ b/saw-core/src/Verifier/SAW/OpenTerm.hs @@ -76,13 +76,13 @@ module Verifier.SAW.OpenTerm ( SpecTerm(), defineSpecOpenTerm, lambdaPureSpecTerm, lambdaPureSpecTermMulti, lambdaSpecTerm, lambdaSpecTermMulti, piSpecTerm, - applySpecTerm, applySpecTermMulti, openTermSpecTerm, - globalSpecTerm, applyGlobalSpecTerm, lrtToTypeSpecTerm, + applySpecTerm, applySpecTermMulti, openTermSpecTerm, specTermType, + failSpecTerm, globalSpecTerm, applyGlobalSpecTerm, lrtToTypeSpecTerm, mkBaseClosSpecTerm, mkFreshClosSpecTerm, callClosSpecTerm, applyClosSpecTerm, callDefSpecTerm, specMTypeSpecTerm, returnSpecTerm, bindSpecTerm, - errorSpecTerm, flatSpecTerm, unitSpecTerm, pairSpecTerm, pairTypeSpecTerm, - pairLeftSpecTerm, pairRightSpecTerm, ctorSpecTerm, dataTypeSpecTerm, - letSpecTerm, sawLetSpecTerm + errorSpecTerm, flatSpecTerm, natSpecTerm, unitSpecTerm, pairSpecTerm, + pairTypeSpecTerm, pairLeftSpecTerm, pairRightSpecTerm, ctorSpecTerm, + dataTypeSpecTerm, letSpecTerm, sawLetSpecTerm ) where import qualified Data.Vector as V @@ -730,6 +730,16 @@ openTermSpecTerm t = if length ctx == ctx_len then unOpenTerm t else panic "openTermSpecTerm" ["Typing context not of expected length"] +-- | Return the type of a 'SpecTerm' as a 'SpecTerm' +specTermType :: SpecTerm -> SpecTerm +specTermType (SpecTerm m) = + SpecTerm $ flip fmap m $ \info_tm -> fmap openTermType info_tm + +-- | Build a 'SpecTerm' that 'fail's in the underlying monad when completed +failSpecTerm :: String -> SpecTerm +failSpecTerm = openTermSpecTerm . failOpenTerm + +-- | Build a 'SpecTerm' for a natural number literal natSpecTerm :: Natural -> SpecTerm natSpecTerm n = openTermSpecTerm $ natOpenTerm n From 48aae081eb37af78def23adf40f9d8bd2951d64b Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Tue, 25 Jul 2023 18:07:25 -0700 Subject: [PATCH 024/305] fixed some formatting --- heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs index 5e9b04f314..28585ab3fb 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs @@ -2715,7 +2715,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 From 1b6b3c3fb8ec414219fc21ddbf1bdee2facbbab4 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Tue, 25 Jul 2023 18:07:42 -0700 Subject: [PATCH 025/305] more progress getting SAWTranslation.hs to compile --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 385 ++++++++++++------ 1 file changed, 270 insertions(+), 115 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index f15781eecd..dc9ddb5830 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -68,6 +68,7 @@ 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.OpenTerm import Verifier.SAW.Term.Functor import Verifier.SAW.SharedTerm @@ -111,6 +112,11 @@ data TypeDesc = TypeDescPure OpenTerm | TypeDescLRT OpenTerm SpecTerm +-- | Test if a 'TypeDesc' is pure +typeDescIsPure :: TypeDesc -> Bool +typeDescIsPure (TypeDescPure _) = True +typeDescIsPure (TypeDescLRT _ _) = False + -- | Get the type described by a 'TypeDesc' typeDescType :: TypeDesc -> SpecTerm typeDescType (TypeDescPure tp) = openTermSpecTerm tp @@ -157,7 +163,7 @@ bvVecTypeDesc :: OpenTerm -> OpenTerm -> TypeDesc -> TypeDesc bvVecTypeDesc w_term len_term (TypeDescPure elem_tp) = TypeDescPure (applyGlobalOpenTerm "Prelude.BVVec" [w_term, len_term, elem_tp]) -bvVecTypeDesc w_term len_term (TypeDescImpure lrt elem_tpx) = +bvVecTypeDesc w_term len_term (TypeDescLRT lrt elem_tpx) = TypeDescLRT (applyGlobalOpenTerm "Prelude.LRT_BVVec" [w_term, len_term, lrt]) (applyGlobalOpenTerm "Prelude.BVVec" [w_term, len_term, elem_tp]) @@ -443,8 +449,6 @@ data ExprTrans (a :: CrucibleType) where -- | A context mapping bound names to their type-level SAW translations type ExprTransCtx = RAssign ExprTrans --- | A 'TypeTrans' that is relative to an expression context -type RelTypeTrans ectx tp = ExprTransCtx ectx -> TypeTrans tp -- | Destruct an 'ExprTrans' of shape type to a type description unETransShape :: ExprTrans (LLVMShapeType w) -> TypeDesc @@ -452,6 +456,12 @@ unETransShape (ETrans_Shape d) = d unETransShape (ETrans_Term _) = panic "unETransShape" ["Incorrect translation of a shape expression"] +-- | Destruct an 'ExprTrans' of permission type to a type description +unETransPerm :: ExprTrans (ValuePermType a) -> TypeDesc +unETransPerm (ETrans_Perm d) = d +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 @@ -495,7 +505,13 @@ instance IsTermTrans tr => IsTermTrans [tr] where instance IsPureTrans tr => IsPureTrans [tr] where transPureTerms = concatMap transPureTerms -instance IsTermTrans (TypeTrans tr) where +instance IsPureTrans (TypeTrans 'True tr) where + transPureTerms = typeTransTypes + +instance IsTermTrans (TypeTrans 'True tr) where + transTerms = map openTermSpecTerm . transPureTerms + +instance IsTermTrans (TypeTrans 'False tr) where transTerms = typeTransTypes instance IsPureTrans (ExprTrans tp) where @@ -527,6 +543,31 @@ instance IsTermTrans (ExprTransCtx ctx) where exprCtxToTerms :: ExprTransCtx tps -> [SpecTerm] exprCtxToTerms = concat . RL.mapToList transTerms +-- | Map an 'ExprTrans' to its type translation +exprTransType :: ExprTrans tp -> PureTypeTrans (ExprTrans tp) +exprTransType ETrans_LLVM = mkPureTypeTrans0 ETrans_LLVM +exprTransType ETrans_LLVMBlock = mkPureTypeTrans0 ETrans_LLVMBlock +exprTransType ETrans_LLVMFrame = mkPureTypeTrans0 ETrans_LLVMFrame +exprTransType ETrans_Lifetime = mkPureTypeTrans0 ETrans_Lifetime +exprTransType ETrans_RWModality = mkPureTypeTrans0 ETrans_RWModality +exprTransType (ETrans_Struct etranss) = ETrans_Struct <$> exprCtxType etranss +exprTransType ETrans_Fun = mkPureTypeTrans0 ETrans_Fun +exprTransType ETrans_Unit = mkPureTypeTrans0 ETrans_Unit +exprTransType ETrans_AnyVector = mkPureTypeTrans0 ETrans_AnyVector +exprTransType (ETrans_Shape _) = + mkPureTypeTrans1 (dataTypeOpenTerm "Prelude.LetRecType" []) + (ETrans_Shape . typeDescFromLRT) +exprTransType (ETrans_Perm _) = + mkPureTypeTrans1 (dataTypeOpenTerm "Prelude.LetRecType" []) + (ETrans_Perm . typeDescFromLRT) +exprTransType (ETrans_Term t) = mkPureTypeTrans1 (openTermType t) ETrans_Term + +-- | Map a context of expression translation to a list of the SAW core types of +-- all the terms it contains +exprCtxType :: ExprTransCtx ctx -> PureTypeTrans (ExprTransCtx ctx) +exprCtxType MNil = mkPureTypeTrans0 MNil +exprCtxType (ectx :>: e) = (:>) <$> exprCtxType ectx <*> exprTransType e + -- | Map an 'ExprTrans' to the SAW core terms it contains, similarly to -- 'transPureTerms', except that all type descriptions are mapped to pure types, -- not terms of type @LetRecType@. Return 'Nothing' if this is not possible. @@ -588,7 +629,7 @@ inExtMultiTransM (ctx :>: etrans) m = -- | Run a translation computation in an extended context, where we sawLet-bind any -- term in the supplied expression translation -inExtTransSAWLetBindM :: TransInfo info => TypeTrans 'True (ExprTrans tp) -> +inExtTransSAWLetBindM :: TransInfo info => PureTypeTrans (ExprTrans tp) -> SpecTerm -> ExprTrans tp -> TransM info (ctx :> tp) SpecTerm -> TransM info ctx SpecTerm @@ -810,7 +851,7 @@ rightTrans tp_l tp_r tr = -- | Eliminate a SAW @Either@ type eitherElimTransM :: ImpTypeTrans trL -> ImpTypeTrans trR -> - TypeTrans tr -> (trL -> TransM info ctx SpecTerm) -> + ImpTypeTrans tr -> (trL -> TransM info ctx SpecTerm) -> (trR -> TransM info ctx SpecTerm) -> SpecTerm -> TransM info ctx SpecTerm eitherElimTransM tp_l tp_r tp_ret fl fr eith = @@ -865,8 +906,8 @@ sigmaTypePermTransM :: TransInfo info => String -> TransM info ctx TypeDesc sigmaTypePermTransM x ttrans mb_p = case mbMatch mb_p of [nuMP| ValPerm_Eq _ |] -> return $ TypeDescPure $ typeTransTupleType ttrans - _ -> sigmaTypeTransM x ttrans (isPurePerm mb_p) (flip inExtTransM $ - translate mb_p) + _ -> sigmaTypeTransM x ttrans (hasPureTrans mb_p) (flip inExtTransM $ + translate mb_p) -- | 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 @@ -885,7 +926,7 @@ sigmaTransM x tp_l tp_r lhs rhs_m = [typeTransTupleType tp_l, tp_r_trm, transTupleTerm lhs, rhs]) -- | Like `sigmaTransM`, but translates `exists x.eq(y)` into just `x` -sigmaPermTransM :: TransInfo info => String -> TypeTrans (ExprTrans a) -> +sigmaPermTransM :: TransInfo info => String -> PureTypeTrans (ExprTrans a) -> Mb (ctx :> a) (ValuePerm b) -> ExprTrans a -> TransM info ctx (PermTrans ctx b) -> TransM info ctx SpecTerm @@ -981,6 +1022,17 @@ instance (Translate info ctx a tr, NuMatching a) => Translate info ctx [a] [tr] where translate = mapM translate . mbList +-- | Generic function for testing if a particular constuct translates to a pure +-- term in the sense of not depending on the current @FunStack@ or event type, +-- meaning it is an 'OpenTerm', and also that it only contains pure 'TypeDesc's, +-- i.e., ones that do not contain closures. This is used as an optimization for +-- translating sigma types to pure types when their right-hand sides are pure. +class HasPureTrans a where + hasPureTrans :: Mb (ctx :: RList CrucibleType) a -> Bool + +instance HasPureTrans a => HasPureTrans [a] where + hasPureTrans xs = error "FIXME HERE NOWNOW" + ---------------------------------------------------------------------- -- * Translating Types @@ -1135,7 +1187,7 @@ instance TransInfo info => instance TransInfo info => - Translate info ctx (CruCtx as) (TypeTrans (ExprTransCtx as)) where + Translate info ctx (CruCtx as) (PureTypeTrans (ExprTransCtx as)) where translate mb_ctx = case mbMatch mb_ctx of [nuMP| CruCtxNil |] -> return $ mkPureTypeTrans0 MNil [nuMP| CruCtxCons ctx tp |] -> @@ -1291,16 +1343,16 @@ instance TransInfo info => [nuMP| OpaqueShapeBody _ trans_id |] -> exprTransPureTypeTerms <$> translate args >>= \case Just args_trans -> - ETrans_Shape $ applyOpenTermMulti (globalOpenTerm $ - mbLift trans_id) args_trans + ETrans_Shape $ TypeDescPure $ + applyOpenTermMulti (globalOpenTerm $ mbLift trans_id) args_trans Nothing -> panic "translate" ["Heapster cannot yet handle opaque shapes over impure types"] [nuMP| RecShapeBody _ trans_id _ |] -> exprTransPureTypeTerms <$> translate args >>= \case Just args_trans -> - ETrans_Shape $ applyOpenTermMulti (globalOpenTerm $ - mbLift trans_id) args_trans + ETrans_Shape $ TypeDescPure $ + applyOpenTermMulti (globalOpenTerm $ mbLift trans_id) args_trans Nothing -> panic "translate" ["Heapster cannot yet handle recursive shapes over impure types"] @@ -1324,10 +1376,10 @@ instance TransInfo info => do tp_trans <- translate $ fmap bindingType mb_sh ETrans_Shape <$> sigmaTypeTransM "x_exsh" tp_trans - (isPureShape $ mbCombine RL.typeCtxProxies mb_sh) $ \e -> + (hasPureTrans $ mbCombine RL.typeCtxProxies mb_sh) $ \e -> inExtTransM e (translateShape $ mbCombine RL.typeCtxProxies mb_sh) [nuMP| PExpr_FalseShape |] -> - return $ ETrans_Shape $ TypeTransPure $ globalOpenTerm "Prelude.FalseProp" + return $ ETrans_Shape $ TypeDescPure $ globalOpenTerm "Prelude.FalseProp" [nuMP| PExpr_ValPerm p |] -> ETrans_Perm <$> tupleOfTypeDescs <$> typeTransDescs <$> translate p @@ -1359,6 +1411,42 @@ translateShape :: (TransInfo info, HasCallStack) => TransM info ctx TypeDesc translateShape mb_e = unETransShape <$> translate mb_e +instance HasPureTrans (PermExpr a) where + hasPureTrans mb_e = case mbMatch mb_e of + [nuMP| PExpr_Var _ |] -> + -- Variables of shape or permission type always have to quantify over + -- arbitrary @LetRecType@s, and so are considered impure + -- FIXME: should be type-based; only shape or perm variable are impure! + False + [nuMP| PExpr_Struct mb_es |] -> hasPureTrans mb_es + [nuMP| PExpr_PermListCons _ _ p rest |] -> + hasPureTrans p && hasPureTrans rest + [nuMP| PExpr_EmptyShape |] -> True + [nuMP| PExpr_NamedShape _ _ nmsh args |] -> + case mbMatch $ fmap namedShapeBody nmsh of + [nuMP| DefinedShapeBody _ |] -> + hasPureTrans (mbMap2 unfoldNamedShape nmsh args) + [nuMP| OpaqueShapeBody _ _ |] -> hasPureTrans args + [nuMP| RecShapeBody _ _ _ |] -> hasPureTrans args + [nuMP| PExpr_EqShape _ _ |] -> True + [nuMP| PExpr_PtrShape _ _ sh |] -> hasPureTrans sh + [nuMP| PExpr_FieldShape fsh |] -> hasPureTrans fsh + [nuMP| PExpr_ArrayShape mb_len _ sh |] -> hasPureTrans sh + [nuMP| PExpr_SeqShape sh1 sh2 |] -> + hasPureTrans sh1 && hasPureTrans sh2 + [nuMP| PExpr_OrShape sh1 sh2 |] -> + hasPureTrans sh1 && hasPureTrans sh2 + [nuMP| PExpr_ExShape mb_sh |] -> + hasPureTrans $ mbCombine RL.typeCtxProxies mb_sh + [nuMP| PExpr_FalseShape |] -> True + [nuMP| PExpr_ValPerm p |] -> hasPureTrans p + [nuMP| _ |] -> True + +instance HasPureTrans (PermExprs as) where + hasPureTrans e = case mbMatch e of + [nuMP| MNil |] -> True + [nuMP| es :>: e' |] -> hasPureTrans es && hasPureTrans e' + ---------------------------------------------------------------------- -- * Translating Permissions to Types @@ -1389,7 +1477,7 @@ data PermTrans (ctx :: RList CrucibleType) (a :: CrucibleType) where PermTrans ctx a -> PermTrans ctx a -- | The translation for disjunctive, existential, and named permissions - PTrans_Term :: Mb ctx (ValuePerm a) -> OpenTerm -> PermTrans ctx a + PTrans_Term :: Mb ctx (ValuePerm a) -> SpecTerm -> PermTrans ctx a -- | The 'PermTrans' type for atomic permissions @@ -1410,7 +1498,7 @@ data AtomicPermTrans ctx a where -- | The translation of an LLVM block permission is an element of the -- translation of its shape to a type APTrans_LLVMBlock :: (1 <= w, KnownNat w) => - Mb ctx (LLVMBlockPerm w) -> OpenTerm -> + Mb ctx (LLVMBlockPerm w) -> SpecTerm -> AtomicPermTrans ctx (LLVMPointerType w) -- | LLVM free permissions have no computational content @@ -1432,13 +1520,13 @@ data AtomicPermTrans ctx a where -- | The translation of an LLVMBlockShape permission is an element of the -- translation of its shape to a type APTrans_LLVMBlockShape :: (1 <= w, KnownNat w) => - Mb ctx (PermExpr (LLVMShapeType w)) -> OpenTerm -> + Mb ctx (PermExpr (LLVMShapeType w)) -> SpecTerm -> AtomicPermTrans ctx (LLVMBlockType w) -- | Perm_NamedConj permissions are a permission + a term APTrans_NamedConj :: NameSortIsConj ns ~ 'True => NamedPermName ns args a -> Mb ctx (PermExprs args) -> - Mb ctx (PermOffset a) -> OpenTerm -> + Mb ctx (PermOffset a) -> SpecTerm -> AtomicPermTrans ctx a -- | Defined Perm_NamedConj permissions are just a wrapper around the @@ -1458,13 +1546,11 @@ data AtomicPermTrans ctx a where -- 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) -> - ExprTransCtx ctx -> PermTransCtx ctx ps_extra -> - RAssign (Member ctx) ps_extra -> - RelTypeTrans ctx (PermTransCtx ctx ps_in) -> - RelTypeTrans ctx (PermTransCtx ctx ps_out) -> - RelTypeTrans ctx (PermTransCtx ctx ps_extra) -> - LOwnedTransTerm ctx ps_extra ps_in ps_out -> + Mb ctx (ExprPerms ps_in) -> Mb ctx (ExprPerms ps_out) -> ExprTransCtx ctx -> + PermTransCtx ctx ps_extra -> RAssign (Member ctx) ps_extra -> + RelPermTransCtx ctx ps_in -> RelPermTransCtx ctx ps_out -> + RelPermTransCtx ctx ps_extra -> + LOwnedTransTerm ctx (ps_extra :++: ps_in) ps_out -> AtomicPermTrans ctx LifetimeType -- | Simple @lowned@ permissions have no translation, because they represent @@ -1488,7 +1574,7 @@ data AtomicPermTrans ctx a where -- functional type or a recursive call to the @n@th function in the most -- recently bound frame of recursive functions APTrans_Fun :: Mb ctx (FunPerm ghosts (CtxToRList cargs) gouts ret) -> - Either Natural OpenTerm -> + Either Natural SpecTerm -> AtomicPermTrans ctx (FunctionHandleType cargs ret) -- | Propositional permissions are represented by a SAW term @@ -1548,7 +1634,7 @@ data LLVMArrayBorrowTrans ctx w = -} -newtype PermTransInfo ps ctx = +data PermTransInfo ps ctx = PermTransInfo { ptransInfoECtx :: ExprTransCtx ctx, ptransInfoPCtx :: PermTransCtx ctx ps, ptransInfoRetType :: SpecTerm } @@ -1558,7 +1644,8 @@ ptInfoSetPerms :: PermTransCtx ctx ps' -> PermTransInfo ps ctx -> ptInfoSetPerms ps' (PermTransInfo {..}) = PermTransInfo { ptransInfoPCtx = ps', ..} -ptInfoSplit :: RAssign any ps2 -> PermTransInfo (ps1 :++: ps2) ctx -> +ptInfoSplit :: Proxy ps1 -> RAssign any ps2 -> + PermTransInfo (ps1 :++: ps2) ctx -> (PermTransInfo ps1 ctx, PermTransInfo ps2 ctx) ptInfoSplit = error "FIXME HERE NOWNOW" @@ -1571,17 +1658,17 @@ ptInfoAppend :: PermTransInfo ps1 ctx -> PermTransInfo ps2 ctx -> PermTransInfo (ps1 :++: ps2) ctx ptInfoAppend info1 info2 = ptInfoAppendPerms info1 (ptransInfoPCtx info2) -type PermTransM ps ctx = TransM (PermTransInfo ps) +type PermTransM ps = TransM (PermTransInfo ps) -newtype LOwnedTransTerm ctx ps_extra ps_in ps_out = +newtype LOwnedTransTerm ctx ps_in ps_out = LOwnedTransTerm { unLOwnedTransTerm :: forall ctx'. ExprTransCtx ctx' -> PermTransM ps_in (ctx :++: ctx') (PermTransCtx (ctx :++: ctx') ps_out) } -lownedTransTermTerm :: TypeTrans (ExprTransCtx ctx) -> - RelTypeTrans ctx (PermTransCtx ctx ps_in) -> - RelTypeTrans ctx (PermTransCtx ctx ps_out) -> +lownedTransTermTerm :: PureTypeTrans (ExprTransCtx ctx) -> + RelPermTransCtx ctx ps_in -> + RelPermTransCtx ctx ps_out -> LOwnedTransTerm ctx ps_in ps_out -> SpecTerm lownedTransTermTerm ectx ps_inF ps_outF t = lambdaTrans "e" ectx $ \exprs -> @@ -1595,7 +1682,7 @@ extLOwnedTransTerm' :: Proxy ctx -> ExprTrans tp -> LOwnedTransTerm ctx ps_in ps_out -> LOwnedTransTerm (ctx :> tp) ps_in ps_out extLOwnedTransTerm' ctx tp (LOwnedTransTerm f) = - LOwnedTransTerm $ \ ctx' -> case appendRNilConsEq ctx tp ctx' of + LOwnedTransTerm $ \ ctx' -> case RL.appendRNilConsEq ctx tp ctx' of Refl -> f (RL.append (MNil :>: tp) ctx') extLOwnedTransTerm :: ExprTrans tp -> @@ -1607,34 +1694,34 @@ emptyLOwnedTransTerm :: LOwnedTransTerm ctx RNil RNil emptyLOwnedTransTerm = LOwnedTransTerm $ \_ -> return MNil elimSimplLOwnedTransTerm :: (forall ctx'. ExprTransCtx ctx' -> - TypeTrans (PermTransCtx (ctx :++: ctx') ps)) -> + ImpTypeTrans (PermTransCtx (ctx :++: ctx') ps)) -> LOwnedTransTerm ctx ps ps elimSimplLOwnedTransTerm ps = LOwnedTransTerm $ \ctx' -> ptransInfoPCtx <$> ask weakenLOwnedTransTerm :: (forall ctx'. ExprTransCtx ctx' -> - TypeTrans (PermTrans (ctx :++: ctx') tp)) -> + ImpTypeTrans (PermTrans (ctx :++: ctx') tp)) -> LOwnedTransTerm ctx ps_in ps_out -> LOwnedTransTerm ctx (ps_in :> tp) (ps_out :> tp) weakenLOwnedTransTerm tp t = LOwnedTransTerm $ \ectx' -> - do (info_ps, info_tp) <- ptInfoSplit (MNil :>: Proxy) <$> ask + do (info_ps, info_tp) <- ptInfoSplit Proxy (MNil :>: Proxy) <$> ask pctx <- withInfoM (const info_ps) (unLOwnedTransTerm t ectx') return (RL.append pctx $ ptransInfoPCtx info_tp) bindLOwnedTransTerm :: - RAssign any ps_extra2 -> RAssign any ps_in -> + Proxy ps_extra1 -> RAssign any ps_extra2 -> RAssign any 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 -bindLOwnedTransTerm prx_extra2 prx_in t1 t2 = +bindLOwnedTransTerm prx_extra1 prx_extra2 prx_in t1 t2 = LOwnedTransTerm $ \ectx' -> - do (info_extra, info_in) <- ptInfoSplit prx_in <$> ask - let (info_extra1, info_extra2) = ptInfoSplit prx_extra2 <$> ask + do (info_extra, info_in) <- ptInfoSplit Proxy prx_in <$> ask + let (info_extra1, info_extra2) = ptInfoSplit prx_extra1 prx_extra2 info_extra pctx_mid <- - withInfoM (const $ ptInfoAppend info_extra1 info_in) (unLOwnedTransTerm t1) - withInfoM (const $ ptInfoAppendPerms info_extra2 pctx_mid) (unLOwnedTransTerm t2) + withInfoM (const $ ptInfoAppend info_extra1 info_in) (unLOwnedTransTerm t1 ectx') + withInfoM (const $ ptInfoAppendPerms info_extra2 pctx_mid) (unLOwnedTransTerm t2 ectx') -- | The translation of the vacuously true permission @@ -1644,7 +1731,7 @@ pattern PTrans_True = PTrans_Conj [] -- | Build a type translation for a disjunctive, existential, or named -- permission that uses the 'PTrans_Term' constructor mkPermTypeTrans1 :: Mb ctx (ValuePerm a) -> TypeDesc -> - TypeTrans (PermTrans ctx a) + ImpTypeTrans (PermTrans ctx a) mkPermTypeTrans1 mb_p tp = mkImpTypeTrans1 tp (PTrans_Term mb_p) -- | Extract the body of a conjunction or raise an error @@ -1693,6 +1780,15 @@ unPTransLLVMArray str _ = error (str ++ ": not an LLVM array permission") -- | A context mapping bound names to their perm translations type PermTransCtx ctx ps = RAssign (PermTrans ctx) ps +-- | A 'TypeTrans' for a 'PermTransCtx' that is relative to an expr context +type RelPermTransCtx ctx ps = + ExprTransCtx ctx -> ImpTypeTrans (PermTransCtx ctx ps) + +-- | Append two 'RelPermTransCtx's +appRelPermTransCtx :: RelPermTransCtx ctx ps1 -> RelPermTransCtx ctx ps2 -> + RelPermTransCtx ctx (ps1 :++: ps2) +appRelPermTransCtx tps1 tps2 = \ectx -> RL.append <$> tps1 ectx <*> tps2 ectx + -- | Build a permission translation context with just @true@ permissions truePermTransCtx :: CruCtx ps -> PermTransCtx ctx ps truePermTransCtx CruCtxNil = MNil @@ -1727,13 +1823,14 @@ instance IsTermTrans (AtomicPermTrans ctx a) where transTerms (APTrans_NamedConj _ _ _ t) = [t] transTerms (APTrans_DefinedNamedConj _ _ _ ptrans) = transTerms ptrans transTerms (APTrans_LLVMFrame _) = [] - transTerms (APTrans_LOwned _ _ _ _ _ ectx ps_in ps_out ps_extra args_extra f) = - let etps = exprCtxTypes ectx - ps_extra_in = RL.append <$> ps_extra <*> ps_in - lrt = piExprPermLRT etps ps_extra_in ps_out - fun_tm = error "FIXME HERE NOWNOW" in - applyClosSpecTerm lrt (mkFreshClosSpec lrt (const fun_tm)) - (transTerms ectx ++ transTerms args_extra) + transTerms (APTrans_LOwned _ _ _ _ _ + ectx ps_extra _ tps_in tps_out tps_extra lott) = + let etps = exprCtxType ectx + tps_extra_in = appRelPermTransCtx tps_extra tps_in + lrt = piExprPermLRT etps tps_extra_in tps_out + fun_tm = lownedTransTermTerm etps tps_extra_in tps_out lott in + [applyClosSpecTerm lrt (mkFreshClosSpecTerm lrt (const fun_tm)) + (transTerms ectx ++ transTerms ps_extra)] transTerms (APTrans_LOwnedSimple _ _) = [] transTerms (APTrans_LCurrent _) = [] transTerms APTrans_LFinished = [] @@ -1743,7 +1840,7 @@ instance IsTermTrans (AtomicPermTrans ctx a) where -- 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 + [failSpecTerm ("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")] @@ -1767,9 +1864,9 @@ instance IsTermTrans (LLVMArrayBorrowTrans ctx w) where -} --- | Map a context of perm translations to a list of 'OpenTerm's, dropping the +-- | Map a context of perm translations to a list of 'SpecTerm's, dropping the -- "invisible" ones whose permissions are translated to 'Nothing' -permCtxToTerms :: PermTransCtx ctx tps -> [OpenTerm] +permCtxToTerms :: PermTransCtx ctx tps -> [SpecTerm] permCtxToTerms = concat . RL.mapToList transTerms -- | Extract out the permission of a permission translation result @@ -1800,7 +1897,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 @@ -1869,9 +1967,9 @@ instance ExtPermTrans AtomicPermTrans where extPermTrans e (APTrans_LOwned ls tps_in tps_out ps_in ps_out ectx ps_extra vars_extra ptrans_in ptrans_out ptrans_extra t) = APTrans_LOwned (extMb ls) tps_in tps_out (extMb ps_in) (extMb ps_out) - (ectx :>: e) (extPermTransCtx ps_extra) (RL.map Member_Step vars_extra) - (extRelTypeTrans ptrans_in) (extRelTypeTrans ptrans_out) - (extRelTypeTrans ptrans_extra) (extLOwnedTransTerm e t) + (ectx :>: e) (extPermTransCtx e ps_extra) (RL.map Member_Step vars_extra) + (extRelPermTransCtx e ptrans_in) (extRelPermTransCtx e ptrans_out) + (extRelPermTransCtx e ptrans_extra) (extLOwnedTransTerm e t) extPermTrans _ (APTrans_LOwnedSimple tps lops) = APTrans_LOwnedSimple tps (extMb lops) extPermTrans _ (APTrans_LCurrent p) = APTrans_LCurrent $ extMb p @@ -1905,6 +2003,12 @@ extPermTransCtx :: ExprTrans tp -> PermTransCtx ctx ps -> PermTransCtx (ctx :> tp) ps extPermTransCtx e = RL.map (extPermTrans e) +-- | Extend the context of a 'RelPermTransCtx' +extRelPermTransCtx :: ExprTrans tp -> RelPermTransCtx ctx ps -> + RelPermTransCtx (ctx :> tp) ps +extRelPermTransCtx e rel_tp = fmap (extPermTransCtx e) . rel_tp . RL.tail + + -- | Add another permission translation to a permission translation context consPermTransCtx :: PermTransCtx ctx ps -> PermTrans ctx a -> PermTransCtx ctx (ps :> a) @@ -2006,7 +2110,7 @@ llvmArrayTransRemBorrow b_trans arr_trans = -- as returned by 'llvmArrayIndexInArray'. Note that the first proposition -- should always be that the cell number is <= the array length. getLLVMArrayTransCell :: (1 <= w, KnownNat w) => LLVMArrayPermTrans ctx w -> - Mb ctx (PermExpr (BVType w)) -> OpenTerm -> + Mb ctx (PermExpr (BVType w)) -> SpecTerm -> [BVPropTrans ctx w] -> AtomicPermTrans ctx (LLVMPointerType w) getLLVMArrayTransCell arr_trans mb_cell cell_tm (BVPropTrans _ in_rng_pf:_) = @@ -2018,8 +2122,8 @@ getLLVMArrayTransCell arr_trans mb_cell cell_tm (BVPropTrans _ in_rng_pf:_) = offsetLLVMAtomicPermTrans (mbMap2 llvmArrayCellToOffset (llvmArrayTransPerm arr_trans) mb_cell) $ typeTransF (llvmArrayTransHeadCell arr_trans) - [applyOpenTermMulti (globalOpenTerm "Prelude.atBVVec") - [natOpenTerm w, llvmArrayTransLen arr_trans, + [applyGlobalSpecTerm "Prelude.atBVVec" + [natSpecTerm w, openTermSpecTerm (llvmArrayTransLen arr_trans), llvmArrayTransCellType arr_trans, llvmArrayTransTerm arr_trans, cell_tm, in_rng_pf]] getLLVMArrayTransCell _ _ _ _ = @@ -2029,14 +2133,14 @@ 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 -> - OpenTerm -> AtomicPermTrans ctx (LLVMPointerType w) -> + SpecTerm -> AtomicPermTrans ctx (LLVMPointerType w) -> LLVMArrayPermTrans ctx w setLLVMArrayTransCell arr_trans cell_tm cell_value = let w = fromInteger $ natVal arr_trans in arr_trans { llvmArrayTransTerm = - applyOpenTermMulti (globalOpenTerm "Prelude.updBVVec") - [natOpenTerm w, llvmArrayTransLen arr_trans, + applyGlobalSpecTerm "Prelude.updBVVec" + [natSpecTerm w, openTermSpecTerm (llvmArrayTransLen arr_trans), llvmArrayTransCellType arr_trans, llvmArrayTransTerm arr_trans, cell_tm, transTerm1 cell_value] } @@ -2047,14 +2151,13 @@ setLLVMArrayTransCell arr_trans cell_tm cell_value = -- by 'llvmArrayCellsInArray'. Note that the first two of these propositions are -- those returned by 'bvPropRangeSubset'. getLLVMArrayTransSlice :: (1 <= w, KnownNat w) => LLVMArrayPermTrans ctx w -> - TypeTrans (LLVMArrayPermTrans ctx w) -> + ImpTypeTrans (LLVMArrayPermTrans ctx w) -> BVRangeTrans ctx w -> [BVPropTrans ctx w] -> LLVMArrayPermTrans ctx w getLLVMArrayTransSlice arr_trans sub_arr_tp rng_trans prop_transs = let w = fromInteger $ natVal arr_trans - _mb_ap = llvmArrayTransPerm arr_trans elem_tp = llvmArrayTransCellType arr_trans - len_tm = llvmArrayTransLen arr_trans + len_tm = openTermSpecTerm $ llvmArrayTransLen arr_trans v_tm = llvmArrayTransTerm arr_trans off_tm = transTerm1 $ bvRangeTransOff rng_trans len'_tm = transTerm1 $ bvRangeTransLen rng_trans @@ -2062,29 +2165,26 @@ getLLVMArrayTransSlice arr_trans sub_arr_tp rng_trans prop_transs = BVPropTrans _ p1_tm = p1_trans BVPropTrans _ p2_tm = p2_trans in typeTransF sub_arr_tp - [applyOpenTermMulti - (globalOpenTerm "Prelude.sliceBVVec") - [natOpenTerm w, len_tm, elem_tp, off_tm, len'_tm, p1_tm, p2_tm, v_tm]] + [applyGlobalSpecTerm "Prelude.sliceBVVec" + [natSpecTerm w, len_tm, elem_tp, off_tm, len'_tm, p1_tm, p2_tm, v_tm]] -- | Write a slice (= a sub-array) of the translation of an LLVM array -- permission given the translation of the slice and of the offset of that slice -- in the larger array setLLVMArrayTransSlice :: (1 <= w, KnownNat w) => LLVMArrayPermTrans ctx w -> - LLVMArrayPermTrans ctx w -> OpenTerm -> + LLVMArrayPermTrans ctx w -> SpecTerm -> 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 + len_tm = openTermSpecTerm $ llvmArrayTransLen arr_trans arr_tm = llvmArrayTransTerm arr_trans - len'_tm = llvmArrayTransLen sub_arr_trans + len'_tm = openTermSpecTerm $ llvmArrayTransLen sub_arr_trans sub_arr_tm = llvmArrayTransTerm sub_arr_trans in arr_trans { llvmArrayTransTerm = - applyOpenTermMulti - (globalOpenTerm "Prelude.updSliceBVVec") - [natOpenTerm w, len_tm, elem_tp, arr_tm, off_tm, len'_tm, sub_arr_tm] } + applyGlobalSpecTerm "Prelude.updSliceBVVec" + [natSpecTerm 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 @@ -2166,8 +2266,8 @@ instance (1 <= w, KnownNat w, TransInfo info) => translate prop = case mbMatch prop of [nuMP| BVProp_Eq e1 e2 |] -> do let w = natVal4 e1 - t1 <- translate1 e1 - t2 <- translate1 e2 + t1 <- translate1Pure e1 + t2 <- translate1Pure e2 return $ mkBVPropTrans prop $ dataTypeOpenTerm "Prelude.Eq" [applyOpenTermMulti (globalOpenTerm "Prelude.Vec") @@ -2182,8 +2282,8 @@ instance (1 <= w, KnownNat w, TransInfo info) => [nuMP| BVProp_ULt e1 e2 |] -> do let w = natVal4 e1 - t1 <- translate1 e1 - t2 <- translate1 e2 + t1 <- translate1Pure e1 + t2 <- translate1Pure e2 return $ mkBVPropTrans prop $ dataTypeOpenTerm "Prelude.Eq" [globalOpenTerm "Prelude.Bool", @@ -2192,8 +2292,8 @@ instance (1 <= w, KnownNat w, TransInfo info) => [nuMP| BVProp_ULeq e1 e2 |] -> do let w = natVal4 e1 - t1 <- translate1 e1 - t2 <- translate1 e2 + t1 <- translate1Pure e1 + t2 <- translate1Pure e2 return $ mkBVPropTrans prop $ dataTypeOpenTerm "Prelude.Eq" [globalOpenTerm "Prelude.Bool", @@ -2202,9 +2302,9 @@ instance (1 <= w, KnownNat w, TransInfo info) => [nuMP| BVProp_ULeq_Diff e1 e2 e3 |] -> do let w = natVal4 e1 - t1 <- translate1 e1 - t2 <- translate1 e2 - t3 <- translate1 e3 + t1 <- translate1Pure e1 + t2 <- translate1Pure e2 + t3 <- translate1Pure e3 return $ mkBVPropTrans prop $ dataTypeOpenTerm "Prelude.Eq" [globalOpenTerm "Prelude.Bool", @@ -2237,16 +2337,25 @@ 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)) + exprCtxPureTypeTerms <$> translate args >>= \case + Just args_trans -> + return $ mkPermTypeTrans1 p $ TypeDescPure $ + applyGlobalOpenTerm (opaquePermTrans op) (transPureTerms + args_trans) + Nothing -> + panic "translate" + ["Heapster cannot yet handle opaque permissions over impure types"] Just (NamedPerm_Rec rp) -> - return $ mkPermTypeTrans1 p (applyOpenTermMulti - (globalOpenTerm $ recPermTransType rp) - (transTerms args_trans)) + exprCtxPureTypeTerms <$> translate args >>= \case + Just args_trans -> + return $ mkPermTypeTrans1 p $ TypeDescPure $ + applyOpenTermMulti (globalOpenTerm $ + recPermTransType rp) (transPureTerms args_trans) + Nothing -> + panic "translate" + ["Heapster cannot yet handle recursive permissions over impure types"] Just (NamedPerm_Defined dp) -> fmap (PTrans_Defined (mbLift npn) args off) <$> translate (mbMap2 (unfoldDefinedPerm dp) args off) @@ -2254,9 +2363,10 @@ instance TransInfo info => [nuMP| ValPerm_Conj ps |] -> fmap PTrans_Conj <$> listTypeTrans <$> translate ps [nuMP| ValPerm_Var x _ |] -> - mkPermTypeTrans1 p <$> translate1 x + mkPermTypeTrans1 p <$> unETransPerm <$> translate x [nuMP| ValPerm_False |] -> - return $ mkPermTypeTrans1 p $ globalOpenTerm "Prelude.FalseProp" + return $ mkPermTypeTrans1 p $ + TypeDescPure $ globalOpenTerm "Prelude.FalseProp" instance TransInfo info => Translate info ctx (AtomicPerm a) (TypeTrans 'False @@ -2269,7 +2379,7 @@ instance TransInfo info => fmap APTrans_LLVMArray <$> translate ap [nuMP| Perm_LLVMBlock bp |] -> - do tp <- translate1 (fmap llvmBlockShape bp) + do tp <- translateShape (fmap llvmBlockShape bp) return $ mkImpTypeTrans1 tp (APTrans_LLVMBlock bp) [nuMP| Perm_LLVMFree e |] -> @@ -2280,7 +2390,7 @@ instance TransInfo info => [nuMP| Perm_IsLLVMPtr |] -> return $ mkImpTypeTrans0 APTrans_IsLLVMPtr [nuMP| Perm_LLVMBlockShape sh |] -> - do tp <- translateSh sh + do tp <- translateShape sh return $ mkImpTypeTrans1 tp (APTrans_LLVMBlockShape sh) [nuMP| Perm_NamedConj npn args off |] | [nuMP| DefinedSortRepr _ |] <- mbMatch $ fmap namedPermNameSort npn -> @@ -2297,7 +2407,7 @@ instance TransInfo info => APTrans_NamedConj (mbLift npn) args off t _ -> error "translateSimplImpl: Perm_NamedConj") ptrans [nuMP| Perm_LLVMFrame fp |] -> - return $ mkLRTTypeTrans0 $ APTrans_LLVMFrame fp + return $ mkImpTypeTrans0 $ APTrans_LLVMFrame fp [nuMP| Perm_LOwned ls tps_in tps_out ps_in ps_out |] -> error "FIXME HERE NOWNOW" {- @@ -2328,26 +2438,27 @@ instance TransInfo info => -- of the translation of the array translateLLVMArrayPerm :: (1 <= w, KnownNat w, TransInfo info) => Mb ctx (LLVMArrayPerm w) -> - TransM info ctx (OpenTerm,OpenTerm,OpenTerm, - TypeTrans (LLVMArrayPermTrans ctx w)) + TransM info ctx (OpenTerm,OpenTerm,SpecTerm, + ImpTypeTrans (LLVMArrayPermTrans ctx w)) 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 - len_term <- translate1 $ mbLLVMArrayLen mb_ap + len_term <- translate1Pure $ mbLLVMArrayLen mb_ap {- bs_trans <- listTypeTrans <$> mapM (translateLLVMArrayBorrow ap) (mbList bs) -} - let arr_tp = bvVecTypeDesc w_term len_term elem_tp + let arr_tp = bvVecTypeDesc w_term len_term $ + tupleOfTypeDescs $ typeTransDescs sh_trans return (w_term, len_term, elem_tp, mkImpTypeTrans1 arr_tp ({- flip $ -} LLVMArrayPermTrans mb_ap len_term sh_trans {- <*> bs_trans -})) instance (1 <= w, KnownNat w, TransInfo info) => - Translate info ctx (LLVMArrayPerm w) (TypeTrans + Translate info ctx (LLVMArrayPerm w) (ImpTypeTrans (LLVMArrayPermTrans ctx w)) where translate mb_ap = (\(_,_,_,tp_trans) -> tp_trans) <$> translateLLVMArrayPerm mb_ap @@ -2377,7 +2488,7 @@ instance TransInfo info => -- Translate a DistPerms by translating its corresponding ValuePerms instance TransInfo info => - Translate info ctx (DistPerms ps) (TypeTrans + Translate info ctx (DistPerms ps) (ImpTypeTrans (PermTransCtx ctx ps)) where translate = translate . mbDistPermsToValuePerms @@ -2395,12 +2506,56 @@ instance TransInfo info => error ("Translating expression permissions that could not be converted " ++ "to variable permissions:" ++ permPrettyString emptyPPInfo mb_ps) + +instance HasPureTrans (ValuePerm a) where + hasPureTrans p = case mbMatch p of + [nuMP| ValPerm_Eq _ |] -> True + [nuMP| ValPerm_Or p1 p2 |] -> hasPureTrans p1 && hasPureTrans p2 + [nuMP| ValPerm_Exists mb_p |] -> + hasPureTrans (mbCombine RL.typeCtxProxies mb_p) + [nuMP| ValPerm_Named _ args _ |] -> + -- FIXME: this is technically incorrect, since a defined permission could + -- unfold to an impure permission + hasPureTrans args + [nuMP| ValPerm_Conj ps |] -> hasPureTrans ps + [nuMP| ValPerm_Var x _ |] -> False + [nuMP| ValPerm_False |] -> True + +instance HasPureTrans (AtomicPerm a) where + hasPureTrans mb_p = case mbMatch mb_p of + [nuMP| Perm_LLVMField fld |] -> hasPureTrans fld + [nuMP| Perm_LLVMArray ap |] -> hasPureTrans $ mbLLVMArrayCellShape ap + [nuMP| Perm_LLVMBlock bp |] -> hasPureTrans $ mbLLVMBlockShape bp + [nuMP| Perm_LLVMFree _ |] -> True + [nuMP| Perm_LLVMFunPtr _ _ |] -> False + [nuMP| Perm_IsLLVMPtr |] -> True + [nuMP| Perm_LLVMBlockShape sh |] -> hasPureTrans sh + [nuMP| Perm_NamedConj _ args _ |] -> + -- FIXME: this is technically incorrect, since a defined permission could + -- unfold to an impure permission + hasPureTrans args + [nuMP| Perm_LLVMFrame fp |] -> True + [nuMP| Perm_LOwned _ _ _ _ _ |] -> False + [nuMP| Perm_LOwnedSimple _ _ |] -> True + [nuMP| Perm_LCurrent _ |] -> True + [nuMP| Perm_LFinished |] -> True + [nuMP| Perm_Struct ps |] -> hasPureTrans ps + [nuMP| Perm_Fun _ |] -> False + [nuMP| Perm_BVProp _ |] -> True + [nuMP| Perm_Any |] -> True + +instance HasPureTrans (ValuePerms as) where + hasPureTrans p = case mbMatch p of + [nuMP| MNil |] -> True + [nuMP| ps :>: p' |] -> hasPureTrans ps && hasPureTrans p' + + emptyStackOpenTerm :: OpenTerm emptyStackOpenTerm = globalOpenTerm "Prelude.emptyFunStack" -- Translate a FunPerm to a pi-abstraction (FIXME HERE NOW: document translation) instance TransInfo info => - Translate info ctx (FunPerm ghosts args gouts ret) SpecTerm where + Translate info ctx (FunPerm ghosts args gouts ret) TypeDesc where translate (mbMatch -> [nuMP| FunPerm ghosts args gouts ret perms_in perms_out |]) = let tops = appendCruCtx (mbLift ghosts) (mbLift args) @@ -2410,8 +2565,9 @@ instance TransInfo info => (infoCtx <$> ask) >>= \ctx -> case RL.appendAssoc ctx tops_prxs rets_prxs of Refl -> - piLRTExprCtxApp tops $ + fmap typeDescFromLRT $ piLRTExprCtxApp tops $ arrowLRTPermCtx (mbCombine tops_prxs perms_in) $ + fmap typeDescLRT $ translateRetType rets (mbCombine (RL.append tops_prxs rets_prxs) perms_out) @@ -2442,9 +2598,8 @@ arrowLRTPermCtx ps body = -- arguments using @LRT_FunDep@; and values for all the permissions described by -- a 'PermTransCtx' relative to the expressions using @LRT_FunClos@. The return -- type is described by a 'PermTransCtx' as well. -piExprPermLRT :: TypeTrans (ExprTransCtx ctx) -> - RelTypeTrans ctx (PermTransCtx ctx ps_in) -> - RelTypeTrans ctx (PermTransCtx ctx ps_out) -> +piExprPermLRT :: PureTypeTrans (ExprTransCtx ctx) -> + RelPermTransCtx ctx ps_in -> RelPermTransCtx ctx ps_out -> OpenTerm piExprPermLRT ectx pctx_in_F pctx_out_F = error "FIXME HERE NOWNOW" @@ -2456,8 +2611,8 @@ translateRetType :: TransInfo info => CruCtx rets -> TransM info ctx TypeDesc translateRetType rets ret_perms = do tptrans <- translateClosed rets - sigmaTypeTransM "ret" tptrans (flip inExtMultiTransM - (translate ret_perms)) + sigmaTypeTransM "ret" tptrans (hasPureTrans ret_perms) + (flip inExtMultiTransM (translate ret_perms)) -- | Build the return type for the function resulting from an entrypoint translateEntryRetType :: TransInfo info => @@ -5014,8 +5169,8 @@ 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 <- sigmaTypeTransM "ret" rets_trans (hasPureTrans perms_out) + (flip inExtMultiTransM (translate perms_out)) let all_args = exprCtxToTerms ectx_gexprs ++ exprCtxToTerms ectx_args ++ permCtxToTerms pctx_ghosts_args From 67d9d735d86c82889e57cea0d130202ea80f66b6 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 26 Jul 2023 07:24:31 -0700 Subject: [PATCH 026/305] fixing some more compiler errors in SAWTranslation.hs --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 21 ++++++++++--------- 1 file changed, 11 insertions(+), 10 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index dc9ddb5830..7e54afff2e 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -1194,8 +1194,8 @@ instance TransInfo info => liftA2 (:>:) <$> translate ctx <*> translate tp -- | Translate all types in a Crucible context and lambda-abstract over them -lambdaExprCtx :: TransInfo info => CruCtx ctx -> TransM info ctx OpenTerm -> - TransM info RNil OpenTerm +lambdaExprCtx :: TransInfo info => CruCtx ctx -> TransM info ctx SpecTerm -> + TransM info RNil SpecTerm lambdaExprCtx ctx m = translateClosed ctx >>= \tptrans -> lambdaTransM "e" tptrans (\ectx -> inCtxTransM ectx m) @@ -1330,7 +1330,8 @@ instance TransInfo info => [nuMP| PExpr_PermListNil |] -> return $ ETrans_Term unitTypeOpenTerm [nuMP| PExpr_PermListCons _ _ p l |] -> ETrans_Term <$> (pairTypeOpenTerm <$> - (typeTransTupleType <$> translate p) <*> + (typeDescLRT <$> tupleOfTypeDescs <$> + typeTransDescs <$> translate p) <*> (translate1Pure l)) [nuMP| PExpr_RWModality _ |] -> return ETrans_RWModality @@ -1341,9 +1342,9 @@ instance TransInfo info => [nuMP| DefinedShapeBody _ |] -> translate (mbMap2 unfoldNamedShape nmsh args) [nuMP| OpaqueShapeBody _ trans_id |] -> - exprTransPureTypeTerms <$> translate args >>= \case + exprCtxPureTypeTerms <$> translate args >>= \case Just args_trans -> - ETrans_Shape $ TypeDescPure $ + return $ ETrans_Shape $ TypeDescPure $ applyOpenTermMulti (globalOpenTerm $ mbLift trans_id) args_trans Nothing -> panic "translate" @@ -1351,7 +1352,7 @@ instance TransInfo info => [nuMP| RecShapeBody _ trans_id _ |] -> exprTransPureTypeTerms <$> translate args >>= \case Just args_trans -> - ETrans_Shape $ TypeDescPure $ + return $ ETrans_Shape $ TypeDescPure $ applyOpenTermMulti (globalOpenTerm $ mbLift trans_id) args_trans Nothing -> panic "translate" @@ -1371,13 +1372,13 @@ instance TransInfo info => <*> translateShape sh2) [nuMP| PExpr_OrShape sh1 sh2 |] -> ETrans_Shape <$> (typeDescEither - <$> translate1Pure sh1 <*> translate1Pure sh2) + <$> translateShape sh1 <*> translateShape sh2) [nuMP| PExpr_ExShape mb_sh |] -> do tp_trans <- translate $ fmap bindingType mb_sh ETrans_Shape <$> - sigmaTypeTransM "x_exsh" tp_trans - (hasPureTrans $ mbCombine RL.typeCtxProxies mb_sh) $ \e -> - inExtTransM e (translateShape $ mbCombine RL.typeCtxProxies mb_sh) + (sigmaTypeTransM "x_exsh" tp_trans + (hasPureTrans $ mbCombine RL.typeCtxProxies mb_sh) $ \e -> + inExtTransM e (translateShape $ mbCombine RL.typeCtxProxies mb_sh)) [nuMP| PExpr_FalseShape |] -> return $ ETrans_Shape $ TypeDescPure $ globalOpenTerm "Prelude.FalseProp" From 0bdf2e369adfc51d44a43c783e5e8606e00c9beb Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 26 Jul 2023 14:51:21 -0700 Subject: [PATCH 027/305] fixed a few more compiler errors --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 26 ++++++++++--------- 1 file changed, 14 insertions(+), 12 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 7e54afff2e..b61c6f6c3b 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -380,6 +380,10 @@ tupleTypeTrans (TypeTransImpure tps f) = take (length $ typeTransTypes ttrans) [0..] _ -> panic "tupleTypeTrans" ["incorrect number of terms"]) +-- | Form the 'TypeDesc' of the tuple of all the SAW core types in a 'TypeTrans' +typeTransTupleDesc :: TypeTrans b tr -> TypeDesc +typeTransTupleDesc = tupleOfTypeDescs . typeTransDescs + {- -- | 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 @@ -830,8 +834,7 @@ bitvectorTransM m = -- and right types eitherTypeTrans :: ImpTypeTrans trL -> ImpTypeTrans trR -> TypeDesc eitherTypeTrans tp_l tp_r = - typeDescEither (tupleOfTypeDescs $ typeTransDescs tp_l) (tupleOfTypeDescs $ - typeTransDescs tp_r) + typeDescEither (typeTransTupleDesc tp_l) (typeTransTupleDesc tp_r) -- | Apply the @Left@ constructor of the @Either@ type in SAW to the -- 'transTupleTerm' of the input @@ -889,14 +892,13 @@ eithersElimTransM tps tp_ret fs eith = -- or not, in which case it isn't. It is an error if the Boolean flag is 'True' -- but the monadic function returns an impure type description. sigmaTypeTransM :: String -> PureTypeTrans trL -> Bool -> - (trL -> TransM info ctx (ImpTypeTrans trR)) -> + (trL -> TransM info ctx TypeDesc) -> TransM info ctx TypeDesc sigmaTypeTransM _ ttrans@(typeTransTypes -> []) _ tp_f = typeTransTupleType <$> tp_f (typeTransF ttrans []) sigmaTypeTransM x ttrans pure_p tp_f = do info <- ask return $ typeDescSigma x (typeTransTupleType ttrans) pure_p $ \e_tup -> - tupleOfTypeDescs $ typeTransDescs $ runTransM (tp_f $ typeTransF (tupleTypeTrans ttrans) [e_tup]) info -- | Like `sigmaTypeTransM`, but translates `exists x.eq(y)` into just `x` @@ -1330,8 +1332,7 @@ instance TransInfo info => [nuMP| PExpr_PermListNil |] -> return $ ETrans_Term unitTypeOpenTerm [nuMP| PExpr_PermListCons _ _ p l |] -> ETrans_Term <$> (pairTypeOpenTerm <$> - (typeDescLRT <$> tupleOfTypeDescs <$> - typeTransDescs <$> translate p) <*> + (typeDescLRT <$> typeTransTupleDesc <$> translate p) <*> (translate1Pure l)) [nuMP| PExpr_RWModality _ |] -> return ETrans_RWModality @@ -1350,7 +1351,7 @@ instance TransInfo info => panic "translate" ["Heapster cannot yet handle opaque shapes over impure types"] [nuMP| RecShapeBody _ trans_id _ |] -> - exprTransPureTypeTerms <$> translate args >>= \case + exprCtxPureTypeTerms <$> translate args >>= \case Just args_trans -> return $ ETrans_Shape $ TypeDescPure $ applyOpenTermMulti (globalOpenTerm $ mbLift trans_id) args_trans @@ -1383,7 +1384,7 @@ instance TransInfo info => return $ ETrans_Shape $ TypeDescPure $ globalOpenTerm "Prelude.FalseProp" [nuMP| PExpr_ValPerm p |] -> - ETrans_Perm <$> tupleOfTypeDescs <$> typeTransDescs <$> translate p + ETrans_Perm <$> typeTransTupleDesc <$> translate p -- LLVM field shapes translate to the types that the permission they contain -- translates to @@ -2451,8 +2452,7 @@ translateLLVMArrayPerm mb_ap = {- bs_trans <- listTypeTrans <$> mapM (translateLLVMArrayBorrow ap) (mbList bs) -} - let arr_tp = bvVecTypeDesc w_term len_term $ - tupleOfTypeDescs $ typeTransDescs sh_trans + let arr_tp = bvVecTypeDesc w_term len_term $ typeTransTupleDesc sh_trans return (w_term, len_term, elem_tp, mkImpTypeTrans1 arr_tp ({- flip $ -} LLVMArrayPermTrans mb_ap len_term sh_trans @@ -2613,7 +2613,8 @@ translateRetType :: TransInfo info => CruCtx rets -> translateRetType rets ret_perms = do tptrans <- translateClosed rets sigmaTypeTransM "ret" tptrans (hasPureTrans ret_perms) - (flip inExtMultiTransM (translate ret_perms)) + (\ectx -> inExtMultiTransM ectx (typeTransTupleDesc <$> + translate ret_perms)) -- | Build the return type for the function resulting from an entrypoint translateEntryRetType :: TransInfo info => @@ -5171,7 +5172,8 @@ translateStmt loc mb_stmt m = case mbMatch mb_stmt of let (pctx_ghosts_args, _) = RL.split (RL.append ectx_gexprs ectx_args) ectx_gexprs pctx_in fret_tp <- sigmaTypeTransM "ret" rets_trans (hasPureTrans perms_out) - (flip inExtMultiTransM (translate perms_out)) + (\ectx -> inExtMultiTransM ectx (typeTransTupleDesc <$> + translate perms_out)) let all_args = exprCtxToTerms ectx_gexprs ++ exprCtxToTerms ectx_args ++ permCtxToTerms pctx_ghosts_args From ee31998bca6941bb669dd3e5bf1094214911db36 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 27 Jul 2023 07:44:59 -0700 Subject: [PATCH 028/305] added sawLetPureSpecTerm --- saw-core/src/Verifier/SAW/OpenTerm.hs | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/saw-core/src/Verifier/SAW/OpenTerm.hs b/saw-core/src/Verifier/SAW/OpenTerm.hs index f158b26f1b..278fa4fbeb 100644 --- a/saw-core/src/Verifier/SAW/OpenTerm.hs +++ b/saw-core/src/Verifier/SAW/OpenTerm.hs @@ -82,7 +82,7 @@ module Verifier.SAW.OpenTerm ( callDefSpecTerm, specMTypeSpecTerm, returnSpecTerm, bindSpecTerm, errorSpecTerm, flatSpecTerm, natSpecTerm, unitSpecTerm, pairSpecTerm, pairTypeSpecTerm, pairLeftSpecTerm, pairRightSpecTerm, ctorSpecTerm, - dataTypeSpecTerm, letSpecTerm, sawLetSpecTerm + dataTypeSpecTerm, letSpecTerm, sawLetSpecTerm, sawLetPureSpecTerm ) where import qualified Data.Vector as V @@ -1000,14 +1000,22 @@ letSpecTerm :: LocalName -> SpecTerm -> SpecTerm -> (SpecTerm -> SpecTerm) -> SpecTerm letSpecTerm x tp rhs body_f = applySpecTerm (lambdaSpecTerm x tp body_f) rhs --- | Build a let expression as an 'SpecTerm'. This is equivalent to --- > 'applySpecTerm' ('lambdaSpecTerm' x tp body) rhs +-- | Build a let expression as a 'SpecTerm' using the @sawLet@ combinator. This +-- is equivalent to the term @sawLet tp tp_ret rhs (\ (x : tp) -> body_f)@ sawLetSpecTerm :: LocalName -> SpecTerm -> SpecTerm -> SpecTerm -> (SpecTerm -> SpecTerm) -> SpecTerm sawLetSpecTerm x tp tp_ret rhs body_f = applySpecTermMulti (globalSpecTerm "Prelude.sawLet") [tp, tp_ret, rhs, lambdaSpecTerm x tp body_f] +-- | Build a let expression as an 'SpecTerm'. This is equivalent to +-- > 'applySpecTerm' ('lambdaSpecTerm' x tp body) rhs +sawLetPureSpecTerm :: LocalName -> SpecTerm -> SpecTerm -> SpecTerm -> + (OpenTerm -> SpecTerm) -> SpecTerm +sawLetPureSpecTerm x tp tp_ret rhs body_f = + applySpecTermMulti (globalSpecTerm "Prelude.sawLet") + [tp, tp_ret, rhs, lambdaPureSpecTerm x tp body_f] + -------------------------------------------------------------------------------- From 73a0628fa094f8dce4d81207e5c63483b97c07a0 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 27 Jul 2023 07:45:24 -0700 Subject: [PATCH 029/305] figured out how to do sigmaElimTransM wrt the fact that the first type translation is pure --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 58 +++++++++++++------ 1 file changed, 41 insertions(+), 17 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index b61c6f6c3b..3fe2de5398 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -809,7 +809,7 @@ sawLetTransM :: String -> SpecTerm -> SpecTerm -> TransM info ctx SpecTerm -> sawLetTransM x tp tp_ret rhs_m body_m = do r <- ask return $ - sawLetOpenTerm (pack x) tp tp_ret (runTransM rhs_m r) + sawLetSpecTerm (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 @@ -824,6 +824,17 @@ sawLetTransMultiM x (tp:tps) ret_tp (rhs:rhss) f = sawLetTransMultiM _ _ _ _ _ = error "sawLetTransMultiM: numbers of types and right-hand sides disagree" +-- | Build a sawLet-binding in a translation monad that binds a 'SpecTerm' with +-- a pure type to an 'OpenTerm' variable +sawLetPureTransM :: String -> SpecTerm -> SpecTerm -> SpecTerm -> + (OpenTerm -> TransM info ctx SpecTerm) -> + TransM info ctx SpecTerm +sawLetPureTransM x tp tp_ret rhs body_m = + do r <- ask + return $ + sawLetPureSpecTerm (pack x) tp tp_ret rhs + (\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 = @@ -925,7 +936,8 @@ 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 (ctorSpecTerm "Prelude.exists" - [typeTransTupleType tp_l, tp_r_trm, transTupleTerm lhs, rhs]) + [optnTermSpecTerm (typeTransTupleType tp_l), tp_r_trm, + transTupleTerm lhs, rhs]) -- | Like `sigmaTransM`, but translates `exists x.eq(y)` into just `x` sigmaPermTransM :: TransInfo info => String -> PureTypeTrans (ExprTrans a) -> @@ -933,7 +945,7 @@ sigmaPermTransM :: TransInfo info => String -> PureTypeTrans (ExprTrans a) -> TransM info ctx (PermTrans ctx b) -> TransM info ctx SpecTerm sigmaPermTransM x ttrans mb_p etrans rhs_m = case mbMatch mb_p of - [nuMP| ValPerm_Eq _ |] -> return $ openTermSpecTerm $ transTupleTerm etrans + [nuMP| ValPerm_Eq _ |] -> return $ transTupleTerm etrans _ -> sigmaTransM x ttrans (flip inExtTransM $ translate mb_p) etrans rhs_m -- | Eliminate a dependent pair of the type returned by 'sigmaTypeTransM' @@ -945,23 +957,35 @@ sigmaElimTransM :: (IsTermTrans trL, IsTermTrans trR) => SpecTerm -> TransM info ctx SpecTerm 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 + 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 tp_ret_m f sigma = + do let tp_l_trm = openTermSpecTerm $ 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] - f proj_l proj_r + applyGlobalSpecTerm "Prelude.Sigma_proj1" [tp_l_trm, tp_r_trm, sigma] + tp_ret <- typeTransTupleType <$> tp_ret_m + sawLetPureTransM x tp_l_trm tp_ret proj_l_trm $ \proj_l_pure -> + do let proj_l = typeTransF (tupleTypeTrans tp_l) [proj_l_pure] + tp_r_app <- tp_r proj_l + let proj_r_trm = + applyGlobalSpecTerm "Prelude.Sigma_proj2" [tp_l_trm, + tp_r_trm, sigma] + let proj_r = typeTransF (tupleTypeTrans tp_r_app) [proj_r_trm] + f proj_l proj_r + +{- + do let proj1 = typeTransF tp_l [] + tp_r_trans <- tp_r_transF proj1 + let tp_r = typeTransTupleType tp_r_trans + tp_ret <- typeTransTupleType <$> tp_ret_m + -- Let-bind sigma so we can access it as an open term + sawLetPureTransM x tp_r tp_ret sigma $ \sigma_e -> + f proj1 (typeTransF tp_r []) +-} + {- NOTE: the following is the version that inserts a Sigma__rec sigmaElimTransM x tp_l tp_r tp_ret_m f sigma = From 8fdaed01bcfd955b370c9f3877b80a84463397cc Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 27 Jul 2023 18:05:03 -0700 Subject: [PATCH 030/305] added unitTypeSpecTerm --- saw-core/src/Verifier/SAW/OpenTerm.hs | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/saw-core/src/Verifier/SAW/OpenTerm.hs b/saw-core/src/Verifier/SAW/OpenTerm.hs index 278fa4fbeb..4b9ed9b61e 100644 --- a/saw-core/src/Verifier/SAW/OpenTerm.hs +++ b/saw-core/src/Verifier/SAW/OpenTerm.hs @@ -80,9 +80,9 @@ module Verifier.SAW.OpenTerm ( failSpecTerm, globalSpecTerm, applyGlobalSpecTerm, lrtToTypeSpecTerm, mkBaseClosSpecTerm, mkFreshClosSpecTerm, callClosSpecTerm, applyClosSpecTerm, callDefSpecTerm, specMTypeSpecTerm, returnSpecTerm, bindSpecTerm, - errorSpecTerm, flatSpecTerm, natSpecTerm, unitSpecTerm, pairSpecTerm, - pairTypeSpecTerm, pairLeftSpecTerm, pairRightSpecTerm, ctorSpecTerm, - dataTypeSpecTerm, letSpecTerm, sawLetSpecTerm, sawLetPureSpecTerm + errorSpecTerm, flatSpecTerm, natSpecTerm, unitSpecTerm, unitTypeSpecTerm, + pairSpecTerm, pairTypeSpecTerm, pairLeftSpecTerm, pairRightSpecTerm, + ctorSpecTerm, dataTypeSpecTerm, letSpecTerm, sawLetSpecTerm, sawLetPureSpecTerm ) where import qualified Data.Vector as V @@ -956,10 +956,14 @@ flatSpecTerm :: FlatTermF SpecTerm -> SpecTerm flatSpecTerm ftf = SpecTerm $ fmap flatSpecInfoTerm $ sequence (fmap unSpecTerm ftf) --- | Build a 'SpecTerm' for a pair +-- | Build a 'SpecTerm' for the unit object unitSpecTerm :: SpecTerm unitSpecTerm = flatSpecTerm UnitValue +-- | Build a 'SpecTerm' for the unit type +unitTypeSpecTerm :: SpecTerm +unitTypeSpecTerm = flatSpecTerm UnitType + -- | Build a 'SpecTerm' for a pair pairSpecTerm :: SpecTerm -> SpecTerm -> SpecTerm pairSpecTerm t1 t2 = flatSpecTerm $ PairValue t1 t2 From bbbb3c7dd40f45656b88b2b505777007033d9f36 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 27 Jul 2023 18:05:22 -0700 Subject: [PATCH 031/305] Still more progress getting SAWTranslation.hs to compile --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 169 ++++++++---------- 1 file changed, 72 insertions(+), 97 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 3fe2de5398..c56553b713 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -163,7 +163,7 @@ bvVecTypeDesc :: OpenTerm -> OpenTerm -> TypeDesc -> TypeDesc bvVecTypeDesc w_term len_term (TypeDescPure elem_tp) = TypeDescPure (applyGlobalOpenTerm "Prelude.BVVec" [w_term, len_term, elem_tp]) -bvVecTypeDesc w_term len_term (TypeDescLRT lrt elem_tpx) = +bvVecTypeDesc w_term len_term (TypeDescLRT lrt elem_tp) = TypeDescLRT (applyGlobalOpenTerm "Prelude.LRT_BVVec" [w_term, len_term, lrt]) (applyGlobalOpenTerm "Prelude.BVVec" [w_term, len_term, elem_tp]) @@ -191,22 +191,24 @@ typeDescEither = -- type, in which case the returned dependent pair type is pure, or not, in -- which case it isn't. It is an error if the Boolean flag is 'True' but the -- function returns an impure type description. -typeDescSigma :: String -> OpenTerm -> Bool -> (OpenTerm -> TypeDesc) -> +typeDescSigma :: LocalName -> OpenTerm -> Bool -> (OpenTerm -> TypeDesc) -> TypeDesc typeDescSigma x tp_l True tp_r_f = - do tp_f_trm <- lambdaOpenTerm x tp_l $ \tr -> tp_f tr >>= \case - TypeDescPure tp_r -> tp_r - TypeDescLRT _ _ -> - panic "typeDescSigma" - ["Expected a pure type description but got an impure one"] - return $ TypeDescPure $ - dataTypeOpenTerm "Prelude.Sigma" [typeTransTupleType ttrans, tp_f_trm] + let tp_f_trm = + lambdaOpenTerm x tp_l $ \tr -> + case tp_r_f tr of + TypeDescPure tp_r -> tp_r + TypeDescLRT _ _ -> + panic "typeDescSigma" + ["Expected a pure type description but got an impure one"] in + TypeDescPure $ dataTypeOpenTerm "Prelude.Sigma" [tp_l, tp_f_trm] typeDescSigma x tp_l False tp_r_f = TypeDescLRT (ctorOpenTerm "Prelude.LRT_Sigma" [tp_l, lambdaOpenTerm x tp_l (typeDescLRT . tp_r_f)]) (dataTypeSpecTerm "Prelude.Sigma" - [openTermSpecTerm tp_l, lambdaSpecTerm x tp_l (typeDescType . tp_r_f)]) + [openTermSpecTerm tp_l, + lambdaPureSpecTerm x (openTermSpecTerm tp_l) (typeDescType . tp_r_f)]) -- | 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 @@ -219,10 +221,11 @@ tupleOfTypes (tp:tps) = pairTypeOpenTerm tp $ tupleOfTypes tps -- | Like 'tupleOfTypes' but applied to type descriptions tupleOfTypeDescs :: [TypeDesc] -> TypeDesc -tupleOfTypeDescs [] = unitTypeOpenTerm +tupleOfTypeDescs [] = TypeDescPure unitTypeOpenTerm tupleOfTypeDescs [tp] = tp tupleOfTypeDescs (TypeDescPure tp_l : ds) - | TypeDescPure tp_r <- tupleOfTypeDescs ds = pairTypeOpenTerm tp_l tp_r + | TypeDescPure tp_r <- tupleOfTypeDescs ds + = TypeDescPure $ pairTypeOpenTerm tp_l tp_r tupleOfTypeDescs (d : ds) = let d_r = tupleOfTypeDescs ds in TypeDescLRT @@ -249,7 +252,7 @@ projTupleOfTypes (_:tps) i tup = projTupleOfTypes tps (i-1) $ pairRightOpenTerm tup -- | Impure version of 'projTupleOfTypes' -projTupleOfTypesI :: [SpecTerm] -> Integer -> SpecTerm -> SpecTerm +projTupleOfTypesI :: [TypeDesc] -> Integer -> SpecTerm -> SpecTerm projTupleOfTypesI [] _ _ = panic "projTupleOfTypesI" ["projection of empty tuple!"] projTupleOfTypesI [_] 0 tup = tup @@ -334,7 +337,7 @@ mkImpTypeTrans0 tr = TypeTransImpure [] $ \case -- | Build a 'TypeTrans' represented by a "pure" (see 'TypeDesc') SAW type mkPureTypeTrans1 :: OpenTerm -> (OpenTerm -> tr) -> TypeTrans 'True tr -mkPureTypeTrans1 tp f = TypeTransPure [TypeDescPure tp] $ \case +mkPureTypeTrans1 tp f = TypeTransPure [tp] $ \case [t] -> f t _ -> panic "mkPureTypeTrans1" ["incorrect number of terms"] @@ -350,7 +353,7 @@ typeTransType1 :: HasCallStack => TypeTrans p tr -> PurityTerm p typeTransType1 (TypeTransPure [] _) = unitTypeOpenTerm typeTransType1 (TypeTransImpure [] _) = unitTypeSpecTerm typeTransType1 (TypeTransPure [tp] _) = tp -typeTransType1 (TypeTransImpure [tp] _) = tp +typeTransType1 (TypeTransImpure [tp] _) = typeDescType tp typeTransType1 _ = panic "typeTransType1" ["More than one type when at most one expected"] @@ -369,15 +372,13 @@ tupleTypeTrans (TypeTransPure tps f) = TypeTransPure [tupleOfTypes tps] (\case [t] -> - f $ map (\i -> projTupleOfTypes tps i t) $ - take (length $ typeTransTypes ttrans) [0..] + f $ map (\i -> projTupleOfTypes tps i t) $ take (length tps) [0..] _ -> panic "tupleTypeTrans" ["incorrect number of terms"]) tupleTypeTrans (TypeTransImpure tps f) = - TypeTransLRT [tupleOfTypeDescs tps] + TypeTransImpure [tupleOfTypeDescs tps] (\case [t] -> - f $ map (\i -> projTupleOfTypesI tps i t) $ - take (length $ typeTransTypes ttrans) [0..] + f $ map (\i -> projTupleOfTypesI tps i t) $ take (length tps) [0..] _ -> panic "tupleTypeTrans" ["incorrect number of terms"]) -- | Form the 'TypeDesc' of the tuple of all the SAW core types in a 'TypeTrans' @@ -501,7 +502,7 @@ transTerm1 :: HasCallStack => IsTermTrans tr => tr -> SpecTerm transTerm1 (transTerms -> []) = unitSpecTerm transTerm1 (transTerms -> [t]) = t transTerm1 tr = panic "transTerm1" ["Expected at most one term, but found " - ++ length (transTerms tr)] + ++ show (length $ transTerms tr)] instance IsTermTrans tr => IsTermTrans [tr] where transTerms = concatMap transTerms @@ -570,7 +571,7 @@ exprTransType (ETrans_Term t) = mkPureTypeTrans1 (openTermType t) ETrans_Term -- all the terms it contains exprCtxType :: ExprTransCtx ctx -> PureTypeTrans (ExprTransCtx ctx) exprCtxType MNil = mkPureTypeTrans0 MNil -exprCtxType (ectx :>: e) = (:>) <$> exprCtxType ectx <*> exprTransType e +exprCtxType (ectx :>: e) = (:>:) <$> exprCtxType ectx <*> exprTransType e -- | Map an 'ExprTrans' to the SAW core terms it contains, similarly to -- 'transPureTerms', except that all type descriptions are mapped to pure types, @@ -580,7 +581,7 @@ exprTransPureTypeTerms (ETrans_Shape (TypeDescPure tp)) = Just [tp] exprTransPureTypeTerms (ETrans_Shape (TypeDescLRT _ _)) = Nothing exprTransPureTypeTerms (ETrans_Perm (TypeDescPure tp)) = Just [tp] exprTransPureTypeTerms (ETrans_Perm (TypeDescLRT _ _)) = Nothing -exprTransPureTypeTerms etrans = transPureTerms etrans +exprTransPureTypeTerms etrans = Just $ transPureTerms etrans -- | Map an 'ExprTransCtx' to the SAW core terms it contains, similarly to -- 'transPureTerms', except that all type descriptions are mapped to pure types, @@ -631,6 +632,29 @@ 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; +-- the type must be pure as well, even though it is a 'SpecTerm' +sawLetTransM :: String -> SpecTerm -> SpecTerm -> SpecTerm -> + (OpenTerm -> TransM info ctx SpecTerm) -> + TransM info ctx SpecTerm +sawLetTransM x tp tp_ret rhs body_m = + do r <- ask + return $ + sawLetPureSpecTerm (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 -> [SpecTerm] -> SpecTerm -> [SpecTerm] -> + ([OpenTerm] -> TransM info ctx SpecTerm) -> + TransM info ctx SpecTerm +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 _ _ _ _ _ = + error "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 => PureTypeTrans (ExprTrans tp) -> @@ -717,7 +741,8 @@ lambdaTrans x (TypeTransPure tps tr_f) body_f = (body_f . tr_f) lambdaTrans x (TypeTransImpure tps tr_f) body_f = lambdaSpecTermMulti - (zipWith (\i tp -> (pack (x ++ show (i :: Integer)), tp)) [0..] tps) + (zipWith (\i tp -> (pack (x ++ show (i :: Integer)), + typeDescType tp)) [0..] tps) (body_f . tr_f) -- | Build a nested lambda-abstraction @@ -768,9 +793,10 @@ piLRTTransM x tps body_f = arrowLRTTransM :: String -> TypeTrans 'False tr -> TransM info ctx OpenTerm -> TransM info ctx OpenTerm arrowLRTTransM x tps body_top = - foldr (\(i,d) body -> - ctorOpenTerm "Prelude.LRT_FunClos" [typeDescLRT d, body]) - body_top (zip [0..] $ typeTransDescs tps) [] + foldr (\(i,d) body_m -> + body_m >>= \body -> + return $ ctorOpenTerm "Prelude.LRT_FunClos" [typeDescLRT d, body]) + body_top (zip [0..] $ typeTransDescs tps) -- FIXME: should only need to build pi-abstractions as LetRecTypes... right? {- @@ -802,43 +828,10 @@ letTransM x tp rhs_m body_m = return $ letSpecTerm (pack x) tp (runTransM rhs_m r) (\x' -> runTransM (body_m x') r) --- | Build a sawLet-binding in a translation monad -sawLetTransM :: String -> SpecTerm -> SpecTerm -> TransM info ctx SpecTerm -> - (SpecTerm -> TransM info ctx SpecTerm) -> - TransM info ctx SpecTerm -sawLetTransM x tp tp_ret rhs_m body_m = - do r <- ask - return $ - sawLetSpecTerm (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 -> [SpecTerm] -> SpecTerm -> [SpecTerm] -> - ([SpecTerm] -> TransM info ctx SpecTerm) -> - TransM info ctx SpecTerm -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" - --- | Build a sawLet-binding in a translation monad that binds a 'SpecTerm' with --- a pure type to an 'OpenTerm' variable -sawLetPureTransM :: String -> SpecTerm -> SpecTerm -> SpecTerm -> - (OpenTerm -> TransM info ctx SpecTerm) -> - TransM info ctx SpecTerm -sawLetPureTransM x tp tp_ret rhs body_m = - do r <- ask - return $ - sawLetPureSpecTerm (pack x) tp tp_ret rhs - (\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 = - applyPureMultiTransM (return $ globalOpenTerm "Prelude.Vec") + applyMultiPureTransM (return $ globalOpenTerm "Prelude.Vec") [m, return $ globalOpenTerm "Prelude.Bool"] -- | Build an @Either@ type in SAW from the 'typeTransTupleType's of the left @@ -902,25 +895,26 @@ eithersElimTransM tps tp_ret fs eith = -- return a pure type, in which case the returned dependent pair type is pure, -- or not, in which case it isn't. It is an error if the Boolean flag is 'True' -- but the monadic function returns an impure type description. -sigmaTypeTransM :: String -> PureTypeTrans trL -> Bool -> +sigmaTypeTransM :: LocalName -> PureTypeTrans trL -> Bool -> (trL -> TransM info ctx TypeDesc) -> TransM info ctx TypeDesc sigmaTypeTransM _ ttrans@(typeTransTypes -> []) _ tp_f = - typeTransTupleType <$> tp_f (typeTransF ttrans []) + tp_f (typeTransF ttrans []) sigmaTypeTransM x ttrans pure_p tp_f = do info <- ask return $ typeDescSigma x (typeTransTupleType ttrans) pure_p $ \e_tup -> runTransM (tp_f $ typeTransF (tupleTypeTrans ttrans) [e_tup]) info -- | Like `sigmaTypeTransM`, but translates `exists x.eq(y)` into just `x` -sigmaTypePermTransM :: TransInfo info => String -> +sigmaTypePermTransM :: TransInfo info => LocalName -> PureTypeTrans (ExprTrans trL) -> Mb (ctx :> trL) (ValuePerm trR) -> TransM info ctx TypeDesc sigmaTypePermTransM x ttrans mb_p = case mbMatch mb_p of [nuMP| ValPerm_Eq _ |] -> return $ TypeDescPure $ typeTransTupleType ttrans - _ -> sigmaTypeTransM x ttrans (hasPureTrans mb_p) (flip inExtTransM $ - translate mb_p) + _ -> + sigmaTypeTransM x ttrans (hasPureTrans mb_p) $ \etrans -> + inExtTransM etrans (typeTransTupleDesc <$> translate mb_p) -- | 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 @@ -936,7 +930,7 @@ 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 (ctorSpecTerm "Prelude.exists" - [optnTermSpecTerm (typeTransTupleType tp_l), tp_r_trm, + [openTermSpecTerm (typeTransTupleType tp_l), tp_r_trm, transTupleTerm lhs, rhs]) -- | Like `sigmaTransM`, but translates `exists x.eq(y)` into just `x` @@ -967,7 +961,7 @@ sigmaElimTransM x tp_l tp_r tp_ret_m f sigma = let proj_l_trm = applyGlobalSpecTerm "Prelude.Sigma_proj1" [tp_l_trm, tp_r_trm, sigma] tp_ret <- typeTransTupleType <$> tp_ret_m - sawLetPureTransM x tp_l_trm tp_ret proj_l_trm $ \proj_l_pure -> + sawLetTransM x tp_l_trm tp_ret proj_l_trm $ \proj_l_pure -> do let proj_l = typeTransF (tupleTypeTrans tp_l) [proj_l_pure] tp_r_app <- tp_r proj_l let proj_r_trm = @@ -976,31 +970,6 @@ sigmaElimTransM x tp_l tp_r tp_ret_m f sigma = let proj_r = typeTransF (tupleTypeTrans tp_r_app) [proj_r_trm] f proj_l proj_r -{- - do let proj1 = typeTransF tp_l [] - tp_r_trans <- tp_r_transF proj1 - let tp_r = typeTransTupleType tp_r_trans - tp_ret <- typeTransTupleType <$> tp_ret_m - -- Let-bind sigma so we can access it as an open term - sawLetPureTransM x tp_r tp_ret sigma $ \sigma_e -> - f proj1 (typeTransF tp_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) => @@ -1011,10 +980,16 @@ sigmaElimPermTransM :: (TransInfo info) => TransM info ctx SpecTerm) -> SpecTerm -> TransM info ctx SpecTerm -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) +sigmaElimPermTransM x tp_l mb_p tp_ret_m f sigma = case mbMatch mb_p of + [nuMP| ValPerm_Eq e |] -> + do let tp_l_trm = openTermSpecTerm $ typeTransTupleType tp_l + tp_r_trm <- lambdaTupleTransM x tp_l (\tr -> + typeTransTupleType <$> + inExtTransM tr (translate mb_p)) + tp_ret <- typeTransTupleType <$> tp_ret_m + sawLetTransM x tp_l_trm tp_ret sigma $ \sigma_pure -> + f (typeTransF (tupleTypeTrans tp_l) [sigma_pure]) (PTrans_Eq e) + _ -> sigmaElimTransM x tp_l (flip inExtTransM $ translate mb_p) tp_ret_m f sigma From a5a415455a83615e133618a755168551aa03b1ff Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 28 Jul 2023 07:31:07 -0700 Subject: [PATCH 032/305] got the first portion of SAWTranslation.hs to compile, hooray! --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 27 ++++++++++++------- 1 file changed, 17 insertions(+), 10 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index c56553b713..80f72f4808 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -127,9 +127,9 @@ typeDescLRT :: TypeDesc -> OpenTerm typeDescLRT (TypeDescPure tp) = ctorOpenTerm "Prelude.LRT_Type" [tp] typeDescLRT (TypeDescLRT lrt _) = lrt --- | Return the pair of the type and @LetRecType@ of a 'TypeDesc' +-- | Return the pair of the @LetRecType@ of a 'TypeDesc' and the type it encodes typeDescTypeLRT :: TypeDesc -> (OpenTerm,SpecTerm) -typeDescTypeLRT d = (typeDescType d, typeDescLRT d) +typeDescTypeLRT d = (typeDescLRT d, typeDescType d) -- | Build an impure 'TypeDesc' from a term of type @LetRecType@ typeDescFromLRT :: OpenTerm -> TypeDesc @@ -142,7 +142,9 @@ typeDescsPureOrLRT = foldr (\d descs -> case d of TypeDescPure tp | Left tps <- descs -> Left (tp:tps) _ | Right lrt_tps <- descs -> Right (typeDescTypeLRT d : lrt_tps) - _ -> Right $ map typeDescTypeLRT (d:descs)) (Left []) + _ | Left tps <- descs -> + Right (typeDescTypeLRT d : + map (typeDescTypeLRT . TypeDescPure) tps)) (Left []) -- | Apply a binary type-forming operation to two type descriptions, using the -- 'OpenTerm' function if the type descriptions are both pure and otherwise @@ -166,7 +168,8 @@ bvVecTypeDesc w_term len_term (TypeDescPure elem_tp) = bvVecTypeDesc w_term len_term (TypeDescLRT lrt elem_tp) = TypeDescLRT (applyGlobalOpenTerm "Prelude.LRT_BVVec" [w_term, len_term, lrt]) - (applyGlobalOpenTerm "Prelude.BVVec" [w_term, len_term, elem_tp]) + (applyGlobalSpecTerm "Prelude.BVVec" [openTermSpecTerm w_term, + openTermSpecTerm len_term, elem_tp]) -- | The 'TypeDesc' for the unit type typeDescUnit :: TypeDesc @@ -1448,6 +1451,9 @@ instance HasPureTrans (PermExprs as) where [nuMP| MNil |] -> True [nuMP| es :>: e' |] -> hasPureTrans es && hasPureTrans e' +instance HasPureTrans (LLVMFieldShape w) where + hasPureTrans (mbMatch -> [nuMP| LLVMFieldShape p |]) = hasPureTrans p + ---------------------------------------------------------------------- -- * Translating Permissions to Types @@ -2341,19 +2347,17 @@ instance TransInfo info => case lookupNamedPerm env (mbLift npn) of Just (NamedPerm_Opaque op) -> exprCtxPureTypeTerms <$> translate args >>= \case - Just args_trans -> + Just args_exprs -> return $ mkPermTypeTrans1 p $ TypeDescPure $ - applyGlobalOpenTerm (opaquePermTrans op) (transPureTerms - args_trans) + applyGlobalOpenTerm (opaquePermTrans op) args_exprs Nothing -> panic "translate" ["Heapster cannot yet handle opaque permissions over impure types"] Just (NamedPerm_Rec rp) -> exprCtxPureTypeTerms <$> translate args >>= \case - Just args_trans -> + Just args_exprs -> return $ mkPermTypeTrans1 p $ TypeDescPure $ - applyOpenTermMulti (globalOpenTerm $ - recPermTransType rp) (transPureTerms args_trans) + applyOpenTermMulti (globalOpenTerm $ recPermTransType rp) args_exprs Nothing -> panic "translate" ["Heapster cannot yet handle recursive permissions over impure types"] @@ -2549,6 +2553,9 @@ instance HasPureTrans (ValuePerms as) where [nuMP| MNil |] -> True [nuMP| ps :>: p' |] -> hasPureTrans ps && hasPureTrans p' +instance HasPureTrans (LLVMFieldPerm w sz) where + hasPureTrans (mbMatch -> [nuMP| LLVMFieldPerm { llvmFieldContents = p } |]) = + hasPureTrans p emptyStackOpenTerm :: OpenTerm emptyStackOpenTerm = globalOpenTerm "Prelude.emptyFunStack" From 5c8b75a8914413cb2bb1ba41f53b7aed9f2c80f7 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 31 Jul 2023 16:50:28 -0700 Subject: [PATCH 033/305] added stringLitSpecTerm; tweaked bindSpecTerm to take a term instead of a term function, for generality --- saw-core/src/Verifier/SAW/OpenTerm.hs | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/saw-core/src/Verifier/SAW/OpenTerm.hs b/saw-core/src/Verifier/SAW/OpenTerm.hs index 4b9ed9b61e..daa8486914 100644 --- a/saw-core/src/Verifier/SAW/OpenTerm.hs +++ b/saw-core/src/Verifier/SAW/OpenTerm.hs @@ -79,8 +79,9 @@ module Verifier.SAW.OpenTerm ( applySpecTerm, applySpecTermMulti, openTermSpecTerm, specTermType, failSpecTerm, globalSpecTerm, applyGlobalSpecTerm, lrtToTypeSpecTerm, mkBaseClosSpecTerm, mkFreshClosSpecTerm, callClosSpecTerm, applyClosSpecTerm, - callDefSpecTerm, specMTypeSpecTerm, returnSpecTerm, bindSpecTerm, + callDefSpecTerm, monadicSpecOp, specMTypeSpecTerm, returnSpecTerm, bindSpecTerm, errorSpecTerm, flatSpecTerm, natSpecTerm, unitSpecTerm, unitTypeSpecTerm, + stringLitSpecTerm, pairSpecTerm, pairTypeSpecTerm, pairLeftSpecTerm, pairRightSpecTerm, ctorSpecTerm, dataTypeSpecTerm, letSpecTerm, sawLetSpecTerm, sawLetPureSpecTerm ) where @@ -936,10 +937,9 @@ returnSpecTerm tp val = -- | Build a @SpecM@ computation that does a monadic bind bindSpecTerm :: SpecTerm -> SpecTerm -> SpecTerm -> - LocalName -> (SpecTerm -> SpecTerm) -> SpecTerm -bindSpecTerm tp1 tp2 m x f = - applySpecTermMulti (monadicSpecOp "Prelude.bindS") - [tp1, tp2, m, lambdaSpecTerm x tp1 f] + SpecTerm -> SpecTerm +bindSpecTerm tp1 tp2 m f = + applySpecTermMulti (monadicSpecOp "Prelude.bindS") [tp1, tp2, m, f] -- | Build a @SpecM@ error computation at the given type with the given message errorSpecTerm :: SpecTerm -> Text -> SpecTerm @@ -964,6 +964,10 @@ unitSpecTerm = flatSpecTerm UnitValue unitTypeSpecTerm :: SpecTerm unitTypeSpecTerm = flatSpecTerm UnitType +-- | Build a SAW core string literal +stringLitSpecTerm :: Text -> SpecTerm +stringLitSpecTerm = flatSpecTerm . StringLit + -- | Build a 'SpecTerm' for a pair pairSpecTerm :: SpecTerm -> SpecTerm -> SpecTerm pairSpecTerm t1 t2 = flatSpecTerm $ PairValue t1 t2 From 620764aea7a71434cb7793c0ddc51b90bed90bdb Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Tue, 8 Aug 2023 10:33:08 -0700 Subject: [PATCH 034/305] Changed the catch and ElimOrs rules so they now contain debug strings to be used in error messages --- .../src/Verifier/SAW/Heapster/Implication.hs | 39 ++++++++++++------- 1 file changed, 25 insertions(+), 14 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs b/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs index 7315c6aae1..56b7f48fd3 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs @@ -1464,7 +1464,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: -- @@ -1483,7 +1485,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: -- @@ -1852,7 +1858,7 @@ permImplCatch pimpl1 pimpl2 = 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) @@ -1860,7 +1866,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 @@ -2765,7 +2771,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 @@ -2789,7 +2795,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 @@ -3255,13 +3261,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 |] -> @@ -3963,6 +3969,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 @@ -4000,10 +4011,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 @@ -4070,8 +4081,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" From 737961a9ab7e26cd8022ee3c35f0570572bb03fa Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Tue, 8 Aug 2023 11:49:03 -0700 Subject: [PATCH 035/305] generalized the OpenTerm interface to use the mroe general OpenTermLike class for arbitrary term-like types --- saw-core/src/Verifier/SAW/OpenTerm.hs | 276 +++++++++++++++++++------- 1 file changed, 199 insertions(+), 77 deletions(-) diff --git a/saw-core/src/Verifier/SAW/OpenTerm.hs b/saw-core/src/Verifier/SAW/OpenTerm.hs index daa8486914..af2a81f358 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 @@ -72,18 +74,22 @@ module Verifier.SAW.OpenTerm ( OpenTermM(..), completeOpenTermM, dedupOpenTermM, lambdaOpenTermM, piOpenTermM, 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, -- * Building SpecM computations - SpecTerm(), defineSpecOpenTerm, - lambdaPureSpecTerm, lambdaPureSpecTermMulti, lambdaSpecTerm, - lambdaSpecTermMulti, piSpecTerm, - applySpecTerm, applySpecTermMulti, openTermSpecTerm, specTermType, - failSpecTerm, globalSpecTerm, applyGlobalSpecTerm, lrtToTypeSpecTerm, + SpecTerm(), defineSpecOpenTerm, lambdaPureSpecTerm, lambdaPureSpecTermMulti, + sawLetPureSpecTerm, lrtToTypeSpecTerm, mkBaseClosSpecTerm, mkFreshClosSpecTerm, callClosSpecTerm, applyClosSpecTerm, - callDefSpecTerm, monadicSpecOp, specMTypeSpecTerm, returnSpecTerm, bindSpecTerm, - errorSpecTerm, flatSpecTerm, natSpecTerm, unitSpecTerm, unitTypeSpecTerm, - stringLitSpecTerm, - pairSpecTerm, pairTypeSpecTerm, pairLeftSpecTerm, pairRightSpecTerm, - ctorSpecTerm, dataTypeSpecTerm, letSpecTerm, sawLetSpecTerm, sawLetPureSpecTerm + callDefSpecTerm, monadicSpecOp, + specMTypeSpecTerm, returnSpecTerm, bindSpecTerm, errorSpecTerm, ) where import qualified Data.Vector as V @@ -544,6 +550,175 @@ 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 + +-- 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] + + -------------------------------------------------------------------------------- -- Building SpecM computations @@ -710,6 +885,16 @@ runSpecTermM ev n m = OpenTerm $ -- thus the use of the 'SpecInfoTerm' type. newtype SpecTerm = SpecTerm { unSpecTerm :: SpecTermM SpecInfoTerm } +instance OpenTermLike SpecTerm where + openTermLike = openTermSpecTerm + typeOfTermLike = specTermType + flatTermLike = flatSpecTerm + applyTermLike = applySpecTerm + lambdaTermLike = lambdaSpecTerm + piTermLike = piSpecTerm + ctorTermLike = ctorSpecTerm + dataTypeTermLike = dataTypeSpecTerm + applySpecTerm :: SpecTerm -> SpecTerm -> SpecTerm applySpecTerm (SpecTerm f) (SpecTerm arg) = SpecTerm (applySpecInfoTerm <$> f <*> arg) @@ -736,20 +921,6 @@ specTermType :: SpecTerm -> SpecTerm specTermType (SpecTerm m) = SpecTerm $ flip fmap m $ \info_tm -> fmap openTermType info_tm --- | Build a 'SpecTerm' that 'fail's in the underlying monad when completed -failSpecTerm :: String -> SpecTerm -failSpecTerm = openTermSpecTerm . failOpenTerm - --- | Build a 'SpecTerm' for a natural number literal -natSpecTerm :: Natural -> SpecTerm -natSpecTerm n = openTermSpecTerm $ natOpenTerm n - -globalSpecTerm :: Ident -> SpecTerm -globalSpecTerm ident = openTermSpecTerm $ globalOpenTerm ident - -applyGlobalSpecTerm :: Ident -> [SpecTerm] -> SpecTerm -applyGlobalSpecTerm f args = applySpecTermMulti (globalSpecTerm f) args - -- | Build the 'SpecTerm' for the extended function stack extStackSpecTerm :: SpecTerm extStackSpecTerm = specInfoTermTerm extStackSpecInfoTerm @@ -791,13 +962,6 @@ lambdaSpecTerm :: LocalName -> SpecTerm -> (SpecTerm -> SpecTerm) -> SpecTerm lambdaSpecTerm x tp body_f = lambdaPureSpecTerm x tp (body_f . openTermSpecTerm) --- | Build a nested sequence of lambda abstractions as a 'SpecTerm' -lambdaSpecTermMulti :: [(LocalName, SpecTerm)] -> - ([SpecTerm] -> SpecTerm) -> SpecTerm -lambdaSpecTermMulti xs_tps body_f = - foldr (\(x,tp) rest_f xs -> - lambdaSpecTerm x tp (rest_f . (:xs))) (body_f . reverse) xs_tps [] - -- | Build a pi abstraction as a 'SpecTerm' piSpecTerm :: LocalName -> SpecTerm -> (SpecTerm -> SpecTerm) -> SpecTerm piSpecTerm x (SpecTerm tpM) body_f = SpecTerm $ @@ -810,7 +974,7 @@ piSpecTerm x (SpecTerm tpM) body_f = SpecTerm $ -- forming the term @LRTArg stk lrt@ lrtToTypeSpecTerm :: OpenTerm -> SpecTerm lrtToTypeSpecTerm lrt = - applyGlobalSpecTerm "Prelude.LRTArg" + applyGlobalTermLike "Prelude.LRTArg" [specInfoTermTerm (specInfoExtStack <$> ask), openTermSpecTerm lrt] funStackTypeOpenTerm :: OpenTerm @@ -901,8 +1065,8 @@ mkFreshClosSpecTerm lrt body_f = SpecTerm $ -- | Apply a closure of a given @LetRecType@ to a list of arguments applyClosSpecTerm :: OpenTerm -> SpecTerm -> [SpecTerm] -> SpecTerm applyClosSpecTerm lrt clos args = - applyGlobalSpecTerm "Prelude.applyLRTClosN" - (extStackSpecTerm : natSpecTerm (fromIntegral $ length args) + applyGlobalTermLike "Prelude.applyLRTClosN" + (extStackSpecTerm : natTermLike (fromIntegral $ length args) : openTermSpecTerm lrt : clos : args) -- | Build a @SpecM@ computation that calls a closure with the given return @@ -956,34 +1120,6 @@ flatSpecTerm :: FlatTermF SpecTerm -> SpecTerm flatSpecTerm ftf = SpecTerm $ fmap flatSpecInfoTerm $ sequence (fmap unSpecTerm ftf) --- | Build a 'SpecTerm' for the unit object -unitSpecTerm :: SpecTerm -unitSpecTerm = flatSpecTerm UnitValue - --- | Build a 'SpecTerm' for the unit type -unitTypeSpecTerm :: SpecTerm -unitTypeSpecTerm = flatSpecTerm UnitType - --- | Build a SAW core string literal -stringLitSpecTerm :: Text -> SpecTerm -stringLitSpecTerm = flatSpecTerm . StringLit - --- | Build a 'SpecTerm' for a pair -pairSpecTerm :: SpecTerm -> SpecTerm -> SpecTerm -pairSpecTerm t1 t2 = flatSpecTerm $ PairValue t1 t2 - --- | Build a 'SpecTerm' for a pair type -pairTypeSpecTerm :: SpecTerm -> SpecTerm -> SpecTerm -pairTypeSpecTerm t1 t2 = flatSpecTerm $ PairType t1 t2 - --- | Build a 'SpecTerm' for the left projection of a pair -pairLeftSpecTerm :: SpecTerm -> SpecTerm -pairLeftSpecTerm t = flatSpecTerm $ PairLeft t - --- | Build a 'SpecTerm' for the right projection of a pair -pairRightSpecTerm :: SpecTerm -> SpecTerm -pairRightSpecTerm t = flatSpecTerm $ PairRight t - -- | Build a 'SpecInfoTerm' for a constructor applied to its arguments ctorSpecInfoTerm :: Ident -> [SpecInfoTerm] -> SpecInfoTerm ctorSpecInfoTerm c args = fmap (ctorOpenTerm c) (sequence args) @@ -1002,26 +1138,12 @@ dataTypeSpecTerm :: Ident -> [SpecTerm] -> SpecTerm dataTypeSpecTerm d args = SpecTerm $ fmap (dataTypeSpecInfoTerm d) $ sequence $ map unSpecTerm args --- | Build a let expression as an 'SpecTerm'. This is equivalent to --- > 'applySpecTerm' ('lambdaSpecTerm' x tp body) rhs -letSpecTerm :: LocalName -> SpecTerm -> SpecTerm -> (SpecTerm -> SpecTerm) -> - SpecTerm -letSpecTerm x tp rhs body_f = applySpecTerm (lambdaSpecTerm x tp body_f) rhs - --- | Build a let expression as a 'SpecTerm' using the @sawLet@ combinator. This --- is equivalent to the term @sawLet tp tp_ret rhs (\ (x : tp) -> body_f)@ -sawLetSpecTerm :: LocalName -> SpecTerm -> SpecTerm -> SpecTerm -> - (SpecTerm -> SpecTerm) -> SpecTerm -sawLetSpecTerm x tp tp_ret rhs body_f = - applySpecTermMulti (globalSpecTerm "Prelude.sawLet") - [tp, tp_ret, rhs, lambdaSpecTerm x tp body_f] - -- | Build a let expression as an 'SpecTerm'. This is equivalent to -- > 'applySpecTerm' ('lambdaSpecTerm' x tp body) rhs sawLetPureSpecTerm :: LocalName -> SpecTerm -> SpecTerm -> SpecTerm -> (OpenTerm -> SpecTerm) -> SpecTerm sawLetPureSpecTerm x tp tp_ret rhs body_f = - applySpecTermMulti (globalSpecTerm "Prelude.sawLet") + applySpecTermMulti (globalTermLike "Prelude.sawLet") [tp, tp_ret, rhs, lambdaPureSpecTerm x tp body_f] From fc98dd71ec2d299541bff01acb63db29c01f562a Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 9 Aug 2023 11:36:55 -0700 Subject: [PATCH 036/305] Adapted to use the new TermLike interface; cleaned up how translatePermImpl works to make the interface simpler and more intuitive --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 1132 ++++++++++------- 1 file changed, 688 insertions(+), 444 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 80f72f4808..d8840d1897 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -36,6 +36,7 @@ import Data.Maybe import Numeric.Natural import Data.List hiding (inits) import Data.Text (pack) +import Data.Kind import GHC.TypeLits import Data.BitVector.Sized (BV) import qualified Data.BitVector.Sized as BV @@ -73,6 +74,7 @@ import Verifier.SAW.OpenTerm import Verifier.SAW.Term.Functor import Verifier.SAW.SharedTerm +import Verifier.SAW.Heapster.GenMonad import Verifier.SAW.Heapster.CruUtil import Verifier.SAW.Heapster.PatternMatchUtil import Verifier.SAW.Heapster.Permissions @@ -119,7 +121,7 @@ typeDescIsPure (TypeDescLRT _ _) = False -- | Get the type described by a 'TypeDesc' typeDescType :: TypeDesc -> SpecTerm -typeDescType (TypeDescPure tp) = openTermSpecTerm tp +typeDescType (TypeDescPure tp) = openTermLike tp typeDescType (TypeDescLRT _ tp) = tp -- | Get the @LetRecType@ that encodes the type of a 'TypeDesc' @@ -168,8 +170,8 @@ bvVecTypeDesc w_term len_term (TypeDescPure elem_tp) = bvVecTypeDesc w_term len_term (TypeDescLRT lrt elem_tp) = TypeDescLRT (applyGlobalOpenTerm "Prelude.LRT_BVVec" [w_term, len_term, lrt]) - (applyGlobalSpecTerm "Prelude.BVVec" [openTermSpecTerm w_term, - openTermSpecTerm len_term, elem_tp]) + (applyGlobalTermLike "Prelude.BVVec" [openTermLike w_term, + openTermLike len_term, elem_tp]) -- | The 'TypeDesc' for the unit type typeDescUnit :: TypeDesc @@ -178,7 +180,7 @@ typeDescUnit = TypeDescPure unitTypeOpenTerm -- | Build a type description for the pair of two type descriptions typeDescPair :: TypeDesc -> TypeDesc -> TypeDesc typeDescPair = - typeDescBinOp pairTypeOpenTerm "Prelude.LRT_Pair" pairTypeSpecTerm + typeDescBinOp pairTypeOpenTerm "Prelude.LRT_Pair" pairTypeTermLike -- | Build a type description for the @Either@ of two type descriptions typeDescEither :: TypeDesc -> TypeDesc -> TypeDesc @@ -186,7 +188,7 @@ typeDescEither = typeDescBinOp (\tp1 tp2 -> dataTypeOpenTerm "Prelude.Either" [tp1,tp2]) "Prelude.LRT_Either" - (\tp1 tp2 -> dataTypeSpecTerm "Prelude.Either" [tp1,tp2]) + (\tp1 tp2 -> dataTypeTermLike "Prelude.Either" [tp1,tp2]) -- | Build a type description for a @Sigma@ type from a pure type for the first -- projection and a function to a type description for the second projection. @@ -209,9 +211,9 @@ typeDescSigma x tp_l False tp_r_f = TypeDescLRT (ctorOpenTerm "Prelude.LRT_Sigma" [tp_l, lambdaOpenTerm x tp_l (typeDescLRT . tp_r_f)]) - (dataTypeSpecTerm "Prelude.Sigma" - [openTermSpecTerm tp_l, - lambdaPureSpecTerm x (openTermSpecTerm tp_l) (typeDescType . tp_r_f)]) + (dataTypeTermLike "Prelude.Sigma" + [openTermLike tp_l, + lambdaPureSpecTerm x (openTermLike tp_l) (typeDescType . tp_r_f)]) -- | 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 @@ -233,16 +235,22 @@ tupleOfTypeDescs (d : ds) = let d_r = tupleOfTypeDescs ds in TypeDescLRT (applyGlobalOpenTerm "Prelude.LRT_Pair" [typeDescLRT d, typeDescLRT d_r]) - (pairTypeSpecTerm (typeDescType d) (typeDescType d_r)) + (pairTypeTermLike (typeDescType d) (typeDescType d_r)) + +-- | Build the type description for the type @SpecM a@ for one of @a@ +specMTypeDesc :: TypeDesc -> TypeDesc +specMTypeDesc d = + TypeDescLRT (ctorOpenTerm "LRT_SpecM" [typeDescLRT d]) + (specMTypeSpecTerm $ typeDescType d) -- | 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 :: [SpecTerm] -> SpecTerm -tupleOfTerms [] = unitSpecTerm +tupleOfTerms [] = unitTermLike tupleOfTerms [t] = t -tupleOfTerms (t:ts) = pairSpecTerm t $ tupleOfTerms ts +tupleOfTerms (t:ts) = pairTermLike t $ tupleOfTerms ts -- | Project the @i@th element from a term of type @'tupleOfTypes' tps@. Note -- that this requires knowing the length of @tps@. @@ -259,9 +267,9 @@ projTupleOfTypesI :: [TypeDesc] -> Integer -> SpecTerm -> SpecTerm projTupleOfTypesI [] _ _ = panic "projTupleOfTypesI" ["projection of empty tuple!"] projTupleOfTypesI [_] 0 tup = tup -projTupleOfTypesI (_:_) 0 tup = pairLeftSpecTerm tup +projTupleOfTypesI (_:_) 0 tup = pairLeftTermLike tup projTupleOfTypesI (_:tps) i tup = - projTupleOfTypesI tps (i-1) $ pairRightSpecTerm tup + projTupleOfTypesI tps (i-1) $ pairRightTermLike tup -- | The result of translating a type-like construct such as a 'TypeRepr' or a -- permission, parameterized by the (Haskell) type of the translations of the @@ -354,12 +362,23 @@ mkImpTypeTrans1 d f = TypeTransImpure [d] $ \case -- type if it has 0 SAW types. It is an error if it has 2 or more SAW types. typeTransType1 :: HasCallStack => TypeTrans p tr -> PurityTerm p typeTransType1 (TypeTransPure [] _) = unitTypeOpenTerm -typeTransType1 (TypeTransImpure [] _) = unitTypeSpecTerm +typeTransType1 (TypeTransImpure [] _) = unitTypeTermLike typeTransType1 (TypeTransPure [tp] _) = tp typeTransType1 (TypeTransImpure [tp] _) = typeDescType tp typeTransType1 _ = panic "typeTransType1" ["More than one type when at most one expected"] +-- | 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. The +-- term is always impure, i.e., returned as a 'SpecTerm'. +typeTransType1Imp :: HasCallStack => TypeTrans p tr -> SpecTerm +typeTransType1Imp (TypeTransPure [] _) = unitTypeTermLike +typeTransType1Imp (TypeTransImpure [] _) = unitTypeTermLike +typeTransType1Imp (TypeTransPure [tp] _) = openTermLike tp +typeTransType1Imp (TypeTransImpure [tp] _) = typeDescType tp +typeTransType1Imp _ = + panic "typeTransType1Imp" ["More than one type when at most one 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 @@ -502,7 +521,7 @@ strictTransTupleTerm tr = tupleOpenTerm $ transTerms tr -- | Like 'transTupleTerm' but raise an error if there are more than 1 terms transTerm1 :: HasCallStack => IsTermTrans tr => tr -> SpecTerm -transTerm1 (transTerms -> []) = unitSpecTerm +transTerm1 (transTerms -> []) = unitTermLike transTerm1 (transTerms -> [t]) = t transTerm1 tr = panic "transTerm1" ["Expected at most one term, but found " ++ show (length $ transTerms tr)] @@ -517,7 +536,7 @@ instance IsPureTrans (TypeTrans 'True tr) where transPureTerms = typeTransTypes instance IsTermTrans (TypeTrans 'True tr) where - transTerms = map openTermSpecTerm . transPureTerms + transTerms = map openTermLike . transPureTerms instance IsTermTrans (TypeTrans 'False tr) where transTerms = typeTransTypes @@ -538,14 +557,14 @@ instance IsPureTrans (ExprTrans tp) where transPureTerms (ETrans_Term t) = [t] instance IsTermTrans (ExprTrans tp) where - transTerms = map openTermSpecTerm . transPureTerms + transTerms = map openTermLike . transPureTerms instance IsPureTrans (ExprTransCtx ctx) where transPureTerms MNil = [] transPureTerms (ctx :>: etrans) = transPureTerms ctx ++ transPureTerms etrans instance IsTermTrans (ExprTransCtx ctx) where - transTerms = map openTermSpecTerm . transPureTerms + transTerms = map openTermLike . transPureTerms -- | Map a context of expression translations to a list of 'SpecTerm's exprCtxToTerms :: ExprTransCtx tps -> [SpecTerm] @@ -604,7 +623,7 @@ class TransInfo info where -- 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 @@ -665,7 +684,7 @@ inExtTransSAWLetBindM :: TransInfo info => PureTypeTrans (ExprTrans tp) -> TransM info (ctx :> tp) SpecTerm -> TransM info ctx SpecTerm inExtTransSAWLetBindM tp_trans tp_ret etrans m = - sawLetTransMultiM "z" (map openTermSpecTerm $ + sawLetTransMultiM "z" (map openTermLike $ typeTransTypes tp_trans) tp_ret (transTerms etrans) $ \var_tms -> inExtTransM (typeTransF tp_trans var_tms) m @@ -700,7 +719,7 @@ applyPureTransM m1 m2 = applyOpenTerm <$> m1 <*> m2 -- | Apply the result of an impure translation to that of another applyImpTransM :: TransM info ctx SpecTerm -> TransM info ctx SpecTerm -> TransM info ctx SpecTerm -applyImpTransM m1 m2 = applySpecTerm <$> m1 <*> m2 +applyImpTransM m1 m2 = applyTermLike <$> m1 <*> m2 -- | Apply the result of a pure translation to that of multiple translations applyMultiPureTransM :: TransM info ctx OpenTerm -> @@ -709,10 +728,10 @@ applyMultiPureTransM :: TransM info ctx OpenTerm -> applyMultiPureTransM m ms = foldl applyPureTransM m ms -- | Apply the result of an impure translation to that of multiple translations -applyMultiImpTransM :: TransM info ctx SpecTerm -> - [TransM info ctx SpecTerm] -> - TransM info ctx SpecTerm -applyMultiImpTransM m ms = foldl applyImpTransM m ms +applyGlobalImpTransM :: Ident -> [TransM info ctx SpecTerm] -> + TransM info ctx SpecTerm +applyGlobalImpTransM ident ms = + foldl applyImpTransM (return $ globalTermLike ident) ms -- | Build a lambda-abstraction as an 'OpenTerm' inside the 'TransM' monad lambdaOpenTermTransM :: String -> OpenTerm -> @@ -728,7 +747,7 @@ lambdaSpecTermTransM :: String -> SpecTerm -> TransM info ctx SpecTerm lambdaSpecTermTransM x tp body_f = ask >>= \info -> - return (lambdaSpecTerm (pack x) tp $ \t -> runTransM (body_f t) info) + return (lambdaTermLike (pack x) tp $ \t -> runTransM (body_f t) info) -- | Build a nested lambda-abstraction -- @@ -740,10 +759,10 @@ lambdaTrans :: String -> TypeTrans p tr -> (tr -> SpecTerm) -> SpecTerm lambdaTrans x (TypeTransPure tps tr_f) body_f = lambdaPureSpecTermMulti (zipWith (\i tp -> (pack (x ++ show (i :: Integer)), tp)) [0..] $ - map openTermSpecTerm tps) + map openTermLike tps) (body_f . tr_f) lambdaTrans x (TypeTransImpure tps tr_f) body_f = - lambdaSpecTermMulti + lambdaTermLikeMulti (zipWith (\i tp -> (pack (x ++ show (i :: Integer)), typeDescType tp)) [0..] tps) (body_f . tr_f) @@ -829,7 +848,7 @@ letTransM :: String -> SpecTerm -> TransM info ctx SpecTerm -> letTransM x tp rhs_m body_m = do r <- ask return $ - letSpecTerm (pack x) tp (runTransM rhs_m r) (\x' -> runTransM (body_m x') r) + letTermLike (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 @@ -848,7 +867,7 @@ eitherTypeTrans tp_l tp_r = leftTrans :: IsTermTrans trL => ImpTypeTrans trL -> ImpTypeTrans trR -> trL -> SpecTerm leftTrans tp_l tp_r tr = - ctorSpecTerm "Prelude.Left" + ctorTermLike "Prelude.Left" [typeTransTupleType tp_l, typeTransTupleType tp_r, transTupleTerm tr] -- | Apply the @Right@ constructor of the @Either@ type in SAW to the @@ -856,7 +875,7 @@ leftTrans tp_l tp_r tr = rightTrans :: IsTermTrans trR => ImpTypeTrans trL -> ImpTypeTrans trR -> trR -> SpecTerm rightTrans tp_l tp_r tr = - ctorSpecTerm "Prelude.Right" + ctorTermLike "Prelude.Right" [typeTransTupleType tp_l, typeTransTupleType tp_r, transTupleTerm tr] -- | Eliminate a SAW @Either@ type @@ -867,7 +886,7 @@ eitherElimTransM :: ImpTypeTrans trL -> ImpTypeTrans 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 $ applySpecTermMulti (globalSpecTerm "Prelude.either") + return $ applyTermLikeMulti (globalTermLike "Prelude.either") [ typeTransTupleType tp_l, typeTransTupleType tp_r, typeTransTupleType tp_ret, fl_trans, fr_trans, eith ] @@ -882,13 +901,13 @@ eithersElimTransM tps tp_ret fs eith = foldr (\(tp,f) restM -> do f_trans <- lambdaTupleTransM "x_eith_elim" tp f rest <- restM - return (ctorSpecTerm "Prelude.FunsTo_Cons" + return (ctorTermLike "Prelude.FunsTo_Cons" [typeTransTupleType tp_ret, typeTransTupleType tp, f_trans, rest])) - (return $ ctorSpecTerm "Prelude.FunsTo_Nil" [typeTransTupleType tp_ret]) + (return $ ctorTermLike "Prelude.FunsTo_Nil" [typeTransTupleType tp_ret]) (zip tps fs) >>= \elims_trans -> - return (applyGlobalSpecTerm "Prelude.eithers" + return (applyGlobalTermLike "Prelude.eithers" [typeTransTupleType tp_ret, elims_trans, eith]) -- | Build the dependent pair type whose first projection type is the @@ -932,8 +951,8 @@ 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 (ctorSpecTerm "Prelude.exists" - [openTermSpecTerm (typeTransTupleType tp_l), tp_r_trm, + return (ctorTermLike "Prelude.exists" + [openTermLike (typeTransTupleType tp_l), tp_r_trm, transTupleTerm lhs, rhs]) -- | Like `sigmaTransM`, but translates `exists x.eq(y)` into just `x` @@ -958,17 +977,17 @@ sigmaElimTransM _ tp_l@(typeTransTypes -> []) tp_r _ f sigma = proj_r <- flip (typeTransF . tupleTypeTrans) [sigma] <$> tp_r proj_l f proj_l proj_r sigmaElimTransM x tp_l tp_r tp_ret_m f sigma = - do let tp_l_trm = openTermSpecTerm $ typeTransTupleType tp_l + do let tp_l_trm = openTermLike $ typeTransTupleType tp_l tp_r_trm <- lambdaTupleTransM x tp_l (\tr -> typeTransTupleType <$> tp_r tr) let proj_l_trm = - applyGlobalSpecTerm "Prelude.Sigma_proj1" [tp_l_trm, tp_r_trm, sigma] + applyGlobalTermLike "Prelude.Sigma_proj1" [tp_l_trm, tp_r_trm, sigma] tp_ret <- typeTransTupleType <$> tp_ret_m sawLetTransM x tp_l_trm tp_ret proj_l_trm $ \proj_l_pure -> do let proj_l = typeTransF (tupleTypeTrans tp_l) [proj_l_pure] tp_r_app <- tp_r proj_l let proj_r_trm = - applyGlobalSpecTerm "Prelude.Sigma_proj2" [tp_l_trm, + applyGlobalTermLike "Prelude.Sigma_proj2" [tp_l_trm, tp_r_trm, sigma] let proj_r = typeTransF (tupleTypeTrans tp_r_app) [proj_r_trm] f proj_l proj_r @@ -985,7 +1004,7 @@ sigmaElimPermTransM :: (TransInfo info) => TransM info ctx SpecTerm sigmaElimPermTransM x tp_l mb_p tp_ret_m f sigma = case mbMatch mb_p of [nuMP| ValPerm_Eq e |] -> - do let tp_l_trm = openTermSpecTerm $ typeTransTupleType tp_l + do let tp_l_trm = openTermLike $ typeTransTupleType tp_l tp_r_trm <- lambdaTupleTransM x tp_l (\tr -> typeTransTupleType <$> inExtTransM tr (translate mb_p)) @@ -1251,24 +1270,18 @@ 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 @@ -1628,7 +1641,7 @@ data LLVMArrayPermTrans ctx w = LLVMArrayPermTrans { -- | Get the SAW type of the cells of the translation of an array permission llvmArrayTransCellType :: LLVMArrayPermTrans ctx w -> SpecTerm -llvmArrayTransCellType = typeTransType1 . llvmArrayTransHeadCell +llvmArrayTransCellType = typeTransType1Imp . llvmArrayTransHeadCell -- | The translation of an 'LLVMArrayBorrow' is an element / proof of the @@ -1847,7 +1860,7 @@ instance IsTermTrans (AtomicPermTrans ctx a) where -- 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 - [failSpecTerm + [failTermLike ("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")] @@ -2129,8 +2142,8 @@ getLLVMArrayTransCell arr_trans mb_cell cell_tm (BVPropTrans _ in_rng_pf:_) = offsetLLVMAtomicPermTrans (mbMap2 llvmArrayCellToOffset (llvmArrayTransPerm arr_trans) mb_cell) $ typeTransF (llvmArrayTransHeadCell arr_trans) - [applyGlobalSpecTerm "Prelude.atBVVec" - [natSpecTerm w, openTermSpecTerm (llvmArrayTransLen arr_trans), + [applyGlobalTermLike "Prelude.atBVVec" + [natTermLike w, openTermLike (llvmArrayTransLen arr_trans), llvmArrayTransCellType arr_trans, llvmArrayTransTerm arr_trans, cell_tm, in_rng_pf]] getLLVMArrayTransCell _ _ _ _ = @@ -2146,8 +2159,8 @@ setLLVMArrayTransCell arr_trans cell_tm cell_value = let w = fromInteger $ natVal arr_trans in arr_trans { llvmArrayTransTerm = - applyGlobalSpecTerm "Prelude.updBVVec" - [natSpecTerm w, openTermSpecTerm (llvmArrayTransLen arr_trans), + applyGlobalTermLike "Prelude.updBVVec" + [natTermLike w, openTermLike (llvmArrayTransLen arr_trans), llvmArrayTransCellType arr_trans, llvmArrayTransTerm arr_trans, cell_tm, transTerm1 cell_value] } @@ -2164,7 +2177,7 @@ getLLVMArrayTransSlice :: (1 <= w, KnownNat w) => LLVMArrayPermTrans ctx w -> getLLVMArrayTransSlice arr_trans sub_arr_tp rng_trans prop_transs = let w = fromInteger $ natVal arr_trans elem_tp = llvmArrayTransCellType arr_trans - len_tm = openTermSpecTerm $ llvmArrayTransLen arr_trans + len_tm = openTermLike $ llvmArrayTransLen arr_trans v_tm = llvmArrayTransTerm arr_trans off_tm = transTerm1 $ bvRangeTransOff rng_trans len'_tm = transTerm1 $ bvRangeTransLen rng_trans @@ -2172,8 +2185,8 @@ getLLVMArrayTransSlice arr_trans sub_arr_tp rng_trans prop_transs = BVPropTrans _ p1_tm = p1_trans BVPropTrans _ p2_tm = p2_trans in typeTransF sub_arr_tp - [applyGlobalSpecTerm "Prelude.sliceBVVec" - [natSpecTerm w, len_tm, elem_tp, off_tm, len'_tm, p1_tm, p2_tm, v_tm]] + [applyGlobalTermLike "Prelude.sliceBVVec" + [natTermLike w, len_tm, elem_tp, off_tm, len'_tm, p1_tm, p2_tm, v_tm]] -- | Write a slice (= a sub-array) of the translation of an LLVM array -- permission given the translation of the slice and of the offset of that slice @@ -2184,14 +2197,14 @@ setLLVMArrayTransSlice :: (1 <= w, KnownNat w) => LLVMArrayPermTrans ctx w -> setLLVMArrayTransSlice arr_trans sub_arr_trans off_tm = let w = fromInteger $ natVal arr_trans elem_tp = llvmArrayTransCellType arr_trans - len_tm = openTermSpecTerm $ llvmArrayTransLen arr_trans + len_tm = openTermLike $ llvmArrayTransLen arr_trans arr_tm = llvmArrayTransTerm arr_trans - len'_tm = openTermSpecTerm $ llvmArrayTransLen sub_arr_trans + len'_tm = openTermLike $ llvmArrayTransLen sub_arr_trans sub_arr_tm = llvmArrayTransTerm sub_arr_trans in arr_trans { llvmArrayTransTerm = - applyGlobalSpecTerm "Prelude.updSliceBVVec" - [natSpecTerm w, len_tm, elem_tp, arr_tm, off_tm, len'_tm, sub_arr_tm] } + applyGlobalTermLike "Prelude.updSliceBVVec" + [natTermLike 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 @@ -2450,7 +2463,7 @@ translateLLVMArrayPerm mb_ap = let w_term = natOpenTerm w sh_trans <- translate $ mbMapCl $(mkClosed [| Perm_LLVMBlock . llvmArrayPermHead |]) mb_ap - let elem_tp = typeTransType1 sh_trans + let elem_tp = typeTransType1Imp sh_trans len_term <- translate1Pure $ mbLLVMArrayLen mb_ap {- bs_trans <- @@ -2636,16 +2649,6 @@ translateEntryRetType (TypedEntry {..} translateRetType typedEntryRets mb_perms_out -{- -NOWNOW: -- change uses of TypeTrans to include the purity flag -- NOTE: PermExprs translate to pure terms / OpenTerms -- compReturnTypeM should return a TypeDesc -- need a variant of piTransM that builds TypeDescs -- update the translation of shapes and perms to use ETrans_Shape and ETrans_Perm -- IDEA: change LOwnedTransTerm to have a single PermTransM that returns a - PermTransCtx; also remove the vars input from PermTransInfo - ---------------------------------------------------------------------- -- * The Implication Translation Monad ---------------------------------------------------------------------- @@ -2715,35 +2718,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 = @@ -2755,9 +2729,8 @@ data ImpTransInfo ext blocks tops rets ps ctx = itiPermStackVars :: RAssign (Member ctx) ps, itiPermEnv :: PermEnv, itiBlockMapTrans :: TypedBlockMapTrans ext blocks tops rets, - itiReturnType :: OpenTerm, - itiChecksFlag :: ChecksFlag, - itiFunStack :: FunStack + itiReturnType :: TypeDesc, + itiChecksFlag :: ChecksFlag } instance TransInfo (ImpTransInfo ext blocks tops rets ps) where @@ -2772,7 +2745,7 @@ instance TransInfo (ImpTransInfo ext blocks tops rets ps) where , .. } --- | 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) @@ -2780,11 +2753,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 -> TypeDesc -> 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, @@ -2793,8 +2765,7 @@ impTransM pvars pctx mapTrans stack retType = itiPermEnv = penv, itiBlockMapTrans = mapTrans, itiReturnType = retType, - itiChecksFlag = pflag, - itiFunStack = stack + itiChecksFlag = pflag } -- | Run an inner 'ImpTransM' computation that does not use the block map @@ -2956,94 +2927,444 @@ 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 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 :: SpecTerm -> ImpTypeTrans tr -> String -> + (tr -> ImpTransM ext blocks tops rets ps ctx SpecTerm) -> + ImpTransM ext blocks tops rets ps ctx SpecTerm 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] + return $ bindSpecTerm (typeTransType1Imp m_tp) ret_tp m k_tm + +-- | The current non-monadic return type as a type description +returnTypeDescM :: ImpTransM ext blocks tops rets ps_out ctx TypeDesc +returnTypeDescM = itiReturnType <$> ask + +-- | The current non-monadic return type as a term +returnTypeM :: ImpTransM ext blocks tops rets ps_out ctx SpecTerm +returnTypeM = typeDescType <$> returnTypeDescM --- | The current non-monadic return type -returnTypeM :: ImpTransM ext blocks tops rets ps_out ctx OpenTerm -returnTypeM = itiReturnType <$> ask +-- | Build the monadic return type @SpecM E evRetType stack ret@ as a type +-- description, where @ret@ is the current return type in 'itiReturnType' +compReturnTypeDescM :: ImpTransM ext blocks tops rets ps_out ctx TypeDesc +compReturnTypeDescM = specMTypeDesc <$> returnTypeDescM -- | 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 TypeDesc -compReturnTypeM = error "FIXME HERE NOWNOW" -- returnTypeM >>= specMImpTransM +compReturnTypeM :: ImpTransM ext blocks tops rets ps_out ctx SpecTerm +compReturnTypeM = typeDescType <$> compReturnTypeDescM -- | Like 'compReturnTypeM' but build a 'TypeTrans' compReturnTypeTransM :: - ImpTransM ext blocks tops rets ps_out ctx (TypeTrans 'False SpecTerm) -compReturnTypeTransM = flip mkImpTypeTrans1 id <$> compReturnTypeM + ImpTransM ext blocks tops rets ps_out ctx (ImpTypeTrans SpecTerm) +compReturnTypeTransM = flip mkImpTypeTrans1 id <$> compReturnTypeDescM -- | Build an @errorS@ computation with the given error message -mkErrorComp :: String -> ImpTransM ext blocks tops rets ps_out ctx OpenTerm +mkErrorComp :: String -> ImpTransM ext blocks tops rets ps_out ctx SpecTerm mkErrorComp msg = do ret_tp <- returnTypeM - applyNamedSpecOpM "Prelude.errorS" [ret_tp, stringLitOpenTerm (pack msg)] + return $ errorSpecTerm ret_tp (pack 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 + translateF :: Mb ctx (f ps) -> ImpTransM ext blocks tops rets ps ctx SpecTerm ---------------------------------------------------------------------- -- * 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 SpecTerm + -- | An error message to print on failure + | ImplFailContMsg String + +-- | Convert an 'ImplFailCont' to an error, which should have the given type +implFailContTerm :: SpecTerm -> ImplFailCont -> SpecTerm +implFailContTerm _ (ImplFailContTerm t) = t +implFailContTerm tp (ImplFailContMsg msg) = errorSpecTerm tp (pack msg) + +-- | Convert an 'ImplFailCont' to an error as in 'implFailContTerm', but use an +-- alternate error message in the case of 'ImplFailContMsg' +implFailAltContTerm :: SpecTerm -> String -> ImplFailCont -> SpecTerm +implFailAltContTerm _ _ (ImplFailContTerm t) = t +implFailAltContTerm tp msg (ImplFailContMsg _) = errorSpecTerm tp (pack 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 SpecTerm } + 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 -> compReturnTypeM >>= \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 -> + compReturnTypeM >>= \tp -> + return (implFailContTerm tp (case k of + ImplFailContMsg _ -> ImplFailContMsg msg + _ -> k)) + +-- | "Force" an optional 'PImplTerm' to a 'PImplTerm' by converting a 'Nothing' +-- to the 'failPImplTerm' +forcePImplTerm :: Maybe (PImplTerm ext blocks tops rets ps ctx) -> + PImplTerm ext blocks tops rets ps ctx +forcePImplTerm (Just t) = t +forcePImplTerm Nothing = failPImplTerm + + +-- | A flag to indicate whether a 'PImplTerm' calls its failure continuation +data HasFailures = HasFailures | NoFailures deriving Eq + +instance Semigroup HasFailures where + HasFailures <> _ = HasFailures + _ <> HasFailures = HasFailures + NoFailures <> NoFailures = NoFailures + +instance Monoid HasFailures where + mempty = NoFailures + +-- | A function for translating an @r@ +newtype ImpRTransFun r ext blocks tops rets = + ImpRTransFun { appImpTransFun :: + forall ps ctx. Mb ctx (r ps) -> + ImpTransM ext blocks tops rets ps ctx SpecTerm } + +-- | A monad transformer that adds an 'ImpRTransFun' translation function +newtype ImpRTransFunT r ext blocks tops rets m a = + ImpRTransFunT { unImpRTransFunT :: + ReaderT (ImpRTransFun r ext blocks tops rets) 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 m a -> + ImpRTransFun r ext blocks tops rets -> 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 m a -> + ImpRTransFunT r ext blocks tops rets 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 ps ctx = + MaybeT (WriterT ([String], HasFailures) + (ImpRTransFunT r ext blocks tops rets Identity)) + +-- | Run a 'PermImplTransM' computation +runPermImplTransM :: + PImplTransM r ext blocks tops rets ps ctx a -> + ImpRTransFun r ext blocks tops rets -> + (Maybe a, ([String], HasFailures)) +runPermImplTransM m rTransFun = + runIdentity $ runImpRTransFunT (runWriterT $ runMaybeT m) rTransFun + +-- | Look up the @r@ translation function +pimplRTransFunM :: PImplTransM r ext blocks tops rets ps ctx + (ImpRTransFun r ext blocks tops rets) +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 ps 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 ps ctx a -> + PImplTransM r ext blocks tops rets ps 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 ps ctx a -> + PImplTransM r ext blocks tops rets ps 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 ps 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 + + +{- +FIXME HERE NOWNOW: old stuff +-- | 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 SpecTerm + -- | An error message to print on failure + | ImplFailContMsg String + +-- | Convert an 'ImplFailCont' to an error, which should have the given type +implFailContTerm :: SpecTerm -> ImplFailCont -> SpecTerm +implFailContTerm _ (ImplFailContTerm t) = t +implFailContTerm tp (ImplFailContMsg msg) = errorSpecTerm tp (pack msg) + +-- | The type of terms use to translation permission implications, which can +-- contain calls to the current failure continuation; note that the destructor +-- "pops" the PImpl abstraction, returning a regular 'SpecTerm' +newtype PImplTerm = PImplTerm { popPImplTerm :: ImplFailCont -> SpecTerm } + deriving OpenTermLike + +-- | Lift a 'SpecTerm' to a 'PImplTerm' +specPImplTerm :: SpecTerm -> PImplTerm +specPImplTerm = PImplTerm . const + +-- | Build a 'PImplTerm' that let-binds a 'PImplTerm' using the supplied +-- variable name and type as the failure continuation for a body 'PImplTerm' +letFailPImplTerm :: LocalName -> SpecTerm -> PImplTerm -> PImplTerm -> PImplTerm +letFailPImplTerm x tp rhs body = + PImplTerm $ \k -> + letTermLike x tp (popPImplTerm rhs k) $ \k_tm -> + popPImplTerm body $ ImplFailContTerm k_tm + +-- | The failure 'PImplTerm', which immediately calls its failure continuation; +-- this should have the supplied type +failPImplTerm :: SpecTerm -> PImplTerm +failPImplTerm tp = PImplTerm $ \k -> 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 :: SpecTerm -> String -> PImplTerm +failPImplTermAlt tp msg = PImplTerm $ \k -> + implFailContTerm tp (case k of + ImplFailContMsg _ -> ImplFailContMsg msg + _ -> k) + +-- | "Force" an optional 'PImplTerm' to a 'PImplTerm' by converting a 'Nothing' +-- to the 'failPImplTerm', which should have the supplied type +forcePImplTerm :: SpecTerm -> Maybe PImplTerm -> PImplTerm +forcePImplTerm _ (Just t) = t +forcePImplTerm tp Nothing = failPImplTerm tp + + +-- | A flag to indicate whether a 'PImplTerm' calls its failure continuation +data HasFailures = HasFailures | NoFailures deriving Eq + +instance Semigroup HasFailures where + HasFailures <> _ = HasFailures + _ <> HasFailures = HasFailures + NoFailures <> NoFailures = NoFailures + +instance Monoid HasFailures where + mempty = NoFailures + +-- | A function for translating an @r@ +newtype ImpRTransFun r ext blocks tops rets = + ImpRTransFun { appImpTransCont :: + forall ps ctx. Mb ctx (r ps) -> + ImpTransM ext blocks tops rets ps ctx SpecTerm } + +-- | A monad transformer that adds an 'ImpRTransFun' translation function +newtype ImpRTransFunT r ext blocks tops rets m a = + ImpRTransFunT { unImpRTransFunT :: + ReaderT (ImpRTransFun r ext blocks tops rets) 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 m a -> + ImpRTransFun r ext blocks tops rets -> 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 m a -> + ImpRTransFunT r ext blocks tops rets 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; an +-- 'ImpRTransFunT' to pass along a function for translating the final @r@ result +-- inside the current 'PermImpl'; and an 'ImpTransM' for doing the impure +-- translation. +type PImplTransM r ext blocks tops rets ps ctx = + MaybeT (WriterT ([String], HasFailures) + (ImpRTransFunT r ext blocks tops rets + (ImpTransM ext blocks tops rets ps ctx))) + +-- | Run a 'PermImplTransM' computation +runPermImplTransM :: + PImplTransM r ext blocks tops rets ps ctx a -> + ImpRTransFun r ext blocks tops rets -> + ImpTransM ext blocks tops rets ps ctx (Maybe a, ([String], HasFailures)) +runPermImplTransM m rTransFun = + runImpRTransFunT (runWriterT $ runMaybeT m) rTransFun + +-- | Look up the @r@ translation function +pimplRTransFunM :: PImplTransM r ext blocks tops rets ps ctx + (ImpRTransFun r ext blocks tops rets) +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 ps ctx PImplTerm +pimplFailM msg = tell ([msg],HasFailures) >> mzero + +-- | Catch a potential 'Nothing' return value in a 'PImplTransM' computation +pimplCatchM :: PImplTransM r ext blocks tops rets ps ctx a -> + PImplTransM r ext blocks tops rets ps ctx (Maybe a) +pimplCatchM m = lift $ runMaybeT m + +-- | 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 :: PImplTransM r ext blocks tops rets ps ctx PImplTerm -> + PImplTransM r ext blocks tops rets ps ctx PImplTerm -> + PImplTransM r ext blocks tops rets ps ctx PImplTerm +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 t_catch <- m_catch + ret_tp <- lift $ lift $ lift compReturnTypeM + return $ letFailPImplTerm "catchpoint" ret_tp t_catch t + (Nothing, _) -> + -- If t definitely fails, then just use m_catch + m_catch + + +-- | Lift an 'ImpTransM' computation to 'PImplTransM' +pimplLift :: ImpTransM ext blocks tops rets ps_out ctx a -> + PImplTransM r ext blocks tops rets ps_out ctx a +pimplLift = lift . lift . lift + +-- | Call 'translate' in the 'PImplTransM' monad +pimplTranslate :: (Translate (ImpTransInfo ext blocks tops rets ps) ctx a tr, + HasCallStack) => + Mb ctx a -> PImplTransM r ext blocks tops rets ps ctx tr +pimplTranslate = pimplLift . translate + +-- | Call 'translate1' in the 'PImplTransM' monad +pimplTranslate1 :: (Translate (ImpTransInfo ext blocks tops rets ps) ctx a tr, + HasCallStack, IsTermTrans tr) => + Mb ctx a -> PImplTransM r ext blocks tops rets ps ctx SpecTerm +pimplTranslate1 = pimplLift . translate1 + +-- | The current non-monadic return type as a 'PImplTerm' +returnPImplTypeM :: PImplTransM r ext blocks tops rets ps_out ctx PImplTerm +returnPImplTypeM = specPImplTerm <$> returnTypeM + +-- | Like 'lambdaTransM' but over 'PImplTerm's +lambdaPImplTransM :: String -> TypeTrans p tr -> (tr -> TransM info ctx PImplTerm) -> + PImplTransM r ext blocks tops rets ps ctx PImplTerm +lambdaPImplTransM x tp body_f = + ask >>= \info -> + return (PImplTerm $ \k -> + lambdaTrans x tp (flip popPImplTerm k . flip runTransM info . body_f)) + +-- | Like 'bindSpecMTransM' but using 'PImplTerm's in the 'PImplTransM'. Note +-- that this will always say that it uses the failure continuation, because the +-- current interface for 'PImplTerm' cannot handle a lambda whose body returns a +-- 'Maybe' result, so we always have to force the body. +bindPImplSpecMTransM :: SpecTerm -> ImpTypeTrans tr -> String -> + (tr -> PImplTransM r ext blocks tops rets ps ctx PImplTerm) -> + PImplTransM r ext blocks tops rets ps ctx PImplTerm +bindPImplSpecMTransM m m_tp str f = + do ret_tp <- returnTypeM + k_tm <- lambdaPImplTransM str m_tp f + return $ PImplTerm $ \fk -> + bindSpecTerm (typeTransType1Imp m_tp) ret_tp m (popPImplTerm k_tm fk) +-} + + -- | Translate the output permissions of a 'SimplImpl' translateSimplImplOut :: Mb ctx (SimplImpl ps_in ps_out) -> ImpTransM ext blocks tops rets ps ctx - (TypeTrans (PermTransCtx ctx ps_out)) + (ImpTypeTrans (PermTransCtx ctx ps_out)) translateSimplImplOut = translate . mbSimplImplOut -- | Translate the head output permission of a 'SimplImpl' translateSimplImplOutHead :: Mb ctx (SimplImpl ps_in (ps_out :> a)) -> ImpTransM ext blocks tops rets ps ctx - (TypeTrans (PermTrans ctx a)) + (ImpTypeTrans (PermTrans ctx a)) translateSimplImplOutHead = translate . mbMapCl $(mkClosed [| varAndPermPerm . RL.head |]) . mbSimplImplOut -- | Translate the head of the tail of the output permission of a 'SimplImpl' translateSimplImplOutTailHead :: Mb ctx (SimplImpl ps_in (ps_out :> a :> b)) -> ImpTransM ext blocks tops rets ps ctx - (TypeTrans (PermTrans ctx a)) + (ImpTypeTrans (PermTrans ctx a)) translateSimplImplOutTailHead = translate . mbMapCl $(mkClosed [| varAndPermPerm . RL.head . RL.tail |]) . mbSimplImplOut @@ -3051,8 +3372,8 @@ translateSimplImplOutTailHead = -- | Translate a 'SimplImpl' to a function on translation computations translateSimplImpl :: Proxy ps -> Mb ctx (SimplImpl ps_in ps_out) -> - ImpTransM ext blocks tops rets (ps :++: ps_out) ctx OpenTerm -> - ImpTransM ext blocks tops rets (ps :++: ps_in) ctx OpenTerm + ImpTransM ext blocks tops rets (ps :++: ps_out) ctx SpecTerm -> + ImpTransM ext blocks tops rets (ps :++: ps_in) ctx SpecTerm translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of [nuMP| SImpl_Drop _ _ |] -> withPermStackM (\(xs :>: _) -> xs) (\(ps :>: _) -> ps) m @@ -3265,7 +3586,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of do tptrans <- translateSimplImplOutHead mb_simpl withPermStackM id (\(pctx :>: _) -> - pctx :>: typeTransF tptrans [globalOpenTerm $ mbLift ident]) + pctx :>: typeTransF tptrans [globalTermLike $ mbLift ident]) m [nuMP| SImpl_CastLLVMWord _ _ _ |] -> @@ -3451,10 +3772,11 @@ 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] + let arr_out_comp_tm = + applyTermLikeMulti (monadicSpecOp "Prelude.appendCastBVVecS") + [openTermLike w_term, openTermLike len1_tm, + openTermLike len2_tm, len3_tm, elem_tp, + transTerm1 ptrans1, transTerm1 ptrans2] bindSpecMTransM arr_out_comp_tm tp_trans "appended_array" $ \ptrans_arr' -> withPermStackM RL.tail (\(pctx :>: _ :>: _) -> pctx :>: ptrans_arr') m @@ -3475,15 +3797,16 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of [nuMP| SImpl_LLVMArrayEmpty x mb_ap |] -> do (w_tm, _, elem_tp, ap_tp_trans) <- translateLLVMArrayPerm mb_ap -- First we build a term of type Vec 0 elem_tp using EmptyVec - let vec_tm = applyGlobalOpenTerm "Prelude.EmptyVec" [elem_tp] + let vec_tm = applyGlobalTermLike "Prelude.EmptyVec" [elem_tp] -- Next, we build a computation that casts it to BVVec w 0x0 elem_tp let w = fromIntegral $ natVal2 mb_ap let bvZero_nat_tm = + openTermLike $ applyGlobalOpenTerm "Prelude.bvToNat" [w_tm, bvLitOpenTerm (replicate w False)] - vec_cast_m <- - applyNamedSpecOpM "Prelude.castVecS" [elem_tp, natOpenTerm 0, - bvZero_nat_tm, vec_tm] + let vec_cast_m = + applyTermLikeMulti (monadicSpecOp "Prelude.castVecS") + [elem_tp, natTermLike 0, bvZero_nat_tm, vec_tm] bindSpecMTransM vec_cast_m ap_tp_trans "empty_vec" $ \ptrans_arr -> withPermStackM (:>: translateVar x) (\pctx -> pctx :>: PTrans_Conj [APTrans_LLVMArray ptrans_arr]) @@ -3495,8 +3818,9 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of withPermStackM (:>: translateVar x) (\(pctx :>: ptrans_block) -> let arr_term = - applyOpenTermMulti (globalOpenTerm "Prelude.repeatBVVec") - [w_tm, len_tm, elem_tp, transTerm1 ptrans_block] in + applyGlobalTermLike "Prelude.repeatBVVec" + [openTermLike w_tm, openTermLike len_tm, + elem_tp, transTerm1 ptrans_block] in pctx :>: PTrans_Conj [APTrans_LLVMArray $ typeTransF ap_tp_trans [arr_term]] :>: ptrans_block) @@ -3519,8 +3843,9 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of applyOpenTermMulti (globalOpenTerm "Prelude.singletonBVVec") [w_tm, elem_tp, transTerm1 ptrans_cell] -} - applyOpenTermMulti (globalOpenTerm "Prelude.repeatBVVec") - [w_tm, len_tm, elem_tp, transTerm1 ptrans_cell] in + applyGlobalTermLike "Prelude.repeatBVVec" + [openTermLike w_tm, openTermLike len_tm, + elem_tp, transTerm1 ptrans_cell] in pctx :>: PTrans_Conj [APTrans_LLVMArray $ typeTransF ap_tp_trans [arr_term]]) m @@ -3610,10 +3935,11 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of -- 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] + let arr_out_comp_tm = + applyTermLikeMulti (monadicSpecOp "Prelude.mapBVVecS") + [elem_tp, typeTransType1Imp cell_out_trans, impl_tm, + openTermLike w_term, openTermLike 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' -> @@ -3638,6 +3964,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of m [nuMP| SImpl_SplitLifetime _ f args l _ _ _ _ ps_in ps_out |] -> + error "FIXME HERE NOWNOW" {- do pctx_out_trans <- translateSimplImplOut mb_simpl ps_in_trans <- translate ps_in ps_out_trans <- translate ps_out @@ -3655,7 +3982,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of -- output with tupleSpecMFunBoth RL.append pctx $ typeTransF pctx_out_trans (transTerms ptrans_x ++ [f_tm])) - m + m -} [nuMP| SImpl_SubsumeLifetime _ _ _ _ _ _ _ |] -> do pctx_out_trans <- translateSimplImplOut mb_simpl @@ -3698,7 +4025,9 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of [nuMP| SImpl_MapLifetime l _ _ _ ps_in ps_out _ _ ps_in' ps_out' ps1 ps2 impl_in impl_out |] -> + error "FIXME HERE NOWNOW" -- 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 @@ -3739,22 +4068,24 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of 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] + [typeTransType1Imp ps_in_trans, typeTransType1Imp ps_out_trans, + typeTransType1Imp 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] + [typeTransType1Imp ps_in'_trans, typeTransType1Imp ps_in_trans, + typeTransType1Imp ps_out'_trans, impl_in_tm, l_res_tm_h] -- Finally, update the permissions withPermStackM (\_ -> vars_out) (\_ -> RL.append pctx_ps $ typeTransF pctx_out_trans [l_res_tm]) 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 + error "FIXME HERE NOWNOW" {- do ps_out_trans <- tupleTypeTrans <$> translate ps_out let prxs_in = mbRAssignProxies ps_in :>: Proxy @@ -3775,8 +4106,8 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of -- in the rest of the computation lifted_m <- applyNamedSpecOpM "Prelude.liftStackS" - [typeTransType1 ps_out_trans, - applyOpenTerm (transTerm1 ptrans_l) (transTupleTerm pctx_in)] + [typeTransType1Imp ps_out_trans, + applyTermLike (transTerm1 ptrans_l) (transTupleTerm pctx_in)] bindSpecMTransM lifted_m ps_out_trans @@ -3786,9 +4117,11 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of (\(_ :>: l) -> vars_out :>: l) (\_ -> RL.append pctx_ps pctx_out :>: PTrans_Conj [APTrans_LFinished]) - m) + m) -} [nuMP| SImpl_IntroLOwnedSimple _ _ _ |] -> + error "FIXME HERE NOWNOW" + {- do let prx_ps_l = mbRAssignProxies $ mbSimplImplIn mb_simpl ttrans <- translateSimplImplOut mb_simpl withPermStackM id @@ -3796,16 +4129,19 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of let (pctx0, pctx_ps :>: _) = RL.split ps0 prx_ps_l pctx in RL.append pctx0 $ typeTransF ttrans (transTerms pctx_ps)) m + -} [nuMP| SImpl_ElimLOwnedSimple _ _ mb_lops |] -> + error "FIXME HERE NOWNOW" + {- do ttrans <- translateSimplImplOutHead mb_simpl lops_tp <- typeTransTupleType <$> translate mb_lops f_tm <- - lambdaOpenTermTransM "ps" lops_tp $ \x -> - applyNamedSpecOpEmptyM "Prelude.retS" [lops_tp, x] + lambdaSpecTermTransM "ps" lops_tp $ \x -> + return $ returnSpecTerm lops_tp x withPermStackM id (\(pctx0 :>: _) -> pctx0 :>: typeTransF ttrans [f_tm]) - m + m -} [nuMP| SImpl_LCurrentRefl l |] -> do ttrans <- translateSimplImplOutHead mb_simpl @@ -3825,25 +4161,25 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of [nuMP| SImpl_IntroLLVMBlockEmpty x _ |] -> do ttrans <- translateSimplImplOutHead mb_simpl withPermStackM (:>: translateVar x) - (\pctx -> pctx :>: typeTransF ttrans [unitOpenTerm]) + (\pctx -> pctx :>: typeTransF ttrans [unitTermLike]) m [nuMP| SImpl_CoerceLLVMBlockEmpty _ _ |] -> do ttrans <- translateSimplImplOutHead mb_simpl withPermStackM id - (\(pctx :>: _) -> pctx :>: typeTransF ttrans [unitOpenTerm]) + (\(pctx :>: _) -> pctx :>: typeTransF ttrans [unitTermLike]) m [nuMP| SImpl_ElimLLVMBlockToBytes _ mb_bp |] -> do let w = natVal2 mb_bp - let w_term = natOpenTerm w + let w_term = natTermLike w len_term <- translate1 $ fmap llvmBlockLen mb_bp ttrans <- translateSimplImplOutHead mb_simpl withPermStackM id (\(pctx :>: _) -> let arr_term = - applyOpenTermMulti (globalOpenTerm "Prelude.repeatBVVec") - [w_term, len_term, unitTypeOpenTerm, unitOpenTerm] in + applyGlobalTermLike "Prelude.repeatBVVec" + [w_term, len_term, unitTypeTermLike, unitTermLike] in pctx :>: typeTransF ttrans [arr_term]) m @@ -3851,22 +4187,22 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of do ttrans <- translateSimplImplOutHead mb_simpl withPermStackM id (\(pctx :>: ptrans) -> - pctx :>: typeTransF ttrans [pairOpenTerm (transTerm1 ptrans) - unitOpenTerm]) + pctx :>: typeTransF ttrans [pairTermLike (transTerm1 ptrans) + unitTermLike]) m [nuMP| SImpl_ElimLLVMBlockSeqEmpty _ _ |] -> do ttrans <- translateSimplImplOutHead mb_simpl withPermStackM id (\(pctx :>: ptrans) -> - pctx :>: typeTransF ttrans [pairLeftOpenTerm (transTerm1 ptrans)]) + pctx :>: typeTransF ttrans [pairLeftTermLike (transTerm1 ptrans)]) m [nuMP| SImpl_SplitLLVMBlockEmpty _ _ _ |] -> do ttrans <- translateSimplImplOutHead mb_simpl withPermStackM id (\(pctx :>: _) -> - pctx :>: typeTransF ttrans [unitOpenTerm, unitOpenTerm]) + pctx :>: typeTransF ttrans [unitTermLike, unitTermLike]) m -- Intro for a recursive named shape applies the fold function to the @@ -3883,8 +4219,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of _ -> error "Folding recursive shape before it is defined!" withPermStackM id (\(pctx :>: ptrans_x) -> - pctx :>: typeTransF ttrans [applyOpenTermMulti - (globalOpenTerm $ mbLift fold_id) + pctx :>: typeTransF ttrans [applyGlobalTermLike (mbLift fold_id) (transTerms args_trans ++ transTerms ptrans_x)]) m @@ -3912,8 +4247,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of _ -> error "Unfolding recursive shape before it is defined!" withPermStackM id (\(pctx :>: ptrans_x) -> - pctx :>: typeTransF ttrans [applyOpenTermMulti - (globalOpenTerm $ mbLift unfold_id) + pctx :>: typeTransF ttrans [applyGlobalTermLike (mbLift unfold_id) (transTerms args_trans ++ transTerms ptrans_x)]) m @@ -3996,7 +4330,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of withPermStackM RL.tail (\(pctx :>: ptrans1 :>: ptrans2) -> let pair_term = - pairOpenTerm (transTerm1 ptrans1) (transTerm1 ptrans2) in + pairTermLike (transTerm1 ptrans1) (transTerm1 ptrans2) in pctx :>: typeTransF ttrans [pair_term]) m @@ -4004,8 +4338,8 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of do ttrans <- translateSimplImplOutHead mb_simpl withPermStackM id (\(pctx :>: ptrans) -> - pctx :>: typeTransF ttrans [pairLeftOpenTerm (transTerm1 ptrans), - pairRightOpenTerm (transTerm1 ptrans)]) + pctx :>: typeTransF ttrans [pairLeftTermLike (transTerm1 ptrans), + pairRightTermLike (transTerm1 ptrans)]) m [nuMP| SImpl_IntroLLVMBlockOr _ _ _ |] -> @@ -4044,8 +4378,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of let fold_ident = mbLift $ fmap recPermFoldFun rp withPermStackM id (\(pctx :>: ptrans_x) -> - pctx :>: typeTransF ttrans [applyOpenTermMulti - (globalOpenTerm fold_ident) + pctx :>: typeTransF ttrans [applyGlobalTermLike fold_ident (transTerms args_trans ++ transTerms ptrans_x)]) m @@ -4057,8 +4390,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of withPermStackM id (\(pctx :>: ptrans_x) -> pctx :>: - typeTransF (tupleTypeTrans ttrans) [applyOpenTermMulti - (globalOpenTerm unfold_ident) + typeTransF (tupleTypeTrans ttrans) [applyGlobalTermLike unfold_ident (transTerms args_trans ++ [transTerm1 ptrans_x])]) m @@ -4127,8 +4459,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of withPermStackM RL.tail (\(pctx :>: ptrans_x :>: ptrans_y) -> pctx :>: - typeTransF (tupleTypeTrans ttrans) [applyOpenTermMulti - (globalOpenTerm trans_ident) + typeTransF (tupleTypeTrans ttrans) [applyGlobalTermLike trans_ident (transTerms args_trans ++ transTerms e_trans ++ transTerms y_trans @@ -4162,137 +4493,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) + (ImpTransM ext blocks tops rets ps_out (ctx :++: bs) SpecTerm -> + ImpTransM ext blocks tops rets ps ctx SpecTerm) -> + 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 + PImplTerm <$> fmap f <$> popPImplTerm <$> + translatePermImpl (mbCombine RL.typeCtxProxies 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 |], _) -> @@ -4313,27 +4545,28 @@ 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) + popPImplTerm (forcePImplTerm maybe_trans) k) (transTupleTerm top_ptrans) -- An existential elimination performs a pattern-match on a Sigma @@ -4353,11 +4586,11 @@ 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 - applyImpMultiTransM (return $ globalOpenTerm "Prelude.efq") + applyGlobalImpTransM "Prelude.efq" [compReturnTypeM, return $ transTerm1 top_ptrans] -- A SimplImpl is translated using translateSimplImpl @@ -4434,7 +4667,7 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl tp_trans2 <- translate mb_p_out2 withPermStackM (:>: Member_Base) (\(pctx :>: ptrans) -> - pctx :>: typeTransF tp_trans1 [unitOpenTerm] :>: + pctx :>: typeTransF tp_trans1 [unitTermLike] :>: typeTransF tp_trans2 [transTerm1 ptrans]) m @@ -4446,9 +4679,7 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl e_tm <- translate1Pure 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) $ @@ -4476,9 +4707,7 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl e_tm <- translate1Pure 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) $ @@ -4521,6 +4750,8 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl m ([nuMP| Impl1_BeginLifetime |], _) -> + error "FIXME HERE NOWNOW" + {- translatePermImplUnary mb_impls $ \m -> inExtTransM ETrans_Lifetime $ do tp_trans <- translateClosed (ValPerm_LOwned @@ -4529,15 +4760,16 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl lambdaOpenTermTransM "ps_empty" unitTypeOpenTerm $ \x -> applyNamedSpecOpM "Prelude.retS" [unitTypeOpenTerm, x] withPermStackM (:>: Member_Base) (:>: typeTransF tp_trans [id_fun]) m + -} -- If e1 and e2 are already equal, short-circuit the proof construction and then -- elimination ([nuMP| Impl1_TryProveBVProp x prop@(BVProp_Eq e1 e2) _ |], _) | mbLift (mbMap2 bvEq e1 e2) -> translatePermImplUnary mb_impls $ \m -> - do bv_tp <- typeTransType1 <$> translateClosed (mbExprType e1) + do bv_tp <- typeTransType1Imp <$> translateClosed (mbExprType e1) e1_trans <- translate1 e1 - let pf = ctorOpenTerm "Prelude.Refl" [bv_tp, e1_trans] + let pf = ctorTermLike "Prelude.Refl" [bv_tp, e1_trans] withPermStackM (:>: translateVar x) (:>: PTrans_Conj [APTrans_BVProp (BVPropTrans prop pf)]) m @@ -4545,7 +4777,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 @@ -4554,168 +4786,168 @@ 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 - applyImpMultiTransM (return $ globalOpenTerm "Prelude.maybe") - [ return (typeTransType1 prop_tp_trans), compReturnTypeM - , implTransAltErr (mbLift prop_str) k + ret_tp <- compReturnTypeM + applyGlobalImpTransM "Prelude.maybe" + [ return (typeTransType1Imp prop_tp_trans), return ret_tp + , return (implFailAltContTerm ret_tp (mbLift prop_str) k) , lambdaTransM "eq_pf" prop_tp_trans (\prop_trans -> withPermStackM (:>: translateVar x) (:>: bvPropPerm prop_trans) $ - trans k) - , applyImpMultiTransM (return $ globalOpenTerm "Prelude.bvEqWithProof") - [ return (natOpenTerm $ natVal2 prop) , translate1 e1, translate1 e2]] + popPImplTerm trans k) + , applyGlobalImpTransM "Prelude.bvEqWithProof" + [ return (natTermLike $ natVal2 prop) , translate1 e1, translate1 e2]] -- If e1 and e2 are already unequal, short-circuit and do nothing ([nuMP| Impl1_TryProveBVProp x prop@(BVProp_Neq e1 e2) _ |], _) | not $ mbLift (mbMap2 bvCouldEqual e1 e2) -> translatePermImplUnary mb_impls $ withPermStackM (:>: translateVar x) - (:>: PTrans_Conj [APTrans_BVProp (BVPropTrans prop unitOpenTerm)]) + (:>: PTrans_Conj [APTrans_BVProp (BVPropTrans prop unitTermLike)]) -- 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 - applyImpMultiTransM (return $ globalOpenTerm "Prelude.ite") + applyGlobalImpTransM "Prelude.ite" [ compReturnTypeM - , applyImpMultiTransM (return $ globalOpenTerm "Prelude.bvEq") - [ return (natOpenTerm w), translate1 e1, translate1 e2 ] - , implTransAltErr (mbLift prop_str) k + , applyGlobalImpTransM "Prelude.bvEq" + [ return (natTermLike w), translate1 e1, translate1 e2 ] + , (\ret_tp -> + implFailAltContTerm ret_tp (mbLift prop_str) k) <$> compReturnTypeM , withPermStackM (:>: translateVar x) - (:>: PTrans_Conj [APTrans_BVProp (BVPropTrans prop unitOpenTerm)]) $ - trans k] + (:>: PTrans_Conj [APTrans_BVProp (BVPropTrans prop unitTermLike)]) $ + 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") - [natOpenTerm w, t1, t2] + applyGlobalTermLike "Prelude.unsafeAssertBVULt" + [natTermLike 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 ([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 - applyImpMultiTransM (return $ globalOpenTerm "Prelude.maybe") - [ return (typeTransType1 prop_tp_trans), compReturnTypeM - , implTransAltErr (mbLift prop_str) k + ret_tp <- compReturnTypeM + applyGlobalImpTransM "Prelude.maybe" + [ return (typeTransType1Imp prop_tp_trans), return ret_tp + , return (implFailAltContTerm ret_tp (mbLift prop_str) k) , lambdaTransM "ult_pf" prop_tp_trans (\prop_trans -> withPermStackM (:>: translateVar x) (:>: bvPropPerm prop_trans) $ - trans k) - , applyImpMultiTransM (return $ globalOpenTerm "Prelude.bvultWithProof") - [ return (natOpenTerm $ natVal2 prop), translate1 e1, translate1 e2] + popPImplTerm trans k) + , applyGlobalImpTransM "Prelude.bvultWithProof" + [ return (natTermLike $ natVal2 prop), translate1 e1, translate1 e2] ] -- 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") - [natOpenTerm w, t1, t2] + applyGlobalTermLike "Prelude.unsafeAssertBVULe" + [natTermLike 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 ([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 - applyImpMultiTransM (return $ globalOpenTerm "Prelude.maybe") - [ return (typeTransType1 prop_tp_trans), compReturnTypeM - , implTransAltErr (mbLift prop_str) k + ret_tp <- compReturnTypeM + applyGlobalImpTransM "Prelude.maybe" + [ return (typeTransType1Imp prop_tp_trans), return ret_tp + , return (implFailAltContTerm ret_tp (mbLift prop_str) k) , lambdaTransM "ule_pf" prop_tp_trans (\prop_trans -> withPermStackM (:>: translateVar x) (:>: bvPropPerm prop_trans) $ - trans k) - , applyImpMultiTransM (return $ globalOpenTerm "Prelude.bvuleWithProof") - [ return (natOpenTerm $ natVal2 prop), translate1 e1, translate1 e2] + popPImplTerm trans k) + , applyGlobalImpTransM "Prelude.bvuleWithProof" + [ return (natTermLike $ natVal2 prop), translate1 e1, translate1 e2] ] -- 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") - [natOpenTerm w, t1, - applyOpenTermMulti (globalOpenTerm - "Prelude.bvSub") [natOpenTerm w, t2, t3]] + applyGlobalTermLike "Prelude.unsafeAssertBVULe" + [natTermLike w, t1, + applyGlobalTermLike "Prelude.bvSub" [natTermLike 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 ([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 - applyImpMultiTransM (return $ globalOpenTerm "Prelude.maybe") - [ return (typeTransType1 prop_tp_trans), compReturnTypeM - , implTransAltErr (mbLift prop_str) k + ret_tp <- compReturnTypeM + applyGlobalImpTransM "Prelude.maybe" + [ return (typeTransType1Imp prop_tp_trans), return ret_tp + , 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) - , applyImpMultiTransM (return $ globalOpenTerm "Prelude.bvuleWithProof") - [ return (natOpenTerm $ natVal2 prop), translate1 e1, - applyImpMultiTransM (return $ globalOpenTerm "Prelude.bvSub") - [return (natOpenTerm $ natVal2 prop), translate1 e2, translate1 e3]] + popPImplTerm trans k) + , applyGlobalImpTransM "Prelude.bvuleWithProof" + [ return (natTermLike $ natVal2 prop), translate1 e1, + applyGlobalImpTransM "Prelude.bvSub" + [return (natTermLike $ natVal2 prop), translate1 e2, translate1 e3]] ] ([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 r [nuMP| PermImpl_Step impl1 mb_impls |] -> - translatePermImpl1 prx impl1 mb_impls - + translatePermImpl1 impl1 mb_impls +{- instance ImplTranslateF r ext blocks tops rets => Translate (ImpTransInfo ext blocks tops rets ps) - ctx (AnnotPermImpl r ps) OpenTerm where + ctx (AnnotPermImpl r ps) SpecTerm where translate (mbMatch -> [nuMP| AnnotPermImpl err impl |]) = let (transF, (errs,_)) = runPermImplTransM $ translatePermImpl Proxy impl in forceImplTrans transF $ @@ -4728,13 +4960,14 @@ instance ImplTranslateF (LocalImplRet ps) ext blocks ps_in rets where translateF _ = do pctx <- itiPermStack <$> ask ret_tp <- returnTypeM - applyNamedSpecOpM "Prelude.retS" [ret_tp, transTupleTerm pctx] + return $ returnSpecTerm ret_tp (transTupleTerm pctx) -- | Translate a local implication to its output, adding an error message translateLocalPermImpl :: String -> Mb ctx (LocalPermImpl ps_in ps_out) -> - ImpTransM ext blocks tops rets ps_in ctx OpenTerm + ImpTransM ext blocks tops rets ps_in ctx SpecTerm translateLocalPermImpl err (mbMatch -> [nuMP| LocalPermImpl impl |]) = clearVarPermsM $ translate $ fmap (AnnotPermImpl err) impl +-} -- | Translate a local implication over two sequences of permissions (already -- translated to types) to a monadic function with the first sequence of @@ -4745,17 +4978,29 @@ translateLocalPermImpl err (mbMatch -> [nuMP| LocalPermImpl impl |]) = translateCurryLocalPermImpl :: String -> Mb ctx (LocalPermImpl (ps1 :++: ps2) ps_out) -> PermTransCtx ctx ps1 -> RAssign (Member ctx) ps1 -> - TypeTrans (PermTransCtx ctx ps2) -> RAssign (Member ctx) ps2 -> - TypeTrans (PermTransCtx ctx ps_out) -> - ImpTransM ext blocks tops rets ps ctx OpenTerm + ImpTypeTrans (PermTransCtx ctx ps2) -> RAssign (Member ctx) ps2 -> + ImpTypeTrans (PermTransCtx ctx ps_out) -> + ImpTransM ext blocks tops rets ps ctx SpecTerm +translateCurryLocalPermImpl = error "FIXME HERE NOWNOW" +{- 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 = typeTransTupleDesc tp_trans_out }) $ withPermStackM (const (RL.append vars1 vars2)) (const (RL.append pctx1 pctx2)) (translateLocalPermImpl err impl) +-} +{- +NOWNOW: +- change uses of TypeTrans to include the purity flag +- NOTE: PermExprs translate to pure terms / OpenTerms +- compReturnTypeM should return a TypeDesc +- need a variant of piTransM that builds TypeDescs +- update the translation of shapes and perms to use ETrans_Shape and ETrans_Perm +- IDEA: change LOwnedTransTerm to have a single PermTransM that returns a + PermTransCtx; also remove the vars input from PermTransInfo ---------------------------------------------------------------------- -- * Translating Typed Crucible Expressions @@ -5208,7 +5453,7 @@ translateStmt loc mb_stmt m = case mbMatch mb_stmt of -- FIXME HERE: figure out why these asserts always translate to ite True [nuMP| TypedAssert e _ |] -> - applyImpMultiTransM (return $ globalOpenTerm "Prelude.ite") + applyGlobalImpTransM "Prelude.ite" [compReturnTypeM, translate1 e, m, mkErrorComp ("Failed Assert at " ++ renderDoc (ppShortFileName (plSourceLoc loc)))] @@ -5393,7 +5638,7 @@ instance PermCheckExtC ext exprExt => (flip inExtMultiTransM $ translate $ mbCombine rets_prxs mb_perms) rets_ns_trans (itiPermStack <$> ask) - applyNamedSpecOpM "Prelude.retS" [ret_tp, sigma_trm] + returnSpecTerm ret_tp sigma_trm instance PermCheckExtC ext exprExt => ImplTranslateF (TypedRet tops rets) ext blocks tops rets where @@ -5405,7 +5650,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 |] -> - applyImpMultiTransM (return $ globalOpenTerm "Prelude.ite") + applyGlobalImpTransM "Prelude.ite" [compReturnTypeM, translate1 reg, translate impl_tgt1, translate impl_tgt2] [nuMP| TypedReturn impl_ret |] -> translate impl_ret @@ -5569,14 +5814,14 @@ translateTypedBlockMap blkMap = -- over the top-level, local, and ghost arguments and (the translations of) the -- input permissions of the entrypoint 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 = +translateEntryBody mapTrans entry = lambdaExprCtx (typedEntryAllArgs 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 @@ -5591,11 +5836,11 @@ translateBlockMapBodies stack mapTrans blkMap = -- | FIXME HERE NOW: docs translateCFGInitEntryBody :: - PermCheckExtC ext exprExt => FunStack -> + 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) = +translateCFGInitEntryBody mapTrans (cfg :: TypedCFG ext blocks ghosts inits gouts ret) = let fun_perm = tpcfgFunPerm cfg h = tpcfgHandle cfg ctx = typedFnHandleAllArgs h @@ -5616,20 +5861,20 @@ translateCFGInitEntryBody stack mapTrans (cfg :: TypedCFG ext blocks ghosts init let all_membs = RL.members pctx all_px = RL.map (\_ -> Proxy) pctx init_entry = lookupEntryTransCast (tpcfgEntryID cfg) CruCtxNil mapTrans in - impTransM all_membs pctx mapTrans stack retTypeTrans $ + impTransM all_membs pctx mapTrans retTypeTrans $ translateCallEntry "CFG" init_entry (nuMulti all_px id) (nuMulti all_px $ const MNil) -- | FIXME HERE NOW: docs -translateCFGBodies :: PermCheckExtC ext exprExt => FunStack -> Natural -> +translateCFGBodies :: PermCheckExtC ext exprExt => Natural -> TypedCFG ext blocks ghosts inits gouts ret -> TypeTransM RNil [OpenTerm] -translateCFGBodies stack start_ix cfg = +translateCFGBodies 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 + init_body <- translateCFGInitEntryBody mapTrans cfg return (init_body : bodies) -- | Lambda-abstract over all the expression and permission arguments of the @@ -5778,7 +6023,6 @@ tcTranslateAddCFGs sc mod_name env checks endianness dlevel cfgs_and_perms = 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 @@ -5845,7 +6089,7 @@ translateCompleteFunPerm sc env fun_perm = -- | Translate a 'TypeRepr' to the SAW core type it represents translateCompleteType :: SharedContext -> PermEnv -> TypeRepr tp -> IO Term translateCompleteType sc env typ_perm = - completeNormOpenTerm sc $ typeTransType1 $ + completeNormOpenTerm sc $ typeTransType1Imp $ runNilTypeTransM env noChecks $ translate $ emptyMb typ_perm -- | Translate a 'TypeRepr' within the given context of type arguments to the @@ -5854,7 +6098,7 @@ translateCompleteTypeInCtx :: SharedContext -> PermEnv -> CruCtx args -> Mb args (TypeRepr a) -> IO Term translateCompleteTypeInCtx sc env args ret = completeNormOpenTerm sc $ - runNilTypeTransM env noChecks (piExprCtx args (typeTransType1 <$> + runNilTypeTransM env noChecks (piExprCtx args (typeTransType1Imp <$> translate ret)) -- | Translate an input list of 'ValuePerms' and an output 'ValuePerm' to a SAW From f5f174a0621f363f351b93f047c63f3d08242f82 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 9 Aug 2023 12:08:07 -0700 Subject: [PATCH 037/305] Updated SAWTranslation.hs as far as translating statements and sequences of statements --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 171 ++++++++++-------- 1 file changed, 96 insertions(+), 75 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index d8840d1897..c6c6371600 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -526,6 +526,13 @@ transTerm1 (transTerms -> [t]) = t transTerm1 tr = panic "transTerm1" ["Expected at most one term, but found " ++ show (length $ transTerms tr)] +-- | Like 'transTerm1' but for pure terms +transPureTerm1 :: HasCallStack => IsPureTrans tr => tr -> OpenTerm +transPureTerm1 (transPureTerms -> []) = unitOpenTerm +transPureTerm1 (transPureTerms -> [t]) = t +transPureTerm1 tr = panic "transPureTerm1" ["Expected at most one term, but found " + ++ show (length $ transPureTerms tr)] + instance IsTermTrans tr => IsTermTrans [tr] where transTerms = concatMap transTerms @@ -2660,7 +2667,7 @@ translateEntryRetType (TypedEntry {..} data TypedEntryTrans ext blocks tops rets args ghosts = TypedEntryTrans { typedEntryTransEntry :: TypedEntry TransPhase ext blocks tops rets args ghosts, - typedEntryTransRecIx :: Maybe Natural } + typedEntryTransRecIx :: Maybe (Natural, OpenTerm) } -- | A mapping from a block to the SAW functions for each entrypoint data TypedBlockTrans ext blocks tops rets args = @@ -4944,17 +4951,19 @@ translatePermImpl mb_impl = case mbMatch mb_impl of [nuMP| PermImpl_Step impl1 mb_impls |] -> translatePermImpl1 impl1 mb_impls -{- instance ImplTranslateF r ext blocks tops rets => Translate (ImpTransInfo ext blocks tops rets ps) ctx (AnnotPermImpl r ps) SpecTerm where translate (mbMatch -> [nuMP| AnnotPermImpl err impl |]) = - let (transF, (errs,_)) = runPermImplTransM $ translatePermImpl Proxy impl in - forceImplTrans transF $ + let (maybe_ptm, (errs,_)) = + runPermImplTransM (translatePermImpl impl) (ImpRTransFun + translateF) in + popPImplTerm (forcePImplTerm maybe_ptm) $ ImplFailContMsg (mbLift err ++ "\n\n" ++ concat (intersperse "\n\n--------------------\n\n" errs)) +{- -- We translate a LocalImplRet to a term that returns all current permissions instance ImplTranslateF (LocalImplRet ps) ext blocks ps_in rets where translateF _ = @@ -4993,14 +5002,10 @@ translateCurryLocalPermImpl err impl pctx1 vars1 tp_trans2 vars2 tp_trans_out = -} {- -NOWNOW: -- change uses of TypeTrans to include the purity flag -- NOTE: PermExprs translate to pure terms / OpenTerms -- compReturnTypeM should return a TypeDesc -- need a variant of piTransM that builds TypeDescs -- update the translation of shapes and perms to use ETrans_Shape and ETrans_Perm -- IDEA: change LOwnedTransTerm to have a single PermTransM that returns a - PermTransCtx; also remove the vars input from PermTransInfo +FIXME HERE NOWNOW: change LOwnedTransTerms to be continuation computations, and +add a function to translate PermImpls to these computations for MapLifetime +-} + ---------------------------------------------------------------------- -- * Translating Typed Crucible Expressions @@ -5024,10 +5029,10 @@ instance TransInfo info => [nuMP| RegWithVal _ e |] -> translate e [nuMP| RegNoVal x |] -> translate x --- | Translate a 'RegWithVal' to exactly one SAW term via 'transTerm1' +-- | Translate a 'RegWithVal' to exactly one SAW term via 'transPureTerm1' translateRWV :: TransInfo info => Mb ctx (RegWithVal a) -> TransM info ctx OpenTerm -translateRWV mb_rwv = transTerm1 <$> translate mb_rwv +translateRWV mb_rwv = transPureTerm1 <$> translate mb_rwv -- translate for a TypedExpr yields an ExprTrans instance (PermCheckExtC ext exprExt, TransInfo info) => @@ -5035,15 +5040,15 @@ instance (PermCheckExtC ext exprExt, TransInfo info) => translate mb_e = case mbMatch mb_e of [nuMP| BaseIsEq BaseBoolRepr e1 e2 |] -> ETrans_Term <$> - applyPureMultiTransM (return $ globalOpenTerm "Prelude.boolEq") + applyMultiPureTransM (return $ globalOpenTerm "Prelude.boolEq") [translateRWV e1, translateRWV e2] -- [nuMP| BaseIsEq BaseNatRepr e1 e2 |] -> -- ETrans_Term <$> - -- applyPureMultiTransM (return $ globalOpenTerm "Prelude.equalNat") + -- applyMultiPureTransM (return $ globalOpenTerm "Prelude.equalNat") -- [translateRWV e1, translateRWV e2] [nuMP| BaseIsEq (BaseBVRepr w) e1 e2 |] -> ETrans_Term <$> - applyPureMultiTransM (return $ globalOpenTerm "Prelude.bvEq") + applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvEq") [translate w, translateRWV e1, translateRWV e2] [nuMP| EmptyApp |] -> return ETrans_Unit @@ -5055,19 +5060,19 @@ instance (PermCheckExtC ext exprExt, TransInfo info) => return $ ETrans_Term $ globalOpenTerm "Prelude.False" [nuMP| Not e |] -> ETrans_Term <$> - applyPureMultiTransM (return $ globalOpenTerm "Prelude.not") + applyMultiPureTransM (return $ globalOpenTerm "Prelude.not") [translateRWV e] [nuMP| And e1 e2 |] -> ETrans_Term <$> - applyPureMultiTransM (return $ globalOpenTerm "Prelude.and") + applyMultiPureTransM (return $ globalOpenTerm "Prelude.and") [translateRWV e1, translateRWV e2] [nuMP| Or e1 e2 |] -> ETrans_Term <$> - applyPureMultiTransM (return $ globalOpenTerm "Prelude.or") + applyMultiPureTransM (return $ globalOpenTerm "Prelude.or") [translateRWV e1, translateRWV e2] [nuMP| BoolXor e1 e2 |] -> ETrans_Term <$> - applyPureMultiTransM (return $ globalOpenTerm "Prelude.xor") + applyMultiPureTransM (return $ globalOpenTerm "Prelude.xor") [translateRWV e1, translateRWV e2] -- Natural numbers @@ -5075,32 +5080,32 @@ instance (PermCheckExtC ext exprExt, TransInfo info) => return $ ETrans_Term $ natOpenTerm $ mbLift n [nuMP| NatLt e1 e2 |] -> ETrans_Term <$> - applyPureMultiTransM (return $ globalOpenTerm "Prelude.ltNat") + applyMultiPureTransM (return $ globalOpenTerm "Prelude.ltNat") [translateRWV e1, translateRWV e2] -- [nuMP| NatLe _ _ |] -> [nuMP| NatEq e1 e2 |] -> ETrans_Term <$> - applyPureMultiTransM (return $ globalOpenTerm "Prelude.equalNat") + applyMultiPureTransM (return $ globalOpenTerm "Prelude.equalNat") [translateRWV e1, translateRWV e2] [nuMP| NatAdd e1 e2 |] -> ETrans_Term <$> - applyPureMultiTransM (return $ globalOpenTerm "Prelude.addNat") + applyMultiPureTransM (return $ globalOpenTerm "Prelude.addNat") [translateRWV e1, translateRWV e2] [nuMP| NatSub e1 e2 |] -> ETrans_Term <$> - applyPureMultiTransM (return $ globalOpenTerm "Prelude.subNat") + applyMultiPureTransM (return $ globalOpenTerm "Prelude.subNat") [translateRWV e1, translateRWV e2] [nuMP| NatMul e1 e2 |] -> ETrans_Term <$> - applyPureMultiTransM (return $ globalOpenTerm "Prelude.mulNat") + applyMultiPureTransM (return $ globalOpenTerm "Prelude.mulNat") [translateRWV e1, translateRWV e2] [nuMP| NatDiv e1 e2 |] -> ETrans_Term <$> - applyPureMultiTransM (return $ globalOpenTerm "Prelude.divNat") + applyMultiPureTransM (return $ globalOpenTerm "Prelude.divNat") [translateRWV e1, translateRWV e2] [nuMP| NatMod e1 e2 |] -> ETrans_Term <$> - applyPureMultiTransM (return $ globalOpenTerm "Prelude.modNat") + applyMultiPureTransM (return $ globalOpenTerm "Prelude.modNat") [translateRWV e1, translateRWV e2] -- Function handles: the expression part of a function handle has no @@ -5116,126 +5121,126 @@ instance (PermCheckExtC ext exprExt, TransInfo info) => return $ ETrans_Term $ bvBVOpenTerm (mbLift w) $ mbLift mb_bv [nuMP| BVConcat w1 w2 e1 e2 |] -> ETrans_Term <$> - applyPureMultiTransM (return $ globalOpenTerm "Prelude.join") + applyMultiPureTransM (return $ globalOpenTerm "Prelude.join") [translate w1, translate w2, translateRWV e1, translateRWV e2] [nuMP| BVTrunc w1 w2 e |] -> ETrans_Term <$> - applyPureMultiTransM (return $ globalOpenTerm "Prelude.bvTrunc") + applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvTrunc") [return (natOpenTerm (natValue (mbLift w2) - natValue (mbLift w1))), translate w1, translateRWV e] [nuMP| BVZext w1 w2 e |] -> ETrans_Term <$> - applyPureMultiTransM (return $ globalOpenTerm "Prelude.bvUExt") + applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvUExt") [return (natOpenTerm (natValue (mbLift w1) - natValue (mbLift w2))), translate w2, translateRWV e] [nuMP| BVSext w1 w2 e |] -> ETrans_Term <$> - applyPureMultiTransM (return $ globalOpenTerm "Prelude.bvSExt") + applyMultiPureTransM (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 <$> - applyPureMultiTransM (return $ globalOpenTerm "Prelude.bvNot") + applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvNot") [translate w, translateRWV e] [nuMP| BVAnd w e1 e2 |] -> ETrans_Term <$> - applyPureMultiTransM (return $ globalOpenTerm "Prelude.bvAnd") + applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvAnd") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVOr w e1 e2 |] -> ETrans_Term <$> - applyPureMultiTransM (return $ globalOpenTerm "Prelude.bvOr") + applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvOr") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVXor w e1 e2 |] -> ETrans_Term <$> - applyPureMultiTransM (return $ globalOpenTerm "Prelude.bvXor") + applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvXor") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVNeg w e |] -> ETrans_Term <$> - applyPureMultiTransM (return $ globalOpenTerm "Prelude.bvNeg") + applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvNeg") [translate w, translateRWV e] [nuMP| BVAdd w e1 e2 |] -> ETrans_Term <$> - applyPureMultiTransM (return $ globalOpenTerm "Prelude.bvAdd") + applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvAdd") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVSub w e1 e2 |] -> ETrans_Term <$> - applyPureMultiTransM (return $ globalOpenTerm "Prelude.bvSub") + applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvSub") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVMul w e1 e2 |] -> ETrans_Term <$> - applyPureMultiTransM (return $ globalOpenTerm "Prelude.bvMul") + applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvMul") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVUdiv w e1 e2 |] -> ETrans_Term <$> - applyPureMultiTransM (return $ globalOpenTerm "Prelude.bvUDiv") + applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvUDiv") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVSdiv w e1 e2 |] -> ETrans_Term <$> - applyPureMultiTransM (return $ globalOpenTerm "Prelude.bvSDiv") + applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvSDiv") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVUrem w e1 e2 |] -> ETrans_Term <$> - applyPureMultiTransM (return $ globalOpenTerm "Prelude.bvURem") + applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvURem") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVSrem w e1 e2 |] -> ETrans_Term <$> - applyPureMultiTransM (return $ globalOpenTerm "Prelude.bvSRem") + applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvSRem") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVUle w e1 e2 |] -> ETrans_Term <$> - applyPureMultiTransM (return $ globalOpenTerm "Prelude.bvule") + applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvule") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVUlt w e1 e2 |] -> ETrans_Term <$> - applyPureMultiTransM (return $ globalOpenTerm "Prelude.bvult") + applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvult") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVSle w e1 e2 |] -> ETrans_Term <$> - applyPureMultiTransM (return $ globalOpenTerm "Prelude.bvsle") + applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvsle") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVSlt w e1 e2 |] -> ETrans_Term <$> - applyPureMultiTransM (return $ globalOpenTerm "Prelude.bvslt") + applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvslt") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVCarry w e1 e2 |] -> ETrans_Term <$> - applyPureMultiTransM (return $ globalOpenTerm "Prelude.bvCarry") + applyMultiPureTransM (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 <$> - applyPureMultiTransM (return $ globalOpenTerm "Prelude.bvSCarry") + applyMultiPureTransM (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 <$> - applyPureMultiTransM (return $ globalOpenTerm "Prelude.bvSBorrow") + applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvSBorrow") [return w_minus_1, translateRWV e1, translateRWV e2] [nuMP| BVShl w e1 e2 |] -> ETrans_Term <$> - applyPureMultiTransM (return $ globalOpenTerm "Prelude.bvShiftL") + applyMultiPureTransM (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 <$> - applyPureMultiTransM (return $ globalOpenTerm "Prelude.bvShiftR") + applyMultiPureTransM (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 <$> - applyPureMultiTransM (return $ globalOpenTerm "Prelude.bvSShiftR") + applyMultiPureTransM (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 <$> - applyPureMultiTransM (return $ globalOpenTerm "Prelude.ite") + applyMultiPureTransM (return $ globalOpenTerm "Prelude.ite") [bitvectorTransM (translate mb_w), translateRWV e, return (bvBVOpenTerm w (BV.one w)), @@ -5244,7 +5249,7 @@ instance (PermCheckExtC ext exprExt, TransInfo info) => let w = mbLift mb_w in ETrans_Term <$> applyPureTransM (return $ globalOpenTerm "Prelude.not") - (applyPureMultiTransM (return $ globalOpenTerm "Prelude.bvEq") + (applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvEq") [translate mb_w, translateRWV e, return (bvBVOpenTerm w (BV.zero w))]) @@ -5288,6 +5293,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 @@ -5309,6 +5315,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 @@ -5319,7 +5326,7 @@ translateCallEntry :: forall ext exprExt tops args ghosts blocks ctx rets. Mb ctx (RAssign ExprVar (tops :++: args)) -> Mb ctx (RAssign ExprVar ghosts) -> ImpTransM ext blocks tops rets - ((tops :++: args) :++: ghosts) ctx OpenTerm + ((tops :++: args) :++: ghosts) ctx SpecTerm translateCallEntry nm entry_trans mb_tops_args mb_ghosts = -- First test that the stack == the required perms for entryID do let entry = typedEntryTransEntry entry_trans @@ -5335,14 +5342,15 @@ translateCallEntry nm entry_trans mb_tops_args mb_ghosts = -- Now check if entryID has an associated multiFixS-bound function case typedEntryTransRecIx entry_trans of - Just ix -> + Just (ix, lrt) -> -- 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) + return (applyClosSpecTerm lrt (mkBaseClosSpecTerm ix) + (exprCtxToTerms e_args ++ permCtxToTerms i_args)) Nothing -> inEmptyEnvImpTransM $ inCtxTransM ectx $ do perms_trans <- translate $ typedEntryPermsIn entry @@ -5353,7 +5361,7 @@ translateCallEntry nm entry_trans mb_tops_args mb_ghosts = instance PermCheckExtC ext exprExt => Translate (ImpTransInfo ext blocks tops rets ps) ctx - (CallSiteImplRet blocks tops args ghosts ps) OpenTerm where + (CallSiteImplRet blocks tops args ghosts ps) SpecTerm where translate (mbMatch -> [nuMP| CallSiteImplRet entryID ghosts Refl mb_tavars mb_gvars |]) = do entry_trans <- @@ -5369,7 +5377,7 @@ instance PermCheckExtC ext exprExt => instance PermCheckExtC ext exprExt => Translate (ImpTransInfo ext blocks tops rets ps) ctx - (TypedJumpTarget blocks tops ps) OpenTerm where + (TypedJumpTarget blocks tops ps) SpecTerm where translate (mbMatch -> [nuMP| TypedJumpTarget siteID _ _ mb_perms_in |]) = do SomeTypedCallSite site <- lookupCallSite (mbLift siteID) <$> itiBlockMapTrans <$> ask @@ -5390,8 +5398,8 @@ instance PermCheckExtC ext exprExt => translateStmt :: PermCheckExtC ext exprExt => ProgramLoc -> Mb ctx (TypedStmt ext stmt_rets ps_in ps_out) -> - ImpTransM ext blocks tops rets ps_out (ctx :++: stmt_rets) OpenTerm -> - ImpTransM ext blocks tops rets ps_in ctx OpenTerm + ImpTransM ext blocks tops rets ps_out (ctx :++: stmt_rets) SpecTerm -> + ImpTransM ext blocks tops rets ps_in ctx SpecTerm translateStmt loc mb_stmt m = case mbMatch mb_stmt of [nuMP| TypedSetReg tp e |] -> do tp_trans <- translate tp @@ -5408,6 +5416,8 @@ translateStmt loc mb_stmt m = case mbMatch mb_stmt of -- FIXME HERE: document this! [nuMP| TypedCall _freg fun_perm _ gexprs args |] -> + error "FIXME HERE NOWNOW: call the def" + {- do f_trans <- getTopPermM ectx_outer <- itiExprCtx <$> ask let rets = mbLift $ mbMapCl $(mkClosed [| funPermRets |]) fun_perm @@ -5431,7 +5441,7 @@ translateStmt loc mb_stmt m = case mbMatch mb_stmt of fret_trm <- case f_trans of PTrans_Conj [APTrans_Fun _ (Right f)] -> applyNamedSpecOpM "Prelude.liftStackS" - [fret_tp, applyOpenTermMulti f all_args] + [fret_tp, applyTermLikeMulti f all_args] PTrans_Conj [APTrans_Fun _ (Left ix)] -> applyCallS ix all_args _ -> error "translateStmt: TypedCall: unexpected function permission" @@ -5449,7 +5459,7 @@ translateStmt loc mb_stmt m = case mbMatch mb_stmt of suffixMembers ectx_outer rets_prxs) (const pctx) m) - ret_val + ret_val -} -- FIXME HERE: figure out why these asserts always translate to ite True [nuMP| TypedAssert e _ |] -> @@ -5464,8 +5474,8 @@ translateStmt loc mb_stmt m = case mbMatch mb_stmt of -- | Translate a 'TypedStmt' to a function on translation computations translateLLVMStmt :: Mb ctx (TypedLLVMStmt r ps_in ps_out) -> - ImpTransM ext blocks tops rets ps_out (ctx :> r) OpenTerm -> - ImpTransM ext blocks tops rets ps_in ctx OpenTerm + ImpTransM ext blocks tops rets ps_out (ctx :> r) SpecTerm -> + ImpTransM ext blocks tops rets ps_in ctx SpecTerm translateLLVMStmt mb_stmt m = case mbMatch mb_stmt of [nuMP| ConstructLLVMWord (TypedReg x) |] -> inExtTransM ETrans_LLVM $ @@ -5552,9 +5562,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 [unitTermLike]) m [nuMP| TypedLLVMCreateFrame |] -> @@ -5601,7 +5611,8 @@ translateLLVMStmt mb_stmt m = case mbMatch mb_stmt of ++ globalSymbolName (mbLift gsym)) Just (_, Right ts) -> translate (extMb p) >>= \ptrans -> - withPermStackM (:>: Member_Base) (:>: typeTransF ptrans ts) m + let ts_imp = map openTermLike ts in + withPermStackM (:>: Member_Base) (:>: typeTransF ptrans ts_imp) m [nuMP| TypedLLVMIte _ mb_r1 _ _ |] -> inExtTransM ETrans_LLVM $ @@ -5612,7 +5623,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 @@ -5622,7 +5633,7 @@ translateLLVMStmt mb_stmt m = case mbMatch mb_stmt of instance PermCheckExtC ext exprExt => Translate (ImpTransInfo ext blocks tops rets ps) ctx - (TypedRet tops rets ps) OpenTerm where + (TypedRet tops rets ps) SpecTerm where translate (mbMatch -> [nuMP| TypedRet Refl mb_rets mb_rets_ns mb_perms |]) = do let perms = mbMap2 @@ -5638,7 +5649,7 @@ instance PermCheckExtC ext exprExt => (flip inExtMultiTransM $ translate $ mbCombine rets_prxs mb_perms) rets_ns_trans (itiPermStack <$> ask) - returnSpecTerm ret_tp sigma_trm + return $ returnSpecTerm ret_tp sigma_trm instance PermCheckExtC ext exprExt => ImplTranslateF (TypedRet tops rets) ext blocks tops rets where @@ -5646,7 +5657,7 @@ instance PermCheckExtC ext exprExt => instance PermCheckExtC ext exprExt => Translate (ImpTransInfo ext blocks tops rets ps) ctx - (TypedTermStmt blocks tops rets ps) OpenTerm where + (TypedTermStmt blocks tops rets ps) SpecTerm where translate mb_x = case mbMatch mb_x of [nuMP| TypedJump impl_tgt |] -> translate impl_tgt [nuMP| TypedBr reg impl_tgt1 impl_tgt2 |] -> @@ -5662,7 +5673,7 @@ instance PermCheckExtC ext exprExt => instance PermCheckExtC ext exprExt => Translate (ImpTransInfo ext blocks tops rets ps) ctx - (TypedStmtSeq ext blocks tops rets ps) OpenTerm where + (TypedStmtSeq ext blocks tops rets ps) SpecTerm where translate mb_x = case mbMatch mb_x of [nuMP| TypedImplStmt impl_seq |] -> translate impl_seq [nuMP| TypedConsStmt loc stmt pxys mb_seq |] -> @@ -5675,6 +5686,16 @@ instance PermCheckExtC ext exprExt => translateF mb_seq = translate mb_seq +{- +NOWNOW: +- change uses of TypeTrans to include the purity flag +- NOTE: PermExprs translate to pure terms / OpenTerms +- compReturnTypeM should return a TypeDesc +- need a variant of piTransM that builds TypeDescs +- update the translation of shapes and perms to use ETrans_Shape and ETrans_Perm +- IDEA: change LOwnedTransTerm to have a single PermTransM that returns a + PermTransCtx; also remove the vars input from PermTransInfo + ---------------------------------------------------------------------- -- * Translating CFGs ---------------------------------------------------------------------- From 5b7b5a39e430dfd285ea631a28f0e7979c0f7827 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 14 Aug 2023 18:03:56 -0700 Subject: [PATCH 038/305] exported gput --- heapster-saw/src/Verifier/SAW/Heapster/GenMonad.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/GenMonad.hs b/heapster-saw/src/Verifier/SAW/Heapster/GenMonad.hs index 47e14c81ac..1ea9e64613 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 From 3ed622cf7ccf160130d1fcfdac22a04714bc4b88 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 14 Aug 2023 18:04:28 -0700 Subject: [PATCH 039/305] added a stub for mbExprPermsMembers, to be implemented later --- heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs index 28585ab3fb..b946a10080 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs @@ -2825,6 +2825,11 @@ mbDistPermsToExprPerms = mbMapCl $(mkClosed [| distPermsToExprPerms |]) exprPermsVars :: ExprPerms ps -> Maybe (RAssign Name ps) exprPermsVars = fmap distPermsVars . exprPermsToDistPerms +-- | 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 = error "FIXME HERE NOWNOW" + -- | Convert the expressions in an 'ExprPerms' to variables, if possible, and -- collect them into a list exprPermsVarsList :: ExprPerms ps -> [SomeName CrucibleType] From 7accb2eb1c2bf8afd16be42c8b37291312d534cd Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 14 Aug 2023 18:05:55 -0700 Subject: [PATCH 040/305] changed LOwnedTransTerm to use a generalized state continuation monad, and it almost works but does not quite... --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 332 +++++++++++++----- 1 file changed, 237 insertions(+), 95 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index c6c6371600..0a3e478749 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 $" #-} @@ -43,9 +44,9 @@ import qualified Data.BitVector.Sized as BV import Data.Functor.Compose import Control.Applicative import Control.Lens hiding ((:>), Index, ix, op) -import Control.Monad.Reader hiding (ap) -import Control.Monad.Writer hiding (ap) -import Control.Monad.State hiding (ap) +import Control.Monad.Reader +import Control.Monad.Writer +import Control.Monad.State import Control.Monad.Trans.Maybe import qualified Control.Monad.Fail as Fail @@ -1660,82 +1661,171 @@ data LLVMArrayBorrowTrans ctx w = llvmArrayBorrowTransProps :: [BVPropTrans ctx w] } -} +-- | FIXME HERE NOWNOW: document all of this! +data LOwnedInfo ps ctx = + LOwnedInfo { lownedInfoECtx :: ExprTransCtx ctx, + lownedInfoPCtx :: PermTransCtx ctx ps, + lownedInfoPVars :: RAssign (Member ctx) ps, + lownedInfoRetType :: SpecTerm } + +setLOInfoCtx :: ExprTransCtx ctx' -> LOwnedInfo ps ctx -> LOwnedInfo ps ctx' +setLOInfoCtx ectx (LOwnedInfo {..}) = LOwnedInfo { lownedInfoECtx = ectx, .. } + +-- | Convert an 'ImpTransInfo' to an 'LOwnedInfo' +impInfoToLOwned :: ImpTransInfo ext blocks tops rets ps ctx -> LOwnedInfo ps ctx +impInfoToLOwned = error "FIXME HERE NOWNOW" + +-- | Convert an 'LOwnedInfo' to an 'ImpTransInfo' using an existing 'ImpTransInfo' +lownedInfoToImp :: LOwnedInfo px ctx -> ImpTransInfo ext blocks tops rets ps' ctx' -> + ImpTransInfo ext blocks tops rets ps ctx +lownedInfoToImp = error "FIXME HERE NOWNOW" + +loInfoSetPerms :: PermTransCtx ctx ps' -> RAssign (Member ctx) ps' -> + LOwnedInfo ps ctx -> LOwnedInfo ps' ctx +loInfoSetPerms ps' vars' (LOwnedInfo {..}) = + LOwnedInfo { lownedInfoPCtx = ps', lownedInfoPVars = vars', ..} + +loInfoSplit :: Proxy ps1 -> RAssign any ps2 -> + LOwnedInfo (ps1 :++: ps2) ctx -> + (LOwnedInfo ps1 ctx, LOwnedInfo ps2 ctx) +loInfoSplit = error "FIXME HERE NOWNOW" + +loInfoAppend :: LOwnedInfo ps1 ctx -> LOwnedInfo ps2 ctx -> + LOwnedInfo (ps1 :++: ps2) ctx +loInfoAppend info1 info2 = + LOwnedInfo { lownedInfoPCtx = + RL.append (lownedInfoPCtx info1) (lownedInfoPCtx info2) + , lownedInfoPVars = + RL.append (lownedInfoPVars info1) (lownedInfoPVars info2) + , .. } + +-- | An extension of type 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 ectx3') = + error "FIXME HERE NOWNOW" -data PermTransInfo ps ctx = - PermTransInfo { ptransInfoECtx :: ExprTransCtx ctx, - ptransInfoPCtx :: PermTransCtx ctx ps, - ptransInfoRetType :: SpecTerm } - -ptInfoSetPerms :: PermTransCtx ctx ps' -> PermTransInfo ps ctx -> - PermTransInfo ps' ctx -ptInfoSetPerms ps' (PermTransInfo {..}) = - PermTransInfo { ptransInfoPCtx = ps', ..} - -ptInfoSplit :: Proxy ps1 -> RAssign any ps2 -> - PermTransInfo (ps1 :++: ps2) ctx -> - (PermTransInfo ps1 ctx, PermTransInfo ps2 ctx) -ptInfoSplit = error "FIXME HERE NOWNOW" - -ptInfoAppendPerms :: PermTransInfo ps1 ctx -> PermTransCtx ctx ps2 -> - PermTransInfo (ps1 :++: ps2) ctx -ptInfoAppendPerms (PermTransInfo {..}) pctx2 = - PermTransInfo { ptransInfoPCtx = RL.append ptransInfoPCtx pctx2, .. } - -ptInfoAppend :: PermTransInfo ps1 ctx -> PermTransInfo ps2 ctx -> - PermTransInfo (ps1 :++: ps2) ctx -ptInfoAppend info1 info2 = ptInfoAppendPerms info1 (ptransInfoPCtx info2) +extMbExt :: ExprCtxExt ctx1 ctx2 -> Mb ctx1 a -> Mb ctx2 a +extMbExt = error "FIXME HERE NOWNOW" + +-- | 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) + +-- | Un-extend the left-hand context of an expression context extension +extMultiExprCtxExt :: ExprTransCtx ctx2 -> ExprCtxExt (ctx1 :++: ctx2) ctx3 -> + ExprCtxExt ctx1 ctx3 +extMultiExprCtxExt = error "FIXME HERE NOWNOW" + +type LOwnedTransM ps_in ps_out ctx = + GenStateContT (LOwnedInfo ps_out ctx) SpecTerm + (LOwnedInfo ps_in ctx) SpecTerm Identity + +runLOwnedTransM :: LOwnedTransM ps_in ps_out ctx a -> LOwnedInfo ps_in ctx -> + (LOwnedInfo ps_out ctx -> a -> SpecTerm) -> + SpecTerm +runLOwnedTransM m info_in k = + runIdentity $ runGenStateContT m info_in $ \info_out a -> + return $ k info_out a + +-- | FIXME HERE NOWNOW: docs; explain that it's as if the input LOwnedInfo is +-- relative to ctx_in and the output is relative to ctx_out except this ensures +-- that those are extensions of what they are supposed to be +{- +newtype LOwnedTransM ps_in ps_out ctx a = + LOwnedTransM { + runLOwnedTransM :: + forall ctx_in. ExprCtxExt ctx ctx_in -> LOwnedInfo ps_in ctx -> + (forall ctx_out. ExprCtxExt ctx_in ctx_out -> LOwnedInfo ps_out ctx -> + a -> SpecTerm) -> + SpecTerm } + +(>>>=) :: 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'') + +(>>>) :: 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 + (<*>) = ap + +instance Monad (LOwnedTransM ps ps ctx) where + (>>=) = (>>>=) + +gput :: LOwnedInfo ps_out ctx -> LOwnedTransM ps_in ps_out ctx () +gput loInfo = LOwnedTransM $ \_ _ k -> k reflExprCtxExt loInfo () + +instance ps_in ~ ps_out => + MonadState (LOwnedInfo ps_in ctx) (LOwnedTransM ps_in ps_out ctx) where + get = LOwnedTransM $ \cext s k -> k reflExprCtxExt s s + put = gput + +gmodify :: (LOwnedInfo ps_in ctx -> LOwnedInfo ps_out ctx) -> + LOwnedTransM ps_in ps_out ctx () +gmodify f = get >>>= \loInfo -> gput (f loInfo) +-} -type PermTransM ps = TransM (PermTransInfo ps) +extLOwnedTransM :: ExprTrans tp -> LOwnedTransM ps_in ps_out ctx a -> + LOwnedTransM ps_in ps_out (ctx :> tp) a +extLOwnedTransM etrans m = + error "FIXME HERE NOWNOW" + -- LOwnedTransM $ \ctx_ext -> m (extExprCtxExt etrans ctx_ext) -newtype LOwnedTransTerm ctx ps_in ps_out = - LOwnedTransTerm { - unLOwnedTransTerm :: - forall ctx'. ExprTransCtx ctx' -> - PermTransM ps_in (ctx :++: ctx') (PermTransCtx (ctx :++: ctx') ps_out) } +type LOwnedTransTerm ctx ps_in ps_out = LOwnedTransM ps_in ps_out ctx () lownedTransTermTerm :: PureTypeTrans (ExprTransCtx ctx) -> + Mb ctx (ExprPerms ps_in) -> RelPermTransCtx ctx ps_in -> RelPermTransCtx ctx ps_out -> LOwnedTransTerm ctx ps_in ps_out -> SpecTerm -lownedTransTermTerm ectx ps_inF ps_outF t = +lownedTransTermTerm ectx (mbExprPermsMembers -> + Just vars_in) ps_inF ps_outF t = lambdaTrans "e" ectx $ \exprs -> lambdaTrans "p" (ps_inF exprs) $ \ps_in -> - flip runTransM (PermTransInfo - { ptransInfoECtx = exprs, ptransInfoPCtx = ps_in, - ptransInfoRetType = typeTransTupleType (ps_outF exprs) }) $ - (transTupleTerm <$> unLOwnedTransTerm t MNil) - -extLOwnedTransTerm' :: Proxy ctx -> ExprTrans tp -> - LOwnedTransTerm ctx ps_in ps_out -> - LOwnedTransTerm (ctx :> tp) ps_in ps_out -extLOwnedTransTerm' ctx tp (LOwnedTransTerm f) = - LOwnedTransTerm $ \ ctx' -> case RL.appendRNilConsEq ctx tp ctx' of - Refl -> f (RL.append (MNil :>: tp) ctx') + let loInfo = + LOwnedInfo { lownedInfoECtx = exprs, lownedInfoPCtx = ps_in, + lownedInfoPVars = vars_in, + lownedInfoRetType = typeTransTupleType (ps_outF exprs) } in + runLOwnedTransM t loInfo $ \loInfo_out () -> + transTupleTerm (lownedInfoPCtx loInfo_out) +lownedTransTermTerm _ _ _ _ _ = + error "FIXME HERE NOWNOW: write this error message" extLOwnedTransTerm :: ExprTrans tp -> LOwnedTransTerm ctx ps_in ps_out -> LOwnedTransTerm (ctx :> tp) ps_in ps_out -extLOwnedTransTerm = extLOwnedTransTerm' Proxy - -emptyLOwnedTransTerm :: LOwnedTransTerm ctx RNil RNil -emptyLOwnedTransTerm = LOwnedTransTerm $ \_ -> return MNil - -elimSimplLOwnedTransTerm :: (forall ctx'. ExprTransCtx ctx' -> - ImpTypeTrans (PermTransCtx (ctx :++: ctx') ps)) -> - LOwnedTransTerm ctx ps ps -elimSimplLOwnedTransTerm ps = - LOwnedTransTerm $ \ctx' -> ptransInfoPCtx <$> ask - -weakenLOwnedTransTerm :: - (forall ctx'. ExprTransCtx ctx' -> - ImpTypeTrans (PermTrans (ctx :++: ctx') tp)) -> - LOwnedTransTerm ctx ps_in ps_out -> - LOwnedTransTerm ctx (ps_in :> tp) (ps_out :> tp) -weakenLOwnedTransTerm tp t = - LOwnedTransTerm $ \ectx' -> - do (info_ps, info_tp) <- ptInfoSplit Proxy (MNil :>: Proxy) <$> ask - pctx <- withInfoM (const info_ps) (unLOwnedTransTerm t ectx') - return (RL.append pctx $ ptransInfoPCtx info_tp) +extLOwnedTransTerm = extLOwnedTransM + +idLOwnedTransTerm :: LOwnedTransTerm ctx ps ps +idLOwnedTransTerm = return () + +weakenLOwnedTransTerm :: LOwnedTransTerm ctx ps_in ps_out -> + LOwnedTransTerm ctx (ps_in :> tp) (ps_out :> tp) +weakenLOwnedTransTerm t = + (loInfoSplit Proxy (MNil :>: Proxy) <$> get) >>>= \(info_ps_in, info_tp) -> + gput info_ps_in >>> + t >>> gmodify (flip loInfoAppend info_tp) bindLOwnedTransTerm :: Proxy ps_extra1 -> RAssign any ps_extra2 -> RAssign any ps_in -> @@ -1743,12 +1833,13 @@ bindLOwnedTransTerm :: LOwnedTransTerm ctx (ps_extra2 :++: ps_mid) ps_out -> LOwnedTransTerm ctx ((ps_extra1 :++: ps_extra2) :++: ps_in) ps_out bindLOwnedTransTerm prx_extra1 prx_extra2 prx_in t1 t2 = - LOwnedTransTerm $ \ectx' -> - do (info_extra, info_in) <- ptInfoSplit Proxy prx_in <$> ask - let (info_extra1, info_extra2) = ptInfoSplit prx_extra1 prx_extra2 info_extra - pctx_mid <- - withInfoM (const $ ptInfoAppend info_extra1 info_in) (unLOwnedTransTerm t1 ectx') - withInfoM (const $ ptInfoAppendPerms info_extra2 pctx_mid) (unLOwnedTransTerm t2 ectx') + (loInfoSplit Proxy prx_in <$> get) >>>= \(info_extra, info_in) -> + let (info_extra1, info_extra2) = + loInfoSplit prx_extra1 prx_extra2 info_extra in + gput (loInfoAppend info_extra1 info_in) >>> + t1 >>> + gmodify (loInfoAppend info_extra2) >>> + t2 -- | The translation of the vacuously true permission @@ -1850,12 +1941,14 @@ instance IsTermTrans (AtomicPermTrans ctx a) where transTerms (APTrans_NamedConj _ _ _ t) = [t] transTerms (APTrans_DefinedNamedConj _ _ _ ptrans) = transTerms ptrans transTerms (APTrans_LLVMFrame _) = [] - transTerms (APTrans_LOwned _ _ _ _ _ + transTerms (APTrans_LOwned _ _ _ eps_in _ ectx ps_extra _ tps_in tps_out tps_extra lott) = let etps = exprCtxType ectx tps_extra_in = appRelPermTransCtx tps_extra tps_in lrt = piExprPermLRT etps tps_extra_in tps_out - fun_tm = lownedTransTermTerm etps tps_extra_in tps_out lott in + fun_tm = + -- lownedTransTermTerm etps eps_in tps_extra_in tps_out lott + error "FIXME HERE NOWNOW" in [applyClosSpecTerm lrt (mkFreshClosSpecTerm lrt (const fun_tm)) (transTerms ectx ++ transTerms ps_extra)] transTerms (APTrans_LOwnedSimple _ _) = [] @@ -3056,11 +3149,22 @@ instance Monoid HasFailures where mempty = NoFailures -- | A function for translating an @r@ +-- FIXME HERE NOWNOW: remove ctx type arg newtype ImpRTransFun r ext blocks tops rets = ImpRTransFun { appImpTransFun :: forall ps ctx. Mb ctx (r ps) -> ImpTransM ext blocks tops rets ps ctx SpecTerm } +{- +extImpRTransFun :: ExprTransCtx 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 (extMultiExprCtxExt ctx' cext) mb_r +-} + + -- | A monad transformer that adds an 'ImpRTransFun' translation function newtype ImpRTransFunT r ext blocks tops rets m a = ImpRTransFunT { unImpRTransFunT :: @@ -3073,7 +3177,8 @@ runImpRTransFunT :: ImpRTransFunT r ext blocks tops rets 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 m a -> +mapImpRTransFunT :: (m a -> n b) -> + ImpRTransFunT r ext blocks tops rets m a -> ImpRTransFunT r ext blocks tops rets n b mapImpRTransFunT f = ImpRTransFunT . mapReaderT f . unImpRTransFunT @@ -3087,6 +3192,7 @@ mapImpRTransFunT f = ImpRTransFunT . mapReaderT f . unImpRTransFunT type PImplTransM r ext blocks tops rets ps ctx = MaybeT (WriterT ([String], HasFailures) (ImpRTransFunT r ext blocks tops rets Identity)) +-- FIXME HERE NOWNOW: PImplTransM doesn't need ps or ctx -- | Run a 'PermImplTransM' computation runPermImplTransM :: @@ -3096,6 +3202,33 @@ runPermImplTransM :: runPermImplTransM m rTransFun = runIdentity $ runImpRTransFunT (runWriterT $ runMaybeT m) rTransFun +{- +extPermImplTransM :: prx 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 +-} + +{- +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 ps ctx (ImpRTransFun r ext blocks tops rets) @@ -4513,7 +4646,6 @@ translatePermImplUnary (mbMatch -> [nuMP| MbPermImpls_Cons _ _ mb_impl |]) f = PImplTerm <$> fmap f <$> popPImplTerm <$> translatePermImpl (mbCombine RL.typeCtxProxies mb_impl) - -- | Translate a 'PermImpl1' to a function on translation computations translatePermImpl1 :: NuMatchingAny1 r => Mb ctx (PermImpl1 ps ps_outs) -> @@ -4579,8 +4711,8 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o -- 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 @@ -4951,17 +5083,23 @@ translatePermImpl mb_impl = case mbMatch mb_impl of [nuMP| PermImpl_Step impl1 mb_impls |] -> translatePermImpl1 impl1 mb_impls +translatePermImplToTerm :: NuMatchingAny1 r => String -> + Mb ctx (PermImpl r ps) -> + ImpRTransFun r ext blocks tops rets -> + ImpTransM ext blocks tops rets ps ctx SpecTerm +translatePermImplToTerm err mb_impl k = + let (maybe_ptm, (errs,_)) = + runPermImplTransM (translatePermImpl mb_impl) k in + popPImplTerm (forcePImplTerm maybe_ptm) $ + ImplFailContMsg (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) SpecTerm where - translate (mbMatch -> [nuMP| AnnotPermImpl err impl |]) = - let (maybe_ptm, (errs,_)) = - runPermImplTransM (translatePermImpl impl) (ImpRTransFun - translateF) in - popPImplTerm (forcePImplTerm maybe_ptm) $ - 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 translateF) {- -- We translate a LocalImplRet to a term that returns all current permissions @@ -5001,10 +5139,20 @@ translateCurryLocalPermImpl err impl pctx1 vars1 tp_trans2 vars2 tp_trans_out = (translateLocalPermImpl err impl) -} -{- -FIXME HERE NOWNOW: change LOwnedTransTerms to be continuation computations, and -add a function to translate PermImpls to these computations for MapLifetime --} +-- | 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 $ GenStateContT $ \loinfo_in k -> + return $ flip runTransM (lownedInfoToImp loinfo_in info_top) $ + translatePermImplToTerm err mb_impl $ ImpRTransFun $ \r -> + case mbMatch r of + [nuMP| LocalImplRet Refl |] -> + ask >>= \info_out -> return $ runIdentity $ + k (setLOInfoCtx (itiExprCtx info_top) $ + impInfoToLOwned info_out) () ---------------------------------------------------------------------- @@ -5689,12 +5837,6 @@ instance PermCheckExtC ext exprExt => {- NOWNOW: - change uses of TypeTrans to include the purity flag -- NOTE: PermExprs translate to pure terms / OpenTerms -- compReturnTypeM should return a TypeDesc -- need a variant of piTransM that builds TypeDescs -- update the translation of shapes and perms to use ETrans_Shape and ETrans_Perm -- IDEA: change LOwnedTransTerm to have a single PermTransM that returns a - PermTransCtx; also remove the vars input from PermTransInfo ---------------------------------------------------------------------- -- * Translating CFGs From b779e1fa131f8b7a62e61fcaaef7024cdebaeee8 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 14 Aug 2023 19:24:58 -0700 Subject: [PATCH 041/305] changed LOwnedTransM to an even more generalized monad that quantifies over ExprTransCtx extensions --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 153 +++++++++++------- 1 file changed, 97 insertions(+), 56 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 0a3e478749..b71c1c728e 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -75,7 +75,7 @@ import Verifier.SAW.OpenTerm import Verifier.SAW.Term.Functor import Verifier.SAW.SharedTerm -import Verifier.SAW.Heapster.GenMonad +-- import Verifier.SAW.Heapster.GenMonad import Verifier.SAW.Heapster.CruUtil import Verifier.SAW.Heapster.PatternMatchUtil import Verifier.SAW.Heapster.Permissions @@ -1668,15 +1668,13 @@ data LOwnedInfo ps ctx = lownedInfoPVars :: RAssign (Member ctx) ps, lownedInfoRetType :: SpecTerm } -setLOInfoCtx :: ExprTransCtx ctx' -> LOwnedInfo ps ctx -> LOwnedInfo ps ctx' -setLOInfoCtx ectx (LOwnedInfo {..}) = LOwnedInfo { lownedInfoECtx = ectx, .. } - -- | Convert an 'ImpTransInfo' to an 'LOwnedInfo' impInfoToLOwned :: ImpTransInfo ext blocks tops rets ps ctx -> LOwnedInfo ps ctx impInfoToLOwned = error "FIXME HERE NOWNOW" -- | Convert an 'LOwnedInfo' to an 'ImpTransInfo' using an existing 'ImpTransInfo' -lownedInfoToImp :: LOwnedInfo px ctx -> ImpTransInfo ext blocks tops rets ps' ctx' -> +lownedInfoToImp :: LOwnedInfo px ctx -> + ImpTransInfo ext blocks tops rets ps' ctx' -> ImpTransInfo ext blocks tops rets ps ctx lownedInfoToImp = error "FIXME HERE NOWNOW" @@ -1717,6 +1715,11 @@ transExprCtxExt (ExprCtxExt ectx2') (ExprCtxExt ectx3') = extMbExt :: ExprCtxExt ctx1 ctx2 -> Mb ctx1 a -> Mb ctx2 a extMbExt = error "FIXME HERE NOWNOW" +extTransMExt :: TransInfo info => ExprCtxExt ctx1 ctx2 -> TransM info ctx2 a -> + TransM info ctx1 a +extTransMExt (ExprCtxExt ectx3) m = inExtMultiTransM ectx3 m + + -- | Un-extend the left-hand context of an expression context extension extExprCtxExt :: ExprTrans tp -> ExprCtxExt (ctx1 :> tp) ctx2 -> ExprCtxExt ctx1 ctx2 @@ -1729,6 +1732,11 @@ extMultiExprCtxExt :: ExprTransCtx ctx2 -> ExprCtxExt (ctx1 :++: ctx2) ctx3 -> ExprCtxExt ctx1 ctx3 extMultiExprCtxExt = error "FIXME HERE NOWNOW" +extLOwnedInfo :: ExprCtxExt ctx1 ctx2 -> LOwnedInfo ps ctx1 -> + LOwnedInfo ps ctx2 +extLOwnedInfo = error "FIXME HERE NOWNOW" + +{- type LOwnedTransM ps_in ps_out ctx = GenStateContT (LOwnedInfo ps_out ctx) SpecTerm (LOwnedInfo ps_in ctx) SpecTerm Identity @@ -1739,16 +1747,16 @@ runLOwnedTransM :: LOwnedTransM ps_in ps_out ctx a -> LOwnedInfo ps_in ctx -> runLOwnedTransM m info_in k = runIdentity $ runGenStateContT m info_in $ \info_out a -> return $ k info_out a +-} -- | FIXME HERE NOWNOW: docs; explain that it's as if the input LOwnedInfo is -- relative to ctx_in and the output is relative to ctx_out except this ensures -- that those are extensions of what they are supposed to be -{- newtype LOwnedTransM ps_in ps_out ctx a = LOwnedTransM { runLOwnedTransM :: - forall ctx_in. ExprCtxExt ctx ctx_in -> LOwnedInfo ps_in ctx -> - (forall ctx_out. ExprCtxExt ctx_in ctx_out -> LOwnedInfo ps_out ctx -> + 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 -> SpecTerm) -> SpecTerm } @@ -1760,7 +1768,7 @@ m >>>= f = LOwnedTransM $ \cext s1 k -> k (transExprCtxExt cext' cext'') (>>>) :: LOwnedTransM ps_in ps' ctx a -> LOwnedTransM ps' ps_out ctx b -> - LOwnedTransM ps_in ps_out ctx b + LOwnedTransM ps_in ps_out ctx b m1 >>> m2 = m1 >>>= \_ -> m2 instance Functor (LOwnedTransM ps_in ps_out ctx) where @@ -1773,21 +1781,36 @@ instance Applicative (LOwnedTransM ps ps ctx) where instance Monad (LOwnedTransM ps ps ctx) where (>>=) = (>>>=) +data ExtLOwnedInfo ps ctx where + ExtLOwnedInfo :: ExprCtxExt ctx ctx' -> LOwnedInfo ps ctx' -> + ExtLOwnedInfo ps ctx + gput :: LOwnedInfo ps_out ctx -> LOwnedTransM ps_in ps_out ctx () -gput loInfo = LOwnedTransM $ \_ _ k -> k reflExprCtxExt loInfo () +gput loInfo = + LOwnedTransM $ \cext _ k -> k reflExprCtxExt (extLOwnedInfo cext loInfo) () +{- instance ps_in ~ ps_out => - MonadState (LOwnedInfo ps_in ctx) (LOwnedTransM ps_in ps_out ctx) where - get = LOwnedTransM $ \cext s k -> k reflExprCtxExt s s + 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 +-} + +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' -gmodify :: (LOwnedInfo ps_in ctx -> LOwnedInfo ps_out ctx) -> +gmodify :: (forall ctx'. ExprCtxExt ctx ctx' -> + LOwnedInfo ps_in ctx' -> LOwnedInfo ps_out ctx') -> LOwnedTransM ps_in ps_out ctx () -gmodify f = get >>>= \loInfo -> gput (f loInfo) --} +gmodify f = ggetting $ \cext loInfo -> gput (f cext loInfo) -extLOwnedTransM :: ExprTrans tp -> LOwnedTransM ps_in ps_out ctx a -> - LOwnedTransM ps_in ps_out (ctx :> tp) a +extLOwnedTransM :: ExprCtxExt ctx ctx' -> LOwnedTransM ps_in ps_out ctx a -> + LOwnedTransM ps_in ps_out ctx' a extLOwnedTransM etrans m = error "FIXME HERE NOWNOW" -- LOwnedTransM $ \ctx_ext -> m (extExprCtxExt etrans ctx_ext) @@ -1807,15 +1830,15 @@ lownedTransTermTerm ectx (mbExprPermsMembers -> LOwnedInfo { lownedInfoECtx = exprs, lownedInfoPCtx = ps_in, lownedInfoPVars = vars_in, lownedInfoRetType = typeTransTupleType (ps_outF exprs) } in - runLOwnedTransM t loInfo $ \loInfo_out () -> + runLOwnedTransM t reflExprCtxExt loInfo $ \_ loInfo_out () -> transTupleTerm (lownedInfoPCtx loInfo_out) lownedTransTermTerm _ _ _ _ _ = error "FIXME HERE NOWNOW: write this error message" -extLOwnedTransTerm :: ExprTrans tp -> - LOwnedTransTerm ctx ps_in ps_out -> - LOwnedTransTerm (ctx :> tp) ps_in ps_out -extLOwnedTransTerm = extLOwnedTransM +extLOwnedTransTerm1 :: ExprTrans tp -> + LOwnedTransTerm ctx ps_in ps_out -> + LOwnedTransTerm (ctx :> tp) ps_in ps_out +extLOwnedTransTerm1 etrans = extLOwnedTransM (ExprCtxExt (MNil :>: etrans)) idLOwnedTransTerm :: LOwnedTransTerm ctx ps ps idLOwnedTransTerm = return () @@ -1823,9 +1846,11 @@ idLOwnedTransTerm = return () weakenLOwnedTransTerm :: LOwnedTransTerm ctx ps_in ps_out -> LOwnedTransTerm ctx (ps_in :> tp) (ps_out :> tp) weakenLOwnedTransTerm t = - (loInfoSplit Proxy (MNil :>: Proxy) <$> get) >>>= \(info_ps_in, info_tp) -> + ggetting $ \cext info_top -> + let (info_ps_in, info_tp) = loInfoSplit Proxy (MNil :>: Proxy) info_top in gput info_ps_in >>> - t >>> gmodify (flip loInfoAppend info_tp) + extLOwnedTransM cext t >>> + gmodify (\cext' info' -> loInfoAppend info' (extLOwnedInfo cext' info_tp)) bindLOwnedTransTerm :: Proxy ps_extra1 -> RAssign any ps_extra2 -> RAssign any ps_in -> @@ -1833,13 +1858,15 @@ bindLOwnedTransTerm :: LOwnedTransTerm ctx (ps_extra2 :++: ps_mid) ps_out -> LOwnedTransTerm ctx ((ps_extra1 :++: ps_extra2) :++: ps_in) ps_out bindLOwnedTransTerm prx_extra1 prx_extra2 prx_in t1 t2 = + error "FIXME HERE NOW" + {- (loInfoSplit Proxy prx_in <$> get) >>>= \(info_extra, info_in) -> let (info_extra1, info_extra2) = loInfoSplit prx_extra1 prx_extra2 info_extra in gput (loInfoAppend info_extra1 info_in) >>> t1 >>> gmodify (loInfoAppend info_extra2) >>> - t2 + t2 -} -- | The translation of the vacuously true permission @@ -2089,7 +2116,7 @@ instance ExtPermTrans AtomicPermTrans where APTrans_LOwned (extMb ls) tps_in tps_out (extMb ps_in) (extMb ps_out) (ectx :>: e) (extPermTransCtx e ps_extra) (RL.map Member_Step vars_extra) (extRelPermTransCtx e ptrans_in) (extRelPermTransCtx e ptrans_out) - (extRelPermTransCtx e ptrans_extra) (extLOwnedTransTerm e t) + (extRelPermTransCtx e ptrans_extra) (extLOwnedTransTerm1 e t) extPermTrans _ (APTrans_LOwnedSimple tps lops) = APTrans_LOwnedSimple tps (extMb lops) extPermTrans _ (APTrans_LCurrent p) = APTrans_LCurrent $ extMb p @@ -3148,38 +3175,51 @@ instance Semigroup HasFailures where instance Monoid HasFailures where mempty = NoFailures +data CtxExt ctx1 ctx2 where + CtxExt :: RAssign Proxy ctx3 -> CtxExt ctx1 (ctx1 :++: ctx3) + +reflCtxExt :: CtxExt ctx ctx +reflCtxExt = CtxExt MNil + +extCtxExt :: RAssign Proxy ctx2 -> CtxExt (ctx1 :++: ctx2) ctx3 -> + CtxExt ctx1 ctx3 +extCtxExt = error "FIXME HERE NOWNOW" + +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 + -- | A function for translating an @r@ -- FIXME HERE NOWNOW: remove ctx type arg -newtype ImpRTransFun r ext blocks tops rets = +newtype ImpRTransFun r ext blocks tops rets ctx = ImpRTransFun { appImpTransFun :: - forall ps ctx. Mb ctx (r ps) -> - ImpTransM ext blocks tops rets ps ctx SpecTerm } + forall ps ctx'. CtxExt ctx ctx' -> Mb ctx' (r ps) -> + ImpTransM ext blocks tops rets ps ctx' SpecTerm } -{- -extImpRTransFun :: ExprTransCtx ctx' -> +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 (extMultiExprCtxExt ctx' cext) mb_r --} + appImpTransFun f (extCtxExt ctx' cext) mb_r -- | A monad transformer that adds an 'ImpRTransFun' translation function -newtype ImpRTransFunT r ext blocks tops rets m a = +newtype ImpRTransFunT r ext blocks tops rets ctx m a = ImpRTransFunT { unImpRTransFunT :: - ReaderT (ImpRTransFun r ext blocks tops rets) m a } + 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 m a -> - ImpRTransFun r ext blocks tops rets -> m a +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 m a -> - ImpRTransFunT r ext blocks tops rets 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 @@ -3191,25 +3231,23 @@ mapImpRTransFunT f = ImpRTransFunT . mapReaderT f . unImpRTransFunT -- result inside the current 'PermImpl' type PImplTransM r ext blocks tops rets ps ctx = MaybeT (WriterT ([String], HasFailures) - (ImpRTransFunT r ext blocks tops rets Identity)) --- FIXME HERE NOWNOW: PImplTransM doesn't need ps or ctx + (ImpRTransFunT r ext blocks tops rets ctx Identity)) +-- FIXME HERE NOWNOW: PImplTransM doesn't need ps -- | Run a 'PermImplTransM' computation runPermImplTransM :: PImplTransM r ext blocks tops rets ps ctx a -> - ImpRTransFun r ext blocks tops rets -> + ImpRTransFun r ext blocks tops rets ctx -> (Maybe a, ([String], HasFailures)) runPermImplTransM m rTransFun = runIdentity $ runImpRTransFunT (runWriterT $ runMaybeT m) rTransFun -{- -extPermImplTransM :: prx ctx' -> +extPermImplTransM :: RAssign Proxy 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 --} {- extPermImplTransM :: ExprTransCtx ctx' -> @@ -3231,7 +3269,7 @@ extPermImplTransMTerm ctx' m = -- | Look up the @r@ translation function pimplRTransFunM :: PImplTransM r ext blocks tops rets ps ctx - (ImpRTransFun r ext blocks tops rets) + (ImpRTransFun r ext blocks tops rets ctx) pimplRTransFunM = lift $ lift $ ImpRTransFunT ask -- | Build an error term by recording the error message and returning 'Nothing' @@ -4643,8 +4681,9 @@ translatePermImplUnary :: ImpTransM ext blocks tops rets ps ctx SpecTerm) -> PImplTransMTerm r ext blocks tops rets ps ctx translatePermImplUnary (mbMatch -> [nuMP| MbPermImpls_Cons _ _ mb_impl |]) f = + let bs = RL.typeCtxProxies in PImplTerm <$> fmap f <$> popPImplTerm <$> - translatePermImpl (mbCombine RL.typeCtxProxies mb_impl) + extPermImplTransM bs (translatePermImpl (mbCombine bs mb_impl)) -- | Translate a 'PermImpl1' to a function on translation computations translatePermImpl1 :: NuMatchingAny1 r => @@ -5079,13 +5118,13 @@ translatePermImpl :: NuMatchingAny1 r => Mb ctx (PermImpl r ps) -> translatePermImpl mb_impl = case mbMatch mb_impl of [nuMP| PermImpl_Done r |] -> do f <- pimplRTransFunM - return $ PImplTerm $ const $ appImpTransFun f r + return $ PImplTerm $ const $ appImpTransFun f reflCtxExt r [nuMP| PermImpl_Step impl1 mb_impls |] -> translatePermImpl1 impl1 mb_impls translatePermImplToTerm :: NuMatchingAny1 r => String -> Mb ctx (PermImpl r ps) -> - ImpRTransFun r ext blocks tops rets -> + ImpRTransFun r ext blocks tops rets ctx -> ImpTransM ext blocks tops rets ps ctx SpecTerm translatePermImplToTerm err mb_impl k = let (maybe_ptm, (errs,_)) = @@ -5099,7 +5138,8 @@ instance ImplTranslateF r ext blocks tops rets => Translate (ImpTransInfo ext blocks tops rets ps) ctx (AnnotPermImpl r ps) SpecTerm where translate (mbMatch -> [nuMP| AnnotPermImpl err mb_impl |]) = - translatePermImplToTerm (mbLift err) mb_impl (ImpRTransFun translateF) + translatePermImplToTerm (mbLift err) mb_impl (ImpRTransFun $ + const translateF) {- -- We translate a LocalImplRet to a term that returns all current permissions @@ -5145,14 +5185,15 @@ translateLOwnedPermImpl :: String -> Mb ctx (LocalPermImpl ps_in ps_out) -> (LOwnedTransTerm ctx ps_in ps_out) translateLOwnedPermImpl err (mbMatch -> [nuMP| LocalPermImpl mb_impl |]) = ask >>= \info_top -> - return $ GenStateContT $ \loinfo_in k -> - return $ flip runTransM (lownedInfoToImp loinfo_in info_top) $ - translatePermImplToTerm err mb_impl $ ImpRTransFun $ \r -> + 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 |] -> - ask >>= \info_out -> return $ runIdentity $ - k (setLOInfoCtx (itiExprCtx info_top) $ - impInfoToLOwned info_out) () + do info_out <- ask + let e_ext' = ctxExtToExprExt cext' $ itiExprCtx info_out + return $ k e_ext' (impInfoToLOwned info_out) () ---------------------------------------------------------------------- From 9f66c56f1c6d728bac47c1dbc94c33698aed0adb Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Tue, 15 Aug 2023 07:20:25 -0700 Subject: [PATCH 042/305] implemented mbExprPermsMembers --- heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs index b946a10080..97bd8f77fe 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs @@ -2828,7 +2828,11 @@ exprPermsVars = fmap distPermsVars . exprPermsToDistPerms -- | 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 = error "FIXME HERE NOWNOW" +mbExprPermsMembers mb_ps = + mbMaybe (mbMapCl $(mkClosed [| exprPermsVars |]) mb_ps) >>= \mb_ns -> + traverseRAssign (\(Compose mb_n) -> case mbNameBoundP mb_n of + Left memb -> Just memb + _ -> Nothing) (mbRAssign mb_ns) -- | Convert the expressions in an 'ExprPerms' to variables, if possible, and -- collect them into a list From 9c1d838f22e574803f12a44093fc42094594a144 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Tue, 15 Aug 2023 18:30:41 -0700 Subject: [PATCH 043/305] moved some of the contents of APTrans_LOwned to a new LOwnedTrans type; implemented some FIXMEs --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 147 ++++++++++-------- 1 file changed, 79 insertions(+), 68 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index b71c1c728e..b969222cf3 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -43,7 +43,7 @@ import Data.BitVector.Sized (BV) import qualified Data.BitVector.Sized as BV import Data.Functor.Compose import Control.Applicative -import Control.Lens hiding ((:>), Index, ix, op) +import Control.Lens hiding ((:>), Index, ix, op, getting) import Control.Monad.Reader import Control.Monad.Writer import Control.Monad.State @@ -1573,12 +1573,9 @@ 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) -> ExprTransCtx ctx -> - PermTransCtx ctx ps_extra -> RAssign (Member ctx) ps_extra -> - RelPermTransCtx ctx ps_in -> RelPermTransCtx ctx ps_out -> - RelPermTransCtx ctx ps_extra -> - LOwnedTransTerm ctx (ps_extra :++: ps_in) ps_out -> + (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 @@ -1665,18 +1662,22 @@ data LLVMArrayBorrowTrans ctx w = data LOwnedInfo ps ctx = LOwnedInfo { lownedInfoECtx :: ExprTransCtx ctx, lownedInfoPCtx :: PermTransCtx ctx ps, - lownedInfoPVars :: RAssign (Member ctx) ps, - lownedInfoRetType :: SpecTerm } + lownedInfoPVars :: RAssign (Member ctx) ps } -- | Convert an 'ImpTransInfo' to an 'LOwnedInfo' impInfoToLOwned :: ImpTransInfo ext blocks tops rets ps ctx -> LOwnedInfo ps ctx -impInfoToLOwned = error "FIXME HERE NOWNOW" +impInfoToLOwned (ImpTransInfo {..}) = + LOwnedInfo { lownedInfoECtx = itiExprCtx, lownedInfoPCtx = itiPermStack, + lownedInfoPVars = itiPermStackVars } -- | Convert an 'LOwnedInfo' to an 'ImpTransInfo' using an existing 'ImpTransInfo' -lownedInfoToImp :: LOwnedInfo px ctx -> +lownedInfoToImp :: LOwnedInfo ps ctx -> ImpTransInfo ext blocks tops rets ps' ctx' -> ImpTransInfo ext blocks tops rets ps ctx -lownedInfoToImp = error "FIXME HERE NOWNOW" +lownedInfoToImp (LOwnedInfo {..}) (ImpTransInfo {..}) = + ImpTransInfo { itiExprCtx = lownedInfoECtx, itiPermStack = lownedInfoPCtx, + itiPermStackVars = lownedInfoPVars, + itiPermCtx = RL.map (const PTrans_True) lownedInfoECtx, .. } loInfoSetPerms :: PermTransCtx ctx ps' -> RAssign (Member ctx) ps' -> LOwnedInfo ps ctx -> LOwnedInfo ps' ctx @@ -1686,7 +1687,11 @@ loInfoSetPerms ps' vars' (LOwnedInfo {..}) = loInfoSplit :: Proxy ps1 -> RAssign any ps2 -> LOwnedInfo (ps1 :++: ps2) ctx -> (LOwnedInfo ps1 ctx, LOwnedInfo ps2 ctx) -loInfoSplit = error "FIXME HERE NOWNOW" +loInfoSplit prx1 prx2 loInfo = + let ctx = lownedInfoECtx loInfo + (ps1, ps2) = RL.split prx1 prx2 (lownedInfoPCtx loInfo) + (vars1, vars2) = RL.split prx1 prx2 (lownedInfoPVars loInfo) in + (LOwnedInfo ctx ps1 vars1, LOwnedInfo ctx ps2 vars2) loInfoAppend :: LOwnedInfo ps1 ctx -> LOwnedInfo ps2 ctx -> LOwnedInfo (ps1 :++: ps2) ctx @@ -1715,11 +1720,6 @@ transExprCtxExt (ExprCtxExt ectx2') (ExprCtxExt ectx3') = extMbExt :: ExprCtxExt ctx1 ctx2 -> Mb ctx1 a -> Mb ctx2 a extMbExt = error "FIXME HERE NOWNOW" -extTransMExt :: TransInfo info => ExprCtxExt ctx1 ctx2 -> TransM info ctx2 a -> - TransM info ctx1 a -extTransMExt (ExprCtxExt ectx3) m = inExtMultiTransM ectx3 m - - -- | Un-extend the left-hand context of an expression context extension extExprCtxExt :: ExprTrans tp -> ExprCtxExt (ctx1 :> tp) ctx2 -> ExprCtxExt ctx1 ctx2 @@ -1736,18 +1736,6 @@ extLOwnedInfo :: ExprCtxExt ctx1 ctx2 -> LOwnedInfo ps ctx1 -> LOwnedInfo ps ctx2 extLOwnedInfo = error "FIXME HERE NOWNOW" -{- -type LOwnedTransM ps_in ps_out ctx = - GenStateContT (LOwnedInfo ps_out ctx) SpecTerm - (LOwnedInfo ps_in ctx) SpecTerm Identity - -runLOwnedTransM :: LOwnedTransM ps_in ps_out ctx a -> LOwnedInfo ps_in ctx -> - (LOwnedInfo ps_out ctx -> a -> SpecTerm) -> - SpecTerm -runLOwnedTransM m info_in k = - runIdentity $ runGenStateContT m info_in $ \info_out a -> - return $ k info_out a --} -- | FIXME HERE NOWNOW: docs; explain that it's as if the input LOwnedInfo is -- relative to ctx_in and the output is relative to ctx_out except this ensures @@ -1781,15 +1769,15 @@ instance Applicative (LOwnedTransM ps ps ctx) where instance Monad (LOwnedTransM ps ps ctx) where (>>=) = (>>>=) -data ExtLOwnedInfo ps ctx where - ExtLOwnedInfo :: ExprCtxExt ctx ctx' -> LOwnedInfo ps ctx' -> - ExtLOwnedInfo ps ctx - gput :: LOwnedInfo ps_out ctx -> LOwnedTransM ps_in ps_out ctx () gput loInfo = LOwnedTransM $ \cext _ k -> k reflExprCtxExt (extLOwnedInfo 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) @@ -1811,29 +1799,24 @@ gmodify f = ggetting $ \cext loInfo -> gput (f cext loInfo) extLOwnedTransM :: ExprCtxExt ctx ctx' -> LOwnedTransM ps_in ps_out ctx a -> LOwnedTransM ps_in ps_out ctx' a -extLOwnedTransM etrans m = - error "FIXME HERE NOWNOW" - -- LOwnedTransM $ \ctx_ext -> m (extExprCtxExt etrans ctx_ext) +extLOwnedTransM cext m = + LOwnedTransM $ \cext' -> runLOwnedTransM m (transExprCtxExt cext cext') type LOwnedTransTerm ctx ps_in ps_out = LOwnedTransM ps_in ps_out ctx () lownedTransTermTerm :: PureTypeTrans (ExprTransCtx ctx) -> - Mb ctx (ExprPerms ps_in) -> + RAssign (Member ctx) ps_in -> RelPermTransCtx ctx ps_in -> RelPermTransCtx ctx ps_out -> LOwnedTransTerm ctx ps_in ps_out -> SpecTerm -lownedTransTermTerm ectx (mbExprPermsMembers -> - Just vars_in) ps_inF ps_outF t = +lownedTransTermTerm ectx vars_in ps_inF ps_outF t = lambdaTrans "e" ectx $ \exprs -> lambdaTrans "p" (ps_inF exprs) $ \ps_in -> let loInfo = LOwnedInfo { lownedInfoECtx = exprs, lownedInfoPCtx = ps_in, - lownedInfoPVars = vars_in, - lownedInfoRetType = typeTransTupleType (ps_outF exprs) } in + lownedInfoPVars = vars_in } in runLOwnedTransM t reflExprCtxExt loInfo $ \_ loInfo_out () -> transTupleTerm (lownedInfoPCtx loInfo_out) -lownedTransTermTerm _ _ _ _ _ = - error "FIXME HERE NOWNOW: write this error message" extLOwnedTransTerm1 :: ExprTrans tp -> LOwnedTransTerm ctx ps_in ps_out -> @@ -1858,15 +1841,54 @@ bindLOwnedTransTerm :: LOwnedTransTerm ctx (ps_extra2 :++: ps_mid) ps_out -> LOwnedTransTerm ctx ((ps_extra1 :++: ps_extra2) :++: ps_in) ps_out bindLOwnedTransTerm prx_extra1 prx_extra2 prx_in t1 t2 = - error "FIXME HERE NOW" - {- - (loInfoSplit Proxy prx_in <$> get) >>>= \(info_extra, info_in) -> - let (info_extra1, info_extra2) = + 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) >>> - t1 >>> - gmodify (loInfoAppend info_extra2) >>> - t2 -} + extLOwnedTransM cext t1 >>> + gmodify (\cext' info_out -> + loInfoAppend (extLOwnedInfo cext' info_extra2) info_out) >>> + extLOwnedTransM cext t2 + +-- | The translation of an @lowned@ permission +data LOwnedTrans ctx ps_extra ps_in ps_out = + LOwnedTrans + (ExprTransCtx ctx) + (PermTransCtx ctx ps_extra) (RAssign (Member ctx) ps_extra) + (RelPermTransCtx ctx ps_in) (RelPermTransCtx ctx ps_out) + (RelPermTransCtx ctx ps_extra) + (LOwnedTransTerm ctx (ps_extra :++: ps_in) ps_out) + +-- | Extend the context of an 'LOwnedTrans' +extLOwnedTrans :: ExprTrans tp -> LOwnedTrans ctx ps_extra ps_in ps_out -> + LOwnedTrans (ctx :> tp) ps_extra ps_in ps_out +extLOwnedTrans e (LOwnedTrans ectx ps_extra vars_extra ptrans_in ptrans_out + ptrans_extra t) = + LOwnedTrans + (ectx :>: e) (extPermTransCtx e ps_extra) (RL.map Member_Step vars_extra) + (extRelPermTransCtx e ptrans_in) (extRelPermTransCtx e ptrans_out) + (extRelPermTransCtx e ptrans_extra) (extLOwnedTransTerm1 e t) + +-- | Convert an 'LOwnedTrans' to a closure that gets added to the list of +-- closures for the current spec definition +lownedTransTerm :: Mb ctx (ExprPerms ps_in) -> + LOwnedTrans ctx ps_extra ps_in ps_out -> SpecTerm +lownedTransTerm (mbExprPermsMembers -> + Just vars_in) (LOwnedTrans + ectx ps_extra vars_extra + tps_in tps_out tps_extra lott) = + let etps = exprCtxType ectx + tps_extra_in = appRelPermTransCtx tps_extra tps_in + vars_extra_in = RL.append vars_extra vars_in + lrt = piExprPermLRT etps tps_extra_in tps_out + fun_tm = + lownedTransTermTerm etps vars_extra_in tps_extra_in tps_out lott in + applyClosSpecTerm lrt (mkFreshClosSpecTerm lrt (const fun_tm)) + (transTerms ectx ++ transTerms ps_extra) +lownedTransTerm _ _ = + failTermLike "FIXME HERE NOWNOW: write this error message" + -- | The translation of the vacuously true permission @@ -1968,16 +1990,8 @@ instance IsTermTrans (AtomicPermTrans ctx a) where transTerms (APTrans_NamedConj _ _ _ t) = [t] transTerms (APTrans_DefinedNamedConj _ _ _ ptrans) = transTerms ptrans transTerms (APTrans_LLVMFrame _) = [] - transTerms (APTrans_LOwned _ _ _ eps_in _ - ectx ps_extra _ tps_in tps_out tps_extra lott) = - let etps = exprCtxType ectx - tps_extra_in = appRelPermTransCtx tps_extra tps_in - lrt = piExprPermLRT etps tps_extra_in tps_out - fun_tm = - -- lownedTransTermTerm etps eps_in tps_extra_in tps_out lott - error "FIXME HERE NOWNOW" in - [applyClosSpecTerm lrt (mkFreshClosSpecTerm lrt (const fun_tm)) - (transTerms ectx ++ transTerms ps_extra)] + transTerms (APTrans_LOwned _ _ _ eps_in _ lotr) = + [lownedTransTerm eps_in lotr] transTerms (APTrans_LOwnedSimple _ _) = [] transTerms (APTrans_LCurrent _) = [] transTerms APTrans_LFinished = [] @@ -2044,8 +2058,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 @@ -2111,12 +2125,9 @@ instance ExtPermTrans AtomicPermTrans where extPermTrans e (APTrans_DefinedNamedConj npn args off ptrans) = APTrans_DefinedNamedConj npn (extMb args) (extMb off) (extPermTrans e ptrans) extPermTrans _ (APTrans_LLVMFrame fp) = APTrans_LLVMFrame $ extMb fp - extPermTrans e (APTrans_LOwned ls tps_in tps_out ps_in ps_out ectx - ps_extra vars_extra ptrans_in ptrans_out ptrans_extra t) = + extPermTrans e (APTrans_LOwned ls tps_in tps_out ps_in ps_out lotr) = APTrans_LOwned (extMb ls) tps_in tps_out (extMb ps_in) (extMb ps_out) - (ectx :>: e) (extPermTransCtx e ps_extra) (RL.map Member_Step vars_extra) - (extRelPermTransCtx e ptrans_in) (extRelPermTransCtx e ptrans_out) - (extRelPermTransCtx e ptrans_extra) (extLOwnedTransTerm1 e t) + (extLOwnedTrans e lotr) extPermTrans _ (APTrans_LOwnedSimple tps lops) = APTrans_LOwnedSimple tps (extMb lops) extPermTrans _ (APTrans_LCurrent p) = APTrans_LCurrent $ extMb p From d0d1f11a50e449ed482b758bb8d9db6fb57bcd31 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 17 Aug 2023 06:56:03 -0700 Subject: [PATCH 044/305] Changed extPermTrans to be implemented in terms of extPermTransMulti, ostensibly for efficiency; implemented a few more FIXMEs --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 186 ++++++++++-------- 1 file changed, 109 insertions(+), 77 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index b969222cf3..42a9f23845 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -93,11 +93,11 @@ 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) ---------------------------------------------------------------------- @@ -1714,11 +1714,13 @@ reflExprCtxExt = ExprCtxExt MNil -- | Transitively combine two context extensions transExprCtxExt :: ExprCtxExt ctx1 ctx2 -> ExprCtxExt ctx2 ctx3 -> ExprCtxExt ctx1 ctx3 -transExprCtxExt (ExprCtxExt ectx2') (ExprCtxExt ectx3') = - error "FIXME HERE NOWNOW" +transExprCtxExt ((ExprCtxExt ectx2') + :: ExprCtxExt ctx1 ctx2) (ExprCtxExt ectx3') + | Refl <- RL.appendAssoc (Proxy :: Proxy ctx1) ectx2' ectx3' + = ExprCtxExt (RL.append ectx2' ectx3') extMbExt :: ExprCtxExt ctx1 ctx2 -> Mb ctx1 a -> Mb ctx2 a -extMbExt = error "FIXME HERE NOWNOW" +extMbExt (ExprCtxExt ctx2) = extMbAny ctx2 -- | Un-extend the left-hand context of an expression context extension extExprCtxExt :: ExprTrans tp -> ExprCtxExt (ctx1 :> tp) ctx2 -> @@ -1727,14 +1729,20 @@ extExprCtxExt etrans ((ExprCtxExt ctx3) :: ExprCtxExt (ctx1 :> tp) ctx2) = case RL.appendRNilConsEq (Proxy :: Proxy ctx1) etrans ctx3 of Refl -> ExprCtxExt (RL.append (MNil :>: etrans) ctx3) --- | Un-extend the left-hand context of an expression context extension -extMultiExprCtxExt :: ExprTransCtx ctx2 -> ExprCtxExt (ctx1 :++: ctx2) ctx3 -> - ExprCtxExt ctx1 ctx3 -extMultiExprCtxExt = error "FIXME HERE NOWNOW" +-- | Extend the context of a permission translation using an 'ExprCtxExt' +extPermTransExt :: ExprCtxExt ctx1 ctx2 -> PermTrans ctx1 a -> + PermTrans ctx2 a +extPermTransExt (ExprCtxExt ectx) ptrans = extPermTransMulti ectx ptrans + +-- | Extend the context of a permission translation context using an +-- 'ExprCtxExt' +extPermTransCtxExt :: ExprCtxExt ctx1 ctx2 -> PermTransCtx ctx1 ps -> + PermTransCtx ctx2 ps +extPermTransCtxExt cext = RL.map (extPermTransExt cext) -extLOwnedInfo :: ExprCtxExt ctx1 ctx2 -> LOwnedInfo ps ctx1 -> - LOwnedInfo ps ctx2 -extLOwnedInfo = error "FIXME HERE NOWNOW" +extLOwnedInfoExt :: ExprCtxExt ctx1 ctx2 -> LOwnedInfo ps ctx1 -> + LOwnedInfo ps ctx2 +extLOwnedInfoExt = error "FIXME HERE NOWNOW" -- | FIXME HERE NOWNOW: docs; explain that it's as if the input LOwnedInfo is @@ -1771,7 +1779,7 @@ instance Monad (LOwnedTransM ps ps ctx) where gput :: LOwnedInfo ps_out ctx -> LOwnedTransM ps_in ps_out ctx () gput loInfo = - LOwnedTransM $ \cext _ k -> k reflExprCtxExt (extLOwnedInfo cext loInfo) () + LOwnedTransM $ \cext _ k -> k reflExprCtxExt (extLOwnedInfoExt cext loInfo) () {- data ExtLOwnedInfo ps ctx where @@ -1818,10 +1826,10 @@ lownedTransTermTerm ectx vars_in ps_inF ps_outF t = runLOwnedTransM t reflExprCtxExt loInfo $ \_ loInfo_out () -> transTupleTerm (lownedInfoPCtx loInfo_out) -extLOwnedTransTerm1 :: ExprTrans tp -> - LOwnedTransTerm ctx ps_in ps_out -> - LOwnedTransTerm (ctx :> tp) ps_in ps_out -extLOwnedTransTerm1 etrans = extLOwnedTransM (ExprCtxExt (MNil :>: etrans)) +extLOwnedTransTerm :: ExprTransCtx ctx2 -> + LOwnedTransTerm ctx1 ps_in ps_out -> + LOwnedTransTerm (ctx1 :++: ctx2) ps_in ps_out +extLOwnedTransTerm ectx2 = extLOwnedTransM (ExprCtxExt ectx2) idLOwnedTransTerm :: LOwnedTransTerm ctx ps ps idLOwnedTransTerm = return () @@ -1833,7 +1841,7 @@ weakenLOwnedTransTerm t = 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' (extLOwnedInfo cext' info_tp)) + gmodify (\cext' info' -> loInfoAppend info' (extLOwnedInfoExt cext' info_tp)) bindLOwnedTransTerm :: Proxy ps_extra1 -> RAssign any ps_extra2 -> RAssign any ps_in -> @@ -1848,7 +1856,7 @@ bindLOwnedTransTerm prx_extra1 prx_extra2 prx_in t1 t2 = gput (loInfoAppend info_extra1 info_in) >>> extLOwnedTransM cext t1 >>> gmodify (\cext' info_out -> - loInfoAppend (extLOwnedInfo cext' info_extra2) info_out) >>> + loInfoAppend (extLOwnedInfoExt cext' info_extra2) info_out) >>> extLOwnedTransM cext t2 -- | The translation of an @lowned@ permission @@ -1861,14 +1869,18 @@ data LOwnedTrans ctx ps_extra ps_in ps_out = (LOwnedTransTerm ctx (ps_extra :++: ps_in) ps_out) -- | Extend the context of an 'LOwnedTrans' -extLOwnedTrans :: ExprTrans tp -> LOwnedTrans ctx ps_extra ps_in ps_out -> - LOwnedTrans (ctx :> tp) ps_extra ps_in ps_out -extLOwnedTrans e (LOwnedTrans ectx ps_extra vars_extra ptrans_in ptrans_out - ptrans_extra t) = +extLOwnedTransMulti :: ExprTransCtx ctx2 -> + LOwnedTrans ctx1 ps_extra ps_in ps_out -> + LOwnedTrans (ctx1 :++: ctx2) ps_extra ps_in ps_out +extLOwnedTransMulti ectx2 (LOwnedTrans ectx1 ps_extra vars_extra ptrans_in + ptrans_out ptrans_extra t) = LOwnedTrans - (ectx :>: e) (extPermTransCtx e ps_extra) (RL.map Member_Step vars_extra) - (extRelPermTransCtx e ptrans_in) (extRelPermTransCtx e ptrans_out) - (extRelPermTransCtx e ptrans_extra) (extLOwnedTransTerm1 e t) + (RL.append ectx1 ectx2) (extPermTransCtxMulti ectx2 ps_extra) + (RL.map (weakenMemberR ectx2) vars_extra) + (extRelPermTransCtxMulti ectx2 ptrans_in) + (extRelPermTransCtxMulti ectx2 ptrans_out) + (extRelPermTransCtxMulti ectx2 ptrans_extra) + (extLOwnedTransTerm ectx2 t) -- | Convert an 'LOwnedTrans' to a closure that gets added to the list of -- closures for the current spec definition @@ -2091,58 +2103,68 @@ permTransPermEq ptrans mb_p = permTransPerm (mbToProxy mb_p) ptrans == mb_p -extsMb :: CruCtx ctx2 -> Mb ctx a -> Mb (ctx :++: ctx2) a -extsMb ctx = mbCombine proxies . fmap (nus proxies . const) - where - proxies = cruCtxProxies ctx +extMbAny :: RAssign any ctx2 -> Mb ctx1 a -> Mb (ctx1 :++: ctx2) a +extMbAny ctx2 = extMbMulti (RL.map (const Proxy) ctx2) + +extPermTrans :: ExtPermTrans f => ExprTrans tp -> f ctx a -> f (ctx :> tp) a +extPermTrans e = extPermTransMulti (MNil :>: e) -- | Generic function to extend the context of the translation of a permission class ExtPermTrans f where - extPermTrans :: ExprTrans tp -> 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 e (PTrans_Conj aps) = - PTrans_Conj (map (extPermTrans e) aps) - extPermTrans e (PTrans_Defined n args a ptrans) = - PTrans_Defined n (extMb args) (extMb a) (extPermTrans e 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 e (APTrans_LLVMField fld ptrans) = - APTrans_LLVMField (extMb fld) (extPermTrans e ptrans) - extPermTrans e (APTrans_LLVMArray arr_trans) = - APTrans_LLVMArray $ extPermTrans e arr_trans - extPermTrans _ (APTrans_LLVMBlock mb_bp t) = APTrans_LLVMBlock (extMb mb_bp) t - extPermTrans _ (APTrans_LLVMFree e) = APTrans_LLVMFree $ extMb e - extPermTrans e (APTrans_LLVMFunPtr tp ptrans) = - APTrans_LLVMFunPtr tp (extPermTrans e 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 e (APTrans_DefinedNamedConj npn args off ptrans) = - APTrans_DefinedNamedConj npn (extMb args) (extMb off) (extPermTrans e ptrans) - extPermTrans _ (APTrans_LLVMFrame fp) = APTrans_LLVMFrame $ extMb fp - extPermTrans e (APTrans_LOwned ls tps_in tps_out ps_in ps_out lotr) = - APTrans_LOwned (extMb ls) tps_in tps_out (extMb ps_in) (extMb ps_out) - (extLOwnedTrans e lotr) - extPermTrans _ (APTrans_LOwnedSimple tps lops) = - APTrans_LOwnedSimple tps (extMb lops) - extPermTrans _ (APTrans_LCurrent p) = APTrans_LCurrent $ extMb p - extPermTrans _ APTrans_LFinished = APTrans_LFinished - extPermTrans e (APTrans_Struct ps) = - APTrans_Struct $ RL.map (extPermTrans e) ps - extPermTrans _ (APTrans_Fun fp trans) = APTrans_Fun (extMb fp) trans - extPermTrans e (APTrans_BVProp prop_trans) = - APTrans_BVProp $ extPermTrans e 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 t) = + APTrans_LLVMBlock (extMbAny ectx mb_bp) t + 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 t) = + APTrans_LLVMBlockShape (extMbAny ectx mb_sh) t + 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 e (LLVMArrayPermTrans ap len sh {- bs -} t) = - LLVMArrayPermTrans (extMb ap) len (fmap (extPermTrans e) 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 @@ -2151,20 +2173,30 @@ 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 +extPermTransCtxMulti :: ExprTransCtx ctx2 -> PermTransCtx ctx1 ps -> + PermTransCtx (ctx1 :++: ctx2) ps +extPermTransCtxMulti ectx2 = RL.map (extPermTransMulti ectx2) + -- | Extend the context of a 'RelPermTransCtx' -extRelPermTransCtx :: ExprTrans tp -> RelPermTransCtx ctx ps -> - RelPermTransCtx (ctx :> tp) ps -extRelPermTransCtx e rel_tp = fmap (extPermTransCtx e) . rel_tp . RL.tail +extRelPermTransCtxMulti :: ExprTransCtx ctx2 -> RelPermTransCtx ctx1 ps -> + RelPermTransCtx (ctx1 :++: ctx2) ps +extRelPermTransCtxMulti ectx2 (rel_tp :: RelPermTransCtx ctx1 ps) = + \ectx12 -> + let (ectx1, _) = RL.split (Proxy :: Proxy ctx1) ectx2 ectx12 in + fmap (extPermTransCtxMulti ectx2) $ rel_tp ectx1 -- | Add another permission translation to a permission translation context From c2ca45373589e05f2e2842276be84741446dd723 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 17 Aug 2023 07:20:13 -0700 Subject: [PATCH 045/305] fixed a few more FIXMEs; removed some commented code that is no longer needed --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 253 ++---------------- 1 file changed, 29 insertions(+), 224 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 42a9f23845..9080278a61 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -1061,8 +1061,8 @@ instance (Translate info ctx a tr, NuMatching a) => class HasPureTrans a where hasPureTrans :: Mb (ctx :: RList CrucibleType) a -> Bool -instance HasPureTrans a => HasPureTrans [a] where - hasPureTrans xs = error "FIXME HERE NOWNOW" +instance (HasPureTrans a, NuMatching a) => HasPureTrans [a] where + hasPureTrans = and . map hasPureTrans . mbList ---------------------------------------------------------------------- @@ -1722,12 +1722,18 @@ transExprCtxExt ((ExprCtxExt ectx2') 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) +-} + +extExprTransCtx :: ExprCtxExt ctx1 ctx2 -> ExprTransCtx ctx1 -> + ExprTransCtx ctx2 +extExprTransCtx (ExprCtxExt ectx2) ectx1 = RL.append ectx1 ectx2 -- | Extend the context of a permission translation using an 'ExprCtxExt' extPermTransExt :: ExprCtxExt ctx1 ctx2 -> PermTrans ctx1 a -> @@ -1742,7 +1748,10 @@ extPermTransCtxExt cext = RL.map (extPermTransExt cext) extLOwnedInfoExt :: ExprCtxExt ctx1 ctx2 -> LOwnedInfo ps ctx1 -> LOwnedInfo ps ctx2 -extLOwnedInfoExt = error "FIXME HERE NOWNOW" +extLOwnedInfoExt cext@(ExprCtxExt ectx3) (LOwnedInfo {..}) = + LOwnedInfo { lownedInfoECtx = extExprTransCtx cext lownedInfoECtx, + lownedInfoPCtx = extPermTransCtxExt cext lownedInfoPCtx, + lownedInfoPVars = RL.map (weakenMemberR ectx3) lownedInfoPVars } -- | FIXME HERE NOWNOW: docs; explain that it's as if the input LOwnedInfo is @@ -3218,15 +3227,18 @@ instance Semigroup HasFailures where instance Monoid HasFailures where mempty = NoFailures +-- | FIXME HERE NOWNOW: docs! data CtxExt ctx1 ctx2 where CtxExt :: RAssign Proxy ctx3 -> CtxExt ctx1 (ctx1 :++: ctx3) reflCtxExt :: CtxExt ctx ctx reflCtxExt = CtxExt MNil -extCtxExt :: RAssign Proxy ctx2 -> CtxExt (ctx1 :++: ctx2) ctx3 -> +extCtxExt :: Proxy ctx1 -> RAssign Proxy ctx2 -> CtxExt (ctx1 :++: ctx2) ctx3 -> CtxExt ctx1 ctx3 -extCtxExt = error "FIXME HERE NOWNOW" +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 @@ -3234,7 +3246,6 @@ ctxExtToExprExt ((CtxExt ctx3) :: CtxExt ctx1 ctx2) ectx = ExprCtxExt $ snd $ RL.split (Proxy :: Proxy ctx1) ctx3 ectx -- | A function for translating an @r@ --- FIXME HERE NOWNOW: remove ctx type arg newtype ImpRTransFun r ext blocks tops rets ctx = ImpRTransFun { appImpTransFun :: forall ps ctx'. CtxExt ctx ctx' -> Mb ctx' (r ps) -> @@ -3245,7 +3256,7 @@ extImpRTransFun :: RAssign Proxy ctx' -> ImpRTransFun r ext blocks tops rets (ctx :++: ctx') extImpRTransFun ctx' f = ImpRTransFun $ \cext mb_r -> - appImpTransFun f (extCtxExt ctx' cext) mb_r + appImpTransFun f (extCtxExt Proxy ctx' cext) mb_r -- | A monad transformer that adds an 'ImpRTransFun' translation function @@ -3272,22 +3283,21 @@ mapImpRTransFunT f = ImpRTransFunT . mapReaderT f . unImpRTransFunT -- 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 ps ctx = +type PImplTransM r ext blocks tops rets ctx = MaybeT (WriterT ([String], HasFailures) (ImpRTransFunT r ext blocks tops rets ctx Identity)) --- FIXME HERE NOWNOW: PImplTransM doesn't need ps -- | Run a 'PermImplTransM' computation runPermImplTransM :: - PImplTransM r ext blocks tops rets ps ctx a -> + 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 ps (ctx :++: ctx') a -> - PImplTransM r ext blocks tops rets ps ctx a + 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 @@ -3311,27 +3321,27 @@ extPermImplTransMTerm ctx' m = -} -- | Look up the @r@ translation function -pimplRTransFunM :: PImplTransM r ext blocks tops rets ps ctx +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 ps ctx a +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 ps ctx a -> - PImplTransM r ext blocks tops rets ps ctx (Maybe a) +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 ps ctx a -> - PImplTransM r ext blocks tops rets ps ctx a +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 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 @@ -3369,206 +3379,6 @@ pimplHandleFailM m m_catch = m_catch -{- -FIXME HERE NOWNOW: old stuff --- | 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 SpecTerm - -- | An error message to print on failure - | ImplFailContMsg String - --- | Convert an 'ImplFailCont' to an error, which should have the given type -implFailContTerm :: SpecTerm -> ImplFailCont -> SpecTerm -implFailContTerm _ (ImplFailContTerm t) = t -implFailContTerm tp (ImplFailContMsg msg) = errorSpecTerm tp (pack msg) - --- | The type of terms use to translation permission implications, which can --- contain calls to the current failure continuation; note that the destructor --- "pops" the PImpl abstraction, returning a regular 'SpecTerm' -newtype PImplTerm = PImplTerm { popPImplTerm :: ImplFailCont -> SpecTerm } - deriving OpenTermLike - --- | Lift a 'SpecTerm' to a 'PImplTerm' -specPImplTerm :: SpecTerm -> PImplTerm -specPImplTerm = PImplTerm . const - --- | Build a 'PImplTerm' that let-binds a 'PImplTerm' using the supplied --- variable name and type as the failure continuation for a body 'PImplTerm' -letFailPImplTerm :: LocalName -> SpecTerm -> PImplTerm -> PImplTerm -> PImplTerm -letFailPImplTerm x tp rhs body = - PImplTerm $ \k -> - letTermLike x tp (popPImplTerm rhs k) $ \k_tm -> - popPImplTerm body $ ImplFailContTerm k_tm - --- | The failure 'PImplTerm', which immediately calls its failure continuation; --- this should have the supplied type -failPImplTerm :: SpecTerm -> PImplTerm -failPImplTerm tp = PImplTerm $ \k -> 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 :: SpecTerm -> String -> PImplTerm -failPImplTermAlt tp msg = PImplTerm $ \k -> - implFailContTerm tp (case k of - ImplFailContMsg _ -> ImplFailContMsg msg - _ -> k) - --- | "Force" an optional 'PImplTerm' to a 'PImplTerm' by converting a 'Nothing' --- to the 'failPImplTerm', which should have the supplied type -forcePImplTerm :: SpecTerm -> Maybe PImplTerm -> PImplTerm -forcePImplTerm _ (Just t) = t -forcePImplTerm tp Nothing = failPImplTerm tp - - --- | A flag to indicate whether a 'PImplTerm' calls its failure continuation -data HasFailures = HasFailures | NoFailures deriving Eq - -instance Semigroup HasFailures where - HasFailures <> _ = HasFailures - _ <> HasFailures = HasFailures - NoFailures <> NoFailures = NoFailures - -instance Monoid HasFailures where - mempty = NoFailures - --- | A function for translating an @r@ -newtype ImpRTransFun r ext blocks tops rets = - ImpRTransFun { appImpTransCont :: - forall ps ctx. Mb ctx (r ps) -> - ImpTransM ext blocks tops rets ps ctx SpecTerm } - --- | A monad transformer that adds an 'ImpRTransFun' translation function -newtype ImpRTransFunT r ext blocks tops rets m a = - ImpRTransFunT { unImpRTransFunT :: - ReaderT (ImpRTransFun r ext blocks tops rets) 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 m a -> - ImpRTransFun r ext blocks tops rets -> 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 m a -> - ImpRTransFunT r ext blocks tops rets 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; an --- 'ImpRTransFunT' to pass along a function for translating the final @r@ result --- inside the current 'PermImpl'; and an 'ImpTransM' for doing the impure --- translation. -type PImplTransM r ext blocks tops rets ps ctx = - MaybeT (WriterT ([String], HasFailures) - (ImpRTransFunT r ext blocks tops rets - (ImpTransM ext blocks tops rets ps ctx))) - --- | Run a 'PermImplTransM' computation -runPermImplTransM :: - PImplTransM r ext blocks tops rets ps ctx a -> - ImpRTransFun r ext blocks tops rets -> - ImpTransM ext blocks tops rets ps ctx (Maybe a, ([String], HasFailures)) -runPermImplTransM m rTransFun = - runImpRTransFunT (runWriterT $ runMaybeT m) rTransFun - --- | Look up the @r@ translation function -pimplRTransFunM :: PImplTransM r ext blocks tops rets ps ctx - (ImpRTransFun r ext blocks tops rets) -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 ps ctx PImplTerm -pimplFailM msg = tell ([msg],HasFailures) >> mzero - --- | Catch a potential 'Nothing' return value in a 'PImplTransM' computation -pimplCatchM :: PImplTransM r ext blocks tops rets ps ctx a -> - PImplTransM r ext blocks tops rets ps ctx (Maybe a) -pimplCatchM m = lift $ runMaybeT m - --- | 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 :: PImplTransM r ext blocks tops rets ps ctx PImplTerm -> - PImplTransM r ext blocks tops rets ps ctx PImplTerm -> - PImplTransM r ext blocks tops rets ps ctx PImplTerm -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 t_catch <- m_catch - ret_tp <- lift $ lift $ lift compReturnTypeM - return $ letFailPImplTerm "catchpoint" ret_tp t_catch t - (Nothing, _) -> - -- If t definitely fails, then just use m_catch - m_catch - - --- | Lift an 'ImpTransM' computation to 'PImplTransM' -pimplLift :: ImpTransM ext blocks tops rets ps_out ctx a -> - PImplTransM r ext blocks tops rets ps_out ctx a -pimplLift = lift . lift . lift - --- | Call 'translate' in the 'PImplTransM' monad -pimplTranslate :: (Translate (ImpTransInfo ext blocks tops rets ps) ctx a tr, - HasCallStack) => - Mb ctx a -> PImplTransM r ext blocks tops rets ps ctx tr -pimplTranslate = pimplLift . translate - --- | Call 'translate1' in the 'PImplTransM' monad -pimplTranslate1 :: (Translate (ImpTransInfo ext blocks tops rets ps) ctx a tr, - HasCallStack, IsTermTrans tr) => - Mb ctx a -> PImplTransM r ext blocks tops rets ps ctx SpecTerm -pimplTranslate1 = pimplLift . translate1 - --- | The current non-monadic return type as a 'PImplTerm' -returnPImplTypeM :: PImplTransM r ext blocks tops rets ps_out ctx PImplTerm -returnPImplTypeM = specPImplTerm <$> returnTypeM - --- | Like 'lambdaTransM' but over 'PImplTerm's -lambdaPImplTransM :: String -> TypeTrans p tr -> (tr -> TransM info ctx PImplTerm) -> - PImplTransM r ext blocks tops rets ps ctx PImplTerm -lambdaPImplTransM x tp body_f = - ask >>= \info -> - return (PImplTerm $ \k -> - lambdaTrans x tp (flip popPImplTerm k . flip runTransM info . body_f)) - --- | Like 'bindSpecMTransM' but using 'PImplTerm's in the 'PImplTransM'. Note --- that this will always say that it uses the failure continuation, because the --- current interface for 'PImplTerm' cannot handle a lambda whose body returns a --- 'Maybe' result, so we always have to force the body. -bindPImplSpecMTransM :: SpecTerm -> ImpTypeTrans tr -> String -> - (tr -> PImplTransM r ext blocks tops rets ps ctx PImplTerm) -> - PImplTransM r ext blocks tops rets ps ctx PImplTerm -bindPImplSpecMTransM m m_tp str f = - do ret_tp <- returnTypeM - k_tm <- lambdaPImplTransM str m_tp f - return $ PImplTerm $ \fk -> - bindSpecTerm (typeTransType1Imp m_tp) ret_tp m (popPImplTerm k_tm fk) --} - - -- | Translate the output permissions of a 'SimplImpl' translateSimplImplOut :: Mb ctx (SimplImpl ps_in ps_out) -> ImpTransM ext blocks tops rets ps ctx @@ -5184,7 +4994,6 @@ instance ImplTranslateF r ext blocks tops rets => 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 _ = @@ -5197,7 +5006,6 @@ translateLocalPermImpl :: String -> Mb ctx (LocalPermImpl ps_in ps_out) -> ImpTransM ext blocks tops rets ps_in ctx SpecTerm translateLocalPermImpl err (mbMatch -> [nuMP| LocalPermImpl impl |]) = clearVarPermsM $ translate $ fmap (AnnotPermImpl err) impl --} -- | Translate a local implication over two sequences of permissions (already -- translated to types) to a monadic function with the first sequence of @@ -5211,8 +5019,6 @@ translateCurryLocalPermImpl :: ImpTypeTrans (PermTransCtx ctx ps2) -> RAssign (Member ctx) ps2 -> ImpTypeTrans (PermTransCtx ctx ps_out) -> ImpTransM ext blocks tops rets ps ctx SpecTerm -translateCurryLocalPermImpl = error "FIXME HERE NOWNOW" -{- translateCurryLocalPermImpl err impl pctx1 vars1 tp_trans2 vars2 tp_trans_out = lambdaTransM "x_local" tp_trans2 $ \pctx2 -> local (\info -> info { itiReturnType = typeTransTupleDesc tp_trans_out }) $ @@ -5220,7 +5026,6 @@ translateCurryLocalPermImpl err impl pctx1 vars1 tp_trans2 vars2 tp_trans_out = (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) -> From 76decf999cbc1bcb1834714f8c69148ea1d236cc Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 17 Aug 2023 20:50:23 -0700 Subject: [PATCH 046/305] added lrtClosTypeSpecTerm --- saw-core/src/Verifier/SAW/OpenTerm.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/saw-core/src/Verifier/SAW/OpenTerm.hs b/saw-core/src/Verifier/SAW/OpenTerm.hs index af2a81f358..2939e430a6 100644 --- a/saw-core/src/Verifier/SAW/OpenTerm.hs +++ b/saw-core/src/Verifier/SAW/OpenTerm.hs @@ -86,7 +86,7 @@ module Verifier.SAW.OpenTerm ( letTermLike, sawLetTermLike, -- * Building SpecM computations SpecTerm(), defineSpecOpenTerm, lambdaPureSpecTerm, lambdaPureSpecTermMulti, - sawLetPureSpecTerm, lrtToTypeSpecTerm, + lrtClosTypeSpecTerm, sawLetPureSpecTerm, lrtToTypeSpecTerm, mkBaseClosSpecTerm, mkFreshClosSpecTerm, callClosSpecTerm, applyClosSpecTerm, callDefSpecTerm, monadicSpecOp, specMTypeSpecTerm, returnSpecTerm, bindSpecTerm, errorSpecTerm, @@ -1036,6 +1036,12 @@ defineSpecOpenTerm ev base_recs_in lrt body_in = mkPolySpecLambda ev local_stk imps (specRecFunsTuple all_recs), mkPolySpecLambda ev local_stk imps body] +-- | Build the type @LRTClos stk lrt@ from @lrt@ in the current stack +lrtClosTypeSpecTerm :: OpenTerm -> SpecTerm +lrtClosTypeSpecTerm lrt = + applyGlobalTermLike "Prelude.LRTClos" [extStackSpecTerm, + openTermSpecTerm lrt] + -- | Internal-only helper function mkClosSpecInfoTerm :: Natural -> SpecInfoTerm mkClosSpecInfoTerm n = From ac197c5f979885606fcabbeef0d28de88445d2b1 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 17 Aug 2023 20:50:43 -0700 Subject: [PATCH 047/305] defined mkLOwnedTrans --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 113 ++++++++++++------ 1 file changed, 75 insertions(+), 38 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 9080278a61..57525d6061 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -625,6 +625,7 @@ exprCtxPureTypeTerms = 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 @@ -1099,12 +1100,19 @@ 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) @@ -1240,7 +1248,7 @@ piLRTExprCtx ctx m = translateClosed ctx >>= \tptrans -> piLRTTransM "e" tptrans (\ectx -> inCtxTransM ectx m) --- | Like 'piExprCtx' but append the newly bound variables to the current +-- | Like 'piLRTExprCtx' but append the newly bound variables to the current -- context, rather than running in the empty context piLRTExprCtxApp :: TransInfo info => CruCtx ctx2 -> TransM info (ctx :++: ctx2) OpenTerm -> @@ -1573,8 +1581,8 @@ 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)) -> + 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 @@ -1735,6 +1743,11 @@ extExprTransCtx :: ExprCtxExt ctx1 ctx2 -> ExprTransCtx ctx1 -> ExprTransCtx ctx2 extExprTransCtx (ExprCtxExt ectx2) ectx1 = RL.append ectx1 ectx2 +unextExprTransCtx :: ExprCtxExt ctx1 ctx2 -> ExprTransCtx ctx2 -> + ExprTransCtx ctx1 +unextExprTransCtx ((ExprCtxExt ectx3) :: ExprCtxExt ctx1 ctx2) ectx2 = + fst $ RL.split (Proxy :: Proxy ctx1) ectx3 ectx2 + -- | Extend the context of a permission translation using an 'ExprCtxExt' extPermTransExt :: ExprCtxExt ctx1 ctx2 -> PermTrans ctx1 a -> PermTrans ctx2 a @@ -1821,10 +1834,27 @@ extLOwnedTransM cext m = type LOwnedTransTerm ctx ps_in ps_out = LOwnedTransM ps_in ps_out ctx () +mkLOwnedTransTermFromTerm :: RelPermsTypeTrans ctx ps_out -> + RAssign (Member ctx) ps_out -> SpecTerm -> + LOwnedTransTerm ctx ps_in ps_out +mkLOwnedTransTermFromTerm ttr_outF vars_out t = + gmodify $ \(ExprCtxExt ectx') loInfo -> + let ttr_out = + extRelPermsTypeTransMulti ectx' ttr_outF $ lownedInfoECtx loInfo in + let ps_out = + if length (typeTransTypes ttr_out) == 0 then + typeTransF ttr_out [] + else + typeTransF (tupleTypeTrans ttr_out) + [applyTermLikeMulti t $ transTerms $ lownedInfoPCtx loInfo] in + LOwnedInfo { lownedInfoECtx = lownedInfoECtx loInfo, + lownedInfoPCtx = ps_out, + lownedInfoPVars = RL.map (weakenMemberR ectx') vars_out } + lownedTransTermTerm :: PureTypeTrans (ExprTransCtx ctx) -> RAssign (Member ctx) ps_in -> - RelPermTransCtx ctx ps_in -> - RelPermTransCtx ctx ps_out -> + RelPermsTypeTrans ctx ps_in -> + RelPermsTypeTrans ctx ps_out -> LOwnedTransTerm ctx ps_in ps_out -> SpecTerm lownedTransTermTerm ectx vars_in ps_inF ps_outF t = lambdaTrans "e" ectx $ \exprs -> @@ -1873,10 +1903,18 @@ data LOwnedTrans ctx ps_extra ps_in ps_out = LOwnedTrans (ExprTransCtx ctx) (PermTransCtx ctx ps_extra) (RAssign (Member ctx) ps_extra) - (RelPermTransCtx ctx ps_in) (RelPermTransCtx ctx ps_out) - (RelPermTransCtx ctx ps_extra) + (RelPermsTypeTrans ctx ps_in) (RelPermsTypeTrans ctx ps_out) + (RelPermsTypeTrans ctx ps_extra) (LOwnedTransTerm ctx (ps_extra :++: ps_in) ps_out) +-- | Build an initial 'LOwnedTrans' with an empty @ps_extra@ +mkLOwnedTrans :: ExprTransCtx ctx -> RelPermsTypeTrans ctx ps_in -> + RelPermsTypeTrans ctx ps_out -> RAssign (Member ctx) ps_out -> + SpecTerm -> LOwnedTrans ctx RNil ps_in ps_out +mkLOwnedTrans ectx ps_inF ps_outF vars_out t = + LOwnedTrans ectx MNil MNil ps_inF ps_outF (const $ pure MNil) + (mkLOwnedTransTermFromTerm ps_outF vars_out t) + -- | Extend the context of an 'LOwnedTrans' extLOwnedTransMulti :: ExprTransCtx ctx2 -> LOwnedTrans ctx1 ps_extra ps_in ps_out -> @@ -1886,9 +1924,9 @@ extLOwnedTransMulti ectx2 (LOwnedTrans ectx1 ps_extra vars_extra ptrans_in LOwnedTrans (RL.append ectx1 ectx2) (extPermTransCtxMulti ectx2 ps_extra) (RL.map (weakenMemberR ectx2) vars_extra) - (extRelPermTransCtxMulti ectx2 ptrans_in) - (extRelPermTransCtxMulti ectx2 ptrans_out) - (extRelPermTransCtxMulti ectx2 ptrans_extra) + (extRelPermsTypeTransMulti ectx2 ptrans_in) + (extRelPermsTypeTransMulti ectx2 ptrans_out) + (extRelPermsTypeTransMulti ectx2 ptrans_extra) (extLOwnedTransTerm ectx2 t) -- | Convert an 'LOwnedTrans' to a closure that gets added to the list of @@ -1900,13 +1938,13 @@ lownedTransTerm (mbExprPermsMembers -> ectx ps_extra vars_extra tps_in tps_out tps_extra lott) = let etps = exprCtxType ectx - tps_extra_in = appRelPermTransCtx tps_extra tps_in + tps_extra_in = appRelPermsTypeTrans tps_extra tps_in vars_extra_in = RL.append vars_extra vars_in lrt = piExprPermLRT etps tps_extra_in tps_out fun_tm = lownedTransTermTerm etps vars_extra_in tps_extra_in tps_out lott in - applyClosSpecTerm lrt (mkFreshClosSpecTerm lrt (const fun_tm)) - (transTerms ectx ++ transTerms ps_extra) + applyClosSpecTerm lrt (mkFreshClosSpecTerm lrt (const fun_tm)) + (transTerms ectx ++ transTerms ps_extra) lownedTransTerm _ _ = failTermLike "FIXME HERE NOWNOW: write this error message" @@ -1969,13 +2007,14 @@ unPTransLLVMArray str _ = error (str ++ ": not an LLVM array permission") type PermTransCtx ctx ps = RAssign (PermTrans ctx) ps -- | A 'TypeTrans' for a 'PermTransCtx' that is relative to an expr context -type RelPermTransCtx ctx ps = +type RelPermsTypeTrans ctx ps = ExprTransCtx ctx -> ImpTypeTrans (PermTransCtx ctx ps) --- | Append two 'RelPermTransCtx's -appRelPermTransCtx :: RelPermTransCtx ctx ps1 -> RelPermTransCtx ctx ps2 -> - RelPermTransCtx ctx (ps1 :++: ps2) -appRelPermTransCtx tps1 tps2 = \ectx -> RL.append <$> tps1 ectx <*> tps2 ectx +-- | Append two 'RelPermsTypeTrans's +appRelPermsTypeTrans :: RelPermsTypeTrans ctx ps1 -> + RelPermsTypeTrans ctx ps2 -> + RelPermsTypeTrans ctx (ps1 :++: ps2) +appRelPermsTypeTrans tps1 tps2 = \ectx -> RL.append <$> tps1 ectx <*> tps2 ectx -- | Build a permission translation context with just @true@ permissions truePermTransCtx :: CruCtx ps -> PermTransCtx ctx ps @@ -2199,10 +2238,10 @@ extPermTransCtxMulti :: ExprTransCtx ctx2 -> PermTransCtx ctx1 ps -> PermTransCtx (ctx1 :++: ctx2) ps extPermTransCtxMulti ectx2 = RL.map (extPermTransMulti ectx2) --- | Extend the context of a 'RelPermTransCtx' -extRelPermTransCtxMulti :: ExprTransCtx ctx2 -> RelPermTransCtx ctx1 ps -> - RelPermTransCtx (ctx1 :++: ctx2) ps -extRelPermTransCtxMulti ectx2 (rel_tp :: RelPermTransCtx ctx1 ps) = +-- | Extend the context of a 'RelPermsTypeTrans' +extRelPermsTypeTransMulti :: ExprTransCtx ctx2 -> RelPermsTypeTrans ctx1 ps -> + RelPermsTypeTrans (ctx1 :++: ctx2) ps +extRelPermsTypeTransMulti ectx2 (rel_tp :: RelPermsTypeTrans ctx1 ps) = \ectx12 -> let (ectx1, _) = RL.split (Proxy :: Proxy ctx1) ectx2 ectx12 in fmap (extPermTransCtxMulti ectx2) $ rel_tp ectx1 @@ -2606,14 +2645,18 @@ instance TransInfo info => [nuMP| Perm_LLVMFrame fp |] -> return $ mkImpTypeTrans0 $ APTrans_LLVMFrame fp [nuMP| Perm_LOwned ls tps_in tps_out ps_in ps_out |] -> - error "FIXME HERE NOWNOW" - {- - 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 $ mkImpTypeTrans1 tp (APTrans_LOwned ls - (mbLift tps_in) (mbLift tps_out) ps_in ps_out) -} + case mbExprPermsMembers ps_out of + Just vars_out -> + do ectx <- infoCtx <$> ask + let etps = exprCtxType ectx + ttr_inF <- tpTransM $ ctxFunTypeTransM $ translate ps_in + ttr_outF <- tpTransM $ ctxFunTypeTransM $ translate ps_out + let tp = typeDescFromLRT $ piExprPermLRT etps ttr_inF ttr_outF + return $ mkImpTypeTrans1 tp $ \t -> + (APTrans_LOwned ls (mbLift tps_in) (mbLift tps_out) ps_in ps_out $ + mkLOwnedTrans ectx ttr_inF ttr_outF vars_out t) + Nothing -> + error "FIXME HERE NOWNOW: handle this error!" [nuMP| Perm_LOwnedSimple tps lops |] -> return $ mkImpTypeTrans0 $ APTrans_LOwnedSimple (mbLift tps) lops [nuMP| Perm_LCurrent l |] -> @@ -2798,7 +2841,7 @@ arrowLRTPermCtx ps body = -- a 'PermTransCtx' relative to the expressions using @LRT_FunClos@. The return -- type is described by a 'PermTransCtx' as well. piExprPermLRT :: PureTypeTrans (ExprTransCtx ctx) -> - RelPermTransCtx ctx ps_in -> RelPermTransCtx ctx ps_out -> + RelPermsTypeTrans ctx ps_in -> RelPermsTypeTrans ctx ps_out -> OpenTerm piExprPermLRT ectx pctx_in_F pctx_out_F = error "FIXME HERE NOWNOW" @@ -2915,6 +2958,7 @@ data ImpTransInfo ext blocks tops rets ps ctx = instance TransInfo (ImpTransInfo ext blocks tops rets ps) where infoCtx = itiExprCtx infoEnv = itiPermEnv + infoChecksFlag = itiChecksFlag extTransInfo etrans (ImpTransInfo {..}) = ImpTransInfo { itiExprCtx = itiExprCtx :>: etrans @@ -2954,13 +2998,6 @@ emptyBlocksImpTransM = withInfoM (\(ImpTransInfo {..}) -> ImpTransInfo { itiBlockMapTrans = emptyTypedBlockMapTrans, .. }) --- | 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 = - withInfoM (\(ImpTransInfo {..}) -> - TypeTransInfo itiExprCtx itiPermEnv itiChecksFlag) - -- | 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 -> From 9468e64cc1801aa1e8b25e38b830a430df0f3c47 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 18 Aug 2023 15:55:24 -0700 Subject: [PATCH 048/305] wrote piExprPermLRT --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 50 +++++++++++++------ 1 file changed, 36 insertions(+), 14 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 57525d6061..d212e9b2f6 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -776,6 +776,18 @@ lambdaTrans x (TypeTransImpure tps tr_f) body_f = typeDescType tp)) [0..] tps) (body_f . tr_f) +-- | Build a nested lambda-abstraction +-- +-- > \x1:tp1 -> ... -> \xn:tpn -> body +-- +-- over the types in a pure 'TypeTrans', using the 'String' as a variable name +-- prefix for the @xi@ variables, returning a pure term +lambdaPureTrans :: String -> PureTypeTrans tr -> (tr -> OpenTerm) -> OpenTerm +lambdaPureTrans x (TypeTransPure tps tr_f) body_f = + lambdaOpenTermMulti + (zipWith (\i tp -> (pack (x ++ show (i :: Integer)), tp)) [0..] tps) + (body_f . tr_f) + -- | Build a nested lambda-abstraction -- -- > \x1:tp1 -> ... -> \xn:tpn -> body @@ -806,14 +818,19 @@ lambdaTupleTransM x ttrans body_f = -- of a pi abstraction over the types @tpi@ in a pure 'TypeTrans', passing the -- abstracted variables to the supplied @body@ function, which should itself -- return a @LetRecType@ +piLRTTrans :: String -> PureTypeTrans tr -> (tr -> OpenTerm) -> OpenTerm +piLRTTrans x tps body_f = + foldr (\(i,tp) rest_f vars -> + let var = pack (x ++ show (i :: Integer)) + t = lambdaOpenTerm var tp (\var -> rest_f (vars ++ [var])) in + ctorOpenTerm "Prelude.LRT_FunDep" [tp, t]) + (body_f . typeTransF tps) (zip [0..] $ typeTransTypes tps) [] + +-- | Perform 'piLRTTrans' inside a translation monad piLRTTransM :: String -> TypeTrans 'True 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_FunDep" [tp, t]) <$> - lambdaOpenTermTransM (x ++ show (i :: Integer)) tp - (\var -> rest_f (vars ++ [var]))) - (body_f . typeTransF tps) (zip [0..] $ typeTransTypes tps) [] + ask >>= \info -> return (piLRTTrans x tps (flip runTransM info . body_f)) -- | Construct a @LetRecType@ inductive description -- @@ -821,14 +838,18 @@ piLRTTransM x tps body_f = -- -- of monadic arrow types over the @LetRecType@ type descriptions @lrti@ in a -- 'TypeTrans' -arrowLRTTransM :: String -> TypeTrans 'False tr -> - TransM info ctx OpenTerm -> TransM info ctx OpenTerm -arrowLRTTransM x tps body_top = - foldr (\(i,d) body_m -> - body_m >>= \body -> - return $ ctorOpenTerm "Prelude.LRT_FunClos" [typeDescLRT d, body]) +arrowLRTTrans :: String -> ImpTypeTrans tr -> OpenTerm -> OpenTerm +arrowLRTTrans x tps body_top = + foldr (\(i,d) body -> + ctorOpenTerm "Prelude.LRT_FunClos" [typeDescLRT d, body]) body_top (zip [0..] $ typeTransDescs tps) +-- | Perform 'arrowLRTTrans' inside a translation monad +arrowLRTTransM :: String -> ImpTypeTrans tr -> + TransM info ctx OpenTerm -> TransM info ctx OpenTerm +arrowLRTTransM x tps body = + ask >>= \info -> return (arrowLRTTrans x tps (runTransM body info)) + -- FIXME: should only need to build pi-abstractions as LetRecTypes... right? {- -- | Build a pi-abstraction over the types in a 'TypeTrans' inside a @@ -2843,9 +2864,10 @@ arrowLRTPermCtx ps body = piExprPermLRT :: PureTypeTrans (ExprTransCtx ctx) -> RelPermsTypeTrans ctx ps_in -> RelPermsTypeTrans ctx ps_out -> OpenTerm -piExprPermLRT ectx pctx_in_F pctx_out_F = - error "FIXME HERE NOWNOW" - +piExprPermLRT etps ptps_in_F ptps_out_F = + piLRTTrans "e" etps $ \ectx -> + arrowLRTTrans "p" (ptps_in_F ectx) $ + typeDescLRT $ typeTransTupleDesc (ptps_out_F ectx) -- | Build the return type for a function; FIXME: documentation translateRetType :: TransInfo info => CruCtx rets -> From 869bca3301f3d0e25925d9feffd8b1979364a86c Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Sat, 19 Aug 2023 08:24:47 -0700 Subject: [PATCH 049/305] implemented the translation for SplitLifetime --- .../src/Verifier/SAW/Heapster/Implication.hs | 14 +- .../Verifier/SAW/Heapster/SAWTranslation.hs | 125 +++++++++++++----- 2 files changed, 98 insertions(+), 41 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs b/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs index 56b7f48fd3..462e95060f 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs @@ -971,7 +971,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 @@ -2483,14 +2483,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) = diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index d212e9b2f6..8bd73acd31 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -1894,14 +1894,19 @@ extLOwnedTransTerm ectx2 = extLOwnedTransM (ExprCtxExt ectx2) idLOwnedTransTerm :: LOwnedTransTerm ctx ps ps idLOwnedTransTerm = return () -weakenLOwnedTransTerm :: LOwnedTransTerm ctx ps_in ps_out -> +weakenLOwnedTransTerm :: ImpTypeTrans (PermTrans ctx tp) -> + LOwnedTransTerm ctx ps_in ps_out -> LOwnedTransTerm ctx (ps_in :> tp) (ps_out :> tp) -weakenLOwnedTransTerm t = +weakenLOwnedTransTerm ttr_out 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)) + gmodify (\cext' info' -> + loInfoAppend info' $ extLOwnedInfoExt cext' $ + info_tp { lownedInfoPCtx = + (MNil :>:) $ extPermTransExt cext $ typeTransF ttr_out $ + transTerms $ lownedInfoPCtx info_tp }) bindLOwnedTransTerm :: Proxy ps_extra1 -> RAssign any ps_extra2 -> RAssign any ps_in -> @@ -1921,12 +1926,14 @@ bindLOwnedTransTerm prx_extra1 prx_extra2 prx_in t1 t2 = -- | The translation of an @lowned@ permission data LOwnedTrans ctx ps_extra ps_in ps_out = - LOwnedTrans - (ExprTransCtx ctx) - (PermTransCtx ctx ps_extra) (RAssign (Member ctx) ps_extra) - (RelPermsTypeTrans ctx ps_in) (RelPermsTypeTrans ctx ps_out) - (RelPermsTypeTrans ctx ps_extra) - (LOwnedTransTerm ctx (ps_extra :++: ps_in) ps_out) + LOwnedTrans { + lotrECtx :: ExprTransCtx ctx, + lotrPsExtra :: PermTransCtx ctx ps_extra, + lotrVarsExtra :: RAssign (Member ctx) ps_extra, + lotrRelTransIn :: RelPermsTypeTrans ctx ps_in, + lotrRelTransOut :: RelPermsTypeTrans ctx ps_out, + lotrRelTransExtra :: RelPermsTypeTrans ctx ps_extra, + lotrTerm :: LOwnedTransTerm ctx (ps_extra :++: ps_in) ps_out } -- | Build an initial 'LOwnedTrans' with an empty @ps_extra@ mkLOwnedTrans :: ExprTransCtx ctx -> RelPermsTypeTrans ctx ps_in -> @@ -1950,6 +1957,16 @@ extLOwnedTransMulti ectx2 (LOwnedTrans ectx1 ps_extra vars_extra ptrans_in (extRelPermsTypeTransMulti ectx2 ptrans_extra) (extLOwnedTransTerm ectx2 t) +weakenLOwnedTrans :: + Rel1PermTypeTrans ctx tp -> + Rel1PermTypeTrans 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 { lotrRelTransIn = app1RelPermsTypeTrans lotrRelTransIn tp_in, + lotrRelTransOut = app1RelPermsTypeTrans lotrRelTransOut tp_out, + lotrTerm = weakenLOwnedTransTerm (tp_out lotrECtx) lotrTerm, .. } + -- | Convert an 'LOwnedTrans' to a closure that gets added to the list of -- closures for the current spec definition lownedTransTerm :: Mb ctx (ExprPerms ps_in) -> @@ -1970,11 +1987,20 @@ lownedTransTerm _ _ = failTermLike "FIXME HERE NOWNOW: write this error message" - -- | 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] + -- | Build a type translation for a disjunctive, existential, or named -- permission that uses the 'PTrans_Term' constructor mkPermTypeTrans1 :: Mb ctx (ValuePerm a) -> TypeDesc -> @@ -2027,6 +2053,10 @@ unPTransLLVMArray str _ = error (str ++ ": not an LLVM array permission") -- | A context mapping bound names to their perm translations type PermTransCtx ctx ps = RAssign (PermTrans ctx) ps +-- | A 'TypeTrans' for a 'PermTrans' that is relative to an expr context +type Rel1PermTypeTrans ctx a = + ExprTransCtx ctx -> ImpTypeTrans (PermTrans ctx a) + -- | A 'TypeTrans' for a 'PermTransCtx' that is relative to an expr context type RelPermsTypeTrans ctx ps = ExprTransCtx ctx -> ImpTypeTrans (PermTransCtx ctx ps) @@ -2037,6 +2067,12 @@ appRelPermsTypeTrans :: RelPermsTypeTrans ctx ps1 -> RelPermsTypeTrans ctx (ps1 :++: ps2) appRelPermsTypeTrans tps1 tps2 = \ectx -> RL.append <$> tps1 ectx <*> tps2 ectx +app1RelPermsTypeTrans :: RelPermsTypeTrans ctx ps -> + Rel1PermTypeTrans ctx tp -> + RelPermsTypeTrans ctx (ps :> tp) +app1RelPermsTypeTrans tps1 tps2 = \ectx -> (:>:) <$> tps1 ectx <*> tps2 ectx + + -- | Build a permission translation context with just @true@ permissions truePermTransCtx :: CruCtx ps -> PermTransCtx ctx ps truePermTransCtx CruCtxNil = MNil @@ -3052,6 +3088,22 @@ 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 that +-- could fail, in which case build an error term with the given string +withPermStackOrErrM :: (RAssign (Member ctx) ps_in -> RAssign (Member ctx) ps_out) -> + (PermTransCtx ctx ps_in -> + Either String (PermTransCtx ctx ps_out)) -> + ImpTransM ext blocks tops rets ps_out ctx SpecTerm -> + ImpTransM ext blocks tops rets ps_in ctx SpecTerm +withPermStackOrErrM f_vars f_p m = + ask >>= \info -> + case f_p (itiPermStack info) of + Left err -> mkErrorComp err + Right ps' -> + withInfoM (\info -> + info { itiPermStack = ps', + itiPermStackVars = f_vars (itiPermStackVars info) }) m + -- | Get the current permission stack as a 'DistPerms' in context getPermStackDistPerms :: ImpTransM ext blocks tops rets ps ctx (Mb ctx (DistPerms ps)) @@ -4053,35 +4105,43 @@ 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 |] -> - error "FIXME HERE NOWNOW" {- - 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 l2 _ _ _ _ _ |] -> + -- FIXME HERE: get rid of the mbMaps! + do let l2_e = fmap PExpr_Var 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 $ ctxFunTypeTransM $ translate f_l_args + f_l2_min_trans <- tpTransM $ ctxFunTypeTransM $ translate f_l2_min + withPermStackOrErrM (\(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])) - m -} + (\case + (pctx :>: ptrans_x :>: _ :>: + PTrans_LOwned mb_ls tps_in tps_out mb_ps_in mb_ps_out t) + -> + return $ + (pctx :>: typeTransF f_l2_args_trans (transTerms ptrans_x) :>: + 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)) + _ -> Left "FIXME HERE NOWNOW: write this error") + m [nuMP| SImpl_SubsumeLifetime _ _ _ _ _ _ _ |] -> + error "FIXME HERE NOWNOW" {- do pctx_out_trans <- translateSimplImplOut mb_simpl withPermStackM id (\(pctx :>: ptrans_l) -> RL.append pctx $ typeTransF pctx_out_trans (transTerms ptrans_l)) - m + m -} [nuMP| SImpl_ContainedLifetimeCurrent _ _ _ _ _ _ _ |] -> + error "FIXME HERE NOWNOW" {- do pctx_out_trans <- translateSimplImplOut mb_simpl withPermStackM (\(ns :>: l1) -> ns :>: l1 :>: l1) @@ -4090,9 +4150,10 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of -- 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 + m -} [nuMP| SImpl_RemoveContainedLifetime _ _ _ _ _ _ _ |] -> + error "FIXME HERE NOWNOW" {- do pctx_out_trans <- translateSimplImplOut mb_simpl withPermStackM (\(ns :>: l1 :>: _) -> ns :>: l1) @@ -4101,7 +4162,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of -- 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 + m -} [nuMP| SImpl_WeakenLifetime _ _ _ _ _ |] -> do pctx_out_trans <- translateSimplImplOut mb_simpl From 6c5d12f0d1f78ad0c736ba7e654f82ad7f67f075 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Sat, 19 Aug 2023 08:37:02 -0700 Subject: [PATCH 050/305] implemented the translation for SImpl_SubsumeLifetime --- .../src/Verifier/SAW/Heapster/SAWTranslation.hs | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 8bd73acd31..3b003cc6c0 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -4132,13 +4132,12 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of _ -> Left "FIXME HERE NOWNOW: write this error") m - [nuMP| SImpl_SubsumeLifetime _ _ _ _ _ _ _ |] -> - error "FIXME HERE NOWNOW" {- - 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 (withPermStackOrErrM id) m $ \case + (ps :>: PTrans_LOwned mb_ls tps_in tps_out mb_ps_in mb_ps_out t) -> + return $ (ps :>:) $ + PTrans_LOwned (mbMap2 (:) mb_l2 mb_ls) tps_in tps_out mb_ps_in mb_ps_out t + _ -> Left "FIXME HERE NOWNOW: write this error" [nuMP| SImpl_ContainedLifetimeCurrent _ _ _ _ _ _ _ |] -> error "FIXME HERE NOWNOW" {- From a8be0fa4d81f9074a38ca419b789a1aaee3f4d13 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Sat, 19 Aug 2023 11:01:24 -0700 Subject: [PATCH 051/305] implemented the translation for SImpl_ContainedLifetimeCurrent and SImpl_RemoveContainedLifetime --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 37 +++++++++---------- 1 file changed, 17 insertions(+), 20 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 3b003cc6c0..b2f1921c1a 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -4134,34 +4134,31 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of [nuMP| SImpl_SubsumeLifetime _ _ _ _ _ _ mb_l2 |] -> flip (withPermStackOrErrM id) m $ \case - (ps :>: PTrans_LOwned mb_ls tps_in tps_out mb_ps_in mb_ps_out t) -> - return $ (ps :>:) $ + (pctx :>: PTrans_LOwned mb_ls tps_in tps_out mb_ps_in mb_ps_out t) -> + return $ (pctx :>:) $ PTrans_LOwned (mbMap2 (:) mb_l2 mb_ls) tps_in tps_out mb_ps_in mb_ps_out t _ -> Left "FIXME HERE NOWNOW: write this error" [nuMP| SImpl_ContainedLifetimeCurrent _ _ _ _ _ _ _ |] -> - error "FIXME HERE NOWNOW" {- - 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)) - m -} + pctx :>: typeTransF ttr_lcur [] :>: ptrans_l) + m - [nuMP| SImpl_RemoveContainedLifetime _ _ _ _ _ _ _ |] -> - error "FIXME HERE NOWNOW" {- - 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 |] -> + withPermStackOrErrM + (\(ns :>: l :>: l2) -> 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 + return $ + (pctx :>: PTrans_LOwned mb_ls' tps_in tps_out mb_ps_in mb_ps_out t) + _ -> Left "FIXME HERE NOWNOW: write this error") + m [nuMP| SImpl_WeakenLifetime _ _ _ _ _ |] -> do pctx_out_trans <- translateSimplImplOut mb_simpl From 3259626ca8cb2726aee72cf4821e5f1612b977a2 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Sun, 20 Aug 2023 12:43:15 -0700 Subject: [PATCH 052/305] implemented SImpl_ElimLOwnedSimple --- .../src/Verifier/SAW/Heapster/Permissions.hs | 20 +++-- .../Verifier/SAW/Heapster/SAWTranslation.hs | 75 ++++++++++++++----- 2 files changed, 70 insertions(+), 25 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs index 97bd8f77fe..1bdd239268 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs @@ -2787,6 +2787,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 = [] @@ -2825,14 +2831,18 @@ 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 mb_ps = - mbMaybe (mbMapCl $(mkClosed [| exprPermsVars |]) mb_ps) >>= \mb_ns -> - traverseRAssign (\(Compose mb_n) -> case mbNameBoundP mb_n of - Left memb -> Just memb - _ -> Nothing) (mbRAssign mb_ns) +mbExprPermsMembers = mbExprPermsToDistPerms >=> mbDistPermsMembers -- | Convert the expressions in an 'ExprPerms' to variables, if possible, and -- collect them into a list diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index b2f1921c1a..37b1a451f1 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -1855,11 +1855,16 @@ extLOwnedTransM cext m = type LOwnedTransTerm ctx ps_in ps_out = LOwnedTransM ps_in ps_out ctx () -mkLOwnedTransTermFromTerm :: RelPermsTypeTrans ctx ps_out -> +mkLOwnedTransTermFromTerm :: ExprTransCtx ctx -> RelPermsTypeTrans ctx ps_in -> + RelPermsTypeTrans ctx ps_out -> RAssign (Member ctx) ps_out -> SpecTerm -> LOwnedTransTerm ctx ps_in ps_out -mkLOwnedTransTermFromTerm ttr_outF vars_out t = +mkLOwnedTransTermFromTerm ectx ttr_inF ttr_outF vars_out t = + LOwnedTransM $ \cext loInfo k -> error "FIXME HERE NOWNOW" {- + gmodify $ \(ExprCtxExt ectx') loInfo -> + let etps = exprCtxType ectx + lrt = piExprPermLRT etps tps_extra_in tps_out let ttr_out = extRelPermsTypeTransMulti ectx' ttr_outF $ lownedInfoECtx loInfo in let ps_out = @@ -1870,7 +1875,7 @@ mkLOwnedTransTermFromTerm ttr_outF vars_out t = [applyTermLikeMulti t $ transTerms $ lownedInfoPCtx loInfo] in LOwnedInfo { lownedInfoECtx = lownedInfoECtx loInfo, lownedInfoPCtx = ps_out, - lownedInfoPVars = RL.map (weakenMemberR ectx') vars_out } + lownedInfoPVars = RL.map (weakenMemberR ectx') vars_out } -} lownedTransTermTerm :: PureTypeTrans (ExprTransCtx ctx) -> RAssign (Member ctx) ps_in -> @@ -1891,8 +1896,22 @@ extLOwnedTransTerm :: ExprTransCtx ctx2 -> LOwnedTransTerm (ctx1 :++: ctx2) ps_in ps_out extLOwnedTransTerm ectx2 = extLOwnedTransM (ExprCtxExt ectx2) -idLOwnedTransTerm :: LOwnedTransTerm ctx ps ps -idLOwnedTransTerm = return () +-- | 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 :: RelPermsTypeTrans ctx ps_out -> + RAssign (Member ctx) ps_out -> + LOwnedTransTerm ctx ps_in ps_out +idLOwnedTransTerm ttr_outF vars_out = + gmodify $ \(ExprCtxExt ectx') loInfo -> + let ectx = lownedInfoECtx loInfo + ttr_out = + extRelPermsTypeTransMulti ectx' ttr_outF $ lownedInfoECtx loInfo + vars_out' = RL.map (weakenMemberR ectx') vars_out in + loInfo { lownedInfoPVars = vars_out', + lownedInfoPCtx = + typeTransF ttr_out (transTerms (lownedInfoPCtx loInfo)) } weakenLOwnedTransTerm :: ImpTypeTrans (PermTrans ctx tp) -> LOwnedTransTerm ctx ps_in ps_out -> @@ -1941,7 +1960,17 @@ mkLOwnedTrans :: ExprTransCtx ctx -> RelPermsTypeTrans ctx ps_in -> SpecTerm -> LOwnedTrans ctx RNil ps_in ps_out mkLOwnedTrans ectx ps_inF ps_outF vars_out t = LOwnedTrans ectx MNil MNil ps_inF ps_outF (const $ pure MNil) - (mkLOwnedTransTermFromTerm ps_outF vars_out t) + (mkLOwnedTransTermFromTerm ectx (preNilRelPermsTypeTrans ps_inF) + ps_outF vars_out t) + +-- | Build an initial 'LOwnedTrans' with an empty @ps_extra@ and an identity +-- function on SAW core terms +mkLOwnedTransId :: ExprTransCtx ctx -> RelPermsTypeTrans ctx ps -> + RelPermsTypeTrans ctx ps -> RAssign (Member ctx) ps -> + LOwnedTrans ctx RNil ps ps +mkLOwnedTransId ectx ps_inF ps_outF vars_out = + LOwnedTrans ectx MNil MNil ps_inF ps_outF (const $ pure MNil) + (idLOwnedTransTerm ps_outF vars_out) -- | Extend the context of an 'LOwnedTrans' extLOwnedTransMulti :: ExprTransCtx ctx2 -> @@ -2072,6 +2101,10 @@ app1RelPermsTypeTrans :: RelPermsTypeTrans ctx ps -> RelPermsTypeTrans ctx (ps :> tp) app1RelPermsTypeTrans tps1 tps2 = \ectx -> (:>:) <$> tps1 ectx <*> tps2 ectx +-- | Prepend an 'RNil' list of permissions to a 'RelPermsTypeTrans' +preNilRelPermsTypeTrans :: RelPermsTypeTrans ctx ps -> + RelPermsTypeTrans ctx (RNil :++: ps) +preNilRelPermsTypeTrans = appRelPermsTypeTrans (const $ pure MNil) -- | Build a permission translation context with just @true@ permissions truePermTransCtx :: CruCtx ps -> PermTransCtx ctx ps @@ -4267,8 +4300,6 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of m) -} [nuMP| SImpl_IntroLOwnedSimple _ _ _ |] -> - error "FIXME HERE NOWNOW" - {- do let prx_ps_l = mbRAssignProxies $ mbSimplImplIn mb_simpl ttrans <- translateSimplImplOut mb_simpl withPermStackM id @@ -4276,19 +4307,23 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of let (pctx0, pctx_ps :>: _) = RL.split ps0 prx_ps_l pctx in RL.append pctx0 $ typeTransF ttrans (transTerms pctx_ps)) m - -} - [nuMP| SImpl_ElimLOwnedSimple _ _ mb_lops |] -> - error "FIXME HERE NOWNOW" - {- - do ttrans <- translateSimplImplOutHead mb_simpl - lops_tp <- typeTransTupleType <$> translate mb_lops - f_tm <- - lambdaSpecTermTransM "ps" lops_tp $ \x -> - return $ returnSpecTerm 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 ectx <- infoCtx <$> ask + let etps = exprCtxType ectx + ttr_inF <- tpTransM $ ctxFunTypeTransM $ translate mb_ps' + ttr_outF <- tpTransM $ ctxFunTypeTransM $ translate mb_ps + withPermStackM id + (\(pctx :>: _) -> + pctx :>: + PTrans_LOwned (fmap (const []) mb_l) + (mbLift mb_tps) (mbLift mb_tps) mb_ps' mb_ps + (mkLOwnedTransId ectx ttr_inF ttr_outF vars)) + m + _ -> + error "FIXME HERE NOWNOW: handle this error!" [nuMP| SImpl_LCurrentRefl l |] -> do ttrans <- translateSimplImplOutHead mb_simpl From 51d354cbfcfe5b919ced541f0c81196c8aaa8b33 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Sun, 20 Aug 2023 13:58:15 -0700 Subject: [PATCH 053/305] correctly (hopefully) re-implemented mkLOwnedTransTermFromTerm to use the input SpecTerm as a closure --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 52 +++++++++---------- 1 file changed, 26 insertions(+), 26 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 37b1a451f1..f738c41d79 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -1691,13 +1691,15 @@ data LLVMArrayBorrowTrans ctx w = data LOwnedInfo ps ctx = LOwnedInfo { lownedInfoECtx :: ExprTransCtx ctx, lownedInfoPCtx :: PermTransCtx ctx ps, - lownedInfoPVars :: RAssign (Member ctx) ps } + lownedInfoPVars :: RAssign (Member ctx) ps, + lownedInfoRetType :: TypeDesc } -- | 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 } + lownedInfoPVars = itiPermStackVars, + lownedInfoRetType = itiReturnType } -- | Convert an 'LOwnedInfo' to an 'ImpTransInfo' using an existing 'ImpTransInfo' lownedInfoToImp :: LOwnedInfo ps ctx -> @@ -1706,7 +1708,8 @@ lownedInfoToImp :: LOwnedInfo ps ctx -> lownedInfoToImp (LOwnedInfo {..}) (ImpTransInfo {..}) = ImpTransInfo { itiExprCtx = lownedInfoECtx, itiPermStack = lownedInfoPCtx, itiPermStackVars = lownedInfoPVars, - itiPermCtx = RL.map (const PTrans_True) lownedInfoECtx, .. } + itiPermCtx = RL.map (const PTrans_True) lownedInfoECtx, + itiReturnType = lownedInfoRetType, .. } loInfoSetPerms :: PermTransCtx ctx ps' -> RAssign (Member ctx) ps' -> LOwnedInfo ps ctx -> LOwnedInfo ps' ctx @@ -1716,11 +1719,11 @@ loInfoSetPerms ps' vars' (LOwnedInfo {..}) = loInfoSplit :: Proxy ps1 -> RAssign any ps2 -> LOwnedInfo (ps1 :++: ps2) ctx -> (LOwnedInfo ps1 ctx, LOwnedInfo ps2 ctx) -loInfoSplit prx1 prx2 loInfo = - let ctx = lownedInfoECtx loInfo - (ps1, ps2) = RL.split prx1 prx2 (lownedInfoPCtx loInfo) - (vars1, vars2) = RL.split prx1 prx2 (lownedInfoPVars loInfo) in - (LOwnedInfo ctx ps1 vars1, LOwnedInfo ctx ps2 vars2) +loInfoSplit prx1 prx2 (LOwnedInfo {..}) = + let (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 @@ -1785,7 +1788,8 @@ extLOwnedInfoExt :: ExprCtxExt ctx1 ctx2 -> LOwnedInfo ps ctx1 -> extLOwnedInfoExt cext@(ExprCtxExt ectx3) (LOwnedInfo {..}) = LOwnedInfo { lownedInfoECtx = extExprTransCtx cext lownedInfoECtx, lownedInfoPCtx = extPermTransCtxExt cext lownedInfoPCtx, - lownedInfoPVars = RL.map (weakenMemberR ectx3) lownedInfoPVars } + lownedInfoPVars = RL.map (weakenMemberR ectx3) lownedInfoPVars, + .. } -- | FIXME HERE NOWNOW: docs; explain that it's as if the input LOwnedInfo is @@ -1860,22 +1864,17 @@ mkLOwnedTransTermFromTerm :: ExprTransCtx ctx -> RelPermsTypeTrans ctx ps_in -> RAssign (Member ctx) ps_out -> SpecTerm -> LOwnedTransTerm ctx ps_in ps_out mkLOwnedTransTermFromTerm ectx ttr_inF ttr_outF vars_out t = - LOwnedTransM $ \cext loInfo k -> error "FIXME HERE NOWNOW" {- - - gmodify $ \(ExprCtxExt ectx') loInfo -> - let etps = exprCtxType ectx - lrt = piExprPermLRT etps tps_extra_in tps_out - let ttr_out = - extRelPermsTypeTransMulti ectx' ttr_outF $ lownedInfoECtx loInfo in - let ps_out = - if length (typeTransTypes ttr_out) == 0 then - typeTransF ttr_out [] - else - typeTransF (tupleTypeTrans ttr_out) - [applyTermLikeMulti t $ transTerms $ lownedInfoPCtx loInfo] in - LOwnedInfo { lownedInfoECtx = lownedInfoECtx loInfo, - lownedInfoPCtx = ps_out, - lownedInfoPVars = RL.map (weakenMemberR ectx') vars_out } -} + LOwnedTransM $ \(ExprCtxExt ectx') loInfo k -> + let lrt = piExprPermLRT (exprCtxType ectx) ttr_inF ttr_outF + t_app = applyClosSpecTerm lrt t (transTerms $ lownedInfoPCtx loInfo) + t_ret_trans = tupleTypeTrans $ ttr_outF ectx + t_ret_tp = typeTransTupleType $ ttr_outF ectx in + bindSpecTerm t_ret_tp (typeDescType $ lownedInfoRetType loInfo) t_app $ + lambdaTermLike "lowned_ret" t_ret_tp $ \lowned_ret -> + let pctx_out' = + extPermTransCtxMulti ectx' $ typeTransF t_ret_trans [lowned_ret] + vars_out' = RL.map (weakenMemberR ectx') vars_out in + k reflExprCtxExt (loInfoSetPerms pctx_out' vars_out' loInfo) () lownedTransTermTerm :: PureTypeTrans (ExprTransCtx ctx) -> RAssign (Member ctx) ps_in -> @@ -1885,9 +1884,10 @@ lownedTransTermTerm :: PureTypeTrans (ExprTransCtx ctx) -> lownedTransTermTerm ectx vars_in ps_inF ps_outF t = lambdaTrans "e" ectx $ \exprs -> lambdaTrans "p" (ps_inF exprs) $ \ps_in -> + let ret_tp = typeTransTupleDesc $ ps_outF exprs in let loInfo = LOwnedInfo { lownedInfoECtx = exprs, lownedInfoPCtx = ps_in, - lownedInfoPVars = vars_in } in + lownedInfoPVars = vars_in, lownedInfoRetType = ret_tp } in runLOwnedTransM t reflExprCtxExt loInfo $ \_ loInfo_out () -> transTupleTerm (lownedInfoPCtx loInfo_out) From 26b5b8c31cddf985e645f3f14b2602f07447c7a1 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Sun, 20 Aug 2023 16:21:07 -0700 Subject: [PATCH 054/305] removed withPermStackOrErrM, since all of the error cases it was handling should instead be panics --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 58 ++++++++----------- 1 file changed, 23 insertions(+), 35 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index f738c41d79..aebd8b9ff9 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -3121,22 +3121,6 @@ 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 that --- could fail, in which case build an error term with the given string -withPermStackOrErrM :: (RAssign (Member ctx) ps_in -> RAssign (Member ctx) ps_out) -> - (PermTransCtx ctx ps_in -> - Either String (PermTransCtx ctx ps_out)) -> - ImpTransM ext blocks tops rets ps_out ctx SpecTerm -> - ImpTransM ext blocks tops rets ps_in ctx SpecTerm -withPermStackOrErrM f_vars f_p m = - ask >>= \info -> - case f_p (itiPermStack info) of - Left err -> mkErrorComp err - Right ps' -> - withInfoM (\info -> - info { itiPermStack = ps', - itiPermStackVars = f_vars (itiPermStackVars info) }) m - -- | Get the current permission stack as a 'DistPerms' in context getPermStackDistPerms :: ImpTransM ext blocks tops rets ps ctx (Mb ctx (DistPerms ps)) @@ -4147,30 +4131,33 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of f_l2_args_trans <- translateSimplImplOutTailHead mb_simpl f_l_args_trans <- tpTransM $ ctxFunTypeTransM $ translate f_l_args f_l2_min_trans <- tpTransM $ ctxFunTypeTransM $ translate f_l2_min - withPermStackOrErrM + withPermStackM (\(ns :>: x :>: _ :>: l2) -> ns :>: x :>: l2) (\case (pctx :>: ptrans_x :>: _ :>: PTrans_LOwned mb_ls tps_in tps_out mb_ps_in mb_ps_out t) -> - return $ - (pctx :>: typeTransF f_l2_args_trans (transTerms ptrans_x) :>: - 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)) - _ -> Left "FIXME HERE NOWNOW: write this error") + pctx :>: typeTransF f_l2_args_trans (transTerms ptrans_x) :>: + PTrans_LOwned mb_ls (CruCtxCons tps_in x_tp) + (CruCtxCons tps_out x_tp) + (mbMap3 (\ps x p -> ps :>: ExprAndPerm (PExpr_Var x) p) + mb_ps_in mb_x f_l2_min) + (mbMap3 (\ps x p -> ps :>: ExprAndPerm (PExpr_Var x) p) + mb_ps_out mb_x f_l_args) + (weakenLOwnedTrans f_l2_min_trans f_l_args_trans t) + _ -> + panic "translateSimplImpl" + ["In SImpl_SplitLifetime rule: expected an lowned permission"]) m [nuMP| SImpl_SubsumeLifetime _ _ _ _ _ _ mb_l2 |] -> - flip (withPermStackOrErrM id) m $ \case + flip (withPermStackM id) m $ \case (pctx :>: PTrans_LOwned mb_ls tps_in tps_out mb_ps_in mb_ps_out t) -> - return $ (pctx :>:) $ + pctx :>: PTrans_LOwned (mbMap2 (:) mb_l2 mb_ls) tps_in tps_out mb_ps_in mb_ps_out t - _ -> Left "FIXME HERE NOWNOW: write this error" + _ -> + panic "translateSimplImpl" + ["In SImpl_SubsumeLifetime rule: expected an lowned permission"] [nuMP| SImpl_ContainedLifetimeCurrent _ _ _ _ _ _ _ |] -> do ttr_lcur <- translateSimplImplOutTailHead mb_simpl @@ -4181,16 +4168,17 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of m [nuMP| SImpl_RemoveContainedLifetime _ _ _ _ _ _ mb_l2 |] -> - withPermStackOrErrM + withPermStackM (\(ns :>: l :>: l2) -> 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 - return $ - (pctx :>: PTrans_LOwned mb_ls' tps_in tps_out mb_ps_in mb_ps_out t) - _ -> Left "FIXME HERE NOWNOW: write this error") + 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 _ _ _ _ _ |] -> @@ -4323,7 +4311,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of (mkLOwnedTransId ectx ttr_inF ttr_outF vars)) m _ -> - error "FIXME HERE NOWNOW: handle this error!" + mkErrorComp "FIXME HERE NOWNOW: write this error!" [nuMP| SImpl_LCurrentRefl l |] -> do ttrans <- translateSimplImplOutHead mb_simpl From ba82e97e82b938bacb59b04ed4ab75c1d5cec7ec Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Sun, 20 Aug 2023 17:16:20 -0700 Subject: [PATCH 055/305] Implemented the translation for the MapLifetime rule --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 142 ++++++++++-------- 1 file changed, 80 insertions(+), 62 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index aebd8b9ff9..709384874a 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -1716,11 +1716,12 @@ loInfoSetPerms :: PermTransCtx ctx ps' -> RAssign (Member ctx) ps' -> loInfoSetPerms ps' vars' (LOwnedInfo {..}) = LOwnedInfo { lownedInfoPCtx = ps', lownedInfoPVars = vars', ..} -loInfoSplit :: Proxy ps1 -> RAssign any ps2 -> +loInfoSplit :: prx ps1 -> RAssign any ps2 -> LOwnedInfo (ps1 :++: ps2) ctx -> (LOwnedInfo ps1 ctx, LOwnedInfo ps2 ctx) -loInfoSplit prx1 prx2 (LOwnedInfo {..}) = - let (ps1, ps2) = RL.split prx1 prx2 lownedInfoPCtx +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, .. }) @@ -1927,12 +1928,13 @@ weakenLOwnedTransTerm ttr_out t = (MNil :>:) $ extPermTransExt cext $ typeTransF ttr_out $ transTerms $ lownedInfoPCtx info_tp }) -bindLOwnedTransTerm :: - Proxy ps_extra1 -> RAssign any ps_extra2 -> RAssign any ps_in -> +-- | 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 -bindLOwnedTransTerm prx_extra1 prx_extra2 prx_in t1 t2 = +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) = @@ -2015,6 +2017,33 @@ lownedTransTerm (mbExprPermsMembers -> lownedTransTerm _ _ = failTermLike "FIXME HERE NOWNOW: write this error message" +-- | Apply the 'SImpl_MapLifetime' rule to an 'LOwnedTrans' +mapLtLOwnedTrans :: + PermTransCtx ctx ps1 -> RAssign (Member ctx) ps1 -> + RelPermsTypeTrans ctx ps1 -> + PermTransCtx ctx ps2 -> RAssign (Member ctx) ps2 -> + RelPermsTypeTrans ctx ps2 -> + RAssign any ps_in' -> RelPermsTypeTrans ctx ps_in' -> + RelPermsTypeTrans 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 ttr1F pctx2 vars2 ttr2F + prx_in' ttr_inF' ttr_outF' t1 t2 + (LOwnedTrans {..}) = + LOwnedTrans + { lotrECtx = lotrECtx + , lotrPsExtra = RL.append (RL.append pctx1 lotrPsExtra) pctx2 + , lotrVarsExtra = RL.append (RL.append vars1 lotrVarsExtra) vars2 + , lotrRelTransIn = ttr_inF' , lotrRelTransOut = ttr_outF' + , lotrRelTransExtra = + appRelPermsTypeTrans (appRelPermsTypeTrans ttr1F lotrRelTransExtra) ttr2F + , lotrTerm = + mapLtLOwnedTransTerm (RL.append pctx1 lotrPsExtra) pctx2 prx_in' + (mapLtLOwnedTransTerm pctx1 lotrPsExtra prx_in' t1 lotrTerm) + t2 + } -- | The translation of the vacuously true permission pattern PTrans_True :: PermTrans ctx a @@ -4191,64 +4220,53 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of RL.append pctx (typeTransF pctx_out_trans $ transTerms ptrans_x)) m - [nuMP| SImpl_MapLifetime l _ _ _ ps_in ps_out _ _ + [nuMP| SImpl_MapLifetime _ _ tps_in tps_out _ _ tps_in' tps_out' ps_in' ps_out' ps1 ps2 impl_in impl_out |] -> - error "FIXME HERE NOWNOW" - -- 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 - - -- 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 - pctx <- itiPermStack <$> ask - (pctx_ps, pctx12 :>: ptrans_l) <- pure $ RL.split ps0 prxs_in pctx - let (pctx1, pctx2) = RL.split prxs1 prxs2 pctx12 + case (mbDistPermsMembers ps1, mbDistPermsMembers ps2) of + (Just vars1, Just vars2) -> + do ttr_inF' <- tpTransM $ ctxFunTypeTransM $ translate ps_in' + ttr_outF' <- tpTransM $ ctxFunTypeTransM $ translate ps_out' + ttr1F <- tpTransM $ ctxFunTypeTransM $ translate ps1 + ttr2F <- tpTransM $ ctxFunTypeTransM $ translate ps2 + t1 <- + translateLOwnedPermImpl "Error mapping lowned input perms:" impl_in + t2 <- + translateLOwnedPermImpl "Error mapping lowned output perms:" impl_out + + -- Next, split out the various input permissions from the rest of the pctx + let prxs1 = mbRAssignProxies ps1 + let prxs2 = mbRAssignProxies ps2 + let prxs_in = RL.append prxs1 prxs2 :>: Proxy + let prxs_in' = cruCtxProxies $ mbLift tps_in' + pctx <- itiPermStack <$> ask + let (pctx0, pctx12 :>: ptrans_l) = RL.split ps0 prxs_in pctx + let (pctx1, pctx2) = RL.split prxs1 prxs2 pctx12 + + -- 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 - -- 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" - [typeTransType1Imp ps_in_trans, typeTransType1Imp ps_out_trans, - typeTransType1Imp ps_out'_trans, transTerm1 ptrans_l, impl_out_tm] - l_res_tm <- - applyNamedSpecOpEmptyM "Prelude.composeS" - [typeTransType1Imp ps_in'_trans, typeTransType1Imp ps_in_trans, - typeTransType1Imp ps_out'_trans, impl_in_tm, l_res_tm_h] - - -- Finally, update the permissions - withPermStackM - (\_ -> vars_out) - (\_ -> RL.append pctx_ps $ typeTransF pctx_out_trans [l_res_tm]) - m - -} + withPermStackM + (\(_ :>: l) -> vars_ps :>: l) + (\case + (_ :>: + PTrans_LOwned mb_ls + (testEquality (mbLift tps_in) -> Just Refl) + (testEquality (mbLift tps_out) -> Just Refl) _ _ 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) + _ -> + panic "translateSimplImpl" + ["In SImpl_MapLifetime rule: expected an lowned permission"]) + m + _ -> + panic "translateSimplImpl" + ["In SImpl_MapLifetime rule: malformed ps1 or ps2"] [nuMP| SImpl_EndLifetime _ _ _ ps_in ps_out |] -> -- First, translate the output permissions and the input and output types of From 754cc3d5cfacacc981d819144ac2ccef21f12a67 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 21 Aug 2023 13:01:20 -0700 Subject: [PATCH 056/305] implemented the translation for the SImpl_EndLifetime; fixed up that of the SImpl_MapLifetime rule --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 161 ++++++++++-------- 1 file changed, 86 insertions(+), 75 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 709384874a..c436bce55f 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -1687,7 +1687,7 @@ data LLVMArrayBorrowTrans ctx w = llvmArrayBorrowTransProps :: [BVPropTrans ctx w] } -} --- | FIXME HERE NOWNOW: document all of this! +-- | FIXME HERE NOW: document all of this! data LOwnedInfo ps ctx = LOwnedInfo { lownedInfoECtx :: ExprTransCtx ctx, lownedInfoPCtx :: PermTransCtx ctx ps, @@ -1793,7 +1793,7 @@ extLOwnedInfoExt cext@(ExprCtxExt ectx3) (LOwnedInfo {..}) = .. } --- | FIXME HERE NOWNOW: docs; explain that it's as if the input LOwnedInfo is +-- | FIXME HERE NOW: docs; explain that it's as if the input LOwnedInfo is -- relative to ctx_in and the output is relative to ctx_out except this ensures -- that those are extensions of what they are supposed to be newtype LOwnedTransM ps_in ps_out ctx a = @@ -2015,7 +2015,7 @@ lownedTransTerm (mbExprPermsMembers -> applyClosSpecTerm lrt (mkFreshClosSpecTerm lrt (const fun_tm)) (transTerms ectx ++ transTerms ps_extra) lownedTransTerm _ _ = - failTermLike "FIXME HERE NOWNOW: write this error message" + failTermLike "FIXME HERE NOW: write this error message" -- | Apply the 'SImpl_MapLifetime' rule to an 'LOwnedTrans' mapLtLOwnedTrans :: @@ -2106,6 +2106,21 @@ unPTransLLVMArray :: String -> PermTrans ctx (LLVMPointerType w) -> unPTransLLVMArray _ (PTrans_Conj [APTrans_LLVMArray aptrans]) = aptrans unPTransLLVMArray str _ = error (str ++ ": not an LLVM array permission") +data SomeLOwnedTrans ctx ps_in ps_out = + forall ps_extra. SomeLOwnedTrans (LOwnedTrans ctx ps_extra ps_in ps_out) + +-- | Extract the 'LOwnedTrans' of a conjunction of a single @lowned@ permission +-- with the specified input and output types +unPTransLOwned :: String -> Mb ctx (CruCtx ps_in) -> Mb ctx (CruCtx ps_out) -> + PermTrans ctx LifetimeType -> + SomeLOwnedTrans ctx ps_in ps_out +unPTransLOwned _ tps_in tps_out + (PTrans_LOwned _ (testEquality (mbLift tps_in) -> Just Refl) + (testEquality (mbLift tps_out) -> Just Refl) _ _ lotr) + = SomeLOwnedTrans lotr +unPTransLOwned fname _ _ _ = + panic fname ["Expected lowned permission"] + -- | Add a borrow translation to the translation of an array permission -- | A context mapping bound names to their perm translations @@ -3384,7 +3399,7 @@ instance Semigroup HasFailures where instance Monoid HasFailures where mempty = NoFailures --- | FIXME HERE NOWNOW: docs! +-- | FIXME HERE NOW: docs! data CtxExt ctx1 ctx2 where CtxExt :: RAssign Proxy ctx3 -> CtxExt ctx1 (ctx1 :++: ctx3) @@ -4220,90 +4235,85 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of RL.append pctx (typeTransF pctx_out_trans $ transTerms ptrans_x)) m - [nuMP| SImpl_MapLifetime _ _ tps_in tps_out _ _ tps_in' tps_out' + [nuMP| SImpl_MapLifetime _ mb_ls tps_in tps_out _ _ tps_in' tps_out' ps_in' ps_out' ps1 ps2 impl_in impl_out |] -> - case (mbDistPermsMembers ps1, mbDistPermsMembers ps2) of - (Just vars1, Just vars2) -> - do ttr_inF' <- tpTransM $ ctxFunTypeTransM $ translate ps_in' - ttr_outF' <- tpTransM $ ctxFunTypeTransM $ translate ps_out' - ttr1F <- tpTransM $ ctxFunTypeTransM $ translate ps1 - ttr2F <- tpTransM $ ctxFunTypeTransM $ translate ps2 - t1 <- - translateLOwnedPermImpl "Error mapping lowned input perms:" impl_in - t2 <- - translateLOwnedPermImpl "Error mapping lowned output perms:" impl_out - - -- Next, split out the various input permissions from the rest of the pctx - let prxs1 = mbRAssignProxies ps1 - let prxs2 = mbRAssignProxies ps2 - let prxs_in = RL.append prxs1 prxs2 :>: Proxy - let prxs_in' = cruCtxProxies $ mbLift tps_in' - pctx <- itiPermStack <$> ask - let (pctx0, pctx12 :>: ptrans_l) = RL.split ps0 prxs_in pctx - let (pctx1, pctx2) = RL.split prxs1 prxs2 pctx12 - - -- 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 - - withPermStackM - (\(_ :>: l) -> vars_ps :>: l) - (\case - (_ :>: - PTrans_LOwned mb_ls - (testEquality (mbLift tps_in) -> Just Refl) - (testEquality (mbLift tps_out) -> Just Refl) _ _ 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) - _ -> - panic "translateSimplImpl" - ["In SImpl_MapLifetime rule: expected an lowned permission"]) - m - _ -> - panic "translateSimplImpl" - ["In SImpl_MapLifetime rule: malformed ps1 or ps2"] + -- First, translate the various permissions and implications + do ttr_inF' <- tpTransM $ ctxFunTypeTransM $ translate ps_in' + ttr_outF' <- tpTransM $ ctxFunTypeTransM $ translate ps_out' + ttr1F <- tpTransM $ ctxFunTypeTransM $ translate ps1 + ttr2F <- tpTransM $ ctxFunTypeTransM $ translate ps2 + t1 <- + translateLOwnedPermImpl "Error mapping lowned input perms:" impl_in + t2 <- + translateLOwnedPermImpl "Error mapping lowned output perms:" impl_out + + -- Next, split out the various input permissions from the rest of the pctx + let prxs1 = mbRAssignProxies ps1 + let prxs2 = mbRAssignProxies ps2 + let prxs_in = RL.append prxs1 prxs2 :>: Proxy + let prxs_in' = cruCtxProxies $ mbLift tps_in' + pctx <- itiPermStack <$> ask + let (pctx0, pctx12 :>: ptrans_l) = RL.split ps0 prxs_in pctx + let (pctx1, pctx2) = RL.split prxs1 prxs2 pctx12 + let some_lotr = + unPTransLOwned "translateSimplImpl" tps_in tps_out ptrans_l + + -- Also split out the input variables and replace them with the ps_out vars + pctx_vars <- itiPermStackVars <$> ask + let (vars_ps, vars12 :>: _) = RL.split ps0 prxs_in pctx_vars + let (vars1, vars2) = RL.split prxs1 prxs2 vars12 - [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 - error "FIXME HERE NOWNOW" {- - do ps_out_trans <- tupleTypeTrans <$> translate ps_out + -- Finally, modify the PTrans_LOwned on top of the stack using + -- mapLtLOwnedTrans + withPermStackM + (\(_ :>: l) -> vars_ps :>: l) + (\_ -> + case some_lotr of + SomeLOwnedTrans lotr -> + pctx0 :>: + PTrans_LOwned mb_ls (mbLift tps_in') (mbLift tps_out') ps_in' ps_out' + (mapLtLOwnedTrans pctx1 vars1 ttr1F pctx2 vars2 ttr2F + prxs_in' ttr_inF' ttr_outF' t1 t2 lotr)) + m + + [nuMP| SImpl_EndLifetime _ tps_in tps_out ps_in ps_out |] -> + -- First, translate the in and out permissions of the lowned permission + do ps_in_trans <- translate ps_in + ps_out_trans <- tupleTypeTrans <$> translate ps_out let prxs_in = mbRAssignProxies ps_in :>: Proxy + let lrt_out = typeDescLRT $ typeTransTupleDesc ps_out_trans + let lrt = arrowLRTTrans "p" ps_in_trans lrt_out -- 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" - [typeTransType1Imp ps_out_trans, - applyTermLike (transTerm1 ptrans_l) (transTupleTerm pctx_in)] - bindSpecMTransM - lifted_m - ps_out_trans - "endl_ps" - (\pctx_out -> - withPermStackM - (\(_ :>: l) -> vars_out :>: l) - (\_ -> RL.append pctx_ps pctx_out :>: - PTrans_Conj [APTrans_LFinished]) - m) -} + case some_lotr of + SomeLOwnedTrans lotr -> + bindSpecMTransM + (callClosSpecTerm + lrt_out (applyClosSpecTerm + lrt (lownedTransTerm ps_in lotr) (transTerms pctx_in))) + ps_out_trans + "endl_ps" + (\pctx_out -> + withPermStackM + (\(_ :>: l) -> RL.append ps_vars vars_out :>: l) + (\_ -> RL.append pctx_ps pctx_out :>: + PTrans_Conj [APTrans_LFinished]) + m) [nuMP| SImpl_IntroLOwnedSimple _ _ _ |] -> do let prx_ps_l = mbRAssignProxies $ mbSimplImplIn mb_simpl @@ -4329,7 +4339,8 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of (mkLOwnedTransId ectx ttr_inF ttr_outF vars)) m _ -> - mkErrorComp "FIXME HERE NOWNOW: write this error!" + panic "translateSimplImpl" + ["In SImpl_ElimLOwnedSimple rule: malformed permissions argument"] [nuMP| SImpl_LCurrentRefl l |] -> do ttrans <- translateSimplImplOutHead mb_simpl From 10d3fbf048e1e857226c83e799d2bd6f2eb3fedb Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 21 Aug 2023 18:19:28 -0700 Subject: [PATCH 057/305] implemented the translation for the Impl1_BeginLifetime rule; fixed a few compiler warnings --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 70 +++++++++---------- 1 file changed, 34 insertions(+), 36 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index c436bce55f..9347dbf137 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -44,9 +44,10 @@ import qualified Data.BitVector.Sized as BV import Data.Functor.Compose import Control.Applicative import Control.Lens hiding ((:>), Index, ix, op, getting) -import Control.Monad.Reader -import Control.Monad.Writer -import Control.Monad.State +import qualified Control.Monad as Monad +import Control.Monad.Reader hiding (ap) +import Control.Monad.Writer hiding (ap) +import Control.Monad.State hiding (ap) import Control.Monad.Trans.Maybe import qualified Control.Monad.Fail as Fail @@ -821,8 +822,8 @@ lambdaTupleTransM x ttrans body_f = piLRTTrans :: String -> PureTypeTrans tr -> (tr -> OpenTerm) -> OpenTerm piLRTTrans x tps body_f = foldr (\(i,tp) rest_f vars -> - let var = pack (x ++ show (i :: Integer)) - t = lambdaOpenTerm var tp (\var -> rest_f (vars ++ [var])) in + let nm = pack (x ++ show (i :: Integer)) + t = lambdaOpenTerm nm tp (\var -> rest_f (vars ++ [var])) in ctorOpenTerm "Prelude.LRT_FunDep" [tp, t]) (body_f . typeTransF tps) (zip [0..] $ typeTransTypes tps) [] @@ -838,17 +839,17 @@ piLRTTransM x tps body_f = -- -- of monadic arrow types over the @LetRecType@ type descriptions @lrti@ in a -- 'TypeTrans' -arrowLRTTrans :: String -> ImpTypeTrans tr -> OpenTerm -> OpenTerm -arrowLRTTrans x tps body_top = - foldr (\(i,d) body -> +arrowLRTTrans :: ImpTypeTrans tr -> OpenTerm -> OpenTerm +arrowLRTTrans tps body_top = + foldr (\d body -> ctorOpenTerm "Prelude.LRT_FunClos" [typeDescLRT d, body]) - body_top (zip [0..] $ typeTransDescs tps) + body_top (typeTransDescs tps) -- | Perform 'arrowLRTTrans' inside a translation monad -arrowLRTTransM :: String -> ImpTypeTrans tr -> +arrowLRTTransM :: ImpTypeTrans tr -> TransM info ctx OpenTerm -> TransM info ctx OpenTerm -arrowLRTTransM x tps body = - ask >>= \info -> return (arrowLRTTrans x tps (runTransM body info)) +arrowLRTTransM tps body = + ask >>= \info -> return (arrowLRTTrans tps (runTransM body info)) -- FIXME: should only need to build pi-abstractions as LetRecTypes... right? {- @@ -1035,9 +1036,6 @@ sigmaElimPermTransM :: (TransInfo info) => sigmaElimPermTransM x tp_l mb_p tp_ret_m f sigma = case mbMatch mb_p of [nuMP| ValPerm_Eq e |] -> do let tp_l_trm = openTermLike $ typeTransTupleType tp_l - tp_r_trm <- lambdaTupleTransM x tp_l (\tr -> - typeTransTupleType <$> - inExtTransM tr (translate mb_p)) tp_ret <- typeTransTupleType <$> tp_ret_m sawLetTransM x tp_l_trm tp_ret sigma $ \sigma_pure -> f (typeTransF (tupleTypeTrans tp_l) [sigma_pure]) (PTrans_Eq e) @@ -1729,11 +1727,12 @@ loInfoSplit (_ :: prx ps1) prx2 (LOwnedInfo {..}) = loInfoAppend :: LOwnedInfo ps1 ctx -> LOwnedInfo ps2 ctx -> LOwnedInfo (ps1 :++: ps2) ctx loInfoAppend info1 info2 = - LOwnedInfo { lownedInfoPCtx = + LOwnedInfo { lownedInfoECtx = lownedInfoECtx info1 + , lownedInfoPCtx = RL.append (lownedInfoPCtx info1) (lownedInfoPCtx info2) , lownedInfoPVars = RL.append (lownedInfoPVars info1) (lownedInfoPVars info2) - , .. } + , lownedInfoRetType = lownedInfoRetType info1 } -- | An extension of type context @ctx1@ to @ctx2@, which is -- just an 'ExprTransCtx' for the suffix @ctx3@ such that @ctx1:++:ctx3 = ctx2@ @@ -1820,7 +1819,7 @@ instance Functor (LOwnedTransM ps_in ps_out ctx) where instance Applicative (LOwnedTransM ps ps ctx) where pure x = LOwnedTransM $ \_ s k -> k reflExprCtxExt s x - (<*>) = ap + (<*>) = Monad.ap instance Monad (LOwnedTransM ps ps ctx) where (>>=) = (>>>=) @@ -1906,8 +1905,7 @@ idLOwnedTransTerm :: RelPermsTypeTrans ctx ps_out -> LOwnedTransTerm ctx ps_in ps_out idLOwnedTransTerm ttr_outF vars_out = gmodify $ \(ExprCtxExt ectx') loInfo -> - let ectx = lownedInfoECtx loInfo - ttr_out = + let ttr_out = extRelPermsTypeTransMulti ectx' ttr_outF $ lownedInfoECtx loInfo vars_out' = RL.map (weakenMemberR ectx') vars_out in loInfo { lownedInfoPVars = vars_out', @@ -2967,7 +2965,7 @@ arrowLRTPermCtx :: TransInfo info => Mb ctx (ValuePerms ps) -> TransM info ctx OpenTerm -> TransM info ctx OpenTerm arrowLRTPermCtx ps body = - translate ps >>= \tptrans -> arrowLRTTransM "p" tptrans body + translate ps >>= \tptrans -> arrowLRTTransM tptrans body -- | Build a @LetRecType@ describing a monadic SAW core function that takes in: -- values for all the expression types in an 'ExprTransCtx' as dependent @@ -2979,7 +2977,7 @@ piExprPermLRT :: PureTypeTrans (ExprTransCtx ctx) -> OpenTerm piExprPermLRT etps ptps_in_F ptps_out_F = piLRTTrans "e" etps $ \ectx -> - arrowLRTTrans "p" (ptps_in_F ectx) $ + arrowLRTTrans (ptps_in_F ectx) $ typeDescLRT $ typeTransTupleDesc (ptps_out_F ectx) -- | Build the return type for a function; FIXME: documentation @@ -4166,9 +4164,9 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of pctx :>: PTrans_Conj [APTrans_IsLLVMPtr] :>: ptrans) m - [nuMP| SImpl_SplitLifetime mb_x f args l l2 _ _ _ _ _ |] -> + [nuMP| SImpl_SplitLifetime mb_x f args l mb_l2 _ _ _ _ _ |] -> -- FIXME HERE: get rid of the mbMaps! - do let l2_e = fmap PExpr_Var l2 + 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 @@ -4213,7 +4211,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of [nuMP| SImpl_RemoveContainedLifetime _ _ _ _ _ _ mb_l2 |] -> withPermStackM - (\(ns :>: l :>: l2) -> ns :>: l) + (\(ns :>: l :>: _) -> ns :>: l) (\case (pctx :>: PTrans_LOwned mb_ls tps_in tps_out mb_ps_in mb_ps_out t :>: _) -> @@ -4282,7 +4280,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of ps_out_trans <- tupleTypeTrans <$> translate ps_out let prxs_in = mbRAssignProxies ps_in :>: Proxy let lrt_out = typeDescLRT $ typeTransTupleDesc ps_out_trans - let lrt = arrowLRTTrans "p" ps_in_trans lrt_out + let lrt = arrowLRTTrans ps_in_trans lrt_out -- Next, split out the ps_in permissions from the rest of the pctx pctx <- itiPermStack <$> ask @@ -4328,7 +4326,6 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of case (mbExprPermsMembers mb_ps, mbMaybe (mbMap2 lownedPermsSimpleIn mb_l mb_ps)) of (Just vars, Just mb_ps') -> do ectx <- infoCtx <$> ask - let etps = exprCtxType ectx ttr_inF <- tpTransM $ ctxFunTypeTransM $ translate mb_ps' ttr_outF <- tpTransM $ ctxFunTypeTransM $ translate mb_ps withPermStackM id @@ -4949,17 +4946,18 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o m ([nuMP| Impl1_BeginLifetime |], _) -> - error "FIXME HERE NOWNOW" - {- 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 ectx <- itiExprCtx <$> ask + let prxs = RL.map (const Proxy) ectx + let mb_ps = (nuMulti prxs (const MNil)) + let ttr = const $ pure MNil + withPermStackM (:>: Member_Base) + (:>: + PTrans_LOwned + (nuMulti prxs (const [])) CruCtxNil CruCtxNil mb_ps mb_ps + (mkLOwnedTransId ectx ttr ttr MNil)) + m -- If e1 and e2 are already equal, short-circuit the proof construction and then -- elimination From 116680c53e5b985579b97549506702fc52245bc6 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Tue, 22 Aug 2023 13:57:28 -0700 Subject: [PATCH 058/305] renamed callDefSpecTerm to importDefSpecTerm, since the operation only does the importing and not actually the calling --- saw-core/src/Verifier/SAW/OpenTerm.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/saw-core/src/Verifier/SAW/OpenTerm.hs b/saw-core/src/Verifier/SAW/OpenTerm.hs index 2939e430a6..fcac6748f1 100644 --- a/saw-core/src/Verifier/SAW/OpenTerm.hs +++ b/saw-core/src/Verifier/SAW/OpenTerm.hs @@ -88,7 +88,7 @@ module Verifier.SAW.OpenTerm ( SpecTerm(), defineSpecOpenTerm, lambdaPureSpecTerm, lambdaPureSpecTermMulti, lrtClosTypeSpecTerm, sawLetPureSpecTerm, lrtToTypeSpecTerm, mkBaseClosSpecTerm, mkFreshClosSpecTerm, callClosSpecTerm, applyClosSpecTerm, - callDefSpecTerm, monadicSpecOp, + importDefSpecTerm, monadicSpecOp, specMTypeSpecTerm, returnSpecTerm, bindSpecTerm, errorSpecTerm, ) where @@ -1082,9 +1082,10 @@ callClosSpecTerm tp clos = applySpecTermMulti (monadicSpecOp "Prelude.CallS") [openTermSpecTerm tp, clos] --- | Call another spec definition inside a spec definition, by importing it -callDefSpecTerm :: OpenTerm -> SpecTerm -callDefSpecTerm def = SpecTerm $ +-- | Import another spec definition inside a spec definition, and return the +-- @SpecFun@ that calls its body +importDefSpecTerm :: OpenTerm -> SpecTerm +importDefSpecTerm def = SpecTerm $ do (imp_ix, st) <- specStInsImport def <$> get put st return $ From 1d1f871e2f173d0619bb6dd656825a2d6a89429a Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Tue, 22 Aug 2023 14:48:24 -0700 Subject: [PATCH 059/305] changed the global translation table to use a new special-purpose type called a GlobalTrans, rather than an Either, to better document its semantics, and to allow for globals to be translated to closures or spec defs as well; changed the translations of function permission proofs to use a new type FunTransTerm, that can either be a closure or a monadic function --- .../src/Verifier/SAW/Heapster/CruUtil.hs | 3 + .../Verifier/SAW/Heapster/LLVMGlobalConst.hs | 12 +- .../src/Verifier/SAW/Heapster/Permissions.hs | 42 ++++--- .../Verifier/SAW/Heapster/SAWTranslation.hs | 109 ++++++++++++------ 4 files changed, 109 insertions(+), 57 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/CruUtil.hs b/heapster-saw/src/Verifier/SAW/Heapster/CruUtil.hs index a5941f520e..6e0477016c 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/CruUtil.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/CruUtil.hs @@ -186,6 +186,9 @@ instance Liftable Ident where instance NuMatching OpenTerm where nuMatchingProof = unsafeMbTypeRepr +instance NuMatching SpecTerm where + nuMatchingProof = unsafeMbTypeRepr + instance NuMatching GlobalSymbol where nuMatchingProof = unsafeMbTypeRepr diff --git a/heapster-saw/src/Verifier/SAW/Heapster/LLVMGlobalConst.hs b/heapster-saw/src/Verifier/SAW/Heapster/LLVMGlobalConst.hs index c5f2807cc6..347db3a4d3 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/LLVMGlobalConst.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/LLVMGlobalConst.hs @@ -95,9 +95,11 @@ 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" + Just (p, GlobalTransTerms [t]) -> return (p,t) + Just (p, GlobalTransTerms ts) -> return (p,tupleOpenTerm ts) + Just (_, _) -> + traceAndZeroM ("Could not translate recursive function symbol: " + ++ show sym) Nothing -> traceAndZeroM ("Could not find symbol: " ++ show sym) return (PExpr_FieldShape (LLVMFieldShape p), t) translateLLVMValue w _ (L.ValArray tp elems) = @@ -266,5 +268,5 @@ permEnvAddGlobalConst sc mod_name dlevel endianness w env global = 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 + (GlobalTransTerms [t_ident])] diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs index 1bdd239268..d2f26b9e6e 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs @@ -79,6 +79,7 @@ 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 @@ -852,6 +853,17 @@ data SomeNamedShape where SomeNamedShape :: (1 <= w, KnownNat w) => NamedShape b args w -> SomeNamedShape +-- | The result of translating a global symbol to a SAW core term +data GlobalTrans + -- | A translation to a list of terms, as defined in @SAWTranslation.hs@ + = GlobalTransTerms [OpenTerm] + -- | A translation to a spec definition, i.e., a term of type @SpecDef@; + -- note that this is only applicable to function permissions + | GlobalTransDef OpenTerm + -- | A translation to a locally-defined closure, i.e., a term of type + -- @LRTClos@; note that this is only applicable to function permissions + | GlobalTransClos SpecTerm + -- | 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 @@ -859,8 +871,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 @@ -959,6 +970,7 @@ $(mkNuMatching [t| PermEnvFunEntry |]) $(mkNuMatching [t| SomeNamedPerm |]) $(mkNuMatching [t| SomeNamedShape |]) $(mkNuMatching [t| PermEnvGlobalEntry |]) +$(mkNuMatching [t| GlobalTrans |]) $(mkNuMatching [t| forall args. BlockHintSort args |]) $(mkNuMatching [t| forall blocks init ret args. BlockHint blocks init ret args |]) @@ -6302,8 +6314,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 @@ -7306,7 +7317,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 @@ -7463,7 +7474,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 @@ -8271,7 +8282,8 @@ permEnvAddGlobalSymFun :: (1 <= w, KnownNat w) => PermEnv -> GlobalSymbol -> 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 (GlobalTransTerms [t]) + : permEnvGlobalSyms env } -- | Add a global symbol with 0 or more function permissions to a 'PermEnv' permEnvAddGlobalSymFunMulti :: (1 <= w, KnownNat w) => PermEnv -> @@ -8280,7 +8292,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 (GlobalTransTerms $ map snd ps_ts) + : permEnvGlobalSyms env } -- | Add some 'PermEnvGlobalEntry's to a 'PermEnv' permEnvAddGlobalSyms :: PermEnv -> [PermEnvGlobalEntry] -> PermEnv @@ -8349,8 +8362,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 @@ -8361,11 +8374,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 @@ -8461,7 +8473,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 @@ -8724,7 +8736,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/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 9347dbf137..a36466ac3e 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -1622,11 +1622,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 closure type APTrans_Fun :: Mb ctx (FunPerm ghosts (CtxToRList cargs) gouts ret) -> - Either Natural SpecTerm -> + FunTransTerm -> AtomicPermTrans ctx (FunctionHandleType cargs ret) -- | Propositional permissions are represented by a SAW term @@ -2043,6 +2041,29 @@ mapLtLOwnedTrans pctx1 vars1 ttr1F pctx2 vars2 ttr2F t2 } + +-- | The translation of a function permission to a term +data FunTransTerm + -- | A monadic function represented as a closure, i.e., a term of type + -- @LRTClos stk lrt@, where @stk@ is the current stack and @lrt@ is the + -- supplied 'OpenTerm' + = FunTransClos OpenTerm SpecTerm + -- | A monadic function represented as a monadic function, i.e., a term of + -- type @SpecFun E stk lrt@, where @E@ is the current event type, @stk@ is + -- the current stack, and @lrt@ is the supplied 'OpenTerm' + | FunTransFun OpenTerm SpecTerm + +-- | Convert a 'FunTransTerm' to a closure, i.e., term of type @LRTClos stk lrt@ +funTransTermToClos :: FunTransTerm -> SpecTerm +funTransTermToClos (FunTransClos _ clos) = clos +funTransTermToClos (FunTransFun lrt f) = mkFreshClosSpecTerm lrt (const f) + +-- | Apply a 'FunTransTerm' to a list of arguments +applyFunTransTerm :: FunTransTerm -> [SpecTerm] -> SpecTerm +applyFunTransTerm (FunTransClos lrt clos) = applyClosSpecTerm lrt clos +applyFunTransTerm (FunTransFun _ f) = applyTermLikeMulti f + + -- | The translation of the vacuously true permission pattern PTrans_True :: PermTrans ctx a pattern PTrans_True = PTrans_Conj [] @@ -2057,6 +2078,12 @@ pattern PTrans_LOwned :: 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) -> + FunTransTerm -> PermTrans ctx a +pattern PTrans_Fun mb_fun_perm tr = PTrans_Conj [APTrans_Fun mb_fun_perm tr] + -- | Build a type translation for a disjunctive, existential, or named -- permission that uses the 'PTrans_Term' constructor mkPermTypeTrans1 :: Mb ctx (ValuePerm a) -> TypeDesc -> @@ -2188,15 +2215,7 @@ instance IsTermTrans (AtomicPermTrans ctx a) where 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 - [failTermLike - ("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 _ t) = [funTransTermToClos t] transTerms (APTrans_BVProp prop) = transTerms prop transTerms APTrans_Any = [] @@ -2799,7 +2818,8 @@ instance TransInfo info => fmap APTrans_Struct <$> translate ps [nuMP| Perm_Fun fun_perm |] -> translate fun_perm >>= \tp_desc -> - return $ mkImpTypeTrans1 tp_desc (APTrans_Fun fun_perm . Right) + return $ mkImpTypeTrans1 tp_desc (APTrans_Fun fun_perm . + FunTransClos (typeDescLRT tp_desc)) [nuMP| Perm_BVProp prop |] -> fmap APTrans_BVProp <$> translate prop [nuMP| Perm_Any |] -> return $ mkImpTypeTrans0 APTrans_Any @@ -3015,7 +3035,7 @@ translateEntryRetType (TypedEntry {..} data TypedEntryTrans ext blocks tops rets args ghosts = TypedEntryTrans { typedEntryTransEntry :: TypedEntry TransPhase ext blocks tops rets args ghosts, - typedEntryTransRecIx :: Maybe (Natural, OpenTerm) } + typedEntryTransClos :: Maybe (OpenTerm, SpecTerm) } -- | A mapping from a block to the SAW functions for each entrypoint data TypedBlockTrans ext blocks tops rets args = @@ -5544,15 +5564,15 @@ translateCallEntry nm entry_trans mb_tops_args mb_ghosts = () <- assertPermStackEqM nm mb_perms -- Now check if entryID has an associated multiFixS-bound function - case typedEntryTransRecIx entry_trans of - Just (ix, lrt) -> + case typedEntryTransClos entry_trans of + Just (lrt, clos_tm) -> -- 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 - return (applyClosSpecTerm lrt (mkBaseClosSpecTerm ix) + return (applyClosSpecTerm lrt clos_tm (exprCtxToTerms e_args ++ permCtxToTerms i_args)) Nothing -> inEmptyEnvImpTransM $ inCtxTransM ectx $ @@ -5619,8 +5639,7 @@ translateStmt loc mb_stmt m = case mbMatch mb_stmt of -- FIXME HERE: document this! [nuMP| TypedCall _freg fun_perm _ gexprs args |] -> - error "FIXME HERE NOWNOW: call the def" - {- + error "FIXME HERE NOWNOW" {- do f_trans <- getTopPermM ectx_outer <- itiExprCtx <$> ask let rets = mbLift $ mbMapCl $(mkClosed [| funPermRets |]) fun_perm @@ -5642,11 +5661,11 @@ translateStmt loc mb_stmt m = case mbMatch mb_stmt of exprCtxToTerms ectx_gexprs ++ exprCtxToTerms ectx_args ++ permCtxToTerms pctx_ghosts_args fret_trm <- case f_trans of - PTrans_Conj [APTrans_Fun _ (Right f)] -> + PTrans_Fun _ (Right f) -> applyNamedSpecOpM "Prelude.liftStackS" [fret_tp, applyTermLikeMulti f all_args] - PTrans_Conj [APTrans_Fun _ (Left ix)] -> - applyCallS ix all_args + PTrans_Fun _ (Left ix) -> + applyCallS ix allo_args _ -> error "translateStmt: TypedCall: unexpected function permission" bindSpecMTransM fret_trm fret_tp "call_ret_val" $ \ret_val -> @@ -5801,21 +5820,37 @@ translateLLVMStmt mb_stmt m = case mbMatch mb_stmt of Nothing -> error ("translateLLVMStmt: TypedLLVMResolveGlobal: " ++ " no translation of symbol " ++ globalSymbolName (mbLift gsym)) - Just (_, Left i) + Just (_, GlobalTransDef spec_def) + | [nuP| ValPerm_LLVMFunPtr fun_tp (ValPerm_Fun fun_perm) |] <- p -> + do lrt <- typeDescLRT <$> translate (extMb fun_perm) + let ptrans = + PTrans_Conj [APTrans_LLVMFunPtr (mbLift fun_tp) $ + PTrans_Fun fun_perm $ FunTransFun lrt $ + importDefSpecTerm spec_def] + withPermStackM (:>: Member_Base) + (:>: extPermTrans ETrans_LLVM ptrans) m + Just (_, GlobalTransDef _) -> + panic "translateLLVMStmt" + ["TypedLLVMResolveGlobal: " + ++ " unexpected recursive function translation for symbol " + ++ globalSymbolName (mbLift gsym)] + Just (_, GlobalTransClos clos) | [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 ETrans_LLVM ptrans) m - Just (_, Left _) -> - error ("translateLLVMStmt: TypedLLVMResolveGlobal: " - ++ " unexpected recursive call translation for symbol " - ++ globalSymbolName (mbLift gsym)) - Just (_, Right ts) -> - translate (extMb p) >>= \ptrans -> - let ts_imp = map openTermLike ts in - withPermStackM (:>: Member_Base) (:>: typeTransF ptrans ts_imp) m + do lrt <- typeDescLRT <$> translate (extMb fun_perm) + let ptrans = + PTrans_Conj [APTrans_LLVMFunPtr (mbLift fun_tp) $ + PTrans_Fun fun_perm $ FunTransClos lrt clos] + withPermStackM (:>: Member_Base) + (:>: extPermTrans ETrans_LLVM ptrans) m + Just (_, GlobalTransClos _) -> + panic "translateLLVMStmt" + ["TypedLLVMResolveGlobal: " + ++ " unexpected recursive function translation for symbol " + ++ globalSymbolName (mbLift gsym)] + Just (_, GlobalTransTerms ts) -> + do ptrans <- translate (extMb p) + let ts_imp = map openTermLike ts + withPermStackM (:>: Member_Base) (:>: typeTransF ptrans ts_imp) m [nuMP| TypedLLVMIte _ mb_r1 _ _ |] -> inExtTransM ETrans_LLVM $ From d8665b8f0eeb2eab7bd2c5358aad2d833f80c4c2 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Tue, 22 Aug 2023 18:27:33 -0700 Subject: [PATCH 060/305] implemented the translation for TypedCall --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 39 ++++++++++++------- 1 file changed, 24 insertions(+), 15 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index a36466ac3e..71d61fe19b 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -360,6 +360,11 @@ mkImpTypeTrans1 d f = TypeTransImpure [d] $ \case [t] -> f t _ -> panic "mkImpTypeTrans1" ["incorrect number of terms"] +-- | Build a type translation whose representation type is just SAW core terms +-- of the supplied type +mkTermImpTypeTrans :: TypeDesc -> ImpTypeTrans SpecTerm +mkTermImpTypeTrans d = mkImpTypeTrans1 d 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 p tr -> PurityTerm p @@ -2935,11 +2940,16 @@ instance HasPureTrans (AtomicPerm a) where [nuMP| Perm_BVProp _ |] -> True [nuMP| Perm_Any |] -> True -instance HasPureTrans (ValuePerms as) where +instance HasPureTrans (ValuePerms ps) where hasPureTrans p = case mbMatch p of [nuMP| MNil |] -> True [nuMP| ps :>: p' |] -> hasPureTrans ps && hasPureTrans p' +instance HasPureTrans (DistPerms ps) where + hasPureTrans p = case mbMatch p of + [nuMP| MNil |] -> True + [nuMP| ps :>: VarAndPerm _ p' |] -> hasPureTrans ps && hasPureTrans p' + instance HasPureTrans (LLVMFieldPerm w sz) where hasPureTrans (mbMatch -> [nuMP| LLVMFieldPerm { llvmFieldContents = p } |]) = hasPureTrans p @@ -3328,7 +3338,7 @@ compReturnTypeM = typeDescType <$> compReturnTypeDescM -- | Like 'compReturnTypeM' but build a 'TypeTrans' compReturnTypeTransM :: ImpTransM ext blocks tops rets ps_out ctx (ImpTypeTrans SpecTerm) -compReturnTypeTransM = flip mkImpTypeTrans1 id <$> compReturnTypeDescM +compReturnTypeTransM = mkTermImpTypeTrans <$> compReturnTypeDescM -- | Build an @errorS@ computation with the given error message mkErrorComp :: String -> ImpTransM ext blocks tops rets ps_out ctx SpecTerm @@ -5639,7 +5649,6 @@ translateStmt loc mb_stmt m = case mbMatch mb_stmt of -- FIXME HERE: document this! [nuMP| TypedCall _freg fun_perm _ gexprs args |] -> - error "FIXME HERE NOWNOW" {- do f_trans <- getTopPermM ectx_outer <- itiExprCtx <$> ask let rets = mbLift $ mbMapCl $(mkClosed [| funPermRets |]) fun_perm @@ -5654,21 +5663,21 @@ 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 (hasPureTrans perms_out) - (\ectx -> inExtMultiTransM ectx (typeTransTupleDesc <$> - translate perms_out)) + fret_tp <- + mkTermImpTypeTrans <$> + sigmaTypeTransM "ret" rets_trans (hasPureTrans perms_out) + (\ectx -> inExtMultiTransM ectx (typeTransTupleDesc <$> + translate perms_out)) let all_args = exprCtxToTerms ectx_gexprs ++ exprCtxToTerms ectx_args ++ permCtxToTerms pctx_ghosts_args - fret_trm <- case f_trans of - PTrans_Fun _ (Right f) -> - applyNamedSpecOpM "Prelude.liftStackS" - [fret_tp, applyTermLikeMulti f all_args] - PTrans_Fun _ (Left ix) -> - applyCallS ix allo_args - _ -> error "translateStmt: TypedCall: unexpected function permission" + let fapp_trm = case f_trans of + PTrans_Fun _ f_trm -> applyFunTransTerm f_trm all_args + _ -> + panic "translateStmt" + ["TypedCall: unexpected function permission"] bindSpecMTransM - fret_trm fret_tp "call_ret_val" $ \ret_val -> + 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 -> @@ -5681,7 +5690,7 @@ translateStmt loc mb_stmt m = case mbMatch mb_stmt of suffixMembers ectx_outer rets_prxs) (const pctx) m) - ret_val -} + ret_val -- FIXME HERE: figure out why these asserts always translate to ite True [nuMP| TypedAssert e _ |] -> From d6e2b6822e17db168aec911c763aaad377b99cb1 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 23 Aug 2023 08:06:15 -0700 Subject: [PATCH 061/305] updated translateBlockMapBodies to compile in the new SAWTranslation.hs --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 157 +++++++----------- 1 file changed, 63 insertions(+), 94 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 71d61fe19b..1e31786852 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -3038,10 +3038,9 @@ translateEntryRetType (TypedEntry {..} -- * The Implication Translation Monad ---------------------------------------------------------------------- --- | A mapping from a block entrypoint to a corresponding SAW variable that is +-- | A mapping from a block entrypoint to a corresponding SAW closure 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 +-- heads of strongly-connect components have translations as closures data TypedEntryTrans ext blocks tops rets args ghosts = TypedEntryTrans { typedEntryTransEntry :: TypedEntry TransPhase ext blocks tops rets args ghosts, @@ -5573,11 +5572,12 @@ translateCallEntry nm entry_trans mb_tops_args mb_ghosts = typedEntryPermsIn entry) mb_s () <- assertPermStackEqM nm mb_perms - -- Now check if entryID has an associated multiFixS-bound function + -- Now check if entryID has an associated recursive closure case typedEntryTransClos entry_trans of Just (lrt, clos_tm) -> - -- If so, build the associated CallS term - -- FIXME: refactor the code that gets the exprs for the stack + -- If so, build the associated CallS term, which applies the closure to + -- the expressions with permissions on the stack followed by the proofs + -- objects for those permissions do expr_ctx <- itiExprCtx <$> ask arg_membs <- itiPermStackVars <$> ask let e_args = RL.map (flip RL.get expr_ctx) arg_membs @@ -5585,6 +5585,9 @@ translateCallEntry nm entry_trans mb_tops_args mb_ghosts = return (applyClosSpecTerm lrt clos_tm (exprCtxToTerms e_args ++ permCtxToTerms i_args)) Nothing -> + -- Otherwise, continue translating with the target entrypoint, with all + -- the current expressions free but with only those permissions on top + -- of the stack inEmptyEnvImpTransM $ inCtxTransM ectx $ do perms_trans <- translate $ typedEntryPermsIn entry withPermStackM @@ -5933,10 +5936,6 @@ instance PermCheckExtC ext exprExt => translateF mb_seq = translate mb_seq -{- -NOWNOW: -- change uses of TypeTrans to include the purity flag - ---------------------------------------------------------------------- -- * Translating CFGs ---------------------------------------------------------------------- @@ -5946,14 +5945,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 -> +-- | Get all entrypoints in a block map that will be translated to closures, +-- which is all entrypoints with in-degree > 1 +typedBlockClosEntries :: TypedBlockMap TransPhase ext blocks tops rets -> [SomeTypedEntry ext blocks tops rets] -typedBlockLetRecEntries = +typedBlockClosEntries = concat . RL.mapToList (map (\(Some entry) -> SomeTypedEntry entry) . filter (anyF typedEntryHasMultiInDegree) @@ -5961,99 +5957,67 @@ typedBlockLetRecEntries = -- | Fold a function over each 'TypedEntry' in a 'TypedBlockMap' that -- corresponds to a letrec-bound variable -foldBlockMapLetRec :: +foldBlockMapClos :: (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 +foldBlockMapClos f r = + foldr (\(SomeTypedEntry entry) -> f entry) r . typedBlockClosEntries -- | Map a function over each 'TypedEntry' in a 'TypedBlockMap' that -- corresponds to a letrec-bound variable -mapBlockMapLetRec :: +mapBlockMapClos :: (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 +mapBlockMapClos f = + map (\(SomeTypedEntry entry) -> f entry) . typedBlockClosEntries -- | 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 $ +-- 'TypedEntry' to a closure +translateEntryLRT :: TypedEntry TransPhase ext blocks tops rets args ghosts -> + TypeTransM ctx OpenTerm +translateEntryLRT entry@(TypedEntry {..}) = + inEmptyCtxTransM $ translateClosed (typedEntryAllArgs entry) >>= \arg_tps -> piLRTTransM "arg" arg_tps $ \ectx -> inCtxTransM ectx $ translate typedEntryPermsIn >>= \perms_in_tps -> - piLRTTransM "p" perms_in_tps $ \_ -> + arrowLRTTransM perms_in_tps $ translateEntryRetType entry >>= \retType -> - return $ ctorOpenTerm "Prelude.LRT_Ret" [retType] + return $ ctorOpenTerm "Prelude.LRT_Ret" [typeDescLRT 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 +-- entrypoints in a 'TypedBlockMap' that will be translated to closures +translateBlockMapLRTs :: TypedBlockMap TransPhase ext blocks tops rets -> + TypeTransM ctx [OpenTerm] +translateBlockMapLRTs blkMap = + sequence $ mapBlockMapClos translateEntryLRT blkMap + +-- | Translate the function permission of a CFG to a @LetRecType@ +translateCFGLRT :: TypedCFG ext blocks ghosts inits gouts ret -> + TypeTransM ctx OpenTerm +translateCFGLRT cfg = + typeDescLRT <$> translateClosed (tpcfgFunPerm cfg) + +-- | Translate a 'TypedEntry' to a 'TypedEntryTrans' by associating a closure +-- term with it if it has one, i.e., if its in-degree is greater than 1. If it +-- does need a closure, the 'Natural' state tracks the index to be used for the +-- next closure, so use the current value and increment it. translateTypedEntry :: Some (TypedEntry TransPhase ext blocks tops rets args) -> - StateT Natural (TypeTransM ctx) (Some (TypedEntryTrans ext blocks tops rets args)) + StateT Natural (TypeTransM ctx) (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)) + lrt <- lift $ translateEntryLRT entry + return (Some (TypedEntryTrans entry $ Just (lrt, mkBaseClosSpecTerm i))) 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) @@ -6061,8 +6025,8 @@ 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 +-- | Translate a 'TypedBlockMap' to a 'TypedBlockMapTrans' by translating every +-- entrypoint using 'translateTypedEntry' translateTypedBlockMap :: TypedBlockMap TransPhase ext blocks tops rets -> StateT Natural (TypeTransM ctx) (TypedBlockMapTrans ext blocks tops rets) @@ -6078,7 +6042,7 @@ translateTypedBlockMap blkMap = translateEntryBody :: PermCheckExtC ext exprExt => TypedBlockMapTrans ext blocks tops rets -> TypedEntry TransPhase ext blocks tops rets args ghosts -> - TypeTransM RNil OpenTerm + TypeTransM RNil SpecTerm translateEntryBody mapTrans entry = lambdaExprCtx (typedEntryAllArgs entry) $ lambdaPermCtx (typedEntryPermsIn entry) $ \pctx -> @@ -6086,15 +6050,20 @@ translateEntryBody mapTrans entry = 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 +-- closures into the @LetRecType@s and bodies of those closures +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 + TypeTransM RNil [(OpenTerm, SpecTerm)] +translateBlockMapBodies mapTrans blkMap = + sequence $ mapBlockMapClos (\entry -> + (,) <$> translateEntryLRT entry <*> + translateEntryBody mapTrans entry) blkMap + +{- +NOWNOW: +- change uses of TypeTrans to include the purity flag -- | FIXME HERE NOW: docs translateCFGInitEntryBody :: From 9fd3ab5799101b20d12f9da7f970917cf6172717 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 23 Aug 2023 12:37:32 -0700 Subject: [PATCH 062/305] implemented applyLRTClosN in SAW core --- saw-core/prelude/Prelude.sawcore | 46 +++++++++++++++++--------------- 1 file changed, 25 insertions(+), 21 deletions(-) diff --git a/saw-core/prelude/Prelude.sawcore b/saw-core/prelude/Prelude.sawcore index f03fdcccdc..d60512c88b 100644 --- a/saw-core/prelude/Prelude.sawcore +++ b/saw-core/prelude/Prelude.sawcore @@ -2528,10 +2528,10 @@ applyLRTClosNRet stk = LetRecType#rec (\ (_:LetRecType) -> sort 0) (\ (R:LetRecType) (_:sort 0) -> Void -> Void) - (\ (A:sort 0) (B:A -> LetRecType) (rec:A -> sort 0) -> - (a:A) -> rec a) - (\ (A:LetRecType) (_:sort 0) (B:LetRecType) (recB:sort 0) -> - LRTArg stk A -> recB) + (\ (A:sort 0) (B:A -> LetRecType) (_:A -> sort 0) -> + (a:A) -> rec (B a)) + (\ (A:LetRecType) (_:sort 0) (B:LetRecType) (_:sort 0) -> + LRTArg stk A -> rec B) (\ (A:sort 0) -> Void -> Void) (\ (F:sort 0 -> sort 0 -> sort 0) (_:ValidLRTFunctor2 F) (_:LetRecType) (_:sort 0) (_:LetRecType) (_:sort 0) -> @@ -2540,7 +2540,6 @@ applyLRTClosNRet stk = lrt); -- Apply an LRTClos to N arguments -{- applyLRTClosN : (stk:FunStack) -> (n:Nat) -> (lrt:LetRecType) -> LRTClos stk lrt -> applyLRTClosNRet stk n lrt; applyLRTClosN stk = @@ -2549,25 +2548,30 @@ applyLRTClosN stk = (\ (lrt:LetRecType) (clos:LRTClos stk lrt) -> clos) (\ (n':Nat) (rec:(lrt:LetRecType) -> LRTClos stk lrt -> applyLRTClosNRet stk n' lrt) - (lrt:LetRecType) -> + (lrt_top:LetRecType) -> LetRecType#rec - (\ (lrt:LetRecType) -> LRTClos stk lrt -> applyLRTClosNRet stk n' lrt) + (\ (lrt:LetRecType) -> LRTClos stk lrt -> + applyLRTClosNRet stk (Succ n') lrt) (\ (R:LetRecType) - (_:LRTClos stk (LRT_SpecM R) -> applyLRTClosNRet stk n' (LRT_SpecM R)) + (_:LRTClos stk R -> applyLRTClosNRet stk (Succ n') R) (_:LRTClos stk (LRT_SpecM R)) (v:Void) -> v) - (\ (A:sort 0) (B:A -> LetRecType) (rec:A -> sort 0) -> - FIXME HERE - - (a:A) -> rec (B a)) - (\ (A:LetRecType) (_:sort 0) (B:LetRecType) (recB:sort 0) -> - LRTArg stk A -> recB) - (\ (A:sort 0) -> Void -> Void) - (\ (F:sort 0 -> sort 0 -> sort 0) (_:ValidLRTFunctor2 F) - (_:LetRecType) (_:sort 0) (_:LetRecType) (_:sort 0) -> - Void -> Void) - (\ (A:sort 0) (_:A -> LetRecType) (_:A -> sort 0) -> Void -> Void) - lrt); --} + (\ (A:sort 0) (B:A -> LetRecType) + (_:(a:A) -> LRTClos stk (B a) -> applyLRTClosNRet stk (Succ n') (B a)) + (clos:LRTClos stk (LRT_FunDep A B)) (a:A) -> + rec (B a) (applyLRTClosDep stk A B clos a)) + (\ (A:LetRecType) (_:LRTClos stk A -> applyLRTClosNRet stk (Succ n') A) + (B:LetRecType) (_:LRTClos stk B -> applyLRTClosNRet stk (Succ n') B) + (clos:LRTClos stk (LRT_FunClos A B)) (arg:LRTArg stk A) -> + rec B (applyLRTClosClos stk A B clos arg)) + (\ (A:sort 0) (_:LRTClos stk (LRT_Type A)) (v:Void) -> v) + (\ (F:sort 0 -> sort 0 -> sort 0) (VF:ValidLRTFunctor2 F) + (A:LetRecType) (_:LRTClos stk A -> applyLRTClosNRet stk (Succ n') A) + (B:LetRecType) (_:LRTClos stk B -> applyLRTClosNRet stk (Succ n') B) + (_:LRTClos stk (LRT_BinOp F VF A B)) (v:Void) -> v) + (\ (A:sort 0) (B:A -> LetRecType) + (_:(a:A) -> LRTClos stk (B a) -> applyLRTClosNRet stk (Succ n') (B a)) + (_:LRTClos stk (LRT_Sigma A B)) (v:Void) -> v) + lrt_top); -- Build the dependent type { a1:A1 & { a2:A2 & ... { an:An & unit } ... }} of From 0ff0df8dc276219a989e5df5d6aec24dca2e7b5a Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 23 Aug 2023 18:31:00 -0700 Subject: [PATCH 063/305] wrote translateCFGsToDefs --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 215 ++++++++++++------ 1 file changed, 145 insertions(+), 70 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 1e31786852..2c68e78254 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -6004,34 +6004,53 @@ translateCFGLRT cfg = -- term with it if it has one, i.e., if its in-degree is greater than 1. If it -- does need a closure, the 'Natural' state tracks the index to be used for the -- next closure, so use the current value and increment it. +-- +-- Note that the return type is a monad inside a monad. This is so that the +-- caller can see the 'Natural' state without running the 'TypeTransM' +-- computation, which is necessary later on for tying the knot translateTypedEntry :: Some (TypedEntry TransPhase ext blocks tops rets args) -> - StateT Natural (TypeTransM ctx) (Some - (TypedEntryTrans ext blocks tops rets args)) + State Natural (TypeTransM RNil (Some + (TypedEntryTrans ext blocks tops rets args))) translateTypedEntry (Some entry) = if typedEntryHasMultiInDegree entry then do i <- get put (i+1) - lrt <- lift $ translateEntryLRT entry - return (Some (TypedEntryTrans entry $ Just (lrt, mkBaseClosSpecTerm i))) - else return $ Some (TypedEntryTrans entry Nothing) + return $ do lrt <- translateEntryLRT entry + return (Some (TypedEntryTrans entry $ + Just (lrt, mkBaseClosSpecTerm i))) + else return $ return $ Some (TypedEntryTrans entry Nothing) -- | Translate a 'TypedBlock' to a 'TypedBlockTrans' by translating each --- entrypoint in the block using 'translateTypedEntry' +-- entrypoint in the block using 'translateTypedEntry'; see +-- 'translateTypedEntry' for an explanation of the monad-in-monad type translateTypedBlock :: TypedBlock TransPhase ext blocks tops rets args -> - StateT Natural (TypeTransM ctx) (TypedBlockTrans ext blocks tops rets args) + State Natural (TypeTransM RNil (TypedBlockTrans ext blocks tops rets args)) translateTypedBlock blk = - TypedBlockTrans <$> + (TypedBlockTrans <$>) <$> sequence <$> mapM translateTypedEntry (blk ^. typedBlockEntries) +-- | Helper function to translate a 'TypedBlockMap' to a 'TypedBlockMapTrans' by +-- translating every entrypoint using 'translateTypedEntry'; see +-- 'translateTypedEntry' for an explanation of the monad-in-monad type +translateTypedBlockMapH :: + RAssign (TypedBlock TransPhase ext blocks tops rets) blks -> + State Natural (TypeTransM RNil + (RAssign (TypedBlockTrans ext blocks tops rets) blks)) +translateTypedBlockMapH MNil = return $ return MNil +translateTypedBlockMapH (blkMap :>: blk) = + do blkMapTransM <- translateTypedBlockMapH blkMap + blkTransM <- translateTypedBlock blk + return ((:>:) <$> blkMapTransM <*> blkTransM) + -- | Translate a 'TypedBlockMap' to a 'TypedBlockMapTrans' by translating every --- entrypoint using 'translateTypedEntry' +-- entrypoint using 'translateTypedEntry'; see 'translateTypedEntry' for an +-- explanation of the monad-in-monad type translateTypedBlockMap :: TypedBlockMap TransPhase ext blocks tops rets -> - StateT Natural (TypeTransM ctx) (TypedBlockMapTrans ext blocks tops rets) -translateTypedBlockMap blkMap = - traverseRAssign translateTypedBlock blkMap + State Natural (TypeTransM RNil (TypedBlockMapTrans ext blocks tops rets)) +translateTypedBlockMap = translateTypedBlockMapH -- | Translate the typed statements of an entrypoint to a function -- @@ -6061,17 +6080,15 @@ translateBlockMapBodies mapTrans blkMap = (,) <$> translateEntryLRT entry <*> translateEntryBody mapTrans entry) blkMap -{- -NOWNOW: -- change uses of TypeTrans to include the purity flag - --- | FIXME HERE NOW: docs -translateCFGInitEntryBody :: +-- | Translate a CFG to a monadic function that takes all the top-level +-- arguments to that CFG and calls into its initial entrypoint; this monadic +-- function is used as the body of one of the closures used to translate the CFG +translateCFGInitBody :: PermCheckExtC ext exprExt => TypedBlockMapTrans ext blocks (ghosts :++: inits) (gouts :> ret) -> TypedCFG ext blocks ghosts inits gouts ret -> - TypeTransM RNil OpenTerm -translateCFGInitEntryBody mapTrans (cfg :: TypedCFG ext blocks ghosts inits gouts ret) = + TypeTransM RNil SpecTerm +translateCFGInitBody mapTrans cfg = let fun_perm = tpcfgFunPerm cfg h = tpcfgHandle cfg ctx = typedFnHandleAllArgs h @@ -6096,17 +6113,64 @@ translateCFGInitEntryBody mapTrans (cfg :: TypedCFG ext blocks ghosts inits gout translateCallEntry "CFG" init_entry (nuMulti all_px id) (nuMulti all_px $ const MNil) --- | FIXME HERE NOW: docs -translateCFGBodies :: PermCheckExtC ext exprExt => Natural -> - TypedCFG ext blocks ghosts inits gouts ret -> - TypeTransM RNil [OpenTerm] -translateCFGBodies start_ix cfg = +-- | Translate a CFG to a monadic function that passes all of its arguments to +-- the closure with the given index, which is meant to be the closure whose body +-- is defined by 'translateCFGInitBody' +translateCFGIxCall :: TypedCFG ext blocks ghosts inits gouts ret -> Natural -> + TypeTransM RNil SpecTerm +translateCFGIxCall cfg ix = + do let fun_perm = tpcfgFunPerm cfg + h = tpcfgHandle cfg + ctx = typedFnHandleAllArgs h + lrt <- translateCFGLRT cfg + lambdaExprCtx ctx $ lambdaPermCtx (funPermIns fun_perm) $ \pctx -> + (infoCtx <$> ask) >>= \ectx -> + return $ + applyClosSpecTerm lrt (mkBaseClosSpecTerm ix) (transTerms ectx ++ + transTerms pctx) + +-- | FIXME HERE NOWNOW: docs +data CFGTrans = + CFGTrans { cfgTransLRT :: OpenTerm, + cfgTransCloss :: [(OpenTerm,SpecTerm)], + cfgTransBody :: SpecTerm } + +-- | Translate a CFG to a list of closure definitions, represented as a pair of +-- a @LetRecType@ and a monadic function of that @LetRecType@. These closures +-- are for the CFG itself and for all of its entrypoints that are translated to +-- closures, i.e., with in-degree > 1. Use the current 'Natural' in the 'State' +-- monad as the starting index for these closures, and increment that 'Natural' +-- state for each closure body returned. Also return the 'Natural' index used +-- for the closure for the entire CFG. See 'translateTypedEntry' for an +-- explanation of the monad-in-monad type. +translateCFG :: PermCheckExtC ext exprExt => + TypedCFG ext blocks ghosts inits gouts ret -> + State Natural (Natural, TypeTransM RNil CFGTrans) +translateCFG cfg = do let blkMap = tpcfgBlockMap cfg - mapTrans <- - evalStateT (translateTypedBlockMap blkMap) (start_ix+1) - bodies <- translateBlockMapBodies stack mapTrans blkMap - init_body <- translateCFGInitEntryBody mapTrans cfg - return (init_body : bodies) + -- Get the natural number index for the top-level closure of the CFG + cfg_ix <- get + put (cfg_ix + 1) + -- Translate the block map of the CFG by generating calls to closures for + -- all the entrypoints with in-degree > 1 + mapTransM <- translateTypedBlockMap blkMap + -- Return the CFG index and the computation for creating the bodies + return + (cfg_ix, + do mapTrans <- mapTransM + -- Generate the actual closure bodies + LRTs for those entrypoints + closs <- translateBlockMapBodies mapTrans blkMap + -- Generate the closure body + LRT for the entire CFG + cfg_clos_body <- translateCFGInitBody mapTrans cfg + cfg_lrt <- translateCFGLRT cfg + let cfg_clos = (cfg_lrt,cfg_clos_body) + -- Generate the body of the CFG, that calls the cfg_body closure + cfg_body <- translateCFGIxCall cfg cfg_ix + -- Then, finally, return all the closure lrts and bodies + return $ CFGTrans cfg_lrt (cfg_clos : closs) cfg_body) + + +{- FIXME HERE NOWNOW: I don't think we need any of the following any more... -- | Lambda-abstract over all the expression and permission arguments of the -- translation of a CFG, passing them to a Haskell function @@ -6139,19 +6203,13 @@ translateCFG env prev_stack frame bodies ix cfg = lambdaCFGArgs env cfg $ \args -> applyNamedEventOpM "Prelude.multiFixS" [prev_stack, frame, bodies, mkFrameCall frame ix args] +-} ---------------------------------------------------------------------- -- * 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 @@ -6159,6 +6217,52 @@ 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 + +-- | Convert a 'SomedTypedCFG' and a closure index for its initial entrypoint +-- closure into an entry in the permission environment +someTypedCFGIxEntry :: HasPtrWidth w => SomeTypedCFG LLVM -> Natural -> + PermEnvGlobalEntry +someTypedCFGIxEntry (SomeTypedCFG sym _ cfg) ix = + withKnownNat ?ptrWidth $ + PermEnvGlobalEntry sym (mkPtrFunPerm $ tpcfgFunPerm cfg) + (GlobalTransClos $ mkBaseClosSpecTerm ix) + +-- | Translate a list of CFGs for mutually recursive functions to a list of spec +-- definitions +translateCFGsToDefs :: HasPtrWidth w => PermEnv -> ChecksFlag -> + [SomeTypedCFG LLVM] -> [OpenTerm] +translateCFGsToDefs env checks some_cfgs = + let (cfg_ixs, cfg_transsM) = + unzip $ evalState (mapM (\(SomeTypedCFG _ _ cfg) -> + translateCFG cfg) some_cfgs) 0 + tmp_env = permEnvAddGlobalSyms env $ + zipWith someTypedCFGIxEntry some_cfgs cfg_ixs + cfg_transs = runNilTypeTransM tmp_env checks $ sequence cfg_transsM + closs = concat $ map cfgTransCloss cfg_transs in + map (\cfg_trans -> + defineSpecOpenTerm (identOpenTerm $ permEnvSpecMEventType env) closs + (cfgTransLRT cfg_trans) (cfgTransBody cfg_trans)) + cfg_transs + + +-- | 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 @@ -6167,12 +6271,6 @@ 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 someCFGAndPermGlobalEntry :: HasPtrWidth w => SomeCFGAndPerm ext -> @@ -6185,35 +6283,12 @@ someCFGAndPermGlobalEntry (SomeCFGAndPerm sym _ _ fun_perm) = -- | 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] +someCFGAndPermLRT env (SomeCFGAndPerm _ _ _ fun_perm) = + typeDescLRT $ runNilTypeTransM env noChecks $ translateClosed 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 --- | 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" []] +{- +NOWNOW -- | FIXME HERE NOW: docs tcTranslateAddCFGs :: From ace53907858134a702658655f213854240bc7328 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 24 Aug 2023 07:22:00 -0700 Subject: [PATCH 064/305] Finished a first complete version of SAWTranslation.hs! --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 172 +++++------------- 1 file changed, 50 insertions(+), 122 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 2c68e78254..99326dc9e7 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -72,6 +72,7 @@ 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 @@ -856,18 +857,18 @@ arrowLRTTransM :: ImpTypeTrans tr -> arrowLRTTransM tps body = ask >>= \info -> return (arrowLRTTrans tps (runTransM body info)) --- FIXME: should only need to build pi-abstractions as LetRecTypes... right? -{- -- | Build a pi-abstraction over the types in a 'TypeTrans' inside a -- translation monad, using the 'String' as a variable name prefix -piTransM :: String -> TypeTrans tr -> (tr -> TransM info ctx OpenTerm) -> +piTransM :: String -> PureTypeTrans tr -> (tr -> TransM info ctx OpenTerm) -> TransM info ctx OpenTerm piTransM x tps body_f = ask >>= \info -> return (piOpenTermMulti - (zipWith (\i tp -> (pack (x ++ show (i :: Integer)), tp)) [0..] $ typeTransTypes tps) + (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) -> @@ -1263,6 +1264,13 @@ lambdaExprCtx ctx m = translateClosed ctx >>= \tptrans -> lambdaTransM "e" tptrans (\ectx -> inCtxTransM ectx m) +-- | Translate all types in a Crucible context and pi-abstract over them +piExprCtx :: TransInfo info => CruCtx ctx -> TransM info ctx OpenTerm -> + TransM info RNil OpenTerm +piExprCtx ctx m = + translateClosed ctx >>= \tptrans -> + piTransM "e" tptrans (\ectx -> inCtxTransM ectx m) + -- | Translate all types in a Crucible context and pi-abstract over them, -- building the resulting type as a @LetRecType@ piLRTExprCtx :: TransInfo info => CruCtx ctx -> @@ -6129,7 +6137,9 @@ translateCFGIxCall cfg ix = applyClosSpecTerm lrt (mkBaseClosSpecTerm ix) (transTerms ectx ++ transTerms pctx) --- | FIXME HERE NOWNOW: docs +-- | The components of the spec definition that a CFG translates to. Note that, +-- if the CFG is for a function that is mutually recursive with other functions, +-- then it also needs the closures of those functions in its spec definition. data CFGTrans = CFGTrans { cfgTransLRT :: OpenTerm, cfgTransCloss :: [(OpenTerm,SpecTerm)], @@ -6170,42 +6180,6 @@ translateCFG cfg = return $ CFGTrans cfg_lrt (cfg_clos : closs) cfg_body) -{- FIXME HERE NOWNOW: I don't think we need any of the following any more... - --- | 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 -> - TypeTransM (ghosts :++: inits) OpenTerm -> - OpenTerm -piCFGArgs env cfg bodyM = - runNilTypeTransM env noChecks $ - piLRTExprCtx (typedFnHandleAllArgs (tpcfgHandle cfg)) $ - arrowLRTPermCtx (funPermIns $ tpcfgFunPerm cfg) bodyM - --- | 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] --} - - ---------------------------------------------------------------------- -- * Translating Sets of CFGs ---------------------------------------------------------------------- @@ -6238,10 +6212,10 @@ someTypedCFGIxEntry (SomeTypedCFG sym _ cfg) ix = PermEnvGlobalEntry sym (mkPtrFunPerm $ tpcfgFunPerm cfg) (GlobalTransClos $ mkBaseClosSpecTerm ix) --- | Translate a list of CFGs for mutually recursive functions to a list of spec --- definitions +-- | Translate a list of CFGs for mutually recursive functions to a list of +-- @LetRecType@s and spec definitions of those @LetRecType@s translateCFGsToDefs :: HasPtrWidth w => PermEnv -> ChecksFlag -> - [SomeTypedCFG LLVM] -> [OpenTerm] + [SomeTypedCFG LLVM] -> [(OpenTerm,OpenTerm)] translateCFGsToDefs env checks some_cfgs = let (cfg_ixs, cfg_transsM) = unzip $ evalState (mapM (\(SomeTypedCFG _ _ cfg) -> @@ -6251,8 +6225,10 @@ translateCFGsToDefs env checks some_cfgs = cfg_transs = runNilTypeTransM tmp_env checks $ sequence cfg_transsM closs = concat $ map cfgTransCloss cfg_transs in map (\cfg_trans -> - defineSpecOpenTerm (identOpenTerm $ permEnvSpecMEventType env) closs - (cfgTransLRT cfg_trans) (cfgTransBody cfg_trans)) + let lrt = cfgTransLRT cfg_trans in + (lrt, + defineSpecOpenTerm (identOpenTerm $ permEnvSpecMEventType env) closs + lrt (cfgTransBody cfg_trans))) cfg_transs @@ -6278,7 +6254,8 @@ someCFGAndPermGlobalEntry :: HasPtrWidth w => SomeCFGAndPerm ext -> someCFGAndPermGlobalEntry (SomeCFGAndPerm sym _ _ fun_perm) = withKnownNat ?ptrWidth $ PermEnvGlobalEntry sym (mkPtrFunPerm fun_perm) $ - error "someCFGAndPermGlobalEntry: unexpected translation during type-checking" + panic "someCFGAndPermGlobalEntry" + ["Attempt to translate CFG during its own type-checking"] -- | Convert the 'FunPerm' of a 'SomeCFGAndPerm' to an inductive @LetRecType@ -- description of the SAW core type it translates to @@ -6287,10 +6264,10 @@ someCFGAndPermLRT env (SomeCFGAndPerm _ _ _ fun_perm) = typeDescLRT $ runNilTypeTransM env noChecks $ translateClosed fun_perm -{- -NOWNOW - --- | 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] -> @@ -6304,7 +6281,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) $ @@ -6312,90 +6289,40 @@ 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 - - -- 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 - ++ "__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 + -- Next, translate all those CFGs to spec definitions + let lrts_defs = translateCFGsToDefs env checks tc_cfgs + + -- Insert each spec definition as a SAW core definition bound to its + -- corresponding ident in the SAW core module mod_name, and generate entries + -- for the environment mapping each function name to its SAW core ident new_entries <- zipWithM - (\(SomeTypedCFG sym nm cfg) i -> + (\(SomeTypedCFG sym nm cfg) (lrt, def_tm) -> 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 + completeNormOpenTerm sc $ + applyGlobalOpenTerm "Prelude.SpecDef" + [identOpenTerm (permEnvSpecMEventType env), lrt] + tm <- completeNormOpenTerm sc def_tm let ident = mkSafeIdent mod_name nm scInsertDef sc mod_name ident tp tm 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 (GlobalTransDef $ + globalOpenTerm ident)) + tc_cfgs lrts_defs + + -- 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 -translateCompleteFunPerm :: SharedContext -> PermEnv -> - FunPerm ghosts args gouts ret -> IO Term -translateCompleteFunPerm sc env fun_perm = - completeNormOpenTerm sc $ - runNilTypeTransM env noChecks (translate $ emptyMb fun_perm) - -- | Translate a 'TypeRepr' to the SAW core type it represents translateCompleteType :: SharedContext -> PermEnv -> TypeRepr tp -> IO Term translateCompleteType sc env typ_perm = - completeNormOpenTerm sc $ typeTransType1Imp $ + completeNormOpenTerm sc $ typeTransType1 $ runNilTypeTransM env noChecks $ translate $ emptyMb typ_perm -- | Translate a 'TypeRepr' within the given context of type arguments to the @@ -6404,9 +6331,10 @@ translateCompleteTypeInCtx :: SharedContext -> PermEnv -> CruCtx args -> Mb args (TypeRepr a) -> IO Term translateCompleteTypeInCtx sc env args ret = completeNormOpenTerm sc $ - runNilTypeTransM env noChecks (piExprCtx args (typeTransType1Imp <$> + 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. From e33b2d54a952ac842e394b11b7a36473d28e7ccf Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 24 Aug 2023 07:38:11 -0700 Subject: [PATCH 065/305] wrote translateCompletePureFun --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 31 +++++++++++++------ 1 file changed, 22 insertions(+), 9 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 99326dc9e7..eb9c57d039 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -127,6 +127,11 @@ typeDescType :: TypeDesc -> SpecTerm typeDescType (TypeDescPure tp) = openTermLike tp typeDescType (TypeDescLRT _ tp) = tp +-- | Get the pure type described by a 'TypeDesc', if there is one +typeDescPureType :: TypeDesc -> Maybe OpenTerm +typeDescPureType (TypeDescPure tp) = Just tp +typeDescPureType (TypeDescLRT _ _) = Nothing + -- | Get the @LetRecType@ that encodes the type of a 'TypeDesc' typeDescLRT :: TypeDesc -> OpenTerm typeDescLRT (TypeDescPure tp) = ctorOpenTerm "Prelude.LRT_Type" [tp] @@ -6334,17 +6339,25 @@ translateCompleteTypeInCtx sc env args ret = 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. +-- | Translate an input list of 'ValuePerms' and an output 'ValuePerm' to a pure +-- SAW core function type, not in the @SpecM@ monad. It is an error if any of +-- the permissions are impure, such as @lowned@ permissions. 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 = - completeNormOpenTerm sc $ runNilTypeTransM env noChecks $ - piExprCtx ctx $ arrowLRTPermCtx args $ - typeTransTupleType <$> translate ret --} +translateCompletePureFun sc env ctx ps_in p_out = + completeNormOpenTerm sc $ runNilTypeTransM env noChecks $ piExprCtx ctx $ + do ps_in_trans <- translate ps_in + p_out_trans <- translate p_out + let justOrPanic (Just x) = x + justOrPanic Nothing = + panic "translateCompletePureFun" + ["Attempt to translate an impure permission to a pure type"] + let (tps_in, tp_out) = + justOrPanic + ((,) <$> + mapM typeDescPureType (typeTransDescs ps_in_trans) <*> + typeDescPureType (tupleOfTypeDescs $ typeTransDescs p_out_trans)) + return $ piOpenTermMulti (map ("_",) tps_in) (const tp_out) From 05abdfad8fd851ae7962fa300a57709b1bef90e0 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 24 Aug 2023 09:26:45 -0700 Subject: [PATCH 066/305] re-added translateCompleteFunPerm, with documentation reflecting the fact that it now generates a SpecDef type --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 19 +++++++++++++++---- 1 file changed, 15 insertions(+), 4 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index eb9c57d039..72f25cb57f 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -6268,6 +6268,12 @@ someCFGAndPermLRT :: PermEnv -> SomeCFGAndPerm ext -> OpenTerm someCFGAndPermLRT env (SomeCFGAndPerm _ _ _ fun_perm) = typeDescLRT $ runNilTypeTransM env noChecks $ translateClosed fun_perm +-- | Construct a spec definition type for the event type in the supplied +-- environment with the supplied @LetRecType@ +permEnvSpecDefOpenTerm :: PermEnv -> OpenTerm -> OpenTerm +permEnvSpecDefOpenTerm env lrt = + applyGlobalOpenTerm "Prelude.SpecDef" + [identOpenTerm (permEnvSpecMEventType env), lrt] -- | 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, @@ -6303,10 +6309,7 @@ tcTranslateAddCFGs sc mod_name env checks endianness dlevel cfgs_and_perms = new_entries <- zipWithM (\(SomeTypedCFG sym nm cfg) (lrt, def_tm) -> - do tp <- - completeNormOpenTerm sc $ - applyGlobalOpenTerm "Prelude.SpecDef" - [identOpenTerm (permEnvSpecMEventType env), lrt] + do tp <- completeNormOpenTerm sc $ permEnvSpecDefOpenTerm env lrt tm <- completeNormOpenTerm sc def_tm let ident = mkSafeIdent mod_name nm scInsertDef sc mod_name ident tp tm @@ -6324,6 +6327,14 @@ tcTranslateAddCFGs sc mod_name env checks endianness dlevel cfgs_and_perms = -- * Top-level Entrypoints for Translating Other Things ---------------------------------------------------------------------- +-- | Translate a function permission to the type of a spec definition for the +-- translation of a function with that permission +translateCompleteFunPerm :: SharedContext -> PermEnv -> + FunPerm ghosts args gouts ret -> IO Term +translateCompleteFunPerm sc env fun_perm = + completeNormOpenTerm sc $ permEnvSpecDefOpenTerm env $ typeDescLRT $ + runNilTypeTransM env noChecks (translateClosed fun_perm) + -- | Translate a 'TypeRepr' to the SAW core type it represents translateCompleteType :: SharedContext -> PermEnv -> TypeRepr tp -> IO Term translateCompleteType sc env typ_perm = From 3ac386c8eaee1f0afff3529a6aeb42da70f2ecf5 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Sat, 26 Aug 2023 07:47:16 -0700 Subject: [PATCH 067/305] added helper functions to SAWTranslation.hs to support IRTTranslation.hs --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 39 +++++++++++++++++-- 1 file changed, 36 insertions(+), 3 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 72f25cb57f..69d092ef0d 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -420,6 +420,16 @@ tupleTypeTrans (TypeTransImpure tps f) = typeTransTupleDesc :: TypeTrans b tr -> TypeDesc typeTransTupleDesc = tupleOfTypeDescs . typeTransDescs +-- | Form the pure SAW core type that is the tuple of all the SAW core types in +-- a 'TypeTrans', if those types are all pure; it is an error if they are not +typeTransPureTupleType :: TypeTrans p tr -> OpenTerm +typeTransPureTupleType (TypeTransPure tps _) = tupleOfTypes tps +typeTransPureTupleType (TypeTransImpure tps _) = + case typeDescPureType $ tupleOfTypeDescs tps of + Just tp -> tp + Nothing -> panic "typeTransPureTupleType" + ["Expected pure type but found impure type"] + {- -- | 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 @@ -590,6 +600,10 @@ instance IsTermTrans (ExprTransCtx ctx) where exprCtxToTerms :: ExprTransCtx tps -> [SpecTerm] exprCtxToTerms = concat . RL.mapToList transTerms +-- | Map a context of expression translations to a list of 'OpenTerm's +exprCtxToPureTerms :: ExprTransCtx tps -> [OpenTerm] +exprCtxToPureTerms = concat . RL.mapToList transPureTerms + -- | Map an 'ExprTrans' to its type translation exprTransType :: ExprTrans tp -> PureTypeTrans (ExprTrans tp) exprTransType ETrans_LLVM = mkPureTypeTrans0 ETrans_LLVM @@ -811,6 +825,18 @@ lambdaTransM :: String -> TypeTrans p tr -> (tr -> TransM info ctx SpecTerm) -> lambdaTransM x tp body_f = ask >>= \info -> return (lambdaTrans x tp (flip runTransM info . body_f)) +-- | Build a nested lambda-abstraction +-- +-- > \x1:tp1 -> ... -> \xn:tpn -> body +-- +-- over the types in a pure 'TypeTrans' inside a translation monad, using the +-- 'String' as a variable name prefix for the @xi@ variables, returning a pure +-- term +lambdaPureTransM :: String -> PureTypeTrans tr -> + (tr -> TransM info ctx OpenTerm) -> TransM info ctx OpenTerm +lambdaPureTransM x tp body_f = + ask >>= \info -> return (lambdaPureTrans x tp (flip runTransM info . body_f)) + -- | Build a lambda-abstraction -- -- > \x1:(tp1, ..., tpn) -> body @@ -1269,6 +1295,13 @@ 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 +lambdaExprCtxPure :: TransInfo info => CruCtx ctx -> TransM info ctx OpenTerm -> + TransM info RNil OpenTerm +lambdaExprCtxPure ctx m = + translateClosed ctx >>= \tptrans -> + lambdaPureTransM "e" tptrans (\ectx -> inCtxTransM ectx m) + -- | Translate all types in a Crucible context and pi-abstract over them piExprCtx :: TransInfo info => CruCtx ctx -> TransM info ctx OpenTerm -> TransM info RNil OpenTerm @@ -1501,7 +1534,7 @@ instance HasPureTrans (PermExpr a) where [nuMP| PExpr_EqShape _ _ |] -> True [nuMP| PExpr_PtrShape _ _ sh |] -> hasPureTrans sh [nuMP| PExpr_FieldShape fsh |] -> hasPureTrans fsh - [nuMP| PExpr_ArrayShape mb_len _ sh |] -> hasPureTrans sh + [nuMP| PExpr_ArrayShape _ _ sh |] -> hasPureTrans sh [nuMP| PExpr_SeqShape sh1 sh2 |] -> hasPureTrans sh1 && hasPureTrans sh2 [nuMP| PExpr_OrShape sh1 sh2 |] -> @@ -2927,7 +2960,7 @@ instance HasPureTrans (ValuePerm a) where -- unfold to an impure permission hasPureTrans args [nuMP| ValPerm_Conj ps |] -> hasPureTrans ps - [nuMP| ValPerm_Var x _ |] -> False + [nuMP| ValPerm_Var _ _ |] -> False [nuMP| ValPerm_False |] -> True instance HasPureTrans (AtomicPerm a) where @@ -2943,7 +2976,7 @@ instance HasPureTrans (AtomicPerm a) where -- FIXME: this is technically incorrect, since a defined permission could -- unfold to an impure permission hasPureTrans args - [nuMP| Perm_LLVMFrame fp |] -> True + [nuMP| Perm_LLVMFrame _ |] -> True [nuMP| Perm_LOwned _ _ _ _ _ |] -> False [nuMP| Perm_LOwnedSimple _ _ |] -> True [nuMP| Perm_LCurrent _ |] -> True From 5f92e7bdcbcd133252c460f9d1715301a5a7bba1 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Sat, 26 Aug 2023 13:56:31 -0700 Subject: [PATCH 068/305] added the notion of pure vs impure type translations, to support IRTTranslation --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 211 ++++++++++-------- 1 file changed, 117 insertions(+), 94 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 69d092ef0d..65c6dbd8c0 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -633,10 +633,8 @@ exprCtxType (ectx :>: e) = (:>:) <$> exprCtxType ectx <*> exprTransType e -- 'transPureTerms', except that all type descriptions are mapped to pure types, -- not terms of type @LetRecType@. Return 'Nothing' if this is not possible. exprTransPureTypeTerms :: ExprTrans tp -> Maybe [OpenTerm] -exprTransPureTypeTerms (ETrans_Shape (TypeDescPure tp)) = Just [tp] -exprTransPureTypeTerms (ETrans_Shape (TypeDescLRT _ _)) = Nothing -exprTransPureTypeTerms (ETrans_Perm (TypeDescPure tp)) = Just [tp] -exprTransPureTypeTerms (ETrans_Perm (TypeDescLRT _ _)) = Nothing +exprTransPureTypeTerms (ETrans_Shape d) = (:[]) <$> typeDescPureType d +exprTransPureTypeTerms (ETrans_Perm d) = (:[]) <$> typeDescPureType d exprTransPureTypeTerms etrans = Just $ transPureTerms etrans -- | Map an 'ExprTransCtx' to the SAW core terms it contains, similarly to @@ -1192,101 +1190,125 @@ instance TransInfo info => Translate info ctx (NatRepr n) OpenTerm where returnType1 :: OpenTerm -> TransM info ctx (PureTypeTrans (ExprTrans a)) returnType1 tp = return $ mkPureTypeTrans1 tp ETrans_Term +-- | Translate a pure 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. The 'Bool' flag indicates +-- whether the translation should be only to pure types, meaning that shapes and +-- permissions are translated to SAW core types; otherwise, they are translated +-- to terms of SAW core type @LetRecType@, which can only be used for describing +-- monadic computations. +translateType :: TransInfo info => Bool -> TypeRepr a -> + TransM info ctx (PureTypeTrans (ExprTrans a)) +translateType _ AnyRepr = + return $ error "Translate: Any" +translateType _ UnitRepr = + return $ mkPureTypeTrans0 ETrans_Unit +translateType _ BoolRepr = + returnType1 $ globalOpenTerm "Prelude.Bool" +translateType _ NatRepr = + returnType1 $ dataTypeOpenTerm "Prelude.Nat" [] +translateType _ IntegerRepr = + return $ error "translate: IntegerRepr" +translateType _ RealValRepr = + return $ error "translate: RealValRepr" +translateType _ ComplexRealRepr = + return $ error "translate: ComplexRealRepr" +translateType _ (SequenceRepr{}) = + return $ error "translate: SequenceRepr" +translateType _ (BVRepr w) = + returnType1 =<< bitvectorTransM (translateClosed w) +translateType _ (VectorRepr AnyRepr) = + return $ mkPureTypeTrans0 ETrans_AnyVector + +-- Our special-purpose intrinsic types, whose translations do not have +-- computational content +translateType _ (LLVMPointerRepr _) = + return $ mkPureTypeTrans0 ETrans_LLVM +translateType _ (LLVMBlockRepr _) = + return $ mkPureTypeTrans0 ETrans_LLVMBlock +translateType _ (LLVMFrameRepr _) = + return $ mkPureTypeTrans0 ETrans_LLVMFrame +translateType _ LifetimeRepr = + return $ mkPureTypeTrans0 ETrans_Lifetime +translateType _ PermListRepr = + returnType1 (sortOpenTerm $ mkSort 0) +translateType _ RWModalityRepr = + return $ mkPureTypeTrans0 ETrans_RWModality + +-- Permissions and LLVM shapes translate to types (for the pure translation) or +-- LetRecTypes (for the impure translation) +translateType False (ValuePermRepr _) = + return $ mkPureTypeTrans1 (dataTypeOpenTerm "Prelude.LetRecType" []) + (ETrans_Perm . typeDescFromLRT) +translateType True (ValuePermRepr _) = + return $ mkPureTypeTrans1 (sortOpenTerm $ mkSort 0) + (ETrans_Perm . TypeDescPure) +translateType False (LLVMShapeRepr _) = + return $ mkPureTypeTrans1 (dataTypeOpenTerm "Prelude.LetRecType" []) + (ETrans_Shape . typeDescFromLRT) +translateType True (LLVMShapeRepr _) = + return $ mkPureTypeTrans1 (sortOpenTerm $ mkSort 0) + (ETrans_Shape . TypeDescPure) + +-- We can't handle any other special-purpose types +translateType _ (IntrinsicRepr _ _) = + return $ error "translate: IntrinsicRepr" + +translateType _ (RecursiveRepr _ _) = + return $ error "translate: RecursiveRepr" +translateType _ (FloatRepr _) = + returnType1 $ dataTypeOpenTerm "Prelude.Float" [] +translateType _ (IEEEFloatRepr _) = + return $ error "translate: IEEEFloatRepr" +translateType _ CharRepr = + return $ error "translate: CharRepr" +translateType _ (StringRepr UnicodeRepr) = + returnType1 stringTypeOpenTerm +translateType _ (StringRepr _) = + return $ error "translate: StringRepr non-unicode" +translateType _ (FunctionHandleRepr _ _) = + -- NOTE: function permissions translate to the SAW function, but the function + -- handle itself has no SAW translation + return $ mkPureTypeTrans0 ETrans_Fun +translateType _ (MaybeRepr _) = + return $ error "translate: MaybeRepr" +translateType _ (VectorRepr _) = + return $ error "translate: VectorRepr (can't map to Vec without size)" +translateType b (StructRepr tps) = + fmap ETrans_Struct <$> translateCtx b (mkCruCtx tps) +translateType _ (VariantRepr _) = + return $ error "translate: VariantRepr" +translateType _ (ReferenceRepr _) = + return $ error "translate: ReferenceRepr" +translateType _ (WordMapRepr _ _) = + return $ error "translate: WordMapRepr" +translateType _ (StringMapRepr _) = + return $ error "translate: StringMapRepr" +translateType _ (SymbolicArrayRepr _ _) = + return $ error "translate: SymbolicArrayRepr" +translateType _ (SymbolicStructRepr _) = + return $ error "translate: SymbolicStructRepr" --- FIXME: explain this translation instance TransInfo info => Translate info ctx (TypeRepr a) (PureTypeTrans (ExprTrans a)) where - translate mb_tp = case mbMatch mb_tp of - [nuMP| AnyRepr |] -> - return $ error "Translate: Any" - [nuMP| UnitRepr |] -> - return $ mkPureTypeTrans0 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 $ mkPureTypeTrans0 ETrans_AnyVector - - -- Our special-purpose intrinsic types, whose translations do not have - -- computational content - [nuMP| LLVMPointerRepr _ |] -> - return $ mkPureTypeTrans0 ETrans_LLVM - [nuMP| LLVMBlockRepr _ |] -> - return $ mkPureTypeTrans0 ETrans_LLVMBlock - [nuMP| LLVMFrameRepr _ |] -> - return $ mkPureTypeTrans0 ETrans_LLVMFrame - [nuMP| LifetimeRepr |] -> - return $ mkPureTypeTrans0 ETrans_Lifetime - [nuMP| PermListRepr |] -> - returnType1 (sortOpenTerm $ mkSort 0) - [nuMP| RWModalityRepr |] -> - return $ mkPureTypeTrans0 ETrans_RWModality - - -- Permissions and LLVM shapes translate to types - [nuMP| ValuePermRepr _ |] -> - return $ mkPureTypeTrans1 (dataTypeOpenTerm "Prelude.LetRecType" []) - (ETrans_Perm . typeDescFromLRT) - [nuMP| LLVMShapeRepr _ |] -> - return $ mkPureTypeTrans1 (dataTypeOpenTerm "Prelude.LetRecType" []) - (ETrans_Shape . typeDescFromLRT) - - -- 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 $ mkPureTypeTrans0 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 mb_tp = translateType False $ mbLift mb_tp +-- | Translate a context of types to a type translation using 'translateType' +translateCtx :: TransInfo info => Bool -> CruCtx tps -> + TransM info ctx (PureTypeTrans (ExprTransCtx tps)) +translateCtx _ CruCtxNil = return $ mkPureTypeTrans0 MNil +translateCtx b (CruCtxCons ctx tp) = + liftA2 (:>:) <$> translateCtx b ctx <*> translateType b tp instance TransInfo info => Translate info ctx (CruCtx as) (PureTypeTrans (ExprTransCtx as)) where - translate mb_ctx = case mbMatch mb_ctx of - [nuMP| CruCtxNil |] -> return $ mkPureTypeTrans0 MNil - [nuMP| CruCtxCons ctx tp |] -> - liftA2 (:>:) <$> translate ctx <*> translate tp + translate mb_ctx = translateCtx False $ mbLift mb_ctx + +-- | Translate all types in a 'CruCtx' to their pure types, meaning specifically +-- that permissions and shapes are translated to types and not @LetRecType@s +translateCtxPure :: TransInfo info => CruCtx ctx -> + TransM info ctx' (PureTypeTrans (ExprTransCtx ctx)) +translateCtxPure = translateCtx True -- | Translate all types in a Crucible context and lambda-abstract over them lambdaExprCtx :: TransInfo info => CruCtx ctx -> TransM info ctx SpecTerm -> @@ -1295,11 +1317,12 @@ 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 +-- | Translate all types in a Crucible context to pure types and lambda-abstract +-- over those types lambdaExprCtxPure :: TransInfo info => CruCtx ctx -> TransM info ctx OpenTerm -> TransM info RNil OpenTerm lambdaExprCtxPure ctx m = - translateClosed ctx >>= \tptrans -> + translateCtxPure ctx >>= \tptrans -> lambdaPureTransM "e" tptrans (\ectx -> inCtxTransM ectx m) -- | Translate all types in a Crucible context and pi-abstract over them From fc54d6bf18c7e742c001ab74bdd563ac1d52a8fa Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Sat, 26 Aug 2023 14:42:45 -0700 Subject: [PATCH 069/305] added psubstOfSubst --- heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs index d2f26b9e6e..12613e7fed 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs @@ -7280,6 +7280,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) From a26bdd7eabfb1c96330d29460a87e6251ff25cb6 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Sun, 27 Aug 2023 06:53:11 -0700 Subject: [PATCH 070/305] added an OpenTermLike instance for OpenTerm itself --- saw-core/src/Verifier/SAW/OpenTerm.hs | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/saw-core/src/Verifier/SAW/OpenTerm.hs b/saw-core/src/Verifier/SAW/OpenTerm.hs index fcac6748f1..8416835fb9 100644 --- a/saw-core/src/Verifier/SAW/OpenTerm.hs +++ b/saw-core/src/Verifier/SAW/OpenTerm.hs @@ -571,6 +571,16 @@ class OpenTermLike t where -- | 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 From d071365667182c1c5793d6024ed822af979654c8 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Sun, 27 Aug 2023 06:53:23 -0700 Subject: [PATCH 071/305] Finished rewriting IRTTranslation.hs --- .../Verifier/SAW/Heapster/IRTTranslation.hs | 206 ++++++++++-------- .../Verifier/SAW/Heapster/SAWTranslation.hs | 27 ++- 2 files changed, 140 insertions(+), 93 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/IRTTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/IRTTranslation.hs index 33f65f3a83..f663bea881 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/IRTTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/IRTTranslation.hs @@ -32,7 +32,6 @@ module Verifier.SAW.Heapster.IRTTranslation ( ) where import Numeric.Natural -import Data.Functor.Const import GHC.TypeLits import Control.Monad.Reader import Control.Monad.State @@ -41,7 +40,6 @@ import Control.Monad.Except 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 @@ -65,7 +63,27 @@ completeOpenTermTyped sc (OpenTerm termM) = -- translation context -- TODO Move this to SAWTranslation.hs? askExprCtxTerms :: TransInfo info => TransM info ctx [OpenTerm] -askExprCtxTerms = exprCtxToTerms <$> infoCtx <$> ask +askExprCtxTerms = exprCtxToPureTerms <$> infoCtx <$> ask + +-- | Build an 'OpenTerm' of type @ListSort@ from 'OpenTerm's of type @sort 0@ +listSortOpenTerm :: [OpenTerm] -> OpenTerm +listSortOpenTerm xs = + foldr (\hd tl -> ctorOpenTerm "Prelude.LS_Cons" [hd, tl]) + (ctorOpenTerm "Prelude.LS_Nil" []) + xs + +-- | Split a 'Member' proof in an appended context into a proof in one of the +-- two contexts being appended +-- FIXME: move to Hobbits +splitMemberApp :: Proxy ctx1 -> RAssign Proxy ctx2 -> + Member (ctx1 :++: ctx2) a -> + Either (Member ctx1 a) (Member ctx2 a) +splitMemberApp _ MNil memb = Left memb +splitMemberApp _ (_ :>: _) Member_Base = Right Member_Base +splitMemberApp ctx1 (ctx2 :>: _) (Member_Step memb) = + case splitMemberApp ctx1 ctx2 memb of + Left memb' -> Left memb' + Right memb' -> Right (Member_Step memb') ---------------------------------------------------------------------- @@ -164,76 +182,87 @@ instance ContainsIRTRecName (LLVMFieldPerm w sz) where -- * The monad for translating IRT type variables ---------------------------------------------------------------------- -data IRTTyVarsTransCtx args ext = - IRTTyVarsTransCtx +-- | The local context maintained by 'irtTyVars' and friends for extracting +-- @IRT@ type variables from a permission or shape in variable binding context +-- @ctx@ with top-level arguments @args@. This information includes the name of +-- the top-level permission or shape being translated, type translations for for +-- all the top-level arguments, the current permission environment, and an +-- extension context, represented as a list of 'Proxy' phantom arguments +data IRTTyVarsTransInfo args (ext :: RList CrucibleType) = + IRTTyVarsTransInfo { irtTRecName :: IRTRecName args, - irtTArgsCtx :: RAssign (Const [OpenTerm]) args, + irtTArgsCtx :: RAssign ExprTypeTrans args, irtTExtCtx :: RAssign Proxy ext, irtTPermEnv :: PermEnv } -- | The monad for translating IRT type variables type IRTTyVarsTransM args ext = - ReaderT (IRTTyVarsTransCtx args ext) (Either String) + ReaderT (IRTTyVarsTransInfo 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 +runIRTTyVarsTransM env n_rec argsCtx m = runReaderT m info + where args_trans = runNilTypeTransM env noChecks $ translateCtx True argsCtx + info = IRTTyVarsTransInfo 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 } +inExtIRTTyVarsTransM = withReaderT $ \info -> + info { irtTExtCtx = irtTExtCtx info :>: 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 +irtTMbCombine x = return $ mbCombine RL.typeCtxProxies x +-} + +irtTArgsProxies :: IRTTyVarsTransM args ext (RAssign Proxy args) +irtTArgsProxies = RL.map (const Proxy) <$> irtTArgsCtx <$> ask -- | Create an @args :++: ext@ binding -irtNus :: (RAssign Name args -> RAssign Name ext -> b) -> +irtNus :: (RAssign Name args -> 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' +irtNus f = + do args <- irtTArgsProxies + ext <- irtTExtCtx <$> ask + return $ extMbMulti ext $ nuMulti args f + +-- | Turn an object in a binding for the bigger context @ctx@ to an object in a +-- binding for just the @args@ context, by substituting 'Nothing' for all the +-- additional variables in @ctx@ 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!" + Mb (args :++: ext) a -> IRTTyVarsTransM args ext (Mb args a) +irtTSubstExt mb_a = + do args_prxs <- irtTArgsProxies + ext <- irtTExtCtx <$> ask + let mb_maybe = + nuMulti args_prxs $ \args -> + partialSubst (psubstAppend (psubstOfSubst (substOfVars args)) + (emptyPSubst ext)) mb_a + case mbMaybe mb_maybe of + Just mb_a' -> return mb_a' + Nothing -> + throwError ("non-array permission in a recursive perm body" + ++ " depends on an existential variable!") ---------------------------------------------------------------------- -- * Trees for keeping track of IRT variable indices ---------------------------------------------------------------------- +-- | An 'IRTVarTree' is a tree that captures the structure of an @IRT@ type +-- description but with elements of type @a@ where that type description has +-- variables. In practice, @a@ can be '()', meaning the tree just tracks where +-- the variables are, or 'Natural', giving the variables indexes into a list of +-- all the variables in an @IRT@ type description. data IRTVarTree a = IRTVarsNil | IRTVarsCons a (IRTVarTree a) | IRTVarsAppend (IRTVarTree a) (IRTVarTree a) @@ -244,7 +273,11 @@ data IRTVarTree a = IRTVarsNil pattern IRTVar :: a -> IRTVarTree a pattern IRTVar ix = IRTVarsCons ix IRTVarsNil +-- | An 'IRTVarTree' that just captures the tree shape of an @IRT@ description type IRTVarTreeShape = IRTVarTree () + +-- | An 'IRTVarTree' that assigns natual number indices to the variables in an +-- @IRT@ description type IRTVarIdxs = IRTVarTree Natural -- | Fill in all the leaves of an 'IRTVarTree' with sequential indices @@ -270,9 +303,8 @@ 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) + do tm <- completeOpenTermTyped sc $ runNilTypeTransM env noChecks $ + lambdaExprCtxPure args (listSortOpenTerm <$> sequence tps) return (tm, setIRTVarIdxs ixs) -- | Given the a recursive shape being defined, translate the shape's body to @@ -289,12 +321,14 @@ translateCompleteShapeIRTTyVars sc env 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) + do tm <- completeOpenTermTyped sc $ runNilTypeTransM env noChecks $ + lambdaExprCtxPure args (listSortOpenTerm <$> sequence tps) return (tm, setIRTVarIdxs ixs) --- | Types from which we can get IRT type variables, e.g. ValuePerm +-- | Generic function to traverse a permission or shape expression and find all +-- of the subterms of that shape or permission whose translation needs to be +-- lifted out as a top-level argument; return those lifted arguments along with +-- a tree shape that describes where they go in the permission or shape class IRTTyVars a where irtTyVars :: Mb (args :++: ext) a -> IRTTyVarsTransM args ext ([TypeTransM args OpenTerm], @@ -312,7 +346,7 @@ instance IRTTyVars (ValuePerm a) where [nuMP| ValPerm_Named npn args off |] -> namedPermIRTTyVars mb_p npn args off [nuMP| ValPerm_Var x _ |] -> - irtTTranslateVar mb_p x + irtTTranslateVar x [nuMP| ValPerm_Conj ps |] -> irtTyVars ps [nuMP| ValPerm_False |] -> return ([], IRTVarsNil) @@ -322,7 +356,7 @@ 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 + let xCbn = mbCombine RL.typeCtxProxies mb_x (tps, ixs) <- inExtIRTTyVarsTransM (irtTyVars xCbn) return (tp_trans : tps, IRTVarsCons () ixs) @@ -330,8 +364,8 @@ instance (KnownRepr TypeRepr tp, IRTTyVars a) => IRTTyVars (Binding tp a) where -- 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) => + (Translate TypeTransInfo args a (ImpTypeTrans tr), + Substable PartialSubst a Maybe, NuMatching a, HasPureTrans a) => Mb (args :++: ext) a -> Mb (args :++: ext) (NamedPermName ns args' tp) -> Mb (args :++: ext) (PermExprs args') -> @@ -339,8 +373,8 @@ namedPermIRTTyVars :: forall args ext a tr ns args' 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) + do npn_args <- irtNus (\ns -> namesToExprs ns) + npn_off <- irtNus (\_ -> NoPermOffset @tp) n_rec <- irtTRecName <$> ask case n_rec of IRTRecPermName npn_rec @@ -356,33 +390,32 @@ namedPermIRTTyVars p npn args off = Just (NamedPerm_Defined dp) -> irtTyVars (mbMap2 (unfoldDefinedPerm dp) args off) _ -> do p' <- irtTSubstExt p - let p_trans = typeTransTupleType <$> translate p' - return ([p_trans], IRTVar ()) + if hasPureTrans p' then return () else + throwError "namedPermIRTTyVars: impure permission" + let p_transM = typeTransPureTupleType <$> translate p' + return ([p_transM], IRTVar ()) + +-- | Test that an expression variable for a permission or shape is bound in the +-- @args@ list (i.e., not as an existential variable), and return a 'Member' +-- proof for it. Throw an error if it is not. +irtTVarMemb :: Mb (args :++: ext) (ExprVar tp) -> + IRTTyVarsTransM args ext (Member args tp) +irtTVarMemb mb_x = + (irtTExtCtx <$> ask) >>= \ctx -> + case mbNameBoundP mb_x of + Left (splitMemberApp Proxy ctx -> Left memb) -> return memb + _ -> throwError "irtTVarMemb: Existentially bound permission or shape variable" -- | 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) -> +irtTTranslateVar :: 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 ()) +irtTTranslateVar x = + do memb <- irtTVarMemb x + return ([tupleOfTerms <$> transPureTerms <$> RL.get memb <$> infoCtx <$> ask], IRTVar ()) -- | Get all IRT type variables in a list instance (NuMatching a, IRTTyVars a) => IRTTyVars [a] where @@ -425,10 +458,10 @@ instance IRTTyVars (AtomicPerm a) where -- | 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_Var x |] -> irtTTranslateVar x [nuMP| PExpr_EmptyShape |] -> return ([], IRTVarsNil) [nuMP| PExpr_NamedShape maybe_rw maybe_l nmsh args |] -> - do args_rec <- irtNus (\ns _ -> namesToExprs ns) + do args_rec <- irtNus (\ns -> namesToExprs ns) n_rec <- irtTRecName <$> ask case n_rec of IRTRecShapeName w_rec nmsh_rec @@ -454,7 +487,9 @@ instance IRTTyVars (PermExpr (LLVMShapeType w)) where throwError ("recursive shape passed to an opaque or" ++ " recursive shape in its definition!") _ -> do sh' <- irtTSubstExt mb_sh - let sh_trans = transTupleTerm <$> translate sh' + if hasPureTrans mb_sh then return () else + throwError "irtTyVars: impure shape" + let sh_trans = translate1Pure sh' return ([sh_trans], IRTVar ()) [nuMP| PExpr_EqShape _ _ |] -> return ([], IRTVarsNil) [nuMP| PExpr_PtrShape _ _ sh |] -> irtTyVars sh @@ -520,6 +555,7 @@ irtDInArgsCtx m = instance TransInfo IRTDescTransInfo where infoCtx = irtDExprCtx infoEnv = irtDPermEnv + infoChecksFlag _ = noChecks extTransInfo etrans (IRTDescTransInfo {..}) = IRTDescTransInfo { irtDExprCtx = irtDExprCtx :>: etrans @@ -565,7 +601,7 @@ translateCompleteIRTDesc :: IRTDescs a => SharedContext -> PermEnv -> Mb args a -> IRTVarIdxs -> IO TypedTerm translateCompleteIRTDesc sc env tyVarsIdent args p ixs = do tm <- completeOpenTerm sc $ - runTransM (lambdaExprCtx args . irtDInArgsCtx $ + runTransM (lambdaExprCtxPure args . irtDInArgsCtx $ do in_mu <- irtDesc p ixs irtCtorOpenTerm "Prelude.IRT_mu" [in_mu]) (emptyIRTDescTransInfo env tyVarsIdent) @@ -573,7 +609,7 @@ translateCompleteIRTDesc sc env tyVarsIdent args p ixs = let irtDescOpenTerm ectx = return $ dataTypeOpenTerm "Prelude.IRTDesc" [ applyOpenTermMulti (globalOpenTerm tyVarsIdent) - (exprCtxToTerms ectx) ] + (exprCtxToPureTerms ectx) ] tp <- completeOpenTerm sc $ runNilTypeTransM env noChecks (translateClosed args >>= \tptrans -> piTransM "e" tptrans irtDescOpenTerm) @@ -602,7 +638,7 @@ instance IRTDescs (ValuePerm a) where ([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 $ + xf <- lambdaPureTransM "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 |], _) -> @@ -646,7 +682,7 @@ instance IRTDescs (AtomicPerm a) where ([nuMP| Perm_LLVMArray mb_ap |], _) -> do let w = natVal2 mb_ap w_term = natOpenTerm w - len_term <- translate1 (fmap llvmArrayLen mb_ap) + len_term <- translate1Pure (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 |], _) -> @@ -696,7 +732,7 @@ instance IRTDescs (PermExpr (LLVMShapeType w)) where ([nuMP| PExpr_ArrayShape mb_len _ mb_sh |], _) -> do let w = natVal4 mb_len w_term = natOpenTerm w - len_term <- translate1 mb_len + len_term <- translate1Pure 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) -> @@ -710,7 +746,7 @@ instance IRTDescs (PermExpr (LLVMShapeType w)) where ([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 $ + xf <- lambdaPureTransM "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 @@ -743,7 +779,7 @@ translateCompleteIRTDef :: SharedContext -> PermEnv -> IO TypedTerm translateCompleteIRTDef sc env tyVarsIdent descIdent args = completeOpenTermTyped sc $ - runNilTypeTransM env noChecks (lambdaExprCtx args $ + runNilTypeTransM env noChecks (lambdaExprCtxPure args $ irtDefinition tyVarsIdent descIdent) -- | Given identifiers whose definitions in the shared context are the results @@ -756,7 +792,7 @@ translateCompleteIRTFoldFun :: SharedContext -> PermEnv -> IO Term translateCompleteIRTFoldFun sc env tyVarsIdent descIdent _ args = completeOpenTerm sc $ - runNilTypeTransM env noChecks (lambdaExprCtx args $ + runNilTypeTransM env noChecks (lambdaExprCtxPure args $ irtFoldFun tyVarsIdent descIdent) -- | Given identifiers whose definitions in the shared context are the results @@ -769,7 +805,7 @@ translateCompleteIRTUnfoldFun :: SharedContext -> PermEnv -> IO Term translateCompleteIRTUnfoldFun sc env tyVarsIdent descIdent _ args = completeOpenTerm sc $ - runNilTypeTransM env noChecks (lambdaExprCtx args $ + runNilTypeTransM env noChecks (lambdaExprCtxPure args $ irtUnfoldFun tyVarsIdent descIdent) -- | Get the terms for the arguments to @IRT@, @foldIRT@, and @unfoldIRT@ diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 65c6dbd8c0..3f3e2b73cb 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -255,7 +255,7 @@ specMTypeDesc d = -- 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 :: [SpecTerm] -> SpecTerm +tupleOfTerms :: OpenTermLike tm => [tm] -> tm tupleOfTerms [] = unitTermLike tupleOfTerms [t] = t tupleOfTerms (t:ts) = pairTermLike t $ tupleOfTerms ts @@ -1275,7 +1275,7 @@ translateType _ (MaybeRepr _) = translateType _ (VectorRepr _) = return $ error "translate: VectorRepr (can't map to Vec without size)" translateType b (StructRepr tps) = - fmap ETrans_Struct <$> translateCtx b (mkCruCtx tps) + fmap ETrans_Struct <$> combineCtxTranss <$> translateCtx b (mkCruCtx tps) translateType _ (VariantRepr _) = return $ error "translate: VariantRepr" translateType _ (ReferenceRepr _) = @@ -1293,22 +1293,33 @@ instance TransInfo info => Translate info ctx (TypeRepr a) (PureTypeTrans (ExprTrans a)) where translate mb_tp = translateType False $ mbLift mb_tp +newtype ExprTypeTrans a = ExprTypeTrans (PureTypeTrans (ExprTrans a)) + -- | Translate a context of types to a type translation using 'translateType' translateCtx :: TransInfo info => Bool -> CruCtx tps -> - TransM info ctx (PureTypeTrans (ExprTransCtx tps)) -translateCtx _ CruCtxNil = return $ mkPureTypeTrans0 MNil -translateCtx b (CruCtxCons ctx tp) = - liftA2 (:>:) <$> translateCtx b ctx <*> translateType b tp + TransM info ctx (RAssign ExprTypeTrans tps) +translateCtx b ctx = + traverseRAssign (\tp -> ExprTypeTrans <$> + translateType b tp) (cruCtxToTypes ctx) + +-- | Combine the translations of each type in a context into a single type +-- translation for the entire context +combineCtxTranss :: RAssign ExprTypeTrans tps -> + PureTypeTrans (ExprTransCtx tps) +combineCtxTranss MNil = mkPureTypeTrans0 MNil +combineCtxTranss (transs :>: ExprTypeTrans trans) = + (:>:) <$> combineCtxTranss transs <*> trans instance TransInfo info => Translate info ctx (CruCtx as) (PureTypeTrans (ExprTransCtx as)) where - translate mb_ctx = translateCtx False $ mbLift mb_ctx + translate mb_ctx = + combineCtxTranss <$> translateCtx False (mbLift mb_ctx) -- | Translate all types in a 'CruCtx' to their pure types, meaning specifically -- that permissions and shapes are translated to types and not @LetRecType@s translateCtxPure :: TransInfo info => CruCtx ctx -> TransM info ctx' (PureTypeTrans (ExprTransCtx ctx)) -translateCtxPure = translateCtx True +translateCtxPure ctx = combineCtxTranss <$> translateCtx True ctx -- | Translate all types in a Crucible context and lambda-abstract over them lambdaExprCtx :: TransInfo info => CruCtx ctx -> TransM info ctx SpecTerm -> From 6b313be0dcd49bcc5251870dffc219d5716b6ae7 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Sun, 27 Aug 2023 06:53:45 -0700 Subject: [PATCH 072/305] added one more import to HeapsterBuiltins.hs to get it to compile --- src/SAWScript/HeapsterBuiltins.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/SAWScript/HeapsterBuiltins.hs b/src/SAWScript/HeapsterBuiltins.hs index 1326c7f5a8..f25625c7a3 100644 --- a/src/SAWScript/HeapsterBuiltins.hs +++ b/src/SAWScript/HeapsterBuiltins.hs @@ -86,6 +86,7 @@ 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.SharedTerm From 2225e4fd80b17a0d0956f26e408945d63531f13d Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Sun, 27 Aug 2023 09:04:50 -0700 Subject: [PATCH 073/305] fixed some variable-binding issues in the definition of defineSpecOpenTerm --- saw-core/src/Verifier/SAW/OpenTerm.hs | 40 +++++++++++++++++---------- 1 file changed, 26 insertions(+), 14 deletions(-) diff --git a/saw-core/src/Verifier/SAW/OpenTerm.hs b/saw-core/src/Verifier/SAW/OpenTerm.hs index 8416835fb9..31bda63c44 100644 --- a/saw-core/src/Verifier/SAW/OpenTerm.hs +++ b/saw-core/src/Verifier/SAW/OpenTerm.hs @@ -832,13 +832,13 @@ specStExtraRecs st = reverse $ specStExtraRecsRev st specStImports :: SpecTermState -> [OpenTerm] specStImports st = reverse (specStImportsRev st) --- | Increment the context length of a 'SpecTermState' -specStIncCtx :: SpecTermState -> SpecTermState -specStIncCtx st = st { specStCtxLen = specStCtxLen st + 1 } +-- | Increment the context length of a 'SpecTermState' by the specified amount +specStIncCtx :: Int -> SpecTermState -> SpecTermState +specStIncCtx inc st = st { specStCtxLen = specStCtxLen st + inc } --- | Decrement the context length of a 'SpecTermState' -specStDecCtx :: SpecTermState -> SpecTermState -specStDecCtx st = st { specStCtxLen = specStCtxLen st - 1 } +-- | Decrement the context length of a 'SpecTermState' by the specified amount +specStDecCtx :: Int -> SpecTermState -> SpecTermState +specStDecCtx dec st = st { specStCtxLen = specStCtxLen st - dec } specStInsTempClos :: OpenTerm -> SpecTermState -> (Natural, SpecTermState) specStInsTempClos lrt st = @@ -924,7 +924,9 @@ openTermSpecTerm t = OpenTerm $ do ctx <- askCtx if length ctx == ctx_len then unOpenTerm t else - panic "openTermSpecTerm" ["Typing context not of expected length"] + panic "openTermSpecTerm" ["Typing context not of expected length\n" ++ + "Found: " ++ show (length ctx) ++ + ", Expected: " ++ show ctx_len] -- | Return the type of a 'SpecTerm' as a 'SpecTerm' specTermType :: SpecTerm -> SpecTerm @@ -944,13 +946,19 @@ topVarSpecTerm = typeInferComplete (LocalVar (inner_ctx_len - outer_ctx_len) :: TermF Term) +-- | Run a 'SpecTermM' computation with a 'specStCtxLen' value that has been +-- incremented by the specified amount. This means that the computation is +-- intuitively inside a binding for that many variables. +withIncCtxLen :: Int -> SpecTermM a -> SpecTermM a +withIncCtxLen inc m = + do modify (specStIncCtx inc) + ret <- m + modify (specStDecCtx inc) + return ret + -- | Run a 'SpecTermM' computation in a context with an extra bound variable -withVarSpecTermM :: SpecTermM a -> SpecTermM a -withVarSpecTermM m = - do modify specStIncCtx - a <- m - modify specStDecCtx - return a +withVarSpecTermM :: SpecTermM SpecInfoTerm -> SpecTermM SpecInfoTerm +withVarSpecTermM m = withIncCtxLen 1 m -- | Build a lambda abstraction as a 'SpecTerm' from a function that takes in a -- pure 'OpenTerm' @@ -1035,8 +1043,12 @@ defineSpecOpenTerm :: OpenTerm -> [(OpenTerm,SpecTerm)] -> defineSpecOpenTerm ev base_recs_in lrt body_in = runSpecTermM ev (fromIntegral $ length base_recs_in) $ do base_recs <- + -- NOTE: the closures and the final body are going to be stuck inside a + -- lambda binding for the stack and stackIncl by mkPolySpecLambda, below, + -- so we increment their context lenghts for their SpecTermM computations + withIncCtxLen 2 $ forM base_recs_in $ \(fun_lrt,fun_tm) -> mkSpecRecFunM fun_lrt fun_tm - body <- unSpecTerm body_in + body <- withIncCtxLen 2 $ unSpecTerm body_in final_st <- get let all_recs = base_recs ++ specStExtraRecs final_st let local_stk = specRecFunsStack all_recs From c86557255782a649d9c03c5cf47820a9fdbd38ba Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Sun, 27 Aug 2023 09:58:19 -0700 Subject: [PATCH 074/305] added applyCallClos to the prelude --- saw-core/prelude/Prelude.sawcore | 42 +++++++++++++++++++++++---- saw-core/src/Verifier/SAW/OpenTerm.hs | 9 +++++- 2 files changed, 44 insertions(+), 7 deletions(-) diff --git a/saw-core/prelude/Prelude.sawcore b/saw-core/prelude/Prelude.sawcore index d60512c88b..0b83b0e8cb 100644 --- a/saw-core/prelude/Prelude.sawcore +++ b/saw-core/prelude/Prelude.sawcore @@ -2755,6 +2755,42 @@ orS E stack a m1 m2 = primitive CallS : (E:EvType) -> (stk:FunStack) -> (R:LetRecType) -> LRTClos stk (LRT_SpecM R) -> SpecM E stk (LRTArg stk R); +-- A monadic function whose type is described by the encoding lrt +SpecFun : EvType -> FunStack -> LetRecType -> sort 0; +SpecFun E stk lrt = + lrtPi stk lrt (\ (args:LRTInput stk lrt) -> + SpecM E stk (LRTOutput stk lrt args)); + +-- Apply a closure to all of its arguments and then call it using CallS +applyCallClos : (E:EvType) -> (stk:FunStack) -> (lrt:LetRecType) -> + LRTClos stk lrt -> SpecFun E stk lrt; +applyCallClos E stk lrt = + LetRecType#rec + (\ (lrt:LetRecType) -> LRTClos stk lrt -> SpecFun E stk lrt) + (\ (R:LetRecType) (_:LRTClos stk R -> SpecFun E stk R) + (clos:LRTClos stk (LRT_SpecM R)) -> + CallS E stk R clos) + (\ (A:sort 0) (B:A -> LetRecType) + (rec:(a:A) -> LRTClos stk (B a) -> SpecFun E stk (B a)) + (clos:LRTClos stk (LRT_FunDep A B)) (a:A) -> + rec a (applyLRTClosDep stk A B clos a)) + (\ (A:LetRecType) (_:LRTClos stk A -> SpecFun E stk A) + (B:LetRecType) (rec:LRTClos stk B -> SpecFun E stk B) + (clos:LRTClos stk (LRT_FunClos A B)) (arg:LRTArg stk A) -> + rec (applyLRTClosClos stk A B clos arg)) + (\ (A:sort 0) (_:LRTClos stk (LRT_Type A)) (v:Void) -> + elimVoid (SpecM E stk (LRTOutput stk (LRT_Type A) v)) v) + (\ (F:sort 0 -> sort 0 -> sort 0) (validF:ValidLRTFunctor2 F) + (A:LetRecType) (_:LRTClos stk A -> SpecFun E stk A) + (B:LetRecType) (_:LRTClos stk B -> SpecFun E stk B) + (_:LRTClos stk (LRT_BinOp F validF A B)) (v:Void) -> + elimVoid (SpecM E stk (LRTOutput stk (LRT_BinOp F validF A B) v)) v) + (\ (A:sort 0) (B:A -> LetRecType) + (_:(a:A) -> LRTClos stk (B a) -> SpecFun E stk (B a)) + (_:LRTClos stk (LRT_Sigma A B)) (v:Void) -> + elimVoid (SpecM E stk (LRTOutput stk (LRT_Sigma A B) v)) v) + lrt; + -- -- The category of stack inclusions @@ -2870,12 +2906,6 @@ weakenRightStackIncl stk1 stk2 = -- Spec definitions -- --- A monadic function whose type is described by the encoding lrt -SpecFun : EvType -> FunStack -> LetRecType -> sort 0; -SpecFun E stk lrt = - lrtPi stk lrt (\ (args:LRTInput stk lrt) -> - SpecM E stk (LRTOutput stk lrt args)); - -- A monadic function that is polymorphic in its function stack PolySpecFun : EvType -> FunStack -> LetRecType -> sort 1; PolySpecFun E stk lrt = diff --git a/saw-core/src/Verifier/SAW/OpenTerm.hs b/saw-core/src/Verifier/SAW/OpenTerm.hs index 31bda63c44..553cddf873 100644 --- a/saw-core/src/Verifier/SAW/OpenTerm.hs +++ b/saw-core/src/Verifier/SAW/OpenTerm.hs @@ -88,7 +88,7 @@ module Verifier.SAW.OpenTerm ( SpecTerm(), defineSpecOpenTerm, lambdaPureSpecTerm, lambdaPureSpecTermMulti, lrtClosTypeSpecTerm, sawLetPureSpecTerm, lrtToTypeSpecTerm, mkBaseClosSpecTerm, mkFreshClosSpecTerm, callClosSpecTerm, applyClosSpecTerm, - importDefSpecTerm, monadicSpecOp, + applyCallClosSpecTerm, importDefSpecTerm, monadicSpecOp, specMTypeSpecTerm, returnSpecTerm, bindSpecTerm, errorSpecTerm, ) where @@ -1104,6 +1104,13 @@ callClosSpecTerm tp clos = applySpecTermMulti (monadicSpecOp "Prelude.CallS") [openTermSpecTerm tp, clos] +-- | Convert a closure of a given @LetRecType@ to a spec function and apply it +-- to some number of arguments +applyCallClosSpecTerm :: OpenTerm -> SpecTerm -> [SpecTerm] -> SpecTerm +applyCallClosSpecTerm lrt clos args = + applySpecTermMulti (monadicSpecOp "Prelude.applyCallClos") + (openTermSpecTerm lrt : clos : args) + -- | Import another spec definition inside a spec definition, and return the -- @SpecFun@ that calls its body importDefSpecTerm :: OpenTerm -> SpecTerm From 70e7594d116b69da29c1f117624a3d61e394f154 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Sun, 27 Aug 2023 09:58:50 -0700 Subject: [PATCH 075/305] fixed translation code that was only applying closures to apply and call them --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 35 +++++++++---------- 1 file changed, 17 insertions(+), 18 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 3f3e2b73cb..aac9c0f995 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -1337,10 +1337,10 @@ lambdaExprCtxPure ctx m = lambdaPureTransM "e" tptrans (\ectx -> inCtxTransM ectx m) -- | Translate all types in a Crucible context and pi-abstract over them -piExprCtx :: TransInfo info => CruCtx ctx -> TransM info ctx OpenTerm -> - TransM info RNil OpenTerm -piExprCtx ctx m = - translateClosed ctx >>= \tptrans -> +piExprCtxPure :: TransInfo info => CruCtx ctx -> TransM info ctx OpenTerm -> + TransM info RNil OpenTerm +piExprCtxPure ctx m = + translateCtxPure ctx >>= \tptrans -> piTransM "e" tptrans (\ectx -> inCtxTransM ectx m) -- | Translate all types in a Crucible context and pi-abstract over them, @@ -1949,7 +1949,7 @@ mkLOwnedTransTermFromTerm :: ExprTransCtx ctx -> RelPermsTypeTrans ctx ps_in -> mkLOwnedTransTermFromTerm ectx ttr_inF ttr_outF vars_out t = LOwnedTransM $ \(ExprCtxExt ectx') loInfo k -> let lrt = piExprPermLRT (exprCtxType ectx) ttr_inF ttr_outF - t_app = applyClosSpecTerm lrt t (transTerms $ lownedInfoPCtx loInfo) + t_app = applyCallClosSpecTerm lrt t (transTerms $ lownedInfoPCtx loInfo) t_ret_trans = tupleTypeTrans $ ttr_outF ectx t_ret_tp = typeTransTupleType $ ttr_outF ectx in bindSpecTerm t_ret_tp (typeDescType $ lownedInfoRetType loInfo) t_app $ @@ -2080,7 +2080,8 @@ weakenLOwnedTrans tp_in tp_out (LOwnedTrans {..}) = lotrTerm = weakenLOwnedTransTerm (tp_out lotrECtx) lotrTerm, .. } -- | Convert an 'LOwnedTrans' to a closure that gets added to the list of --- closures for the current spec definition +-- closures for the current spec definition, and partially apply that closure to +-- the current expression context and its @ps_extra@ terms lownedTransTerm :: Mb ctx (ExprPerms ps_in) -> LOwnedTrans ctx ps_extra ps_in ps_out -> SpecTerm lownedTransTerm (mbExprPermsMembers -> @@ -2145,7 +2146,7 @@ funTransTermToClos (FunTransFun lrt f) = mkFreshClosSpecTerm lrt (const f) -- | Apply a 'FunTransTerm' to a list of arguments applyFunTransTerm :: FunTransTerm -> [SpecTerm] -> SpecTerm -applyFunTransTerm (FunTransClos lrt clos) = applyClosSpecTerm lrt clos +applyFunTransTerm (FunTransClos lrt clos) = applyCallClosSpecTerm lrt clos applyFunTransTerm (FunTransFun _ f) = applyTermLikeMulti f @@ -4410,9 +4411,8 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of case some_lotr of SomeLOwnedTrans lotr -> bindSpecMTransM - (callClosSpecTerm - lrt_out (applyClosSpecTerm - lrt (lownedTransTerm ps_in lotr) (transTerms pctx_in))) + (applyCallClosSpecTerm + lrt (lownedTransTerm ps_in lotr) (transTerms pctx_in)) ps_out_trans "endl_ps" (\pctx_out -> @@ -5662,7 +5662,7 @@ translateCallEntry nm entry_trans mb_tops_args mb_ghosts = arg_membs <- itiPermStackVars <$> ask let e_args = RL.map (flip RL.get expr_ctx) arg_membs i_args <- itiPermStack <$> ask - return (applyClosSpecTerm lrt clos_tm + return (applyCallClosSpecTerm lrt clos_tm (exprCtxToTerms e_args ++ permCtxToTerms i_args)) Nothing -> -- Otherwise, continue translating with the target entrypoint, with all @@ -6206,8 +6206,8 @@ translateCFGIxCall cfg ix = lambdaExprCtx ctx $ lambdaPermCtx (funPermIns fun_perm) $ \pctx -> (infoCtx <$> ask) >>= \ectx -> return $ - applyClosSpecTerm lrt (mkBaseClosSpecTerm ix) (transTerms ectx ++ - transTerms pctx) + applyCallClosSpecTerm lrt (mkBaseClosSpecTerm ix) (transTerms ectx ++ + transTerms pctx) -- | The components of the spec definition that a CFG translates to. Note that, -- if the CFG is for a function that is mutually recursive with other functions, @@ -6406,16 +6406,15 @@ translateCompleteFunPerm sc env fun_perm = translateCompleteType :: SharedContext -> PermEnv -> TypeRepr tp -> IO Term translateCompleteType sc env typ_perm = completeNormOpenTerm sc $ typeTransType1 $ - runNilTypeTransM env noChecks $ translate $ emptyMb typ_perm + runNilTypeTransM env noChecks $ translateType True typ_perm -- | 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)) + completeNormOpenTerm sc $ runNilTypeTransM env noChecks $ + piExprCtxPure args (typeTransType1 <$> translateType True (mbLift ret)) -- | Translate an input list of 'ValuePerms' and an output 'ValuePerm' to a pure -- SAW core function type, not in the @SpecM@ monad. It is an error if any of @@ -6426,7 +6425,7 @@ translateCompletePureFun :: SharedContext -> PermEnv -> Mb ctx (ValuePerm ret) -- ^ Return type perm -> IO Term translateCompletePureFun sc env ctx ps_in p_out = - completeNormOpenTerm sc $ runNilTypeTransM env noChecks $ piExprCtx ctx $ + completeNormOpenTerm sc $ runNilTypeTransM env noChecks $ piExprCtxPure ctx $ do ps_in_trans <- translate ps_in p_out_trans <- translate p_out let justOrPanic (Just x) = x From f360be7e283f3594c9a09366471c34ab430da769 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Sun, 27 Aug 2023 10:05:53 -0700 Subject: [PATCH 076/305] added the LRT_SpecM constructor to LRT output types --- heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index aac9c0f995..0a141647cf 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -101,6 +101,11 @@ weakenMemberR :: RAssign any ctx2 -> Member ctx1 a -> Member (ctx1 :++: ctx2) a weakenMemberR MNil memb = memb weakenMemberR (ctx1 :>: _) memb = Member_Step (weakenMemberR ctx1 memb) +-- | Apply the @LRT_SpecM@ combinator to turn a @LetRecType@ for a return value +-- into a monadic type +specLRTOpenTerm :: OpenTerm -> OpenTerm +specLRTOpenTerm lrt = ctorTermLike "Prelude.LRT_SpecM" [lrt] + ---------------------------------------------------------------------- -- * Type Translations @@ -3052,7 +3057,7 @@ instance TransInfo info => Refl -> fmap typeDescFromLRT $ piLRTExprCtxApp tops $ arrowLRTPermCtx (mbCombine tops_prxs perms_in) $ - fmap typeDescLRT $ + fmap (specLRTOpenTerm . typeDescLRT) $ translateRetType rets (mbCombine (RL.append tops_prxs rets_prxs) perms_out) @@ -3089,7 +3094,7 @@ piExprPermLRT :: PureTypeTrans (ExprTransCtx ctx) -> piExprPermLRT etps ptps_in_F ptps_out_F = piLRTTrans "e" etps $ \ectx -> arrowLRTTrans (ptps_in_F ectx) $ - typeDescLRT $ typeTransTupleDesc (ptps_out_F ectx) + specLRTOpenTerm $ typeDescLRT $ typeTransTupleDesc (ptps_out_F ectx) -- | Build the return type for a function; FIXME: documentation translateRetType :: TransInfo info => CruCtx rets -> From 4fb514dcb3d5f42dded5a22a49fe4fe53ea29c07 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 28 Aug 2023 09:58:25 -0700 Subject: [PATCH 077/305] fixed the translation of the folding and unfolding functions for recursive shapes and permissions to use exprCtxPureTypeTerms for the arguments, to match their definitions --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 33 +++++++++++++------ 1 file changed, 23 insertions(+), 10 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 0a141647cf..2509053005 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -4523,6 +4523,10 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of , [nuMP| PExpr_NamedShape _ _ _ args |] <- mbMatch $ fmap llvmBlockShape bp -> do ttrans <- translateSimplImplOutHead mb_simpl args_trans <- translate args + let args_tms = case exprCtxPureTypeTerms args_trans of + Just tms -> map openTermLike tms + Nothing -> panic "translateSimplImpl" + ["SImpl_IntroLLVMBlockNamed: found impure terms"] fold_id <- case fold_ids of [nuP| Just (fold_id,_) |] -> return fold_id @@ -4530,8 +4534,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of withPermStackM id (\(pctx :>: ptrans_x) -> pctx :>: typeTransF ttrans [applyGlobalTermLike (mbLift fold_id) - (transTerms args_trans ++ - transTerms ptrans_x)]) + (args_tms ++ transTerms ptrans_x)]) m -- Intro for a defined named shape (the other case) is a no-op @@ -4543,6 +4546,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of 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 @@ -4551,6 +4555,10 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of , [nuMP| PExpr_NamedShape _ _ _ args |] <- mbMatch $ fmap llvmBlockShape bp -> do ttrans <- translateSimplImplOutHead mb_simpl args_trans <- translate args + let args_tms = case exprCtxPureTypeTerms args_trans of + Just tms -> map openTermLike tms + Nothing -> panic "translateSimplImpl" + ["SImpl_IntroLLVMBlockNamed: found impure terms"] unfold_id <- case fold_ids of [nuP| Just (_,unfold_id) |] -> return unfold_id @@ -4558,8 +4566,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of withPermStackM id (\(pctx :>: ptrans_x) -> pctx :>: typeTransF ttrans [applyGlobalTermLike (mbLift unfold_id) - (transTerms args_trans ++ - transTerms ptrans_x)]) + (args_tms ++ transTerms ptrans_x)]) m -- Intro for a defined named shape (the other case) is a no-op @@ -4684,25 +4691,31 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of [nuMP| SImpl_FoldNamed _ (NamedPerm_Rec rp) args _ |] -> do args_trans <- translate args + let args_tms = case exprCtxPureTypeTerms args_trans of + Just tms -> map openTermLike tms + Nothing -> panic "translateSimplImpl" + ["SImpl_FoldNamed: impure arguments"] ttrans <- translateSimplImplOutHead mb_simpl let fold_ident = mbLift $ fmap recPermFoldFun rp withPermStackM id (\(pctx :>: ptrans_x) -> pctx :>: typeTransF ttrans [applyGlobalTermLike fold_ident - (transTerms args_trans - ++ transTerms ptrans_x)]) + (args_tms ++ transTerms ptrans_x)]) m [nuMP| SImpl_UnfoldNamed _ (NamedPerm_Rec rp) args _ |] -> do args_trans <- translate args - ttrans <- translateSimplImplOutHead mb_simpl + let args_tms = case exprCtxPureTypeTerms args_trans of + Just tms -> map openTermLike tms + Nothing -> panic "translateSimplImpl" + ["SImpl_UnfoldNamed: impure arguments"] + ttrans <- tupleTypeTrans <$> translateSimplImplOutHead mb_simpl let unfold_ident = mbLift $ fmap recPermUnfoldFun rp withPermStackM id (\(pctx :>: ptrans_x) -> pctx :>: - typeTransF (tupleTypeTrans ttrans) [applyGlobalTermLike unfold_ident - (transTerms args_trans - ++ [transTerm1 ptrans_x])]) + typeTransF ttrans [applyGlobalTermLike unfold_ident + (args_tms ++ [transTerm1 ptrans_x])]) m [nuMP| SImpl_FoldNamed _ (NamedPerm_Defined _) _ _ |] -> From f8704f6b2110f2d29450cd491da81d14a3c0f6b7 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 28 Aug 2023 17:27:12 -0700 Subject: [PATCH 078/305] fixed importDefSpecTerm to turn the import into a SpecImp --- saw-core/src/Verifier/SAW/OpenTerm.hs | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/saw-core/src/Verifier/SAW/OpenTerm.hs b/saw-core/src/Verifier/SAW/OpenTerm.hs index 553cddf873..e014565041 100644 --- a/saw-core/src/Verifier/SAW/OpenTerm.hs +++ b/saw-core/src/Verifier/SAW/OpenTerm.hs @@ -865,10 +865,14 @@ specStSetClosBody clos_ix body st = st { specStExtraRecsRev = setNthClosBodyRev (fromIntegral clos_ix) body (specStExtraRecsRev st) } -specStInsImport :: OpenTerm -> SpecTermState -> (Natural, SpecTermState) -specStInsImport def st = +-- | Add a spec import with the given @LetRecType@ and body to the list of +-- imported spec definitions in a 'SpecTermState' +specStInsImport :: OpenTerm -> OpenTerm -> SpecTermState -> + (Natural, SpecTermState) +specStInsImport lrt def st = + let imp = ctorOpenTerm "Prelude.Build_SpecImp" [specStEvType st, lrt, def] in (fromIntegral (length $ specStImportsRev st), - st { specStImportsRev = def : specStImportsRev st }) + st { specStImportsRev = imp : specStImportsRev st }) initSpecTermState :: OpenTerm -> Natural -> Int -> SpecTermState initSpecTermState ev n ctx_len = @@ -1113,9 +1117,9 @@ applyCallClosSpecTerm lrt clos args = -- | Import another spec definition inside a spec definition, and return the -- @SpecFun@ that calls its body -importDefSpecTerm :: OpenTerm -> SpecTerm -importDefSpecTerm def = SpecTerm $ - do (imp_ix, st) <- specStInsImport def <$> get +importDefSpecTerm :: OpenTerm -> OpenTerm -> SpecTerm +importDefSpecTerm lrt def = SpecTerm $ + do (imp_ix, st) <- specStInsImport lrt def <$> get put st return $ applySpecInfoTerm (applyStackInclOp "Prelude.callNthImportS") From 7be0221a9e9fab9a595ea70fa721ee598ebc930b Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 28 Aug 2023 17:27:40 -0700 Subject: [PATCH 079/305] changed all uses of the LetRecType eliminator to use the explicit eliminator --- saw-core/prelude/Prelude.sawcore | 29 ++++++++++++++++++++++------- 1 file changed, 22 insertions(+), 7 deletions(-) diff --git a/saw-core/prelude/Prelude.sawcore b/saw-core/prelude/Prelude.sawcore index 0b83b0e8cb..929d7f070a 100644 --- a/saw-core/prelude/Prelude.sawcore +++ b/saw-core/prelude/Prelude.sawcore @@ -2443,6 +2443,21 @@ data LetRecType : sort 1 where { LRT_Sigma : (a:sort 0) -> (a -> LetRecType) -> LetRecType; } +-- The explicit recursor for LetRecType +LetRecType__rec : + (P : LetRecType -> sort 1) -> ((R:LetRecType) -> P R -> P (LRT_SpecM R)) -> + ((A : sort 0) -> (B : A -> LetRecType) -> ((a:A) -> P (B a)) -> + P (LRT_FunDep A B)) -> + ((A:LetRecType) -> P A -> (B:LetRecType) -> P B -> P (LRT_FunClos A B)) -> + ((A : sort 0) -> P (LRT_Type A)) -> + ((F : sort 0 -> sort 0 -> sort 0) -> (v : ValidLRTFunctor2 F) -> + (A:LetRecType) -> P A -> (B:LetRecType) -> P B -> P (LRT_BinOp F v A B)) -> + ((A : sort 0) -> (B : A -> LetRecType) -> ((a:A) -> P (B a)) -> + P (LRT_Sigma A B)) -> + (lrt:LetRecType) -> P lrt; +LetRecType__rec P f1 f2 f3 f4 f5 f6 lrt = + LetRecType#rec P f1 f2 f3 f4 f5 f6 lrt; + -- A trivially inhabied "default" LetRecType, representing void -> void default_lrt : LetRecType; default_lrt = LRT_FunDep Void (\ (_:Void) -> LRT_SpecM (LRT_Type Void)); @@ -2495,7 +2510,7 @@ primitive LRTClos : FunStack -> LetRecType -> sort 0; -- to its corresponding SAW core type LRTArg : FunStack -> LetRecType -> sort 0; LRTArg stack argTp = - LetRecType#rec + LetRecType__rec (\ (_:LetRecType) -> sort 0) (\ (R:LetRecType) (_:sort 0) -> LRTClos stack (LRT_SpecM R)) (\ (A:sort 0) (B:A -> LetRecType) (_:A -> sort 0) -> @@ -2525,7 +2540,7 @@ applyLRTClosNRet stk = (\ (_:Nat) -> LetRecType -> sort 0) (LRTClos stk) (\ (_:Nat) (rec:LetRecType -> sort 0) (lrt:LetRecType) -> - LetRecType#rec + LetRecType__rec (\ (_:LetRecType) -> sort 0) (\ (R:LetRecType) (_:sort 0) -> Void -> Void) (\ (A:sort 0) (B:A -> LetRecType) (_:A -> sort 0) -> @@ -2549,7 +2564,7 @@ applyLRTClosN stk = (\ (n':Nat) (rec:(lrt:LetRecType) -> LRTClos stk lrt -> applyLRTClosNRet stk n' lrt) (lrt_top:LetRecType) -> - LetRecType#rec + LetRecType__rec (\ (lrt:LetRecType) -> LRTClos stk lrt -> applyLRTClosNRet stk (Succ n') lrt) (\ (R:LetRecType) @@ -2579,7 +2594,7 @@ applyLRTClosN stk = -- any LetRecType that is not a valid monadic function type. LRTInput : FunStack -> LetRecType -> sort 0; LRTInput stack lrt = - LetRecType#rec + LetRecType__rec (\ (lrt:LetRecType) -> sort 0) (\ (_:LetRecType) (_:sort 0) -> #()) (\ (A:sort 0) (_:A -> LetRecType) (rec:A -> sort 0) -> @@ -2598,7 +2613,7 @@ LRTInput stack lrt = -- function to the arguments a1 ... an in an LRTInput LRTOutput : (stack:FunStack) -> (lrt:LetRecType) -> LRTInput stack lrt -> sort 0; LRTOutput stack lrt = - LetRecType#rec + LetRecType__rec (\ (lrt:LetRecType) -> LRTInput stack lrt -> sort 0) (\ (R:LetRecType) (_:LRTInput stack R -> sort 0) (_:#()) -> LRTArg stack R) (\ (A:sort 0) (B:A -> LetRecType) @@ -2626,7 +2641,7 @@ LRTOutput stack lrt = lrtPi : (stack:FunStack) -> (lrt:LetRecType) -> (LRTInput stack lrt -> sort 0) -> sort 0; lrtPi stack lrt_top = - LetRecType#rec + LetRecType__rec (\ (lrt:LetRecType) -> (LRTInput stack lrt -> sort 0) -> sort 0) (\ (R:LetRecType) (_:(LRTInput stack R -> sort 0) -> sort 0) (rec:#() -> sort 0) -> rec ()) @@ -2765,7 +2780,7 @@ SpecFun E stk lrt = applyCallClos : (E:EvType) -> (stk:FunStack) -> (lrt:LetRecType) -> LRTClos stk lrt -> SpecFun E stk lrt; applyCallClos E stk lrt = - LetRecType#rec + LetRecType__rec (\ (lrt:LetRecType) -> LRTClos stk lrt -> SpecFun E stk lrt) (\ (R:LetRecType) (_:LRTClos stk R -> SpecFun E stk R) (clos:LRTClos stk (LRT_SpecM R)) -> From 6fe20fcae581ae5a8895e9cdbd0648eecb69ac58 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 28 Aug 2023 17:28:39 -0700 Subject: [PATCH 080/305] fixed permEnvAddGlobalSymFun to use a spec definition translation instead of a translation term --- heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs index 12613e7fed..e88f4ec60d 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs @@ -8279,14 +8279,15 @@ permEnvAddOpaqueShape env nm args mb_len tp_id = SomeNamedShape (NamedShape nm args $ OpaqueShapeBody mb_len tp_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 definition 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 (GlobalTransTerms [t]) + PermEnvGlobalEntry sym p (GlobalTransDef t) : permEnvGlobalSyms env } -- | Add a global symbol with 0 or more function permissions to a 'PermEnv' From f7ad5b05b4609c90d5689d29917b1bdb2f57d1fb Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 28 Aug 2023 17:28:59 -0700 Subject: [PATCH 081/305] fixed up call to importDefSpecTerm to use its new def --- heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 2509053005..9407f9aef4 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -5936,7 +5936,7 @@ translateLLVMStmt mb_stmt m = case mbMatch mb_stmt of let ptrans = PTrans_Conj [APTrans_LLVMFunPtr (mbLift fun_tp) $ PTrans_Fun fun_perm $ FunTransFun lrt $ - importDefSpecTerm spec_def] + importDefSpecTerm lrt spec_def] withPermStackM (:>: Member_Base) (:>: extPermTrans ETrans_LLVM ptrans) m Just (_, GlobalTransDef _) -> From c3ce460b1ce6e9b3fdfa60a9f5837ba0e57ce171 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 28 Aug 2023 17:29:24 -0700 Subject: [PATCH 082/305] removed old CompM Coq files from _CoqProject --- saw-core-coq/coq/_CoqProject | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/saw-core-coq/coq/_CoqProject b/saw-core-coq/coq/_CoqProject index 1ca05b0d81..55a6369542 100644 --- a/saw-core-coq/coq/_CoqProject +++ b/saw-core-coq/coq/_CoqProject @@ -5,8 +5,8 @@ generated/CryptolToCoq/SAWCorePrelude.v generated/CryptolToCoq/CryptolPrimitivesForSAWCore.v generated/CryptolToCoq/CryptolMPrimitivesForSAWCore.v -handwritten/CryptolToCoq/CompM.v -handwritten/CryptolToCoq/CompMExtra.v +# handwritten/CryptolToCoq/CompM.v +# handwritten/CryptolToCoq/CompMExtra.v handwritten/CryptolToCoq/CoqVectorsExtra.v handwritten/CryptolToCoq/CryptolPrimitivesForSAWCoreExtra.v handwritten/CryptolToCoq/SAWCoreBitvectors.v From eaafb04a1d9696f811c0174f760c1afe146b604e Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Tue, 29 Aug 2023 16:27:58 -0700 Subject: [PATCH 083/305] Got all the Coq export stuff for the prelude working --- saw-core-coq/coq/_CoqProject | 4 +- .../coq/handwritten/CryptolToCoq/Everything.v | 4 +- .../CryptolToCoq/SAWCoreBitvectors.v | 13 ++- .../CryptolToCoq/SAWCorePrelude_proofs.v | 8 +- .../CryptolToCoq/SAWCoreScaffolding.v | 6 +- .../CryptolToCoq/SAWCoreVectorsAsCoqVectors.v | 11 ++- .../coq/handwritten/CryptolToCoq/SpecMExtra.v | 2 +- .../SAW/Translation/Coq/SpecialTreatment.hs | 97 ++++++++++++------- 8 files changed, 85 insertions(+), 60 deletions(-) diff --git a/saw-core-coq/coq/_CoqProject b/saw-core-coq/coq/_CoqProject index 55a6369542..693407ac57 100644 --- a/saw-core-coq/coq/_CoqProject +++ b/saw-core-coq/coq/_CoqProject @@ -3,7 +3,7 @@ generated/CryptolToCoq/SAWCorePrelude.v generated/CryptolToCoq/CryptolPrimitivesForSAWCore.v -generated/CryptolToCoq/CryptolMPrimitivesForSAWCore.v +# generated/CryptolToCoq/CryptolMPrimitivesForSAWCore.v # handwritten/CryptolToCoq/CompM.v # handwritten/CryptolToCoq/CompMExtra.v @@ -15,6 +15,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/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..46715ee877 100644 --- a/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreBitvectors.v +++ b/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreBitvectors.v @@ -10,7 +10,6 @@ From Coq Require Import Logic.Eqdep. From CryptolToCoq Require Import SAWCorePrelude. From CryptolToCoq Require Import SAWCoreScaffolding. From CryptolToCoq Require Import SAWCoreVectorsAsCoqVectors. -From CryptolToCoq Require Import CompMExtra. Import SAWCorePrelude. Import VectorNotations. @@ -105,13 +104,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 +489,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 +786,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/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..301bd12bf7 100644 --- a/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreScaffolding.v +++ b/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreScaffolding.v @@ -5,12 +5,8 @@ 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 Export EnTreeSpecs. (*** *** sawLet diff --git a/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreVectorsAsCoqVectors.v b/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreVectorsAsCoqVectors.v index 866c163a67..1412eddb93 100644 --- a/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreVectorsAsCoqVectors.v +++ b/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreVectorsAsCoqVectors.v @@ -68,8 +68,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 +213,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 +235,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 +480,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/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/src/Verifier/SAW/Translation/Coq/SpecialTreatment.hs b/saw-core-coq/src/Verifier/SAW/Translation/Coq/SpecialTreatment.hs index 672876b0a6..aaa2484114 100644 --- a/saw-core-coq/src/Verifier/SAW/Translation/Coq/SpecialTreatment.hs +++ b/saw-core-coq/src/Verifier/SAW/Translation/Coq/SpecialTreatment.hs @@ -198,7 +198,10 @@ sawDefinitionsModule :: ModuleName sawDefinitionsModule = mkModuleName ["SAWCoreScaffolding"] entreeSpecsModule :: ModuleName -entreeSpecsModule = mkModuleName ["EnTree.EnTreeSpecs"] +entreeSpecsModule = mkModuleName ["SpecM"] + +polyListModule :: ModuleName +polyListModule = mkModuleName ["PolyList"] sawVectorDefinitionsModule :: TranslationConfiguration -> ModuleName sawVectorDefinitionsModule (TranslationConfiguration {..}) = @@ -490,44 +493,75 @@ sawCorePreludeSpecialTreatmentMap configuration = , ("test_fun6", skip) ] + -- LetRecTypes + ++ + [ ("LetRecType", mapsTo entreeSpecsModule "LetRecType") + , ("LRT_SpecM", mapsToExpl entreeSpecsModule "LRT_SpecM") + , ("LRT_FunDep", mapsToExpl entreeSpecsModule "LRT_FunDep") + , ("LRT_FunClos", mapsToExpl entreeSpecsModule "LRT_FunClos") + , ("LRT_Type", mapsToExpl entreeSpecsModule "LRT_Type") + , ("LRT_BinOp", mapsToExpl entreeSpecsModule "LRT_BinOp") + , ("LRT_Sigma", mapsToExpl entreeSpecsModule "LRT_Sigma") + , ("LetRecType__rec", mapsToExpl entreeSpecsModule "LetRecType_rect") + , ("ValidLRTFunctor2", mapsToExpl entreeSpecsModule "ColimFunctor2") + , ("pair_ValidLRTFunctor2", mapsToExpl entreeSpecsModule "Pair_ColimFunctor2") + , ("either_ValidLRTFunctor2", skip) -- FIXME: implement this! + , ("LRT_Either", skip) -- FIXME: implement this! + , ("Vec_ValidLRTFunctor2", mapsTo entreeSpecsModule "Vec_ColimFunctor2") + ] + -- The specification monad ++ [ ("EvType", mapsTo entreeSpecsModule "EvType") , ("Build_EvType", mapsTo entreeSpecsModule "Build_EvType") , ("evTypeType", mapsTo entreeSpecsModule "evTypeType") , ("evRetType", mapsTo entreeSpecsModule "evRetType") - , ("SpecM", mapsToExpl entreeSpecsModule "SpecM") + , ("FunStack", mapsTo entreeSpecsModule "FunStack") + , ("nthLRT", mapsToExpl entreeSpecsModule "nthLRT") + , ("LRTClos", mapsTo entreeSpecsModule "LRTClos") + , ("LRTArg" , mapsTo entreeSpecsModule "LRTArg") + , ("applyLRTClosDep" , mapsTo entreeSpecsModule "applyLRTClosDep") + , ("applyLRTClosClos" , mapsTo entreeSpecsModule "applyLRTClosClos") + , ("applyLRTClosNRet" , mapsTo entreeSpecsModule "applyLRTClosNRet") + , ("applyLRTClosN" , mapsTo entreeSpecsModule "applyLRTClosN") + , ("LRTInput", mapsToExpl entreeSpecsModule "LRTInput") + , ("LRTOutput", mapsToExpl entreeSpecsModule "LRTOutput") + , ("lrtPi", mapsToExpl entreeSpecsModule "lrtPi") + , ("StackCall", mapsToExpl entreeSpecsModule "StackCall") + , ("StackCallOfArgs", mapsToExpl entreeSpecsModule "StackCallOfArgs") + , ("StackCallRet", mapsToExpl entreeSpecsModule "StackCallRet") + , ("FunStackE", mapsToExpl entreeSpecsModule "FunStackE") + , ("FunStackERet", mapsToExpl entreeSpecsModule "FunStackERet") + , ("SpecM", mapsTo entreeSpecsModule "SpecM") , ("retS", mapsToExpl entreeSpecsModule "RetS") , ("bindS", mapsToExpl entreeSpecsModule "BindS") + , ("triggerS", mapsToExpl entreeSpecsModule "TriggerS") , ("errorS", mapsToExpl entreeSpecsModule "ErrorS") - , ("liftStackS", mapsToExpl entreeSpecsModule "liftStackS") - , ("existsS", mapsToExplInferArg "SpecM.ExistsS" 3) , ("forallS", mapsToExplInferArg "SpecM.ForallS" 3) - , ("FunStack", mapsTo entreeSpecsModule "FunStack") - , ("LRTInput", mapsToExpl entreeSpecsModule "LRTInput") - , ("LRTOutput", mapsToExpl entreeSpecsModule "LRTOutput") - , ("lrt1Pi", mapsToExpl entreeSpecsModule "lrtPi") - , ("lrtLambda", mapsToExpl entreeSpecsModule "lrtLambda") - , ("nthLRT", mapsToExpl entreeSpecsModule "nthLRT") - , ("FrameCall", mapsToExpl entreeSpecsModule "FrameCall") - , ("FrameCallOfArgs", mapsToExpl entreeSpecsModule "FrameCallOfArgs") - , ("mkFrameCall", mapsToExpl entreeSpecsModule "mkFrameCall") - , ("FrameCallRet", mapsToExpl entreeSpecsModule "FrameCallRet") - , ("LRTType", mapsToExpl entreeSpecsModule "LRTType") - , ("FrameTuple", mapsToExpl entreeSpecsModule "FrameTuple") - , ("callS", mapsToExpl entreeSpecsModule "CallS") - , ("multiFixS", mapsToExpl entreeSpecsModule "MultiFixS") - , ("FunStackE_type", mapsToExpl entreeSpecsModule "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"]]))) + , ("existsS", mapsToExplInferArg "SpecM.ExistsS" 3) + , ("assumeS", mapsToExpl entreeSpecsModule "AssumeS") + , ("assertS", mapsToExpl entreeSpecsModule "AssertS") + , ("CallS", mapsToExpl entreeSpecsModule "CallS") + , ("SpecFun", mapsTo entreeSpecsModule "SpecFun") + , ("applyCallClos", skip) -- FIXME: translation bug! + , ("stackIncl", mapsTo entreeSpecsModule "stackIncl") + , ("StackTuple", mapsTo entreeSpecsModule "StackTuple") + , ("SpecDef", mapsTo entreeSpecsModule "SpecDef") + , ("SpecImp", mapsTo entreeSpecsModule "SpecImp") + , ("Build_SpecImp", mapsTo entreeSpecsModule "Build_SpecImp") + , ("SpecImpType", mapsTo entreeSpecsModule "SpecImpType") + , ("defineSpecStack", mapsTo entreeSpecsModule "defineSpecStack") + , ("defineSpec", mapsTo entreeSpecsModule "defineSpec") + , ("mkLocalLRTClos", mapsTo entreeSpecsModule "mkLocalLRTClos") + , ("nthImport", mapsTo entreeSpecsModule "nthImport") + , ("callNthImportS", mapsTo entreeSpecsModule "callNthImportS") + , ("SpecPreRel", mapsToExpl entreeSpecsModule "SpecPreRel") , ("SpecPostRel", mapsToExpl entreeSpecsModule "SpecPostRel") , ("eqPreRel", mapsToExpl entreeSpecsModule "eqPreRel") , ("eqPostRel", mapsToExpl entreeSpecsModule "eqPostRel") - , ("refinesS", mapsToExpl entreeSpecsModule "spec_refines") - , ("refinesS_eq", mapsToExpl entreeSpecsModule "spec_refines_eq") + , ("refinesS", skip) + , ("refinesS_eq", skip) ] -- Dependent pairs @@ -549,18 +583,11 @@ sawCorePreludeSpecialTreatmentMap configuration = -- Lists at sort 1 ++ - [ ("List1", mapsToExpl datatypesModule "list") - , ("Nil1", mapsToExpl datatypesModule "nil") - , ("Cons1", mapsToExpl datatypesModule "cons") + [ ("List1", mapsToExpl polyListModule "plist") + , ("Nil1", mapsToExpl polyListModule "pnil") + , ("Cons1", mapsToExpl polyListModule "pcons") ] - -- Lists at sort 2 - ++ - [ ("List2", mapsToExpl datatypesModule "list") - , ("Nil2", mapsToExpl datatypesModule "nil") - , ("Cons2", mapsToExpl datatypesModule "cons") - , ("List2__rec", mapsToExpl datatypesModule "list_rect") - ] escapeIdent :: String -> String escapeIdent str From bf877ff605c9e2a31f5fa350db430dbda98fa5fc Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 31 Aug 2023 14:25:53 -0700 Subject: [PATCH 084/305] changed Void to translate to the Empty_set type in the Coq standard library --- .../src/Verifier/SAW/Translation/Coq/SpecialTreatment.hs | 4 ++++ 1 file changed, 4 insertions(+) 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 aaa2484114..e801bf8b7a 100644 --- a/saw-core-coq/src/Verifier/SAW/Translation/Coq/SpecialTreatment.hs +++ b/saw-core-coq/src/Verifier/SAW/Translation/Coq/SpecialTreatment.hs @@ -279,6 +279,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. From 4686bf23ec275c4a6811c3a274fb7c21f83f517d Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 31 Aug 2023 14:26:28 -0700 Subject: [PATCH 085/305] removed SpecMExtra from the defaul list of imports in Coq files generated by Heapster --- src/SAWScript/HeapsterBuiltins.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/SAWScript/HeapsterBuiltins.hs b/src/SAWScript/HeapsterBuiltins.hs index f25625c7a3..b3bd0ea9a7 100644 --- a/src/SAWScript/HeapsterBuiltins.hs +++ b/src/SAWScript/HeapsterBuiltins.hs @@ -1243,8 +1243,7 @@ heapster_export_coq _bic _opts henv filename = 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 SAWCoreBitvectors.\n" }, translateSAWModule coq_trans_conf saw_mod] liftIO $ writeFile filename (show coq_doc) From 421c1248a0f5e618e57e9bad94db3f9acfb9291b Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 31 Aug 2023 15:05:17 -0700 Subject: [PATCH 086/305] Changed the type-checker to *not* normalize argument types in lambdas and pis when they are type-checked, in order to make the Coq translation work in cases where these argument types have identifiers that translate to alternate Coq definitions --- saw-core/src/Verifier/SAW/SCTypeCheck.hs | 22 ++++++++++++++-------- saw-core/src/Verifier/SAW/Typechecker.hs | 11 +++++++---- 2 files changed, 21 insertions(+), 12 deletions(-) diff --git a/saw-core/src/Verifier/SAW/SCTypeCheck.hs b/saw-core/src/Verifier/SAW/SCTypeCheck.hs index 9d94d5eef2..20700dac03 100644 --- a/saw-core/src/Verifier/SAW/SCTypeCheck.hs +++ b/saw-core/src/Verifier/SAW/SCTypeCheck.hs @@ -79,9 +79,9 @@ type TCState = Map TermIndex Term -- * Memoizes the most general type inferred for each expression; AND -- -- * Can throw 'TCError's -type TCM a = +type TCM = ReaderT (SharedContext, Maybe ModuleName, [(LocalName, Term)]) - (StateT TCState (ExceptT TCError IO)) a + (StateT TCState (ExceptT TCError IO)) -- | Run a type-checking computation in a given context, starting from the empty -- memoization table @@ -400,16 +400,22 @@ instance TypeInfer (TermF Term) where -- special-case handling itself typeInfer ftf typeInfer (Lambda x a rhs) = - do a_tptrm <- typeInferCompleteWHNF a + do a_whnf <- typeInferCompleteWHNF a -- NOTE: before adding a type to the context, we want to be sure it is in - -- WHNF, so we don't have to normalize each time we look up a var type - rhs_tptrm <- withVar x (typedVal a_tptrm) $ typeInferComplete rhs + -- WHNF, so we don't have to normalize each time we look up a var type, + -- but we want to leave the non-normalized value of a in the returned + -- term, so we create a_tptrm with the type of a_whnf but the value of a + rhs_tptrm <- withVar x (typedVal a_whnf) $ typeInferComplete rhs + let a_tptrm = TypedTerm a (typedType a_whnf) typeInfer (Lambda x a_tptrm rhs_tptrm) typeInfer (Pi x a rhs) = - do a_tptrm <- typeInferCompleteWHNF a + do a_whnf <- typeInferCompleteWHNF a -- NOTE: before adding a type to the context, we want to be sure it is in - -- WHNF, so we don't have to normalize each time we look up a var type - rhs_tptrm <- withVar x (typedVal a_tptrm) $ typeInferComplete rhs + -- WHNF, so we don't have to normalize each time we look up a var type, + -- but we want to leave the non-normalized value of a in the returned + -- term, so we create a_typed with the type of a_whnf but the value of a + rhs_tptrm <- withVar x (typedVal a_whnf) $ typeInferComplete rhs + let a_tptrm = TypedTerm a (typedType a_whnf) typeInfer (Pi x a_tptrm rhs_tptrm) typeInfer (Constant ec _) = -- NOTE: this special case is to prevent us from re-type-checking the diff --git a/saw-core/src/Verifier/SAW/Typechecker.hs b/saw-core/src/Verifier/SAW/Typechecker.hs index a7c21ad96e..1ad0b42757 100644 --- a/saw-core/src/Verifier/SAW/Typechecker.hs +++ b/saw-core/src/Verifier/SAW/Typechecker.hs @@ -208,10 +208,13 @@ typeInferCompleteTerm (Un.App f arg) = >>= typeInferComplete typeInferCompleteTerm (Un.Lambda _ [] t) = typeInferComplete t typeInferCompleteTerm (Un.Lambda p ((Un.termVarLocalName -> x, tp) : ctx) t) = - do tp_trm <- typeInferCompleteWHNF tp - -- Normalize (the Term value of) tp before putting it into the context. See - -- the documentation for withVar. - body <- withVar x (typedVal tp_trm) $ + do tp_trm <- typeInferComplete tp + -- NOTE: we need the type of x to be normalized when we add it to the + -- context in withVar, but we do not want to normalize this type in the + -- output, as the contract for typeInferComplete only normalizes the type, + -- so we use the unnormalized tp_trm in the return + tp_whnf <- typeCheckWHNF $ typedVal tp_trm + body <- withVar x tp_whnf $ typeInferComplete $ Un.Lambda p ctx t typeInferComplete (Lambda x tp_trm body) typeInferCompleteTerm (Un.Pi _ [] t) = typeInferComplete t From b74252b8e8a1f4992d8a5ae8771f2bb00060d667 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 31 Aug 2023 20:09:26 -0700 Subject: [PATCH 087/305] added the termIsClosed function to test if a SAW core term is closed --- saw-core/src/Verifier/SAW/Term/Functor.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/saw-core/src/Verifier/SAW/Term/Functor.hs b/saw-core/src/Verifier/SAW/Term/Functor.hs index 581e1682ef..1caeca2369 100644 --- a/saw-core/src/Verifier/SAW/Term/Functor.hs +++ b/saw-core/src/Verifier/SAW/Term/Functor.hs @@ -60,7 +60,7 @@ module Verifier.SAW.Term.Functor , BitSet, emptyBitSet, inBitSet, unionBitSets, intersectBitSets , decrBitSet, multiDecrBitSet, completeBitSet, singletonBitSet, bitSetElems , smallestBitSetElem - , looseVars, smallestFreeVar + , looseVars, smallestFreeVar, termIsClosed ) where import Data.Bits @@ -609,3 +609,7 @@ looseVars (Unshared f) = freesTermF (fmap looseVars f) -- | Compute the value of the smallest variable in the term, if any. smallestFreeVar :: Term -> Maybe Int smallestFreeVar = smallestBitSetElem . looseVars + +-- | Test whether a 'Term' is closed, i.e., has no free variables +termIsClosed :: Term -> Bool +termIsClosed t = looseVars t == emptyBitSet From 599a1778edf2e3b6d0b80756af91bdbd45c073fa Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 31 Aug 2023 20:10:41 -0700 Subject: [PATCH 088/305] refactored the saw-core-coq translator so that all the local variable information is in a reader effect and not a state effect, making it clearer where in the translator code variables are bound; also fixed #1927 --- .../src/Verifier/SAW/Translation/Coq.hs | 2 +- .../SAW/Translation/Coq/CryptolModule.hs | 8 +- .../Verifier/SAW/Translation/Coq/SAWModule.hs | 14 +- .../src/Verifier/SAW/Translation/Coq/Term.hs | 477 ++++++++++-------- 4 files changed, 275 insertions(+), 226 deletions(-) diff --git a/saw-core-coq/src/Verifier/SAW/Translation/Coq.hs b/saw-core-coq/src/Verifier/SAW/Translation/Coq.hs index 1d8c99bbd7..fd781cd27c 100644 --- a/saw-core-coq/src/Verifier/SAW/Translation/Coq.hs +++ b/saw-core-coq/src/Verifier/SAW/Translation/Coq.hs @@ -121,7 +121,7 @@ translateTermAsDeclImports configuration name t tp = do doc <- TermTranslation.translateDefDoc configuration - (TermTranslation.TranslationReader Nothing) + Nothing [] name t tp return $ vcat [preamble configuration, hardline <> doc] diff --git a/saw-core-coq/src/Verifier/SAW/Translation/Coq/CryptolModule.hs b/saw-core-coq/src/Verifier/SAW/Translation/Coq/CryptolModule.hs index 5af77b41ea..c736b7a65c 100644 --- a/saw-core-coq/src/Verifier/SAW/Translation/Coq/CryptolModule.hs +++ b/saw-core-coq/src/Verifier/SAW/Translation/Coq/CryptolModule.hs @@ -3,7 +3,7 @@ module Verifier.SAW.Translation.Coq.CryptolModule where -import Control.Lens (over, set, view) +import Control.Lens (over, view) import Control.Monad (forM) import Control.Monad.State (modify) import qualified Data.Map as Map @@ -27,9 +27,7 @@ translateTypedTermMap defs = forM defs translateAndRegisterEntry translateAndRegisterEntry (name, t, tp) = do let nameStr = unpackIdent (nameIdent name) decl <- - TermTranslation.withLocalTranslationState $ - do modify $ set TermTranslation.localEnvironment [nameStr] - t_trans <- TermTranslation.translateTerm t + do t_trans <- TermTranslation.translateTerm t tp_trans <- TermTranslation.translateTerm tp return $ TermTranslation.mkDefinition nameStr t_trans tp_trans modify $ over TermTranslation.globalDeclarations (nameStr :) @@ -55,7 +53,7 @@ translateCryptolModule sc env configuration globalDecls (CryptolModule _ tm) = (reverse . view TermTranslation.topLevelDeclarations . snd <$> TermTranslation.runTermTranslationMonad configuration - (TermTranslation.TranslationReader Nothing) -- TODO: this should be Just no? + Nothing -- TODO: this should be Just no? globalDecls [] (translateTypedTermMap defs)) diff --git a/saw-core-coq/src/Verifier/SAW/Translation/Coq/SAWModule.hs b/saw-core-coq/src/Verifier/SAW/Translation/Coq/SAWModule.hs index 60c7c617c9..eca5a410f3 100644 --- a/saw-core-coq/src/Verifier/SAW/Translation/Coq/SAWModule.hs +++ b/saw-core-coq/src/Verifier/SAW/Translation/Coq/SAWModule.hs @@ -42,14 +42,14 @@ import Verifier.SAW.Translation.Coq.Monad -- import Debug.Trace type ModuleTranslationMonad m = - M.TranslationMonad TermTranslation.TranslationReader () m + M.TranslationMonad (Maybe ModuleName) () m runModuleTranslationMonad :: M.TranslationConfiguration -> Maybe ModuleName -> (forall m. ModuleTranslationMonad m => m a) -> Either (M.TranslationError Term) (a, ()) runModuleTranslationMonad configuration modName = - M.runTranslationMonad configuration (TermTranslation.TranslationReader modName) () + M.runTranslationMonad configuration modName () dropPi :: Coq.Term -> Coq.Term dropPi (Coq.Pi (_ : t) r) = Coq.Pi t r @@ -93,22 +93,22 @@ translateDataType (DataType {..}) = translateNamed name = do let inductiveName = name (inductiveParameters, inductiveIndices) <- - liftTermTranslationMonad $ do - ps <- TermTranslation.translateParams dtParams - ixs <- TermTranslation.translateParams dtIndices + liftTermTranslationMonad $ + TermTranslation.translateParams dtParams $ \ps -> + TermTranslation.translateParams dtIndices $ \ixs -> -- Translating the indices of a data type should never yield -- Inhabited constraints, so the result of calling -- `translateParams dtIndices` above should only return Binders and not -- any ImplicitBinders. Moreover, `translateParams` always returns -- Binders where the second field is `Just t`, where `t` is the type. - let errorBecause msg = error $ "translateDataType.translateNamed: " ++ msg + let errorBecause msg = error $ "translateDataType.translateNamed: " ++ msg in let bs = map (\case Coq.Binder s (Just t) -> Coq.PiBinder (Just s) t Coq.Binder _ Nothing -> errorBecause "encountered a Binder without a Type" Coq.ImplicitBinder{} -> errorBecause "encountered an implicit binder") - ixs + ixs in return (ps, bs) let inductiveSort = TermTranslation.translateSort dtSort inductiveConstructors <- mapM (translateCtor inductiveParameters) dtCtors 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 07af2861b8..bc6b338054 100644 --- a/saw-core-coq/src/Verifier/SAW/Translation/Coq/Term.hs +++ b/saw-core-coq/src/Verifier/SAW/Translation/Coq/Term.hs @@ -35,7 +35,8 @@ import qualified Control.Monad.Fail as Fail import Control.Monad.Reader hiding (fail, fix) import Control.Monad.State hiding (fail, fix, state) import Data.Char (isDigit) -import qualified Data.IntMap as IntMap +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IntMap import Data.List (intersperse, sortOn) import Data.Maybe (fromMaybe) import qualified Data.Map as Map @@ -63,8 +64,34 @@ traceTerm :: String -> Term -> a -> a traceTerm ctx t a = trace (ctx ++ ": " ++ showTerm t) a -} -newtype TranslationReader = TranslationReader +-- | A Coq identifier used for sharing subterms through let-bindings, annotated +-- with a 'Bool' flag indicating whether the shared subterm is closed, i.e., has +-- no free variables +data SharedName = SharedName { sharedNameIdent :: Coq.Ident, + sharedNameIsClosed :: Bool } + deriving Show + +-- | The read-only state for translating terms +data TranslationReader = TranslationReader { _currentModule :: Maybe ModuleName + -- ^ The current Coq module for the translation + + , _localEnvironment :: [Coq.Ident] + -- ^ The list of Coq identifiers associated with the current SAW core + -- Bruijn-indexed local variables in scope, innermost (index 0) first + + , _unavailableIdents :: Set.Set Coq.Ident + -- ^ The set of Coq identifiers that are either reserved or already in use. + -- To avoid shadowing, fresh identifiers should be chosen to be disjoint + -- from this set. + + , _sharedNames :: IntMap SharedName + -- ^ Index of identifiers for repeated subterms that have been lifted out + -- into a let expression + + , _nextSharedName :: Coq.Ident + -- ^ The next available name to be used for a let-bound shared + -- sub-expression } deriving (Show) @@ -73,44 +100,113 @@ makeLenses ''TranslationReader data TranslationState = TranslationState { _globalDeclarations :: [String] - -- ^ Some Cryptol terms seem to capture the name and body of some functions - -- they use (whether from the Cryptol prelude, or previously defined in the - -- same file). We want to translate those exactly once, so we need to keep - -- track of which ones have already been translated. + -- ^ Some Cryptol terms seem to capture the name and body of some functions + -- they use (whether from the Cryptol prelude, or previously defined in the + -- same file). We want to translate those exactly once, so we need to keep + -- track of which ones have already been translated. , _topLevelDeclarations :: [Coq.Decl] - -- ^ Because some terms capture their dependencies, translating one term may - -- result in multiple declarations: one for the term itself, but also zero or - -- many for its dependencies. We store all of those in this, so that a caller - -- of the translation may retrieve all the declarations needed to translate - -- the term. The translation function itself will return only the declaration - -- for the term being translated. - - , _localEnvironment :: [Coq.Ident] - -- ^ The list of Coq identifiers for de Bruijn-indexed local - -- variables, innermost (index 0) first. - - , _unavailableIdents :: Set.Set Coq.Ident - -- ^ The set of Coq identifiers that are either reserved or already - -- in use. To avoid shadowing, fresh identifiers should be chosen to - -- be disjoint from this set. - - , _sharedNames :: IntMap.IntMap Coq.Ident - -- ^ Index of identifiers for repeated subterms that have been - -- lifted out into a let expression. - - , _nextSharedName :: Coq.Ident - -- ^ The next available name to be used for a let-bound shared - -- sub-expression. + -- ^ Because some terms capture their dependencies, translating one term may + -- result in multiple declarations: one for the term itself, but also zero + -- or many for its dependencies. We store all of those in this, so that a + -- caller of the translation may retrieve all the declarations needed to + -- translate the term. The translation function itself will return only the + -- declaration for the term being translated. } deriving (Show) makeLenses ''TranslationState +-- | The constraint stating that 'm' can be used for term translation. This +-- requires that it have reader effects for 'TranslationReader' and state +-- effects for 'TranslationState'. type TermTranslationMonad m = TranslationMonad TranslationReader TranslationState m +-- | Get just the 'TranslationReader' component of the reader value +askTrr :: TermTranslationMonad m => m TranslationReader +askTrr = otherConfiguration <$> ask + +-- | Modify just the 'TranslationReader' component of the reader value +localTrr :: TermTranslationMonad m => + (TranslationReader -> TranslationReader) -> m a -> m a +localTrr f = + local (\r -> r { otherConfiguration = f (otherConfiguration r) }) + +-- | Take a Coq identifier that ends in a number (i.e., a sequence of digits) +-- and add 1 to that number, viewing an identifier with no trailing number as +-- ending in 0 +nextVariant :: Coq.Ident -> Coq.Ident +nextVariant = reverse . go . reverse + where + go :: String -> String + go (c : cs) + | c == '9' = '0' : go cs + | isDigit c = succ c : cs + go cs = '1' : cs + +-- | Find an fresh, as-yet-unused variant of the given Coq identifier +freshVariant :: TermTranslationMonad m => Coq.Ident -> m Coq.Ident +freshVariant x = + do used <- view unavailableIdents <$> askTrr + let ident0 = x + let findVariant i = if Set.member i used then findVariant (nextVariant i) else i + return $ findVariant ident0 + +-- | Locally mark a Coq identifier as being used in the translation during a +-- translation computation, so that computation does not shadow it +withUsedCoqIdent :: TermTranslationMonad m => Coq.Ident -> m a -> m a +withUsedCoqIdent ident m = + localTrr (over unavailableIdents (Set.insert ident)) m + +-- | Translate a local name from a saw-core binder into a fresh Coq identifier +translateLocalIdent :: TermTranslationMonad m => LocalName -> m Coq.Ident +translateLocalIdent x = freshVariant (escapeIdent (Text.unpack x)) + +-- | Generate a fresh, unused Coq identifier from a SAW core name and mark it as +-- unavailable in the supplied translation computation +withFreshIdent :: TermTranslationMonad m => LocalName -> (Coq.Ident -> m a) -> + m a +withFreshIdent n f = + do n_coq <- translateLocalIdent n + withUsedCoqIdent n_coq $ f n_coq + +-- | Invalidate all shared subterms that are not closed in a translation +invalidateOpenSharing :: TermTranslationMonad m => m a -> m a +invalidateOpenSharing = + localTrr (over sharedNames $ IntMap.filter sharedNameIsClosed) + +-- | Run a translation in a context with one more SAW core variable with the +-- given name. Pass the corresponding Coq identifier used for this SAW core +-- variable to the computation in which it is bound. This invalidates all +-- non-closed shared names, since sharing does not +withSAWVar :: TermTranslationMonad m => LocalName -> (Coq.Ident -> m a) -> m a +withSAWVar n m = + invalidateOpenSharing $ withFreshIdent n $ \n_coq -> + localTrr (over localEnvironment (n_coq :)) $ m n_coq + +-- | Find a fresh name generated from 'nextSharedName' to use in place of the +-- supplied 'Term' with the supplied index, and associate that index with the +-- fresh name in the 'sharedNames' sharing map. Pass the name that was generated +-- to the computation. +withSharedTerm :: TermTranslationMonad m => TermIndex -> Term -> + (Coq.Ident -> m a) -> m a +withSharedTerm idx t f = + do ident <- (view nextSharedName <$> askTrr) >>= freshVariant + let sh_nm = SharedName ident $ termIsClosed t + localTrr (set nextSharedName (nextVariant ident) . + over sharedNames (IntMap.insert idx sh_nm)) $ + withUsedCoqIdent ident $ f ident + +-- | Use 'withSharedTerm' to mark a list of terms as being shared +withSharedTerms :: TermTranslationMonad m => [(TermIndex,Term)] -> + ([Coq.Ident] -> m a) -> m a +withSharedTerms [] f = f [] +withSharedTerms ((idx,t):ts) f = + withSharedTerm idx t $ \n -> withSharedTerms ts $ \ns -> f (n:ns) + + -- | The set of reserved identifiers in Coq, obtained from section -- "Gallina Specification Language" of the Coq reference manual. -- @@ -149,23 +245,27 @@ getNamesOfAllDeclarations = view allDeclarations <$> get allDeclarations = to (\ (TranslationState {..}) -> namedDecls _topLevelDeclarations ++ _globalDeclarations) +-- | Run a term translation computation runTermTranslationMonad :: TranslationConfiguration -> - TranslationReader -> + Maybe ModuleName -> [String] -> [Coq.Ident] -> (forall m. TermTranslationMonad m => m a) -> Either (TranslationError Term) (a, TranslationState) -runTermTranslationMonad configuration r globalDecls localEnv = - runTranslationMonad configuration r +runTermTranslationMonad configuration mname globalDecls localEnv = + runTranslationMonad configuration + (TranslationReader { + _currentModule = mname + , _localEnvironment = localEnv + , _unavailableIdents = Set.union reservedIdents (Set.fromList localEnv) + , _sharedNames = IntMap.empty + , _nextSharedName = "var__0" }) (TranslationState { _globalDeclarations = globalDecls , _topLevelDeclarations = [] - , _localEnvironment = localEnv - , _unavailableIdents = Set.union reservedIdents (Set.fromList localEnv) - , _sharedNames = IntMap.empty - , _nextSharedName = "var__0" }) +-- | Return a Coq term for an error computation with the given string message errorTermM :: TermTranslationMonad m => String -> m Coq.Term errorTermM str = return $ Coq.App (Coq.Var "error") [Coq.StringLit str] @@ -294,13 +394,10 @@ flatTermFToExpr tf = -- traceFTermF "flatTermFToExpr" tf $ -- (ix1 : _) -> ... -> (ixn : _) -> d ps ixs -> sort -- to get the type of the recursor, we compute -- (ix1 : _) -> ... -> (ixn : _) -> (x:d ps ixs) -> motive ixs x - do let (bs, _srt) = asPiList motiveTy - (varsT,bindersT) <- unzip <$> - (forM bs $ \ (b, bType) -> do - bTypeT <- translateTerm bType - b' <- freshenAndBindName b - return (Coq.Var b', Coq.PiBinder (Just b') bTypeT)) - + let (bs, _srt) = asPiList motiveTy in + translateBinders bs $ \bndrs -> + do let varsT = map (Coq.Var . bindTransIdent) bndrs + let bindersT = concat $ map bindTransToPiBinder bndrs motiveT <- translateTerm motive let bodyT = Coq.App motiveT varsT return $ Coq.Pi bindersT bodyT @@ -388,45 +485,17 @@ asApplyAllRecognizer :: Recognizer Term (Term, [Term]) asApplyAllRecognizer t = do _ <- asApp t return $ asApplyAll t --- | Run a translation, but keep some changes to the translation state local to --- that computation, restoring parts of the original translation state before --- returning. -withLocalTranslationState :: TermTranslationMonad m => m a -> m a -withLocalTranslationState action = do - before <- get - result <- action - after <- get - put (TranslationState - -- globalDeclarations is **not** restored, because we want to translate each - -- global declaration exactly once! - { _globalDeclarations = view globalDeclarations after - -- topLevelDeclarations is **not** restored, because it accumulates the - -- declarations witnessed in a given module so that we can extract it. - , _topLevelDeclarations = view topLevelDeclarations after - -- localEnvironment **is** restored, because the identifiers added to it - -- during translation are local to the term that was being translated. - , _localEnvironment = view localEnvironment before - -- unavailableIdents **is** restored, because the extra identifiers - -- unavailable in the term that was translated are local to it. - , _unavailableIdents = view unavailableIdents before - -- sharedNames **is** restored, because we are leaving the scope of the - -- locally shared names. - , _sharedNames = view sharedNames before - -- nextSharedName **is** restored, because we are leaving the scope of the - -- last names used. - , _nextSharedName = view nextSharedName before - }) - return result - --- | Run a translation in the top-level translation state +-- | Run a translation in the top-level translation state with no free SAW +-- variables and no bound Coq identifiers withTopTranslationState :: TermTranslationMonad m => m a -> m a withTopTranslationState m = - withLocalTranslationState $ - do modify $ set localEnvironment [] - modify $ set unavailableIdents reservedIdents - modify $ set sharedNames IntMap.empty - modify $ set nextSharedName "var__0" - m + localTrr (\r -> + TranslationReader { + _currentModule = view currentModule r, + _localEnvironment = [], + _unavailableIdents = reservedIdents, + _sharedNames = IntMap.empty, + _nextSharedName = "var__0" }) m -- | Generate a Coq @Definition@ with a given name, body, and type, using the -- lambda-bound variable names for the variables if they are available @@ -443,85 +512,65 @@ mkDefinition name (Coq.Lambda bs t) (Coq.Pi bs' tp) Coq.Definition name bs (Just tp) t mkDefinition name t tp = Coq.Definition name [] (Just tp) t --- | Make sure a name is not used in the current environment, adding --- or incrementing a numeric suffix until we find an unused name. When --- we get one, add it to the current environment and return it. -freshenAndBindName :: TermTranslationMonad m => LocalName -> m Coq.Ident -freshenAndBindName n = - do n' <- translateLocalIdent n - modify $ over localEnvironment (n' :) - pure n' - mkLet :: (Coq.Ident, Coq.Term) -> Coq.Term -> Coq.Term mkLet (name, rhs) body = Coq.Let name [] Nothing rhs body --- | Given a list of 'LocalName's and their corresponding types (as 'Term's), --- return a list of explicit 'Binder's, for use representing the bound --- variables in 'Lambda's, 'Let's, etc. -translateParams :: - TermTranslationMonad m => - [(LocalName, Term)] -> m [Coq.Binder] -translateParams bs = concat <$> mapM translateParam bs - --- | Given a 'LocalName' and its type (as a 'Term'), return an explicit --- 'Binder', for use representing a bound variable in a 'Lambda', --- 'Let', etc. -translateParam :: - TermTranslationMonad m => - (LocalName, Term) -> m [Coq.Binder] -translateParam (n, ty) = - translateBinder n ty >>= \(n',ty',nhs) -> - return $ Coq.Binder n' (Just ty') : - map (\(nh,nhty) -> Coq.ImplicitBinder nh (Just nhty)) nhs - --- | Given a list of 'LocalName's and their corresponding types (as 'Term's) --- representing argument types and a 'Term' representing the return type, --- return the resulting 'Pi', with additional implicit arguments added after --- each instance of @isort@, @qsort@, etc. -translatePi :: TermTranslationMonad m => [(LocalName, Term)] -> Term -> m Coq.Term -translatePi binders body = withLocalTranslationState $ do - bindersT <- concat <$> mapM translatePiBinder binders - bodyT <- translateTermLet body - return $ Coq.Pi bindersT bodyT - --- | Given a 'LocalName' and its type (as a 'Term'), return an explicit --- 'PiBinder' followed by zero or more implicit 'PiBinder's representing --- additonal implicit typeclass arguments, added if the given type is @isort@, --- @qsort@, etc. -translatePiBinder :: - TermTranslationMonad m => (LocalName, Term) -> m [Coq.PiBinder] -translatePiBinder (n, ty) = - translateBinder n ty >>= \case - (n',ty',[]) - | n == "_" -> return [Coq.PiBinder Nothing ty'] - | otherwise -> return [Coq.PiBinder (Just n') ty'] - (n',ty',nhs) -> - return $ Coq.PiBinder (Just n') ty' : - map (\(nh,nhty) -> Coq.PiImplicitBinder (Just nh) nhty) nhs - --- | Given a 'LocalName' and its type (as a 'Term'), return the translation of --- the 'LocalName' as an 'Ident', the translation of the type as a 'Type', --- and zero or more additional 'Ident's and 'Type's representing additonal --- implicit typeclass arguments, added if the given type is @isort@, etc. -translateBinder :: - TermTranslationMonad m => - LocalName -> - Term -> - m (Coq.Ident,Coq.Type,[(Coq.Ident,Coq.Type)]) -translateBinder n ty@(asPiList -> (args, asSortWithFlags -> mb_sort)) = +-- | The result of translating a SAW core variable binding to Coq, including the +-- Coq identifier for the variable, the Coq translation of its type, and 0 or +-- more implicit Coq arguments that apply to the variable +data BindTrans = BindTrans { bindTransIdent :: Coq.Ident, + bindTransType :: Coq.Type, + bindTransImps :: [(Coq.Ident,Coq.Type)] } + +-- | Convert a 'BindTrans' to a list of Coq term-level binders +bindTransToBinder :: BindTrans -> [Coq.Binder] +bindTransToBinder (BindTrans {..}) = + Coq.Binder bindTransIdent (Just bindTransType) : + map (\(n,ty) -> Coq.ImplicitBinder n (Just ty)) bindTransImps + +-- | Convert a 'BindTrans' to a list of Coq type-level pi-abstraction binders +bindTransToPiBinder :: BindTrans -> [Coq.PiBinder] +bindTransToPiBinder (BindTrans { bindTransImps = [], .. }) + | bindTransIdent == "_" = [Coq.PiBinder Nothing bindTransType] +bindTransToPiBinder (BindTrans { bindTransImps = [], .. }) = + [Coq.PiBinder (Just bindTransIdent) bindTransType] +bindTransToPiBinder (BindTrans{..}) = + Coq.PiBinder (Just bindTransIdent) bindTransType : + map (\(n,ty) -> Coq.PiImplicitBinder (Just n) ty) bindTransImps + +-- | Given a 'LocalName' and its type (as a 'Term'), translate the 'LocalName' +-- to a Coq identifier, translate the type to a Coq term, and generate zero or +-- more additional 'Ident's and 'Type's representing additonal implicit +-- typeclass arguments, added if the given type is @isort@, etc. Pass all of +-- this information to the supplied computation, in which the SAW core variable +-- is bound to its Coq identifier. +translateBinder :: TermTranslationMonad m => LocalName -> Term -> + (BindTrans -> m a) -> m a +translateBinder n ty@(asPiList -> (args, asSortWithFlags -> mb_sort)) f = do ty' <- translateTerm ty - n' <- freshenAndBindName n let flagValues = sortFlagsToList $ maybe noFlags snd mb_sort flagLocalNames = [("Inh", "SAWCoreScaffolding.Inhabited"), ("QT", "QuantType")] - nhs <- forM (zip flagValues flagLocalNames) $ \(fi,(prefix,tc)) -> - if not fi then return [] - else do nhty <- translateImplicitHyp (Coq.Var tc) args (Coq.Var n') - nh <- translateLocalIdent (prefix <> "_" <> n) - return [(nh,nhty)] - return (n',ty',concat nhs) - --- | Given a typeclass (as a 'Term'), a list of 'LocalName's and their + withSAWVar n $ \n' -> + helper n' (zip flagValues flagLocalNames) (\imps -> + f $ BindTrans n' ty' imps) + where + helper _ [] g = g [] + helper n' ((True,(prefix,tc)):rest) g = + do nhty <- translateImplicitHyp (Coq.Var tc) args (Coq.Var n') + withFreshIdent (prefix <> "_" <> n) $ \nh -> + helper n' rest (g . ((nh,nhty) :)) + helper n' ((False,_):rest) g = helper n' rest g + +-- | Call 'translateBinder' on a list of SAW core bindings +translateBinders :: TermTranslationMonad m => [(LocalName,Term)] -> + ([BindTrans] -> m a) -> m a +translateBinders [] f = f [] +translateBinders ((n,ty):ns_tys) f = + translateBinder n ty $ \bnd -> + translateBinders ns_tys $ \bnds -> f (bnd : bnds) + +-- | Given a typeclass (as a Coq term), a list of 'LocalName's and their -- corresponding types (as 'Term's), and a type-level function with argument -- types given by the prior list, return a 'Pi' of the given arguments, inside -- of which is an 'App' of the typeclass to the fully-applied type-level @@ -530,92 +579,94 @@ translateImplicitHyp :: TermTranslationMonad m => Coq.Term -> [(LocalName, Term)] -> Coq.Term -> m Coq.Term translateImplicitHyp tc [] tm = return (Coq.App tc [tm]) -translateImplicitHyp tc args tm = withLocalTranslationState $ - do args' <- mapM (uncurry translateBinder) args - return $ Coq.Pi (concatMap mkPi args') - (Coq.App tc [Coq.App tm (map mkArg args')]) - where - mkPi (nm,ty,nhs) = - Coq.PiBinder (Just nm) ty : - map (\(nh,nhty) -> Coq.PiImplicitBinder (Just nh) nhty) nhs - mkArg (nm,_,_) = Coq.Var nm - --- | Translate a local name from a saw-core binder into a fresh Coq identifier. -translateLocalIdent :: TermTranslationMonad m => LocalName -> m Coq.Ident -translateLocalIdent x = freshVariant (escapeIdent (Text.unpack x)) +translateImplicitHyp tc args tm = + translateBinders args $ \args' -> + return $ Coq.Pi (concatMap mkPi args') (Coq.App tc [Coq.App tm (map mkArg args')]) + where + mkPi (BindTrans nm ty nhs) = + Coq.PiBinder (Just nm) ty : + map (\(nh,nhty) -> Coq.PiImplicitBinder (Just nh) nhty) nhs + mkArg b = Coq.Var $ bindTransIdent b --- | Find an fresh, as-yet-unused variant of the given Coq identifier. -freshVariant :: TermTranslationMonad m => Coq.Ident -> m Coq.Ident -freshVariant x = - do used <- view unavailableIdents <$> get - let ident0 = x - let findVariant i = if Set.member i used then findVariant (nextVariant i) else i - let ident = findVariant ident0 - modify $ over unavailableIdents (Set.insert ident) - return ident +-- | Given a list of 'LocalName's and their corresponding types (as 'Term's), +-- return a list of explicit 'Binder's, for use representing the bound variables +-- in 'Lambda's, 'Let's, etc. +translateParams :: TermTranslationMonad m => [(LocalName, Term)] -> + ([Coq.Binder] -> m a) -> m a +translateParams bs m = + translateBinders bs (m . concat . map bindTransToBinder) -nextVariant :: Coq.Ident -> Coq.Ident -nextVariant = reverse . go . reverse - where - go :: String -> String - go (c : cs) - | c == '9' = '0' : go cs - | isDigit c = succ c : cs - go cs = '1' : cs +-- | Given a list of 'LocalName's and their corresponding types (as 'Term's) +-- representing argument types and a 'Term' representing the return type, +-- return the resulting 'Pi', with additional implicit arguments added after +-- each instance of @isort@, @qsort@, etc. +translatePi :: TermTranslationMonad m => [(LocalName, Term)] -> Term -> m Coq.Term +translatePi binders body = + translatePiBinders binders $ \bindersT -> + do bodyT <- translateTermLet body + return $ Coq.Pi bindersT bodyT +-- | Given a 'LocalName' and its type (as a 'Term'), return an explicit +-- 'PiBinder' followed by zero or more implicit 'PiBinder's representing +-- additonal implicit typeclass arguments, added if the given type is @isort@, +-- @qsort@, etc. +translatePiBinders :: TermTranslationMonad m => [(LocalName, Term)] -> + ([Coq.PiBinder] -> m a) -> m a +translatePiBinders bs m = + translateBinders bs (m . concat . map bindTransToPiBinder) + +-- | Find all subterms of a SAW core term that should be shared, and generate +-- let-bindings in Coq to bind them to local variables. Translate SAW core term +-- using those let-bindings for the shared subterms. translateTermLet :: TermTranslationMonad m => Term -> m Coq.Term translateTermLet t = - withLocalTranslationState $ - do let counts = scTermCount False t - let locals = fmap fst $ IntMap.filter keep counts - names <- traverse (const nextName) locals - modify $ set sharedNames names - defs <- traverse translateTermUnshared locals + let occ_map = scTermCount False t + shares = IntMap.assocs $ fmap fst $ IntMap.filter keep occ_map + share_tms = map snd shares in + -- NOTE: larger terms always have later stAppIndices than their subterms, so + -- IntMap.elems above is guaranteed to return subterms before superterms; this + -- ensures that the right-hand sides in our nested let-bindings below only + -- refer to variables bound earlier, not later + withSharedTerms shares $ \names -> + do defs <- traverse translateTermUnshared share_tms body <- translateTerm t - -- NOTE: Larger terms always have later IDs than their subterms, - -- so ordering by VarIndex is a valid dependency order. - let binds = IntMap.elems (IntMap.intersectionWith (,) names defs) - pure (foldr mkLet body binds) + pure (foldr mkLet body $ zip names defs) where keep (t', n) = n > 1 && shouldMemoizeTerm t' - nextName = - do x <- view nextSharedName <$> get - x' <- freshVariant x - modify $ set nextSharedName (nextVariant x') - pure x' +-- | Translate a SAW core 'Term' to Coq, using let-bound Coq names when they are +-- associated with the given term for sharing translateTerm :: TermTranslationMonad m => Term -> m Coq.Term translateTerm t = case t of Unshared {} -> translateTermUnshared t STApp { stAppIndex = i } -> - do shared <- view sharedNames <$> get + do shared <- view sharedNames <$> askTrr case IntMap.lookup i shared of Nothing -> translateTermUnshared t - Just x -> pure (Coq.Var x) + Just sh -> pure (Coq.Var $ sharedNameIdent sh) +-- | Translate a SAW core 'Term' to Coq without using sharing translateTermUnshared :: TermTranslationMonad m => Term -> m Coq.Term -translateTermUnshared t = withLocalTranslationState $ do +translateTermUnshared t = do -- traceTerm "translateTerm" t $ -- NOTE: env is in innermost-first order - env <- view localEnvironment <$> get + env <- view localEnvironment <$> askTrr -- let t' = trace ("translateTerm: " ++ "env = " ++ show env ++ ", t =" ++ showTerm t) t -- case t' of case unwrapTermF t of FTermF ftf -> flatTermFToExpr ftf - Pi {} -> translatePi params e - where - (params, e) = asPiList t + Pi {} -> + let (params, e) = asPiList t in + translatePi params e - Lambda {} -> do - paramTerms <- translateParams params - e' <- translateTermLet e - pure (Coq.Lambda paramTerms e') - where - -- params are in normal, outermost first, order - (params, e) = asLambdaList t + Lambda {} -> + let (params, e) = asLambdaList t in + translateParams params $ \paramTerms -> + do e' <- translateTermLet e + return (Coq.Lambda paramTerms e') App {} -> -- asApplyAll: innermost argument first @@ -701,7 +752,7 @@ defaultTermForType typ = do -- type, and pass the results to the supplied function translateTermToDocWith :: TranslationConfiguration -> - TranslationReader -> + Maybe ModuleName -> [String] -> -- ^ globals that have already been translated [String] -> -- ^ string names of local variables in scope (Coq.Term -> Coq.Term -> Doc ann) -> @@ -723,7 +774,7 @@ translateTermToDocWith configuration r globalDecls localEnv f t tp_trm = do -- definition with the supplied name translateDefDoc :: TranslationConfiguration -> - TranslationReader -> + Maybe ModuleName -> [String] -> Coq.Ident -> Term -> Term -> Either (TranslationError Term) (Doc ann) From d8b5ab254dd7d2f0514364d73bf7055843244942 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 1 Sep 2023 07:06:03 -0700 Subject: [PATCH 089/305] moved linked_list.sawcore to use the new SpecDef framework --- heapster-saw/examples/linked_list.sawcore | 41 +++++++++++++++++++++++ 1 file changed, 41 insertions(+) diff --git a/heapster-saw/examples/linked_list.sawcore b/heapster-saw/examples/linked_list.sawcore index 5a6d008856..6c59f0331f 100644 --- a/heapster-saw/examples/linked_list.sawcore +++ b/heapster-saw/examples/linked_list.sawcore @@ -3,10 +3,51 @@ module linked_list where import Prelude; +test : Nat -> Sigma Nat (\ (n:Nat) -> (m:Nat) -> IsLeNat n (Succ m) -> Nat); +test x = + exists Nat (\ (n:Nat) -> (m:Nat) -> IsLeNat n (Succ m) -> Nat) + (addNat (Succ x) (Succ x)) + (\ (m:Nat) (pf:IsLeNat (addNat (Succ x) (Succ x)) (Succ m)) -> m); + List_def : (a:sort 0) -> sort 0; List_def a = List a; +-- The empty list of spec imports +emptyImps : (E:EvType) -> List1 (SpecImp E); +emptyImps E = Nil1 (SpecImp E); + +-- The function stack for simpleSpecDef +simpleSpecStack : (E:EvType) -> FunStack; +simpleSpecStack E = defineSpecStack E emptyFunStack (emptyImps E); + +-- Build a specification definition with no imports and no recursive functions +-- from its body +simpleSpecDef : (E:EvType) -> (lrt:LetRecType) -> + ((stk':FunStack) -> SpecFun E stk' lrt) -> + SpecDef E lrt; +simpleSpecDef E lrt bodyF = + defineSpec + E emptyFunStack lrt (Nil1 (SpecImp E)) + (\ (stk':FunStack) (incl:stackIncl (simpleSpecStack E) stk') -> ()) + (\ (stk':FunStack) (_:stackIncl (simpleSpecStack E) stk') -> bodyF stk'); + +{- mallocSpec : (sz:Vec 64 Bool) -> SpecM VoidEv emptyFunStack (BVVec 64 sz #()); mallocSpec sz = retS VoidEv emptyFunStack (BVVec 64 sz #()) (genBVVec 64 sz #() (\ (i:Vec 64 Bool) (_:is_bvult 64 i sz) -> ())); +-} + +-- Build a LetRecType for a dependent function type of 1 argument +lrtFromPi1 : (A:sort 0) -> (B:A -> sort 0) -> LetRecType; +lrtFromPi1 A B = LRT_FunDep A (\ (a:A) -> LRT_SpecM (LRT_Type (B a))); + +mallocLRT : LetRecType; +mallocLRT = lrtFromPi1 (Vec 64 Bool) (\ (sz:Vec 64 Bool) -> BVVec 64 sz #()); + +mallocSpec : SpecDef VoidEv mallocLRT; +mallocSpec = + simpleSpecDef VoidEv mallocLRT + (\ (stk':FunStack) (sz:Vec 64 Bool) -> + retS VoidEv stk' (BVVec 64 sz #()) + (genBVVec 64 sz #() (\ (i:Vec 64 Bool) (_:is_bvult 64 i sz) -> ()))); From 34690eb2ebff43afc38503a076a961c7e8a5547c Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 1 Sep 2023 08:10:55 -0700 Subject: [PATCH 090/305] replaced llvmZeroInitValue with a new function translateZeroInit that directly translates an LLVM zero initializer to a Heapster permission + SAW core term, so that we use repeatBVVec in the SAW term rather than a giant vector literal --- .../Verifier/SAW/Heapster/LLVMGlobalConst.hs | 45 ++++++++++++++----- 1 file changed, 34 insertions(+), 11 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/LLVMGlobalConst.hs b/heapster-saw/src/Verifier/SAW/Heapster/LLVMGlobalConst.hs index f470783359..66f301fca4 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/LLVMGlobalConst.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/LLVMGlobalConst.hs @@ -54,6 +54,14 @@ bvVecValueOpenTerm w tp ts def_tm = def_tm, natOpenTerm (natValue w), bvLitOfIntOpenTerm (intValue w) (fromIntegral $ length ts)] +-- | Helper function to build a SAW core term of type @BVVec w len a@, i.e., a +-- bitvector-indexed vector, containing a single repeated value +repeatBVVecOpenTerm :: NatRepr w -> OpenTerm -> OpenTerm -> OpenTerm -> + OpenTerm +repeatBVVecOpenTerm w len tp t = + applyOpenTermMulti (globalOpenTerm "Prelude.repeatBVVec") + [natOpenTerm (natValue w), len, tp, t] + -- | The information needed to translate an LLVM global to Heapster data LLVMTransInfo = LLVMTransInfo { llvmTransInfoEnv :: PermEnv, @@ -111,8 +119,7 @@ translateLLVMValue w _ (L.ValArray tp elems) = -- Generate a default element of type tp using the zero initializer; this is -- currently needed by bvVecValueOpenTerm - def_v <- llvmZeroInitValue tp - (_,def_tm) <- translateLLVMValue w tp def_v + (_,def_tm) <- translateZeroInit w tp -- Finally, build our array shape and SAW core value return (PExpr_ArrayShape (bvInt $ fromIntegral $ length elems) sh_len sh, @@ -150,7 +157,7 @@ translateLLVMValue w tp (L.ValString bytes) = translateLLVMValue w _ (L.ValConstExpr ce) = translateLLVMConstExpr w ce translateLLVMValue w tp L.ValZeroInit = - llvmZeroInitValue tp >>= translateLLVMValue w tp + translateZeroInit w tp translateLLVMValue _ _ v = traceAndZeroM ("translateLLVMValue does not yet handle:\n" ++ ppLLVMValue v) @@ -218,14 +225,30 @@ translateLLVMGEP _ tp vtrans ixs isZeroIdx _ = False -- | Build an LLVM value for a @zeroinitializer@ field of the supplied type -llvmZeroInitValue :: L.Type -> LLVMTransM (L.Value) -llvmZeroInitValue (L.PrimType (L.Integer _)) = return $ L.ValInteger 0 -llvmZeroInitValue (L.Array len tp) = - L.ValArray tp <$> replicate (fromIntegral len) <$> llvmZeroInitValue tp -llvmZeroInitValue (L.PackedStruct tps) = - L.ValPackedStruct <$> zipWith L.Typed tps <$> mapM llvmZeroInitValue tps -llvmZeroInitValue tp = - traceAndZeroM ("llvmZeroInitValue cannot handle type:\n" +translateZeroInit :: (1 <= w, KnownNat w) => NatRepr w -> L.Type -> + LLVMTransM (PermExpr (LLVMShapeType w), OpenTerm) +translateZeroInit w tp@(L.PrimType (L.Integer _)) = + translateLLVMValue w tp (L.ValInteger 0) +translateZeroInit w (L.Array len tp) = + -- First, translate the zero element and its type + do (sh, elem_tm) <- translateZeroInit w tp + (_, saw_tp) <- translateLLVMType w tp + + -- Compute the array stride as the length of the element shape + sh_len_expr <- lift $ llvmShapeLength sh + sh_len <- fromInteger <$> lift (bvMatchConstInt sh_len_expr) + + let arr_len = bvInt $ fromIntegral len + let saw_len = bvLitOfIntOpenTerm (intValue w) (fromIntegral len) + return (PExpr_ArrayShape arr_len sh_len sh, + repeatBVVecOpenTerm w saw_len saw_tp elem_tm) + +translateZeroInit w (L.PackedStruct tps) = + mapM (translateZeroInit w) tps >>= \(unzip -> (shs,ts)) -> + return (foldr PExpr_SeqShape PExpr_EmptyShape shs, tupleOpenTerm ts) + +translateZeroInit _ tp = + traceAndZeroM ("translateZeroInit cannot handle type:\n" ++ show (L.ppType tp)) -- | Top-level call to 'translateLLVMValue', running the 'LLVMTransM' monad From 7195c588c431ef28e13a84b16220d4a2c645dffe Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 1 Sep 2023 08:11:49 -0700 Subject: [PATCH 091/305] updated mbox_proofs.v after changes to the Coq translator --- heapster-saw/examples/mbox_proofs.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/heapster-saw/examples/mbox_proofs.v b/heapster-saw/examples/mbox_proofs.v index 7cba5315ee..6c3cc37968 100644 --- a/heapster-saw/examples/mbox_proofs.v +++ b/heapster-saw/examples/mbox_proofs.v @@ -64,7 +64,7 @@ Proof. (bvSub 64 i strt) len (bvSub 64 bv64_128 strt) - e + _1 pf1)) as H. rewrite bvAdd_Sub_cancel. intros H. rewrite (UIP_bool _ _ H pf). From f3fd4170cab36c635de888c2b096771ecf013786 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 1 Sep 2023 08:23:07 -0700 Subject: [PATCH 092/305] renamed askTrr and localTrr to askTR and localTR --- .../src/Verifier/SAW/Translation/Coq/Term.hs | 40 +++++++++---------- 1 file changed, 20 insertions(+), 20 deletions(-) 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 bc6b338054..01738f4570 100644 --- a/saw-core-coq/src/Verifier/SAW/Translation/Coq/Term.hs +++ b/saw-core-coq/src/Verifier/SAW/Translation/Coq/Term.hs @@ -125,13 +125,13 @@ type TermTranslationMonad m = TranslationMonad TranslationReader TranslationState m -- | Get just the 'TranslationReader' component of the reader value -askTrr :: TermTranslationMonad m => m TranslationReader -askTrr = otherConfiguration <$> ask +askTR :: TermTranslationMonad m => m TranslationReader +askTR = otherConfiguration <$> ask -- | Modify just the 'TranslationReader' component of the reader value -localTrr :: TermTranslationMonad m => +localTR :: TermTranslationMonad m => (TranslationReader -> TranslationReader) -> m a -> m a -localTrr f = +localTR f = local (\r -> r { otherConfiguration = f (otherConfiguration r) }) -- | Take a Coq identifier that ends in a number (i.e., a sequence of digits) @@ -149,7 +149,7 @@ nextVariant = reverse . go . reverse -- | Find an fresh, as-yet-unused variant of the given Coq identifier freshVariant :: TermTranslationMonad m => Coq.Ident -> m Coq.Ident freshVariant x = - do used <- view unavailableIdents <$> askTrr + do used <- view unavailableIdents <$> askTR let ident0 = x let findVariant i = if Set.member i used then findVariant (nextVariant i) else i return $ findVariant ident0 @@ -158,7 +158,7 @@ freshVariant x = -- translation computation, so that computation does not shadow it withUsedCoqIdent :: TermTranslationMonad m => Coq.Ident -> m a -> m a withUsedCoqIdent ident m = - localTrr (over unavailableIdents (Set.insert ident)) m + localTR (over unavailableIdents (Set.insert ident)) m -- | Translate a local name from a saw-core binder into a fresh Coq identifier translateLocalIdent :: TermTranslationMonad m => LocalName -> m Coq.Ident @@ -175,7 +175,7 @@ withFreshIdent n f = -- | Invalidate all shared subterms that are not closed in a translation invalidateOpenSharing :: TermTranslationMonad m => m a -> m a invalidateOpenSharing = - localTrr (over sharedNames $ IntMap.filter sharedNameIsClosed) + localTR (over sharedNames $ IntMap.filter sharedNameIsClosed) -- | Run a translation in a context with one more SAW core variable with the -- given name. Pass the corresponding Coq identifier used for this SAW core @@ -184,7 +184,7 @@ invalidateOpenSharing = withSAWVar :: TermTranslationMonad m => LocalName -> (Coq.Ident -> m a) -> m a withSAWVar n m = invalidateOpenSharing $ withFreshIdent n $ \n_coq -> - localTrr (over localEnvironment (n_coq :)) $ m n_coq + localTR (over localEnvironment (n_coq :)) $ m n_coq -- | Find a fresh name generated from 'nextSharedName' to use in place of the -- supplied 'Term' with the supplied index, and associate that index with the @@ -193,10 +193,10 @@ withSAWVar n m = withSharedTerm :: TermTranslationMonad m => TermIndex -> Term -> (Coq.Ident -> m a) -> m a withSharedTerm idx t f = - do ident <- (view nextSharedName <$> askTrr) >>= freshVariant + do ident <- (view nextSharedName <$> askTR) >>= freshVariant let sh_nm = SharedName ident $ termIsClosed t - localTrr (set nextSharedName (nextVariant ident) . - over sharedNames (IntMap.insert idx sh_nm)) $ + localTR (set nextSharedName (nextVariant ident) . + over sharedNames (IntMap.insert idx sh_nm)) $ withUsedCoqIdent ident $ f ident -- | Use 'withSharedTerm' to mark a list of terms as being shared @@ -489,13 +489,13 @@ asApplyAllRecognizer t = do _ <- asApp t -- variables and no bound Coq identifiers withTopTranslationState :: TermTranslationMonad m => m a -> m a withTopTranslationState m = - localTrr (\r -> - TranslationReader { - _currentModule = view currentModule r, - _localEnvironment = [], - _unavailableIdents = reservedIdents, - _sharedNames = IntMap.empty, - _nextSharedName = "var__0" }) m + localTR (\r -> + TranslationReader { + _currentModule = view currentModule r, + _localEnvironment = [], + _unavailableIdents = reservedIdents, + _sharedNames = IntMap.empty, + _nextSharedName = "var__0" }) m -- | Generate a Coq @Definition@ with a given name, body, and type, using the -- lambda-bound variable names for the variables if they are available @@ -641,7 +641,7 @@ translateTerm t = case t of Unshared {} -> translateTermUnshared t STApp { stAppIndex = i } -> - do shared <- view sharedNames <$> askTrr + do shared <- view sharedNames <$> askTR case IntMap.lookup i shared of Nothing -> translateTermUnshared t Just sh -> pure (Coq.Var $ sharedNameIdent sh) @@ -651,7 +651,7 @@ translateTermUnshared :: TermTranslationMonad m => Term -> m Coq.Term translateTermUnshared t = do -- traceTerm "translateTerm" t $ -- NOTE: env is in innermost-first order - env <- view localEnvironment <$> askTrr + env <- view localEnvironment <$> askTR -- let t' = trace ("translateTerm: " ++ "env = " ++ show env ++ ", t =" ++ showTerm t) t -- case t' of case unwrapTermF t of From 655a9cb4fa7669a2f737422e6ab442d3f6c890fb Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 1 Sep 2023 08:31:33 -0700 Subject: [PATCH 093/305] replaced a number of equality tests on the free variables of terms against emptyBitSet with the new termIsClosed function --- saw-core/src/Verifier/SAW/Rewriter.hs | 7 +++---- saw-core/src/Verifier/SAW/SharedTerm.hs | 8 ++++---- saw-core/src/Verifier/SAW/Simulator.hs | 12 ++++++------ saw-core/src/Verifier/SAW/Term/Pretty.hs | 2 +- src/SAWScript/Builtins.hs | 11 ++++------- src/SAWScript/Proof.hs | 10 +++++----- 6 files changed, 23 insertions(+), 27 deletions(-) diff --git a/saw-core/src/Verifier/SAW/Rewriter.hs b/saw-core/src/Verifier/SAW/Rewriter.hs index 4017917745..dc1119875d 100644 --- a/saw-core/src/Verifier/SAW/Rewriter.hs +++ b/saw-core/src/Verifier/SAW/Rewriter.hs @@ -245,8 +245,8 @@ scMatch sc pat term = -- saves the names associated with those bound variables. match :: Int -> [(LocalName, Term)] -> Term -> Term -> MatchState -> MaybeT IO MatchState - match _ _ (STApp i _ fv _) (STApp j _ _ _) s - | fv == emptyBitSet && i == j = return s + match _ _ t@(STApp i _ _ _) (STApp j _ _ _) s + | termIsClosed t && i == j = return s match depth env x y s@(MatchState m cs) = -- (lift $ putStrLn $ "matching (lhs): " ++ scPrettyTerm defaultPPOpts x) >> -- (lift $ putStrLn $ "matching (rhs): " ++ scPrettyTerm defaultPPOpts y) >> @@ -875,8 +875,7 @@ replaceTerm :: Ord a => Term {- ^ the term in which to perform the replacement -} -> IO (Set a, Term) replaceTerm sc ss (pat, repl) t = do - let fvs = looseVars pat - unless (fvs == emptyBitSet) $ fail $ unwords + unless (termIsClosed pat) $ fail $ unwords [ "replaceTerm: term to replace has free variables!", scPrettyTerm defaultPPOpts t ] let rule = ruleOfTerms pat repl let ss' = addRule rule ss diff --git a/saw-core/src/Verifier/SAW/SharedTerm.hs b/saw-core/src/Verifier/SAW/SharedTerm.hs index 0e0eb1cc76..c573994c76 100644 --- a/saw-core/src/Verifier/SAW/SharedTerm.hs +++ b/saw-core/src/Verifier/SAW/SharedTerm.hs @@ -1186,8 +1186,8 @@ instantiateLocalVars sc f initialLevel t0 = go l t = case t of Unshared tf -> go' l tf - STApp{ stAppIndex = tidx, stAppFreeVars = fv, stAppTermF = tf} - | fv == emptyBitSet -> return t -- closed terms map to themselves + STApp{ stAppIndex = tidx, stAppFreeVars = _, stAppTermF = tf} + | termIsClosed t -> return t -- closed terms map to themselves | otherwise -> useCache ?cache (tidx, l) (go' l tf) go' :: (?cache :: Cache IO (TermIndex, DeBruijnIndex) Term) => @@ -1547,7 +1547,7 @@ scConstant :: SharedContext -> Term -- ^ The type -> IO Term scConstant sc name rhs ty = - do unless (looseVars rhs == emptyBitSet) $ + do unless (termIsClosed rhs) $ fail "scConstant: term contains loose variables" let ecs = getAllExts rhs rhs' <- scAbstractExts sc ecs rhs @@ -1568,7 +1568,7 @@ scConstant' :: SharedContext -> Term -- ^ The type -> IO Term scConstant' sc nmi rhs ty = - do unless (looseVars rhs == emptyBitSet) $ + do unless (termIsClosed rhs) $ fail "scConstant: term contains loose variables" let ecs = getAllExts rhs rhs' <- scAbstractExts sc ecs rhs diff --git a/saw-core/src/Verifier/SAW/Simulator.hs b/saw-core/src/Verifier/SAW/Simulator.hs index 4a7e9886b5..57699b0f37 100644 --- a/saw-core/src/Verifier/SAW/Simulator.hs +++ b/saw-core/src/Verifier/SAW/Simulator.hs @@ -507,8 +507,8 @@ mkMemoLocal cfg memoClosed t env = go mempty t where go :: IntMap (Thunk l) -> Term -> EvalM l (IntMap (Thunk l)) go memo (Unshared tf) = goTermF memo tf - go memo (STApp{ stAppIndex = i, stAppFreeVars = fv, stAppTermF = tf }) - | fv == emptyBitSet = pure memo + go memo (t@STApp{ stAppIndex = i, stAppFreeVars = _, stAppTermF = tf }) + | termIsClosed t = pure memo | otherwise = case IMap.lookup i memo of Just _ -> pure memo @@ -551,11 +551,11 @@ evalLocalTermF cfg memoClosed memoLocal tf0 env = evalTermF cfg lam recEval tf0 where lam = evalOpen cfg memoClosed recEval (Unshared tf) = evalTermF cfg lam recEval tf env - recEval (STApp{ stAppIndex = i, stAppFreeVars = fv, stAppTermF = tf }) = + recEval (t@STApp{ stAppIndex = i, stAppFreeVars = _, stAppTermF = tf }) = case IMap.lookup i memo of Just x -> force x Nothing -> evalTermF cfg lam recEval tf env - where memo = if fv == emptyBitSet then memoClosed else memoLocal + where memo = if termIsClosed t then memoClosed else memoLocal {-# SPECIALIZE evalOpen :: Show (Extra l) => @@ -580,11 +580,11 @@ evalOpen cfg memoClosed t env = do memoLocal <- mkMemoLocal cfg memoClosed t env let eval :: Term -> MValue l eval (Unshared tf) = evalF tf - eval (STApp{ stAppIndex = i, stAppFreeVars = fv, stAppTermF = tf }) = + eval (t@STApp{ stAppIndex = i, stAppFreeVars = _, stAppTermF = tf }) = case IMap.lookup i memo of Just x -> force x Nothing -> evalF tf - where memo = if fv == emptyBitSet then memoClosed else memoLocal + where memo = if termIsClosed t then memoClosed else memoLocal evalF :: TermF Term -> MValue l evalF tf = evalTermF cfg (evalOpen cfg memoClosed) eval tf env eval t diff --git a/saw-core/src/Verifier/SAW/Term/Pretty.hs b/saw-core/src/Verifier/SAW/Term/Pretty.hs index 6f82c44cea..a06d930828 100644 --- a/saw-core/src/Verifier/SAW/Term/Pretty.hs +++ b/saw-core/src/Verifier/SAW/Term/Pretty.hs @@ -669,7 +669,7 @@ filterOccurenceMap min_occs global_p = IntMap.filter (\(t,cnt) -> cnt >= min_occs && shouldMemoizeTerm t && - (if global_p then looseVars t == emptyBitSet else True)) + (if global_p then termIsClosed t else True)) -- For each (TermIndex, Term) pair in the occurrence map, pretty-print the diff --git a/src/SAWScript/Builtins.hs b/src/SAWScript/Builtins.hs index f732a1e67b..1e99a1ffe1 100644 --- a/src/SAWScript/Builtins.hs +++ b/src/SAWScript/Builtins.hs @@ -292,13 +292,10 @@ replacePrim pat replace t = do let tpat = ttTerm pat let trepl = ttTerm replace - let fvpat = looseVars tpat - let fvrepl = looseVars trepl - - unless (fvpat == emptyBitSet) $ fail $ unlines + unless (termIsClosed tpat) $ fail $ unlines [ "pattern term is not closed", show tpat ] - unless (fvrepl == emptyBitSet) $ fail $ unlines + unless (termIsClosed trepl) $ fail $ unlines [ "replacement term is not closed", show trepl ] io $ do @@ -781,13 +778,13 @@ build_congruence sc tm = case asPiList ty of ([],_) -> fail "congruence_for: Term is not a function" (pis, body) -> - if looseVars body == emptyBitSet then + if termIsClosed body then loop pis [] else fail "congruence_for: cannot build congruence for dependent functions" where loop ((nm,tp):pis) vars = - if looseVars tp == emptyBitSet then + if termIsClosed tp then do l <- scFreshEC sc (nm <> "_1") tp r <- scFreshEC sc (nm <> "_2") tp loop pis ((l,r):vars) diff --git a/src/SAWScript/Proof.hs b/src/SAWScript/Proof.hs index 2d2c6872a6..8642a315e5 100644 --- a/src/SAWScript/Proof.hs +++ b/src/SAWScript/Proof.hs @@ -291,7 +291,7 @@ splitImpl sc (Prop p) -- Handle the case of (H1 -> H2), where H1 and H2 are in Prop | Just (_nm, arg, c) <- asPi p - , looseVars c == emptyBitSet -- make sure this is a nondependent Pi (AKA arrow type) + , termIsClosed c -- make sure this is a nondependent Pi (AKA arrow type) = termToMaybeProp sc arg >>= \case Nothing -> return Nothing Just h -> return (Just (h, Prop c)) @@ -1458,7 +1458,7 @@ normalizeConcl sc p = case asPi t of Just (_nm, arg, body) -- check that this is non-dependent Pi (AKA arrow type) - | looseVars body == emptyBitSet -> + | termIsClosed body -> termToMaybeProp sc arg >>= \case Nothing -> return (RawSequent [] [p]) Just h -> @@ -1523,7 +1523,7 @@ checkEvidence sc = \e p -> do nenv <- scGetNamingEnv sc -- and the given evidence must match the expected prop. checkApply nenv mkSqt (Prop p) (Right e:es) | Just (_lnm, tp, body) <- asPi p - , looseVars body == emptyBitSet + , termIsClosed body = do (d1,sy1) <- check nenv e . mkSqt =<< termToProp sc tp (d2,sy2,p') <- checkApply nenv mkSqt (Prop body) es return (Set.union d1 d2, sy1 <> sy2, p') @@ -1951,7 +1951,7 @@ sequentToSATQuery sc unintSet sqt = body' <- instantiateVar sc 0 etm body processUnivAssert mmap ((ec,fot):vars) xs body' Nothing - | looseVars body == emptyBitSet -> + | termIsClosed body -> case asEqTrue tp' of Just x -> processUnivAssert mmap vars (x:xs) body Nothing -> @@ -1984,7 +1984,7 @@ sequentToSATQuery sc unintSet sqt = body' <- instantiateVar sc 0 etm body processConcl mmap (Map.insert ec fot vars, xs) body' Nothing - | looseVars body == emptyBitSet -> + | termIsClosed body -> do asrt <- processAssert mmap tp processConcl mmap (vars, asrt : xs) body | otherwise -> From 09ee22bbfea7b3b10278af28d3c3ea9bba2f40ea Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 1 Sep 2023 08:36:14 -0700 Subject: [PATCH 094/305] replaced checkGroundTerm with the now standard termIsClosed function --- saw-core/tests/src/Tests/Parser.hs | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/saw-core/tests/src/Tests/Parser.hs b/saw-core/tests/src/Tests/Parser.hs index 29d9b5d439..1c1ee80356 100644 --- a/saw-core/tests/src/Tests/Parser.hs +++ b/saw-core/tests/src/Tests/Parser.hs @@ -16,9 +16,6 @@ import Verifier.SAW.SharedTerm import Verifier.SAW.Term.Functor -checkGroundTerm :: Term -> Bool -checkGroundTerm t = looseVars t == emptyBitSet - namedMsg :: Ident -> String -> String namedMsg sym msg = "In " ++ show sym ++ ": " ++ msg @@ -26,11 +23,11 @@ checkDef :: Def -> Assertion checkDef d = do let sym = defIdent d let tp = defType d - assertBool (namedMsg sym "Type is not ground.") (checkGroundTerm tp) + assertBool (namedMsg sym "Type is not ground.") (termIsClosed tp) case defBody d of Nothing -> return () Just body -> - assertBool (namedMsg sym "Body is not ground.") (checkGroundTerm body) + assertBool (namedMsg sym "Body is not ground.") (termIsClosed body) checkPrelude :: Assertion checkPrelude = From e65184812e612d9639784b6ad47f580c21b4ee3e Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 1 Sep 2023 08:36:53 -0700 Subject: [PATCH 095/305] whoops, fixed a few lingering bugs related to using termIsClosed --- saw-core/src/Verifier/SAW/Simulator.hs | 8 ++++---- saw-core/src/Verifier/SAW/TypedAST.hs | 2 +- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/saw-core/src/Verifier/SAW/Simulator.hs b/saw-core/src/Verifier/SAW/Simulator.hs index 57699b0f37..f53f7b717f 100644 --- a/saw-core/src/Verifier/SAW/Simulator.hs +++ b/saw-core/src/Verifier/SAW/Simulator.hs @@ -507,8 +507,8 @@ mkMemoLocal cfg memoClosed t env = go mempty t where go :: IntMap (Thunk l) -> Term -> EvalM l (IntMap (Thunk l)) go memo (Unshared tf) = goTermF memo tf - go memo (t@STApp{ stAppIndex = i, stAppFreeVars = _, stAppTermF = tf }) - | termIsClosed t = pure memo + go memo (t'@STApp{ stAppIndex = i, stAppFreeVars = _, stAppTermF = tf }) + | termIsClosed t' = pure memo | otherwise = case IMap.lookup i memo of Just _ -> pure memo @@ -580,11 +580,11 @@ evalOpen cfg memoClosed t env = do memoLocal <- mkMemoLocal cfg memoClosed t env let eval :: Term -> MValue l eval (Unshared tf) = evalF tf - eval (t@STApp{ stAppIndex = i, stAppFreeVars = _, stAppTermF = tf }) = + eval (t'@STApp{ stAppIndex = i, stAppFreeVars = _, stAppTermF = tf }) = case IMap.lookup i memo of Just x -> force x Nothing -> evalF tf - where memo = if termIsClosed t then memoClosed else memoLocal + where memo = if termIsClosed t' then memoClosed else memoLocal evalF :: TermF Term -> MValue l evalF tf = evalTermF cfg (evalOpen cfg memoClosed) eval tf env eval t diff --git a/saw-core/src/Verifier/SAW/TypedAST.hs b/saw-core/src/Verifier/SAW/TypedAST.hs index 2ddfab2329..4f399e4131 100644 --- a/saw-core/src/Verifier/SAW/TypedAST.hs +++ b/saw-core/src/Verifier/SAW/TypedAST.hs @@ -83,7 +83,7 @@ module Verifier.SAW.TypedAST , VarIndex -- * Utility functions , BitSet, emptyBitSet, inBitSet, unionBitSets, intersectBitSets - , decrBitSet, completeBitSet + , decrBitSet, completeBitSet, termIsClosed ) where import Control.Exception (assert) From 6f7ffe7e53155d6cd86963e4e57ce71ddd774170 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 1 Sep 2023 08:38:12 -0700 Subject: [PATCH 096/305] made a few fixes to make the code more readable --- .../src/Verifier/SAW/Translation/Coq/Term.hs | 20 +++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) 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 01738f4570..c1932ca574 100644 --- a/saw-core-coq/src/Verifier/SAW/Translation/Coq/Term.hs +++ b/saw-core-coq/src/Verifier/SAW/Translation/Coq/Term.hs @@ -530,13 +530,13 @@ bindTransToBinder (BindTrans {..}) = -- | Convert a 'BindTrans' to a list of Coq type-level pi-abstraction binders bindTransToPiBinder :: BindTrans -> [Coq.PiBinder] -bindTransToPiBinder (BindTrans { bindTransImps = [], .. }) - | bindTransIdent == "_" = [Coq.PiBinder Nothing bindTransType] -bindTransToPiBinder (BindTrans { bindTransImps = [], .. }) = - [Coq.PiBinder (Just bindTransIdent) bindTransType] -bindTransToPiBinder (BindTrans{..}) = - Coq.PiBinder (Just bindTransIdent) bindTransType : - map (\(n,ty) -> Coq.PiImplicitBinder (Just n) ty) bindTransImps +bindTransToPiBinder (BindTrans { .. }) = + case bindTransImps of + [] | bindTransIdent == "_" -> [Coq.PiBinder Nothing bindTransType] + [] -> [Coq.PiBinder (Just bindTransIdent) bindTransType] + otherwise -> + Coq.PiBinder (Just bindTransIdent) bindTransType : + map (\(n,ty) -> Coq.PiImplicitBinder (Just n) ty) bindTransImps -- | Given a 'LocalName' and its type (as a 'Term'), translate the 'LocalName' -- to a Coq identifier, translate the type to a Coq term, and generate zero or @@ -624,9 +624,9 @@ translateTermLet t = shares = IntMap.assocs $ fmap fst $ IntMap.filter keep occ_map share_tms = map snd shares in -- NOTE: larger terms always have later stAppIndices than their subterms, so - -- IntMap.elems above is guaranteed to return subterms before superterms; this - -- ensures that the right-hand sides in our nested let-bindings below only - -- refer to variables bound earlier, not later + -- IntMap.assocs above is guaranteed to return subterms before superterms; + -- this ensures that the right-hand sides in our nested let-bindings below + -- only refer to variables bound earlier, not later withSharedTerms shares $ \names -> do defs <- traverse translateTermUnshared share_tms body <- translateTerm t From 5d7a40e7102aa2f41b927205c0c0a75287efc5fa Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 1 Sep 2023 08:42:39 -0700 Subject: [PATCH 097/305] a few more tweaks to make the code look nicer --- saw-core-coq/src/Verifier/SAW/Translation/Coq/Term.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) 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 c1932ca574..292a63026f 100644 --- a/saw-core-coq/src/Verifier/SAW/Translation/Coq/Term.hs +++ b/saw-core-coq/src/Verifier/SAW/Translation/Coq/Term.hs @@ -534,7 +534,7 @@ bindTransToPiBinder (BindTrans { .. }) = case bindTransImps of [] | bindTransIdent == "_" -> [Coq.PiBinder Nothing bindTransType] [] -> [Coq.PiBinder (Just bindTransIdent) bindTransType] - otherwise -> + _ -> Coq.PiBinder (Just bindTransIdent) bindTransType : map (\(n,ty) -> Coq.PiImplicitBinder (Just n) ty) bindTransImps @@ -546,9 +546,10 @@ bindTransToPiBinder (BindTrans { .. }) = -- is bound to its Coq identifier. translateBinder :: TermTranslationMonad m => LocalName -> Term -> (BindTrans -> m a) -> m a -translateBinder n ty@(asPiList -> (args, asSortWithFlags -> mb_sort)) f = +translateBinder n ty@(asPiList -> (args, pi_body)) f = do ty' <- translateTerm ty - let flagValues = sortFlagsToList $ maybe noFlags snd mb_sort + let mb_sort = asSortWithFlags pi_body + flagValues = sortFlagsToList $ maybe noFlags snd mb_sort flagLocalNames = [("Inh", "SAWCoreScaffolding.Inhabited"), ("QT", "QuantType")] withSAWVar n $ \n' -> From 1e953dc9626f67cc6eda2d3986da3fc31ad7e8b7 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 1 Sep 2023 10:37:15 -0700 Subject: [PATCH 098/305] finished writing a comment on withSAWVar --- saw-core-coq/src/Verifier/SAW/Translation/Coq/Term.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) 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 292a63026f..7fa6d069fa 100644 --- a/saw-core-coq/src/Verifier/SAW/Translation/Coq/Term.hs +++ b/saw-core-coq/src/Verifier/SAW/Translation/Coq/Term.hs @@ -179,8 +179,10 @@ invalidateOpenSharing = -- | Run a translation in a context with one more SAW core variable with the -- given name. Pass the corresponding Coq identifier used for this SAW core --- variable to the computation in which it is bound. This invalidates all --- non-closed shared names, since sharing does not +-- variable to the computation in which it is bound. This invalidates all shared +-- terms that are not closed, since these shared terms now correspond to +-- different terms (with greater deBruijn indices) that have different +-- 'TermIndex'es. withSAWVar :: TermTranslationMonad m => LocalName -> (Coq.Ident -> m a) -> m a withSAWVar n m = invalidateOpenSharing $ withFreshIdent n $ \n_coq -> From e7f98eeab7e81c26c646d3fea555a3cadd76364e Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 1 Sep 2023 11:47:16 -0700 Subject: [PATCH 099/305] indentation change requested by review --- saw-core-coq/src/Verifier/SAW/Translation/Coq/Term.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) 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 7fa6d069fa..1afaf91218 100644 --- a/saw-core-coq/src/Verifier/SAW/Translation/Coq/Term.hs +++ b/saw-core-coq/src/Verifier/SAW/Translation/Coq/Term.hs @@ -668,8 +668,8 @@ translateTermUnshared t = do Lambda {} -> let (params, e) = asLambdaList t in translateParams params $ \paramTerms -> - do e' <- translateTermLet e - return (Coq.Lambda paramTerms e') + do e' <- translateTermLet e + return (Coq.Lambda paramTerms e') App {} -> -- asApplyAll: innermost argument first From 058f77a64e8a2ba5106d0518099f8fb3785e577d Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 27 Sep 2023 21:52:04 -0700 Subject: [PATCH 100/305] started defining type descriptions; removed the old IRT stuff --- saw-core/prelude/Prelude.sawcore | 394 ++++++++++++++++--------------- 1 file changed, 198 insertions(+), 196 deletions(-) diff --git a/saw-core/prelude/Prelude.sawcore b/saw-core/prelude/Prelude.sawcore index 929d7f070a..e1be0a0156 100644 --- a/saw-core/prelude/Prelude.sawcore +++ b/saw-core/prelude/Prelude.sawcore @@ -2146,202 +2146,6 @@ BV_complete_induction w p f x0 = (bvToNat w x0) x0 (IsLeNat_base (bvToNat w 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; - - -------------------------------------------------------------------------------- -- Lists at sort 1 @@ -2388,6 +2192,204 @@ nth_default1 a d l = l; +-------------------------------------------------------------------------------- +-- Type descriptions + +-- Arithmetic kinds -- + +-- The kinds for objects that can be used in type-level arithmetic expressions +data ArithKind : sort 0 where { + Kind_nat : ArithKind; + Kind_bv : (w:Nat) -> ArithKind; +} + +-- The type of an element of an ArithKind +arithKindElem : ArithKind -> sort 0; +arithKindElem AK = + ArithKind#rec (\ (_:ArithKind) -> sort 0) Nat (\ (w:Nat) -> Vec w Bool) AK; + +-- The unary operations for type-level arithmetic expressions +data ArithUnOp : ArithKind -> ArithKind -> sort 0 where { + UnOp_BVToNat : (w:Nat) -> ArithUnOp (Kind_bv w) Kind_nat; + UnOp_NatToBV : (w:Nat) -> ArithUnOp Kind_nat (Kind_bv w); +} + +-- Evaluate a unary operation to a function on elements of its ArithKinds +evalUnOp : (AK1 AK2:ArithKind) -> ArithUnOp AK1 AK2 -> arithKindElem AK1 -> + arithKindElem AK2; +evalUnOp AK1 AK2 op = + ArithUnOp#rec (\ (AK1 AK2:ArithKind) (_:ArithUnOp AK1 AK2) -> + arithKindElem AK1 -> arithKindElem AK2) + (\ (w:Nat) -> bvToNat w) + (\ (w:Nat) -> bvNat w) + AK1 AK2 op; + +-- The binary operations for type-level arithmetic expressions +data ArithBinOp : ArithKind -> ArithKind -> ArithKind -> sort 0 where { + BinOp_AddNat : ArithBinOp Kind_nat Kind_nat Kind_nat; + BinOp_MulNat : ArithBinOp Kind_nat Kind_nat Kind_nat; + BinOp_AddBV : (w:Nat) -> ArithBinOp (Kind_bv w) (Kind_bv w) (Kind_bv w); + BinOp_MulBV : (w:Nat) -> ArithBinOp (Kind_bv w) (Kind_bv w) (Kind_bv w); +} + +-- Evaluate a binary operation to a function on elements of its ArithKinds +evalBinOp : (AK1 AK2 AK3:ArithKind) -> ArithBinOp AK1 AK2 AK3 -> + arithKindElem AK1 -> arithKindElem AK2 -> arithKindElem AK3; +evalBinOp AK1 AK2 AK3 op = + ArithBinOp#rec (\ (AK1 AK2 AK3:ArithKind) (_:ArithBinOp AK1 AK2 AK3) -> + arithKindElem AK1 -> arithKindElem AK2 -> arithKindElem AK3) + addNat mulNat bvAdd bvMul + AK1 AK2 AK3 op; + + +-- Kind and type descriptions -- + +-- The kinds used for type descriptions, which can either be arithmetic or the +-- kind of type descriptions themselves +data KindDesc : sort 0 where { + Kind_Arith : ArithKind -> KindDesc; + Kind_Tp : KindDesc; +} + +-- Type-level arithmetic expressions +data ArithExpr : ArithKind -> sort 0 where { + Arith_Const : (AK:ArithKind) -> arithKindElem AK -> ArithExpr AK; + Arith_Var : (AK:ArithKind) -> Nat -> ArithExpr AK; + Arith_UnOp : (AK1 AK2:ArithKind) -> ArithUnOp AK1 AK2 -> + ArithExpr AK1 -> ArithExpr AK2; + Arith_BinOp : (AK1 AK2 AK3:ArithKind) -> ArithBinOp AK1 AK2 AK3 -> + ArithExpr AK1 -> ArithExpr AK2 -> ArithExpr AK3; +} + +-- 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; + + -- Vector types + Tp_Vec : TpDesc -> ArithExpr Kind_nat -> TpDesc; + + -- Inductive types, where Kind_Ind A is equivalent to [Kind_Ind A/x]A + Tp_Ind : TpDesc -> TpDesc; + + -- Type variables, used for types bound by pis, sigmas, and inductive types + Tp_Var : Nat -> TpDesc; + + -- The empty type + Tp_Void : TpDesc; +} + + +-- Type-level environments -- + +-- Decide equality for arithmetic kinds +proveEqArithKind : (AK1 AK2 : ArithKind) -> Maybe (Eq ArithKind AK1 AK2); +proveEqArithKind AK1_top = + ArithKind#rec + (\ (AK1:ArithKind) -> (AK2:ArithKind) -> Maybe (Eq ArithKind AK1 AK2)) + (\ (AK2_top:ArithKind) -> + ArithKind#rec (\ (AK2:ArithKind) -> Maybe (Eq ArithKind Kind_nat AK2)) + (Just (Eq ArithKind Kind_nat Kind_nat) (Refl ArithKind Kind_nat)) + (\ (w:Nat) -> Nothing (Eq ArithKind Kind_nat (Kind_bv w))) + AK2_top) + (\ (w1:Nat) (AK2_top:ArithKind) -> + ArithKind#rec (\ (AK2:ArithKind) -> Maybe (Eq ArithKind (Kind_bv w1) AK2)) + (Nothing (Eq ArithKind (Kind_bv w1) Kind_nat)) + (\ (w2:Nat) -> + Maybe__rec + (Eq Nat w1 w2) + (\ (_:Maybe (Eq Nat w1 w2)) -> + Maybe (Eq ArithKind (Kind_bv w1) (Kind_bv w2))) + (Nothing (Eq ArithKind (Kind_bv w1) (Kind_bv w2))) + (\ (e:Eq Nat w1 w2) -> + Just (Eq ArithKind (Kind_bv w1) (Kind_bv w2)) + (eq_cong Nat w1 w2 e ArithKind (\ (w:Nat) -> Kind_bv w))) + (proveEqNat w1 w2)) + AK2_top) + AK1_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)) + (\ (AK1:ArithKind) (K2_top:KindDesc) -> + KindDesc#rec + (\ (K2:KindDesc) -> Maybe (Eq KindDesc (Kind_Arith AK1) K2)) + (\ (AK2:ArithKind) -> + Maybe__rec + (Eq ArithKind AK1 AK2) + (\ (_:Maybe (Eq ArithKind AK1 AK2)) -> + Maybe (Eq KindDesc (Kind_Arith AK1) (Kind_Arith AK2))) + (Nothing (Eq KindDesc (Kind_Arith AK1) (Kind_Arith AK2))) + (\ (e:Eq ArithKind AK1 AK2) -> + Just (Eq KindDesc (Kind_Arith AK1) (Kind_Arith AK2)) + (eq_cong ArithKind AK1 AK2 e KindDesc + (\ (AK:ArithKind) -> Kind_Arith AK))) + (proveEqArithKind AK1 AK2)) + (Nothing (Eq KindDesc (Kind_Arith AK1) Kind_Tp)) + K2_top) + (\ (K2_top:KindDesc) -> + KindDesc#rec + (\ (K2:KindDesc) -> Maybe (Eq KindDesc Kind_Tp K2)) + (\ (AK2:ArithKind) -> Nothing (Eq KindDesc Kind_Tp (Kind_Arith AK2))) + (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) + (\ (AK:ArithKind) -> arithKindElem AK) + TpDesc + K; + +-- The default element of an arithmetic kind +defaultAKElem : (AK:ArithKind) -> arithKindElem AK; +defaultAKElem AK = ArithKind#rec arithKindElem 0 (\ (w:Nat) -> bvNat w 0) AK; + +-- The default element of a kind +defaultKindElem : (K:KindDesc) -> kindElem K; +defaultKindElem K = KindDesc#rec kindElem defaultAKElem Tp_Void 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; + + + +-- FIXME HERE + + -------------------------------------------------------------------------------- -- ITree Specification monad From 4eb1da49390abb0f0dd088eda28266704fa71eab Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 29 Sep 2023 08:08:32 -0700 Subject: [PATCH 101/305] Defined tpElem and indElem --- saw-core/prelude/Prelude.sawcore | 322 ++++++++++++++++++++++++++++++- 1 file changed, 320 insertions(+), 2 deletions(-) diff --git a/saw-core/prelude/Prelude.sawcore b/saw-core/prelude/Prelude.sawcore index e1be0a0156..5d52756702 100644 --- a/saw-core/prelude/Prelude.sawcore +++ b/saw-core/prelude/Prelude.sawcore @@ -1700,7 +1700,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; @@ -2261,6 +2261,15 @@ data ArithExpr : ArithKind -> sort 0 where { ArithExpr AK1 -> ArithExpr AK2 -> ArithExpr AK3; } +-- The natural number N as an ArithExpr +ArithN : Nat -> ArithExpr Kind_nat; +ArithN n = Arith_Const Kind_nat n; + +-- The natural number 0 as an ArithExpr +ArithZ : ArithExpr Kind_nat; +ArithZ = Arith_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 @@ -2385,9 +2394,318 @@ TpEnvElem = Sigma KindDesc kindElem; 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 substitue 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 arithmetic expression e +substArithExpr : Nat -> TpEnv -> (AK:ArithKind) -> ArithExpr AK -> ArithExpr AK; +substArithExpr n env AK_top e = + ArithExpr#rec (\ (AK:ArithKind) (_:ArithExpr AK) -> ArithExpr AK) + (\ (AK:ArithKind) (v:arithKindElem AK) -> Arith_Const AK v) + (\ (AK:ArithKind) (ix:Nat) -> + Either__rec (arithKindElem AK) Nat + (\ (_:Either (arithKindElem AK) Nat) -> ArithExpr AK) + (\ (v:arithKindElem AK) -> Arith_Const AK v) + (\ (ix':Nat) -> Arith_Var AK ix') + (substVar n env (Kind_Arith AK) ix)) + (\ (AK1 AK2:ArithKind) (op:ArithUnOp AK1 AK2) + (_:ArithExpr AK1) (rec:ArithExpr AK1) -> + Arith_UnOp AK1 AK2 op rec) + (\ (AK1 AK2 AK3:ArithKind) (op:ArithBinOp AK1 AK2 AK3) + (_:ArithExpr AK1) (rec1:ArithExpr AK1) + (_:ArithExpr AK2) (rec2:ArithExpr AK2) -> + Arith_BinOp AK1 AK2 AK3 op rec1 rec2) + AK_top + e; + +-- Evaluate an arithmetic expression to a value +evalArithExpr : TpEnv -> (AK:ArithKind) -> ArithExpr AK -> arithKindElem AK; +evalArithExpr env AK_top e = + ArithExpr#rec (\ (AK:ArithKind) (_:ArithExpr AK) -> arithKindElem AK) + (\ (AK:ArithKind) (v:arithKindElem AK) -> v) + (\ (AK:ArithKind) (ix:Nat) -> evalVar 0 env (Kind_Arith AK) ix) + (\ (AK1 AK2:ArithKind) (op:ArithUnOp AK1 AK2) + (_:ArithExpr AK1) (rec:arithKindElem AK1) -> + evalUnOp AK1 AK2 op rec) + (\ (AK1 AK2 AK3:ArithKind) (op:ArithBinOp AK1 AK2 AK3) + (_:ArithExpr AK1) (rec1:arithKindElem AK1) + (_:ArithExpr AK2) (rec2:arithKindElem AK2) -> + evalBinOp AK1 AK2 AK3 op rec1 rec2) + AK_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)) + (\ (_:TpDesc) (rec:Nat -> TpEnv -> TpDesc) (len:ArithExpr Kind_nat) + (n:Nat) (env:TpEnv) -> + Tp_Vec (rec n env) (substArithExpr n env Kind_nat len)) + (\ (_: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)) + (\ (n:Nat) (env:TpEnv) -> Tp_Void) + 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 -- + +-- An identifier for a corecursive function in a SpecM computation. In the Coq +-- model, this is just a natural number index (hence the name), but we leave its +-- structure opaque in SAW because client code should not break the abstraction. +primitive FunIx : TpDesc -> sort 0; + +-- A list of function indexes with the given types +FunIxs : List TpDesc -> sort 0; +FunIxs = List__rec TpDesc (\ (_:List TpDesc) -> sort 0) #() + (\ (T:TpDesc) (_:List TpDesc) (rec:sort 0) -> FunIx T * rec); + +-- Inductively-defined elements of a type description relative to an +-- environment, which acts as a substitution of values for the free variables +data indElem : TpEnv -> TpDesc -> sort 0 where { + -- Monadic and function types are just function indexes + Elem_M : (env:TpEnv) -> (R:TpDesc) -> FunIx (tpSubst 0 env (Tp_M R)) -> + indElem env (Tp_M R); + Elem_Pi : (env:TpEnv) -> (K:KindDesc) -> (T:TpDesc) -> + FunIx (tpSubst 0 env (Tp_Pi K T)) -> indElem env (Tp_Pi K T); + Elem_Arr : (env:TpEnv) -> (T U:TpDesc) -> + FunIx (tpSubst 0 env (Tp_Arr T U)) -> indElem env (Tp_Arr T U); + + -- Tp_Kind K is the type of elements of kind K, lowered to the object level + Elem_Kind : (env:TpEnv) -> (K:KindDesc) -> kindElem K -> indElem env (Tp_Kind K); + + -- Elements of pair and sum types are just pairs and sums + Elem_Pair : (env:TpEnv) -> (T U:TpDesc) -> indElem env T -> indElem env U -> + indElem env (Tp_Pair T U); + Elem_SumL : (env:TpEnv) -> (T U:TpDesc) -> indElem env T -> + indElem env (Tp_Sum T U); + Elem_SumR : (env:TpEnv) -> (T U:TpDesc) -> indElem env U -> + indElem env (Tp_Sum T U); + + -- An element of Tp_Sigma K T is an element e of K plus an element of [e/x]U + Elem_Sigma : (env:TpEnv) -> (K:KindDesc) -> (T:TpDesc) -> + (elem1:kindElem K) -> indElem (envConsElem K elem1 env) T -> + indElem env (Tp_Sigma K T); + + -- Elements of vector types are built using nil and cons constructors, to + -- build a vector of elements with a concrete size, along with a final cast + -- constructor, to cast the size to an expression equal to that concrete size + Elem_VecNil : (env:TpEnv) -> (T:TpDesc) -> indElem env (Tp_Vec T ArithZ); + Elem_VecCons : (env:TpEnv) -> (T:TpDesc) -> (n:Nat) -> + indElem env T -> indElem env (Tp_Vec T (ArithN n)) -> + indElem env (Tp_Vec T (ArithN (Succ n))); + Elem_VecCast : (env:TpEnv) -> (T:TpDesc) -> (e1 e2:ArithExpr Kind_nat) -> + Eq Nat (evalArithExpr env Kind_nat e1) + (evalArithExpr env Kind_nat e2) -> + indElem env (Tp_Vec T e1) -> indElem env (Tp_Vec T e2); + + -- An element of inductive type Tp_Ind T is an element of the one-step + -- unfolding [Tp_Ind T/x]T of the body of the inductive type. Note that we + -- perform the full substitution of env as part of this unfolding, rather than + -- just adding Tp_Ind T to the current environment, because the two are + -- equivalent, but this version is easier to use. + Elem_Ind : (env:TpEnv) -> (T:TpDesc) -> indElem nilTpEnv (unfoldIndTpDesc env T) -> + indElem env (Tp_Ind T); + + -- An element of a variable is an element of the evaluation of that variable + -- to a type (or of TP_Void if the variable is unbound or of the wrong kind) + Elem_Var : (env:TpEnv) -> (var:Nat) -> indElem nilTpEnv (evalVar 0 env Kind_Tp var) -> + indElem env (Tp_Var var); + + -- No constructor for Tp_Void +} --- FIXME HERE +-- Elements of a type description relative to an environment. This is isomorphic +-- to indElem, above, but yields the types you would expect rather than a single +-- inductive type. See indElem for a more detailed explanation of how the types +-- are defined. +tpElemEnv : TpEnv -> TpDesc -> sort 0; +tpElemEnv env_top T_top = + TpDesc#rec (\ (_:TpDesc) -> TpEnv -> sort 0) + (\ (R:TpDesc) (_:TpEnv -> sort 0) (env:TpEnv) -> + FunIx (tpSubst 0 env (Tp_M R))) + (\ (K:KindDesc) (T:TpDesc) (_:TpEnv -> sort 0) (env:TpEnv) -> + FunIx (tpSubst 0 env (Tp_Pi K T))) + (\ (T:TpDesc) (_:TpEnv -> sort 0) (U:TpDesc) (_:TpEnv -> sort 0) (env:TpEnv) -> + FunIx (tpSubst 0 env (Tp_Arr T U))) + (\ (K:KindDesc) (_:TpEnv) -> kindElem K) + (\ (T:TpDesc) (recT:TpEnv -> sort 0) (U:TpDesc) (recU:TpEnv -> sort 0) + (env:TpEnv) -> + recT env * recU env) + (\ (T:TpDesc) (recT:TpEnv -> sort 0) (U:TpDesc) (recU:TpEnv -> sort 0) + (env:TpEnv) -> + Either (recT env) (recU env)) + (\ (K:KindDesc) (T:TpDesc) (rec:TpEnv -> sort 0) (env:TpEnv) -> + Sigma (kindElem K) (\ (v:kindElem K) -> rec (envConsElem K v env))) + (\ (_:TpDesc) (rec:TpEnv -> sort 0) (len:ArithExpr Kind_nat) (env:TpEnv) -> + Vec (evalArithExpr env Kind_nat len) (rec env)) + (\ (T:TpDesc) (rec:TpEnv -> sort 0) (env:TpEnv) -> + indElem nilTpEnv (unfoldIndTpDesc env T)) + (\ (var:Nat) (env:TpEnv) -> + -- 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 nilTpEnv (evalVar 0 env Kind_Tp var)) + (\ (_:TpEnv) -> Void) + T_top env_top; + +-- Elements of a type description = elements relative to the empty environment +tpElem : TpDesc -> sort 0; +tpElem = tpElemEnv nilTpEnv; + +-- Convert an inductively-defined element to a recursively-defined one +primitive indToTpElem : (env:TpEnv) -> (T:TpDesc) -> + indElem env T -> tpElemEnv env T; + +-- Convert a recursively-defined element to an inductively-defined one +primitive tpToIndElem : (env:TpEnv) -> (T:TpDesc) -> + tpElemEnv env T -> indElem env T; + +-- Fold an element of [Tp_Ind T/x]T to an element of Tp_Ind T +foldTpElem : (T:TpDesc) -> tpElem (unfoldIndTpDesc nilTpEnv T) -> + tpElem (Tp_Ind T); +foldTpElem T = tpToIndElem nilTpEnv (unfoldIndTpDesc nilTpEnv T); + +-- Unfold an element of Tp_Ind T to an element of [Tp_Ind T/x]T +unfoldTpElem : (T:TpDesc) -> tpElem (Tp_Ind T) -> + tpElem (unfoldIndTpDesc nilTpEnv T); +unfoldTpElem T = indToTpElem nilTpEnv (unfoldIndTpDesc nilTpEnv T); -------------------------------------------------------------------------------- From 21c81368278d637f192f6f7895ccb3f65d3af764 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Sun, 1 Oct 2023 07:07:21 -0700 Subject: [PATCH 102/305] Updated the SAW core prelude with the new definition of SpecM based on TpDescs --- saw-core/prelude/Prelude.sawcore | 917 ++++++------------------------- 1 file changed, 154 insertions(+), 763 deletions(-) diff --git a/saw-core/prelude/Prelude.sawcore b/saw-core/prelude/Prelude.sawcore index 5d52756702..a75e349db6 100644 --- a/saw-core/prelude/Prelude.sawcore +++ b/saw-core/prelude/Prelude.sawcore @@ -2732,714 +2732,132 @@ evRetType e = VoidEv : EvType; VoidEv = Build_EvType Void (elimVoid (sort 0)); --- Proof that a type-level function is a valid functor for use in a LetRecType; --- this is defined in the translation to Coq, and is only axiomatized here -primitive ValidLRTFunctor2 : (sort 0 -> sort 0 -> sort 0) -> sort 0; - --- The pair functor is a valid binary LRT functor -axiom pair_ValidLRTFunctor2 : ValidLRTFunctor2 (\ (A B:sort 0) -> A * B); - --- The either functor is a valid binary LRT functor -axiom either_ValidLRTFunctor2 : ValidLRTFunctor2 (\ (A B:sort 0) -> Either A B); - --- The Vec type constructor is a valid LRT functor -axiom Vec_ValidLRTFunctor2 : - (n:Nat) -> ValidLRTFunctor2 (\ (A _:sort 0) -> Vec n A); - --- An inductive encoding of monadic function types and their arguments -data LetRecType : sort 1 where { - -- A nullary monadic function, that returns a value of the encoded type - LRT_SpecM : LetRecType -> LetRecType; - -- A dependent monadic function type - LRT_FunDep : (a:sort 0) -> (a -> LetRecType) -> LetRecType; - -- A non-dependent monadic function type, which can take in closures - LRT_FunClos : LetRecType -> LetRecType -> LetRecType; - -- The unit type - LRT_Type : sort 0 -> LetRecType; - -- An application of a binary type function - LRT_BinOp : (F: sort 0 -> sort 0 -> sort 0) -> ValidLRTFunctor2 F -> - LetRecType -> LetRecType -> LetRecType; - -- A dependent pair type - LRT_Sigma : (a:sort 0) -> (a -> LetRecType) -> LetRecType; -} - --- The explicit recursor for LetRecType -LetRecType__rec : - (P : LetRecType -> sort 1) -> ((R:LetRecType) -> P R -> P (LRT_SpecM R)) -> - ((A : sort 0) -> (B : A -> LetRecType) -> ((a:A) -> P (B a)) -> - P (LRT_FunDep A B)) -> - ((A:LetRecType) -> P A -> (B:LetRecType) -> P B -> P (LRT_FunClos A B)) -> - ((A : sort 0) -> P (LRT_Type A)) -> - ((F : sort 0 -> sort 0 -> sort 0) -> (v : ValidLRTFunctor2 F) -> - (A:LetRecType) -> P A -> (B:LetRecType) -> P B -> P (LRT_BinOp F v A B)) -> - ((A : sort 0) -> (B : A -> LetRecType) -> ((a:A) -> P (B a)) -> - P (LRT_Sigma A B)) -> - (lrt:LetRecType) -> P lrt; -LetRecType__rec P f1 f2 f3 f4 f5 f6 lrt = - LetRecType#rec P f1 f2 f3 f4 f5 f6 lrt; - --- A trivially inhabied "default" LetRecType, representing void -> void -default_lrt : LetRecType; -default_lrt = LRT_FunDep Void (\ (_:Void) -> LRT_SpecM (LRT_Type Void)); - --- The LetRecType for the unit type -LRT_Unit : LetRecType; -LRT_Unit = LRT_Type #(); - --- The LetRecType for a pair -LRT_Pair : LetRecType -> LetRecType -> LetRecType; -LRT_Pair lrt_l lrt_r = - LRT_BinOp (\ (A B:sort 0) -> A * B) pair_ValidLRTFunctor2 lrt_l lrt_r; - --- The LetRecType for the Either type -LRT_Either : LetRecType -> LetRecType -> LetRecType; -LRT_Either lrt_l lrt_r = - LRT_BinOp (\ (A B:sort 0) -> Either A B) either_ValidLRTFunctor2 lrt_l lrt_r; - --- The LetRecType for the Vec type -LRT_Vec : Nat -> LetRecType -> LetRecType; -LRT_Vec n lrt = - LRT_BinOp (\ (A _:sort 0) -> Vec n A) (Vec_ValidLRTFunctor2 n) lrt LRT_Unit; - --- The LetRecType for the BVVec type -LRT_BVVec : (n:Nat) -> Vec n Bool -> LetRecType -> LetRecType; -LRT_BVVec n len lrt = LRT_Vec (bvToNat n len) lrt; - --- A function stack is a list of LetRecTypes, which intuitively --- represents a stack of bindings of mutually recursive functions -FunStack : sort 1; -FunStack = List1 LetRecType; - --- The empty FunStack -emptyFunStack : FunStack; -emptyFunStack = Nil1 LetRecType; - --- Get the length of a FunStack -stackLen : FunStack -> Nat; -stackLen = length1 LetRecType; - --- Get the nth element of a FunStack, or void -> void if n is too big -nthLRT : List1 LetRecType -> Nat -> LetRecType; -nthLRT lrts = nth_default1 LetRecType default_lrt lrts; - --- A monadic function closure, whose type is described be a LetRecType; this is --- defined in the translation to Coq, and is only axiomatized here -primitive LRTClos : FunStack -> LetRecType -> sort 0; - --- An argument to a recursive function call, which is a decoding of a LetRecType --- to its corresponding SAW core type -LRTArg : FunStack -> LetRecType -> sort 0; -LRTArg stack argTp = - LetRecType__rec - (\ (_:LetRecType) -> sort 0) - (\ (R:LetRecType) (_:sort 0) -> LRTClos stack (LRT_SpecM R)) - (\ (A:sort 0) (B:A -> LetRecType) (_:A -> sort 0) -> - LRTClos stack (LRT_FunDep A B)) - (\ (A:LetRecType) (_:sort 0) (B:LetRecType) (_:sort 0) -> - LRTClos stack (LRT_FunClos A B)) - (\ (A:sort 0) -> A) - (\ (F:sort 0 -> sort 0 -> sort 0) (_:ValidLRTFunctor2 F) - (_:LetRecType) (recA:sort 0) (_:LetRecType) (recB:sort 0) -> F recA recB) - (\ (A:sort 0) (_:A -> LetRecType) (rec:A -> sort 0) -> Sigma A rec) - argTp; - --- Apply a monadic function closure with a dependent function type -primitive applyLRTClosDep : - (stk:FunStack) -> (A:sort 0) -> (B:A -> LetRecType) -> - LRTClos stk (LRT_FunDep A B) -> (a:A) -> LRTClos stk (B a); - --- Apply a monadic function closure with a non-dependent function type -primitive applyLRTClosClos : - (stk:FunStack) -> (A B:LetRecType) -> - LRTClos stk (LRT_FunClos A B) -> (a:LRTArg stk A) -> LRTClos stk B; - --- The return type of applyLRTClosN, which applies an LRTClos to N arguments -applyLRTClosNRet : (stk:FunStack) -> Nat -> LetRecType -> sort 0; -applyLRTClosNRet stk = - Nat__rec - (\ (_:Nat) -> LetRecType -> sort 0) - (LRTClos stk) - (\ (_:Nat) (rec:LetRecType -> sort 0) (lrt:LetRecType) -> - LetRecType__rec - (\ (_:LetRecType) -> sort 0) - (\ (R:LetRecType) (_:sort 0) -> Void -> Void) - (\ (A:sort 0) (B:A -> LetRecType) (_:A -> sort 0) -> - (a:A) -> rec (B a)) - (\ (A:LetRecType) (_:sort 0) (B:LetRecType) (_:sort 0) -> - LRTArg stk A -> rec B) - (\ (A:sort 0) -> Void -> Void) - (\ (F:sort 0 -> sort 0 -> sort 0) (_:ValidLRTFunctor2 F) - (_:LetRecType) (_:sort 0) (_:LetRecType) (_:sort 0) -> - Void -> Void) - (\ (A:sort 0) (_:A -> LetRecType) (_:A -> sort 0) -> Void -> Void) - lrt); - --- Apply an LRTClos to N arguments -applyLRTClosN : (stk:FunStack) -> (n:Nat) -> (lrt:LetRecType) -> - LRTClos stk lrt -> applyLRTClosNRet stk n lrt; -applyLRTClosN stk = - Nat__rec - (\ (n:Nat) -> (lrt:LetRecType) -> LRTClos stk lrt -> applyLRTClosNRet stk n lrt) - (\ (lrt:LetRecType) (clos:LRTClos stk lrt) -> clos) - (\ (n':Nat) - (rec:(lrt:LetRecType) -> LRTClos stk lrt -> applyLRTClosNRet stk n' lrt) - (lrt_top:LetRecType) -> - LetRecType__rec - (\ (lrt:LetRecType) -> LRTClos stk lrt -> - applyLRTClosNRet stk (Succ n') lrt) - (\ (R:LetRecType) - (_:LRTClos stk R -> applyLRTClosNRet stk (Succ n') R) - (_:LRTClos stk (LRT_SpecM R)) (v:Void) -> v) - (\ (A:sort 0) (B:A -> LetRecType) - (_:(a:A) -> LRTClos stk (B a) -> applyLRTClosNRet stk (Succ n') (B a)) - (clos:LRTClos stk (LRT_FunDep A B)) (a:A) -> - rec (B a) (applyLRTClosDep stk A B clos a)) - (\ (A:LetRecType) (_:LRTClos stk A -> applyLRTClosNRet stk (Succ n') A) - (B:LetRecType) (_:LRTClos stk B -> applyLRTClosNRet stk (Succ n') B) - (clos:LRTClos stk (LRT_FunClos A B)) (arg:LRTArg stk A) -> - rec B (applyLRTClosClos stk A B clos arg)) - (\ (A:sort 0) (_:LRTClos stk (LRT_Type A)) (v:Void) -> v) - (\ (F:sort 0 -> sort 0 -> sort 0) (VF:ValidLRTFunctor2 F) - (A:LetRecType) (_:LRTClos stk A -> applyLRTClosNRet stk (Succ n') A) - (B:LetRecType) (_:LRTClos stk B -> applyLRTClosNRet stk (Succ n') B) - (_:LRTClos stk (LRT_BinOp F VF A B)) (v:Void) -> v) - (\ (A:sort 0) (B:A -> LetRecType) - (_:(a:A) -> LRTClos stk (B a) -> applyLRTClosNRet stk (Succ n') (B a)) - (_:LRTClos stk (LRT_Sigma A B)) (v:Void) -> v) - lrt_top); - - --- Build the dependent type { a1:A1 & { a2:A2 & ... { an:An & unit } ... }} of --- inputs to the LetRecType (LRT_Fun A1 (\ a1 -> ...)). Return the Void type for --- any LetRecType that is not a valid monadic function type. -LRTInput : FunStack -> LetRecType -> sort 0; -LRTInput stack lrt = - LetRecType__rec - (\ (lrt:LetRecType) -> sort 0) - (\ (_:LetRecType) (_:sort 0) -> #()) - (\ (A:sort 0) (_:A -> LetRecType) (rec:A -> sort 0) -> - Sigma A (\ (a:A) -> rec a)) - (\ (A:LetRecType) (_:sort 0) (B:LetRecType) (rec:sort 0) -> - LRTArg stack A * rec) - (\ (A:sort 0) -> Void) - (\ (F:sort 0 -> sort 0 -> sort 0) (_:ValidLRTFunctor2 F) - (_:LetRecType) (_:sort 0) (_:LetRecType) (_:sort 0) -> - Void) - (\ (A:sort 0) (_:A -> LetRecType) (_:A -> sort 0) -> Void) - lrt; - --- Build the output type (R a1 ... an) of the application of a LetRecType --- (LRT_Fun A1 (\ a1 -> ... (LRT_Fun An (\ an -> LRT_SpecM R a1 ... an)))) --- function to the arguments a1 ... an in an LRTInput -LRTOutput : (stack:FunStack) -> (lrt:LetRecType) -> LRTInput stack lrt -> sort 0; -LRTOutput stack lrt = - LetRecType__rec - (\ (lrt:LetRecType) -> LRTInput stack lrt -> sort 0) - (\ (R:LetRecType) (_:LRTInput stack R -> sort 0) (_:#()) -> LRTArg stack R) - (\ (A:sort 0) (B:A -> LetRecType) - (rec:(a:A) -> LRTInput stack (B a) -> sort 0) - (args:Sigma A (\ (a:A) -> LRTInput stack (B a))) -> - rec (Sigma_proj1 A (\ (a:A) -> LRTInput stack (B a)) args) - (Sigma_proj2 A (\ (a:A) -> LRTInput stack (B a)) args)) - (\ (A:LetRecType) (_:LRTInput stack A -> sort 0) - (B:LetRecType) (rec:LRTInput stack B -> sort 0) - (args:LRTArg stack A * LRTInput stack B) -> - rec (args.(2))) - (\ (A:sort 0) (v:Void) -> elimVoid (sort 0) v) - (\ (F:sort 0 -> sort 0 -> sort 0) (_:ValidLRTFunctor2 F) - (A:LetRecType) (_:LRTInput stack A -> sort 0) - (B:LetRecType) (_:LRTInput stack B -> sort 0) (v:Void) -> - elimVoid (sort 0) v) - (\ (A:sort 0) (B:A -> LetRecType) - (_:(a:A) -> LRTInput stack (B a) -> sort 0) (v:Void) -> - elimVoid (sort 0) v) - lrt; - --- Build the function type (a1:A1) -> ... -> (an:An) -> B represented by a --- LetRecType. A LetRecType that is not a monadic function type turns into a --- function from v:void -> F v -lrtPi : (stack:FunStack) -> (lrt:LetRecType) -> - (LRTInput stack lrt -> sort 0) -> sort 0; -lrtPi stack lrt_top = - LetRecType__rec - (\ (lrt:LetRecType) -> (LRTInput stack lrt -> sort 0) -> sort 0) - (\ (R:LetRecType) (_:(LRTInput stack R -> sort 0) -> sort 0) - (rec:#() -> sort 0) -> rec ()) - (\ (A:sort 0) (B: A -> LetRecType) - (rec: (x:A) -> (LRTInput stack (B x) -> sort 0) -> sort 0) - (outF : LRTInput stack (LRT_FunDep A B) -> sort 0) -> - (x:A) -> rec x (\ (args : LRTInput stack (B x)) -> - outF (exists A (\ (y:A) -> LRTInput stack (B y)) x args))) - (\ (A:LetRecType) (_:(LRTInput stack A -> sort 0) -> sort 0) - (B:LetRecType) (rec:(LRTInput stack B -> sort 0) -> sort 0) - (outF : LRTInput stack (LRT_FunClos A B) -> sort 0) -> - (x:LRTArg stack A) -> rec (\ (args : LRTInput stack B) -> outF (x, args))) - (\ (A:sort 0) (rec : Void -> sort 0) -> (v:Void) -> rec v) - (\ (F:sort 0 -> sort 0 -> sort 0) (_:ValidLRTFunctor2 F) - (A:LetRecType) (_:(LRTInput stack A -> sort 0) -> sort 0) - (B:LetRecType) (_:(LRTInput stack B -> sort 0) -> sort 0) - (rec : Void -> sort 0) -> (v:Void) -> rec v) - (\ (A:sort 0) (B:A -> LetRecType) - (_:(a:A) -> (LRTInput stack (B a) -> sort 0) -> sort 0) - (rec : Void -> sort 0) -> (v:Void) -> rec v) - lrt_top; - - --- A recursive call to one of the functions in a FunStack -data StackCall (stack : FunStack) : sort 0 where { - StackCallOfArgs : (n:Nat) -> LRTInput stack (nthLRT stack n) -> StackCall stack; -} - --- The return type for calling a recursive function in a FunStack -StackCallRet : (stack:FunStack) -> StackCall stack -> sort 0; -StackCallRet stack call = - StackCall#rec - stack - (\ (_:StackCall stack) -> sort 0) - (\ (n:Nat) (args:LRTInput stack (nthLRT stack n)) -> - LRTOutput stack (nthLRT stack n) args) - call; - --- The type of events / effects in a SpecM computation, each of which is either --- an error (represented as a String), an E, or a StackCall from stack -FunStackE : (E:EvType) -> FunStack -> sort 0; -FunStackE E stack = Either (StackCall stack) (Either String (evTypeType E)); - --- The return type for a FunStackE effect in a SpecM computation -FunStackERet : (E:EvType) -> (stack:FunStack) -> FunStackE E stack -> sort 0; -FunStackERet E stack eith_top = - Either#rec - (StackCall stack) (Either String (evTypeType E)) - (\ (_:Either (StackCall stack) (Either String (evTypeType E))) -> sort 0) - (StackCallRet stack) - (\ (eith:Either String (evTypeType E)) -> - Either#rec - String (evTypeType E) - (\ (_:Either String (evTypeType E)) -> sort 0) - (\ (_:String) -> Void) (evRetType E) - eith) - eith_top; - -- The monad for specifications of computations (FIXME: document this!) -primitive SpecM : (E:EvType) -> FunStack -> sort 0 -> sort 0; +primitive SpecM : (E:EvType) -> sort 0 -> sort 0; -- Return for SpecM -primitive retS : (E:EvType) -> (stack:FunStack) -> (a:sort 0) -> a -> - SpecM E stack a; +primitive retS : (E:EvType) -> (a:sort 0) -> a -> SpecM E 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; +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) -> (stack:FunStack) -> (e:evTypeType E) -> - SpecM E stack (evRetType E e); +primitive triggerS : (E:EvType) -> (e:evTypeType E) -> SpecM E (evRetType E e); -- Signal an error in SpecM -primitive errorS : (E:EvType) -> (stack:FunStack) -> (a:sort 0) -> String -> - SpecM E stack a; +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) -> (stack:FunStack) -> (a:qsort 0) -> - SpecM E stack 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) -> (stack:FunStack) -> (a:qsort 0) -> - SpecM E stack a; +primitive existsS : (E:EvType) -> (a:qsort 0) -> SpecM E a; -- Assume a proposition holds -primitive assumeS : (E:EvType) -> (stack:FunStack) -> - (p:Prop) -> SpecM E stack #(); +primitive assumeS : (E:EvType) -> (p:Prop) -> SpecM E #(); -- Assume a Boolean value is true -assumeBoolS : (E:EvType) -> (stack:FunStack) -> Bool -> SpecM E stack #(); -assumeBoolS E stack b = assumeS E stack (EqTrue b); +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) -> (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); +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); -- Assert a proposition holds -primitive assertS : (E:EvType) -> (stack:FunStack) -> - (p:Prop) -> SpecM E stack #(); +primitive assertS : (E:EvType) -> (p:Prop) -> SpecM E #(); -- Assert a Boolean value is true -assertBoolS : (E:EvType) -> (stack:FunStack) -> Bool -> SpecM E stack #(); -assertBoolS E stack b = assertS E stack (EqTrue b); +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) -> (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); +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 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); - --- Call a monadic function closure of monadic type -primitive CallS : (E:EvType) -> (stk:FunStack) -> (R:LetRecType) -> - LRTClos stk (LRT_SpecM R) -> SpecM E stk (LRTArg stk R); - --- A monadic function whose type is described by the encoding lrt -SpecFun : EvType -> FunStack -> LetRecType -> sort 0; -SpecFun E stk lrt = - lrtPi stk lrt (\ (args:LRTInput stk lrt) -> - SpecM E stk (LRTOutput stk lrt args)); - --- Apply a closure to all of its arguments and then call it using CallS -applyCallClos : (E:EvType) -> (stk:FunStack) -> (lrt:LetRecType) -> - LRTClos stk lrt -> SpecFun E stk lrt; -applyCallClos E stk lrt = - LetRecType__rec - (\ (lrt:LetRecType) -> LRTClos stk lrt -> SpecFun E stk lrt) - (\ (R:LetRecType) (_:LRTClos stk R -> SpecFun E stk R) - (clos:LRTClos stk (LRT_SpecM R)) -> - CallS E stk R clos) - (\ (A:sort 0) (B:A -> LetRecType) - (rec:(a:A) -> LRTClos stk (B a) -> SpecFun E stk (B a)) - (clos:LRTClos stk (LRT_FunDep A B)) (a:A) -> - rec a (applyLRTClosDep stk A B clos a)) - (\ (A:LetRecType) (_:LRTClos stk A -> SpecFun E stk A) - (B:LetRecType) (rec:LRTClos stk B -> SpecFun E stk B) - (clos:LRTClos stk (LRT_FunClos A B)) (arg:LRTArg stk A) -> - rec (applyLRTClosClos stk A B clos arg)) - (\ (A:sort 0) (_:LRTClos stk (LRT_Type A)) (v:Void) -> - elimVoid (SpecM E stk (LRTOutput stk (LRT_Type A) v)) v) - (\ (F:sort 0 -> sort 0 -> sort 0) (validF:ValidLRTFunctor2 F) - (A:LetRecType) (_:LRTClos stk A -> SpecFun E stk A) - (B:LetRecType) (_:LRTClos stk B -> SpecFun E stk B) - (_:LRTClos stk (LRT_BinOp F validF A B)) (v:Void) -> - elimVoid (SpecM E stk (LRTOutput stk (LRT_BinOp F validF A B) v)) v) - (\ (A:sort 0) (B:A -> LetRecType) - (_:(a:A) -> LRTClos stk (B a) -> SpecFun E stk (B a)) - (_:LRTClos stk (LRT_Sigma A B)) (v:Void) -> - elimVoid (SpecM E stk (LRTOutput stk (LRT_Sigma A B) v)) v) - lrt; +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); --- --- The category of stack inclusions --- +-- A monadic specification function of a given type description +specFun : (E:EvType) -> TpEnv -> TpDesc -> sort 0; +specFun E env_top T_top = + TpDesc#rec (\ (_:TpDesc) -> TpEnv -> sort 0) --- A stack inclusion is a mapping from the indices of one stack to those of --- another that preserves LetRecTypes; however, SAW doesn't need to know --- anything about how these are defined nor how they are built -- they are --- defined and their properties are verified in Coq -- so we just axiomatize --- them here as a primitive -primitive stackIncl : FunStack -> FunStack -> sort 0; + -- For Tp_M R, specFun returns SpecM E [env/xs]R + (\ (R:TpDesc) (_:TpEnv -> sort 0) (env:TpEnv) -> + SpecM E (tpElemEnv nilTpEnv (tpSubst 0 env R))) --- FIXME: keeping the SAW core definition of stackIncls in case we need them... -{- --- A proof that a function is a stack inclusion, i.e., is a mapping from the --- indices of one stack to those of another that preserves LetRecTypes -isStackIncl : (stk1 stk2 : FunStack) -> (Nat -> Nat) -> sort 0; -isStackIncl stk1 stk2 f = - (n : Nat) -> (IsLtNat n (stackLen stk1)) -> - Eq LetRecType (nthLRT stk1 n) (nthLRT stk2 (f n)) * - IsLtNat (f n) (stackLen stk2); - --- A stack inclusion is a mapping from the indices of one stack to those of --- another that preserves LetRecTypes -stackIncl : (stk1 stk2 : FunStack) -> sort 0; -stackIncl stk1 stk2 = Sigma (Nat -> Nat) (isStackIncl stk1 stk2); - --- Helper function to build a stackIncl -mkStackIncl : (stk1 stk2 : FunStack) -> (f:Nat -> Nat) -> - isStackIncl stk1 stk2 f -> stackIncl stk1 stk2; -mkStackIncl stk1 stk2 f pf = - exists (Nat -> Nat) (isStackIncl stk1 stk2) f pf; - --- Project the function out of a stackIncl -applyStackIncl : (stk1 stk2 : FunStack) -> stackIncl stk1 stk2 -> Nat -> Nat; -applyStackIncl stk1 stk2 = - Sigma_proj1 (Nat -> Nat) (isStackIncl stk1 stk2); - --- Project the proof out of a stackIncl -stackInclProof : (stk1 stk2 : FunStack) -> (incl : stackIncl stk1 stk2) -> - isStackIncl stk1 stk2 (applyStackIncl stk1 stk2 incl); -stackInclProof stk1 stk2 = - Sigma_proj2 (Nat -> Nat) (isStackIncl stk1 stk2); - --- The identity function is a stack inclusion for any stack into itself -reflStackIncl : (stk:FunStack) -> stackIncl stk stk; -reflStackIncl stk = - mkStackIncl stk stk - (\ (n:Nat) -> n) - (\ (n:Nat) (lt_pf:IsLtNat n (stackLen stk)) -> - (Refl LetRecType (nthLRT stk n), lt_pf)); - --- Compose two stack inclusions -compStackIncl : (stk1 stk2 stk3 : FunStack) -> stackIncl stk1 stk2 -> - stackIncl stk2 stk3 -> stackIncl stk1 stk3; -compStackIncl stk1 stk2 stk3 incl12 incl23 = - mkStackIncl stk1 stk3 - (\ (n:Nat) -> - applyStackIncl stk2 stk3 incl23 (applyStackIncl stk1 stk2 incl12 n)) - (\ (n:Nat) (lt_pf:IsLtNat n (stackLen stk1)) -> - (trans LetRecType (nthLRT stk1 n) - (nthLRT stk2 (applyStackIncl stk1 stk2 incl12 n)) - (nthLRT stk3 (applyStackIncl stk2 stk3 incl23 - (applyStackIncl stk1 stk2 incl12 n))) - (stackInclProof stk1 stk2 incl12 n lt_pf).1 - (stackInclProof stk2 stk3 incl23 - (applyStackIncl stk1 stk2 incl12 n) - (stackInclProof stk1 stk2 incl12 n lt_pf).(2)).1 - , - (stackInclProof stk2 stk3 incl23 - (applyStackIncl stk1 stk2 incl12 n) - (stackInclProof stk1 stk2 incl12 n lt_pf).(2)).(2))); - --- The function portion of weakenLeftStackIncl -weakenLeftStackInclFun : FunStack -> Nat -> Nat; -weakenLeftStackInclFun stk1 n = addNat (length1 LetRecType stk1) n; - --- Proof that weakenLeftStackIncl is a stack inclusion; note that this is --- provable in SAW core, and in fact the Coq development has the proof, but it's --- just big and not really necessary to prove in SAW core, so we just assume it -axiom -weakenLeftStackInclProof : (stk1 stk2 : FunStack) -> - isStackIncl stk2 (app1 LetRecType stk1 stk2) - (weakenLeftStackInclFun stk1); - --- The inclusion from any stack into the append of another stack on the left -weakenLeftStackIncl : (stk1 stk2 : FunStack) -> - stackIncl stk2 (app1 LetRecType stk1 stk2); -weakenLeftStackIncl stk1 stk2 = - mkStackIncl stk2 (app1 LetRecType stk1 stk2) - (weakenLeftStackInclFun stk1) - (weakenLeftStackInclProof stk1 stk2); - --- Proof that weakenRightStackIncl is a stack inclusion; note that this is --- provable in SAW core, and in fact the Coq development has the proof, but it's --- just big and not really necessary to prove in SAW core, so we just assume it -axiom -weakenRightStackInclProof : (stk1 stk2 : FunStack) -> - isStackIncl stk1 (app1 LetRecType stk1 stk2) - (\ (n:Nat) -> n); - --- The inclusion from any stack into the append of another stack on the right -weakenRightStackIncl : (stk1 stk2 : FunStack) -> - stackIncl stk1 (app1 LetRecType stk1 stk2); -weakenRightStackIncl stk1 stk2 = - mkStackIncl stk1 (app1 LetRecType stk1 stk2) - (\ (n:Nat) -> n) - (weakenRightStackInclProof stk1 stk2); --} + -- For Tp_Pi K T, specFun quantifies over all elem:kindElem K and adds elem + -- to the environment for the recursive call to specFun T + (\ (K:KindDesc) (T:TpDesc) (rec:TpEnv -> sort 0) (env:TpEnv) -> + (elem:kindElem K) -> rec (envConsElem K elem env)) + + -- For Tp_Arr T U, specFun returns the function type tpElem T -> specFun U + (\ (T:TpDesc) (_:TpEnv -> sort 0) (U:TpDesc) (rec:TpEnv -> sort 0) (env:TpEnv) -> + tpElemEnv env T -> rec env) + + -- Everything else is not a function type, so specFun returns the unit type + (\ (K:KindDesc) (_:TpEnv) -> #()) + (\ (T:TpDesc) (_:TpEnv -> sort 0) + (U:TpDesc) (_:TpEnv -> sort 0) (env:TpEnv) -> #()) + (\ (T:TpDesc) (_:TpEnv -> sort 0) + (U:TpDesc) (_:TpEnv -> sort 0) (env:TpEnv) -> #()) + (\ (K:KindDesc) (T:TpDesc) (_:TpEnv -> sort 0) (env:TpEnv) -> #()) + (\ (_:TpDesc) (_:TpEnv -> sort 0) (_:ArithExpr Kind_nat) (env:TpEnv) -> #()) + (\ (T:TpDesc) (_:TpEnv -> sort 0) (env:TpEnv) -> #()) + (\ (var:Nat) (env:TpEnv) -> #()) + (\ (_:TpEnv) -> #()) + T_top env_top; +-- Call a function index in a specification +primitive CallS : (E:EvType) -> (T:TpDesc) -> FunIx T -> specFun E nilTpEnv T; --- --- Spec definitions --- +-- Create a function index from a specification function in a specification +primitive LambdaS : (E:EvType) -> (T:TpDesc) -> specFun E nilTpEnv T -> FunIx T; --- A monadic function that is polymorphic in its function stack -PolySpecFun : EvType -> FunStack -> LetRecType -> sort 1; -PolySpecFun E stk lrt = - (stk':FunStack) -> stackIncl stk stk' -> SpecFun E stk' lrt; +-- Create a lambda as a fixed-point that can call itself. Note that the type of +-- f, FunIx T -> specFun E nil T, is the same as specFun E nil (Tp_Arr T T) when +-- T is a monadic function type. +primitive FixS : (E:EvType) -> (T:TpDesc) -> + (FunIx T -> specFun E nilTpEnv T) -> FunIx T; --- A right-nested tuple of a list of function definitions for all the --- LetRecTypes in the defs list, that can make calls into the calls list -StackTuple : EvType -> FunStack -> FunStack -> sort 0; -StackTuple E calls defs = - List1#rec - LetRecType (\ (_:FunStack) -> sort 0) - #() - (\ (lrt:LetRecType) (_:FunStack) (rec:sort 0) -> SpecFun E calls lrt * rec) - defs; - --- A StackTuple that is polymorphic in its function stack, which defines --- functions for all the defs that can call all the calls -PolyStackTuple : EvType -> FunStack -> FunStack -> sort 1; -PolyStackTuple E calls defs = - (calls':FunStack) -> stackIncl calls calls' -> StackTuple E calls' defs; - --- FIXME: keeping the SAW core definitions for SpecDefs in case we need them... -{- --- Append two StackTuples -appStackTuple : (E:EvType) -> (calls defs1 defs2 : FunStack) -> - StackTuple E calls defs1 -> StackTuple E calls defs2 -> - StackTuple E calls (app1 LetRecType defs1 defs2); -appStackTuple E calls defs1_top defs2 = - List1#rec - LetRecType - (\ (defs1:FunStack) -> StackTuple E calls defs1 -> - StackTuple E calls defs2 -> - StackTuple E calls (app1 LetRecType defs1 defs2)) - (\ (_:#()) (tup2:StackTuple E calls defs2) -> tup2) - (\ (lrt:LetRecType) (defs1:FunStack) - (rec:StackTuple E calls defs1 -> StackTuple E calls defs2 -> - StackTuple E calls (app1 LetRecType defs1 defs2)) - (tup1:StackTuple E calls (Cons1 LetRecType lrt defs1)) - (tup2:StackTuple E calls defs2) -> - (tup1.(1), rec tup1.(2) tup2)) - defs1_top; - --- Append two PolyStackTuples -appPolyStackTuple : (E:EvType) -> (calls defs1 defs2 : FunStack) -> - PolyStackTuple E calls defs1 -> - PolyStackTuple E calls defs2 -> - PolyStackTuple E calls (app1 LetRecType defs1 defs2); -appPolyStackTuple E calls defs1 defs2 ptup1 ptup2 = - \ (calls':FunStack) (incl:stackIncl calls calls') -> - appStackTuple E calls' defs1 defs2 (ptup1 calls' incl) (ptup2 calls' incl); - --- Apply a stackIncl to a PolySpecFun -inclPolyStackTuple : (E:EvType) -> (calls1 calls2 defs : FunStack) -> - stackIncl calls1 calls2 -> PolyStackTuple E calls1 defs -> - PolyStackTuple E calls2 defs; -inclPolyStackTuple E calls1 calls2 defs incl ptup = - \ (calls' : FunStack) (incl' : stackIncl calls2 calls') -> - ptup calls' (compStackIncl calls1 calls2 calls' incl incl'); - --- A "spec definition" represents a definition of a SpecM monadic function via --- (co)recursion over a tuple of recursive function bodies -data SpecDef (E : EvType) : sort 1 where { - MkSpecDef : (stk : FunStack) -> PolyStackTuple E stk stk -> - (lrt : LetRecType) -> PolySpecFun E stk lrt -> - SpecDef E; -} --- Get the stack of a SpecDef -defStack : (E : EvType) -> SpecDef E -> FunStack; -defStack E d = - SpecDef#rec - E (\ (_:SpecDef E) -> FunStack) - (\ (stk:FunStack) (_:PolyStackTuple E stk stk) - (lrt:LetRecType) (_:PolySpecFun E stk lrt) -> stk) - d; - --- Get the function definitions of a SpecDef -defFuns : (E : EvType) -> (d:SpecDef E) -> - PolyStackTuple E (defStack E d) (defStack E d); -defFuns E d = - SpecDef#rec - E (\ (d:SpecDef E) -> PolyStackTuple E (defStack E d) (defStack E d)) - (\ (stk:FunStack) (funs:PolyStackTuple E stk stk) - (lrt:LetRecType) (_:PolySpecFun E stk lrt) -> funs) - d; - --- Get the LetRecType of a SpecDef -defLRT : (E : EvType) -> SpecDef E -> LetRecType; -defLRT E d = - SpecDef#rec - E (\ (_:SpecDef E) -> LetRecType) - (\ (stk:FunStack) (_:PolyStackTuple E stk stk) - (lrt:LetRecType) (_:PolySpecFun E stk lrt) -> lrt) - d; - --- Get the body of a SpecDef -defBody : (E : EvType) -> (d:SpecDef E) -> - PolySpecFun E (defStack E d) (defLRT E d); -defBody E d = - SpecDef#rec - E (\ (d:SpecDef E) -> PolySpecFun E (defStack E d) (defLRT E d)) - (\ (stk:FunStack) (_:PolyStackTuple E stk stk) - (lrt:LetRecType) (body:PolySpecFun E stk lrt) -> body) - d; - --- Build the concatenated FunStack for a list of imported spec defs -impsStack : (E:EvType) -> List1 (SpecDef E) -> FunStack; -impsStack E imps = - concat1 LetRecType (map1 (SpecDef E) FunStack (defStack E) imps); - --- The combined function stack for defineSpec -defineSpecStack : (E:EvType) -> FunStack -> List1 (SpecDef E) -> FunStack; -defineSpecStack E stk imps = app1 LetRecType stk (impsStack E imps); - --- Build the list of recursive functions for a list of imported spec defs -impsFuns : (E:EvType) -> (imps : List1 (SpecDef E)) -> - PolyStackTuple E (impsStack E imps) (impsStack E imps); -impsFuns E imps_top = - List1#rec (SpecDef E) - (\ (imps : List1 (SpecDef E)) -> - PolyStackTuple E (impsStack E imps) (impsStack E imps)) - (\ (calls' : FunStack) (_ : stackIncl emptyFunStack calls') -> ()) - (\ (d:SpecDef E) (imps:List1 (SpecDef E)) - (rec:PolyStackTuple E (impsStack E imps) (impsStack E imps)) -> - appPolyStackTuple - E (impsStack E (Cons1 (SpecDef E) d imps)) - (defStack E d) (impsStack E imps) - (inclPolyStackTuple - E (defStack E d) (impsStack E (Cons1 (SpecDef E) d imps)) - (defStack E d) - (weakenRightStackIncl (defStack E d) (impsStack E imps)) - (defFuns E d)) - (inclPolyStackTuple - E (impsStack E imps) (impsStack E (Cons1 (SpecDef E) d imps)) - (impsStack E imps) - (weakenLeftStackIncl (defStack E d) (impsStack E imps)) - rec)) - imps_top; +-- The multi-arity function type from FunIxs to a given output type +arrowIxs : List TpDesc -> sort 0 -> sort 0; +arrowIxs Ts_top a = + List__rec TpDesc (\ (_:List TpDesc) -> sort 0) a + (\ (T:TpDesc) (_:List TpDesc) (rec:sort 0) -> FunIx T -> rec) + Ts_top; --} +-- The type of a tuple of spec functions of types Us that take in FunIxs for Ts +arrowIxsSpecFuns : EvType -> List TpDesc -> List TpDesc -> sort 0; +arrowIxsSpecFuns E Ts Us = + List__rec TpDesc (\ (_:List TpDesc) -> sort 0) #() + (\ (U:TpDesc) (_:List TpDesc) (rec:sort 0) -> + arrowIxs Ts (specFun E nilTpEnv U) * rec) + Us; --- A "spec definition" represents a definition of a SpecM monadic function via --- corecursion over a tuple of recursive function bodies. However, SAW doesn't --- need to know anything about how these are defined nor how they are built -- --- they are defined and their properties are verified in Coq -- so we just --- axiomatize them here as a primitive -primitive SpecDef : EvType -> LetRecType -> sort 1; - --- A "spec import" is a spec definition that is imported into another spec --- definition, represented as a SpecDef with existential LetRecType -data SpecImp (E: EvType) : sort 1 where { - Build_SpecImp : (lrt : LetRecType) -> SpecDef E lrt -> SpecImp E; -} +-- 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 = arrowIxsSpecFuns E Ts Ts; --- Get the LetRecType of a spec import -SpecImpType : (E:EvType) -> SpecImp E -> LetRecType; -SpecImpType E imp = - SpecImp#rec E (\ (_:SpecImp E) -> LetRecType) - (\ (lrt:LetRecType) (_:SpecDef E lrt) -> lrt) imp; - --- The FunStack used by defineSpec; also defined only in Coq, not in SAW -primitive defineSpecStack : - (E:EvType) -> FunStack -> List1 (SpecImp E) -> FunStack; - --- FIXME HERE: define defineSpec -primitive defineSpec : - (E:EvType) -> (stk:FunStack) -> (lrt:LetRecType) -> (imps:List1 (SpecImp E)) -> - PolyStackTuple E (defineSpecStack E stk imps) stk -> - PolySpecFun E (defineSpecStack E stk imps) lrt -> - SpecDef E lrt; - --- Build a closure that calls the nth corecursive function out of those that are --- defined locally in a SpecDef -primitive mkLocalLRTClos : - (E:EvType) -> (stk: FunStack) -> (imps: List1 (SpecImp E)) -> - (stk': FunStack) -> (incl: stackIncl (defineSpecStack E stk imps) stk') -> - (n: Nat) -> LRTClos stk' (nthLRT stk n); - --- The "default", trivial spec definition -defaultSpecDef : (E:EvType) -> SpecDef E default_lrt; -defaultSpecDef E = - defineSpec E emptyFunStack default_lrt (Nil1 (SpecImp E)) - (\ (stk': FunStack) - (incl: stackIncl (defineSpecStack E emptyFunStack (Nil1 (SpecImp E))) stk') -> - ()) - (\ (stk': FunStack) - (incl: stackIncl (defineSpecStack E emptyFunStack (Nil1 (SpecImp E))) stk') - (v:Void) -> elimVoid (SpecM E stk' Void) v); - --- Get the nth spec import from a list -nthImport : (E:EvType) -> List1 (SpecImp E) -> Nat -> SpecImp E; -nthImport E = - nth_default1 (SpecImp E) (Build_SpecImp E default_lrt (defaultSpecDef E)); - --- Call the body of the nth import from a spec import list -primitive callNthImportS : - (E:EvType) -> (stk:FunStack) -> (imps:List1 (SpecImp E)) -> - (stk':FunStack) -> stackIncl (defineSpecStack E stk imps) stk' -> - (n:Nat) -> SpecFun E stk' (SpecImpType E (nthImport E imps n)); +-- 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 -> SpecM E (FunIxs Ts); + +-- Perform a computation that can call a collection of corecursive functions +LetRecS : (E:EvType) -> (Ts:List TpDesc) -> (a:sort 0) -> + MultiFixBodies E Ts -> (FunIxs Ts -> SpecM E a) -> SpecM E a; +LetRecS E Ts a funs body = bindS E (FunIxs Ts) a (MultiFixS E Ts funs) body; -- @@ -3447,149 +2865,120 @@ primitive callNthImportS : -- -- 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)); +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) -> (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))); +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) -> (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; +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) -> (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; +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) -> (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)); +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) -> (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)); +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) -> (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; +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) -> (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; +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) -> (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; +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) -> (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; +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) -> (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)); +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) -> (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)); +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) -> (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 = +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 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)) + (\ (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 stack b (Vec n b) (Vec (Succ n) b) + 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) -> (stack:FunStack) -> - (a : sort 0) -> (b : isort 0) -> (a -> SpecM E stack b) -> +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 stack (BVVec n len b); -mapBVVecS E stack a b f n len = mapS E stack a b f (bvToNat n len); + 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) -> (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 = +castVecS : (E:EvType) -> (a : sort 0) -> (n1 : Nat) -> (n2 : Nat) -> + Vec n1 a -> SpecM E (Vec n2 a); +castVecS E 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") + (Eq Nat n1 n2) (SpecM E (Vec n2 a)) + (errorS E (Vec n2 a) "Could not cast Vec") (\ (pf:Eq Nat n1 n2) -> retS - E stack (Vec n2 a) + 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)) (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) -> +appendCastBVVecS : (E:EvType) -> (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 = + SpecM E (BVVec n len3 a); +appendCastBVVecS E 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") + (Eq (Vec n Bool) (bvAdd n len1 len2) len3) (SpecM E (BVVec n len3 a)) + (errorS E (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) + 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)) @@ -3601,6 +2990,8 @@ appendCastBVVecS E stack n len1 len2 len3 a v1 v2 = -- Defining refinement on SpecM computations -- +{- + -- 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. @@ -3653,7 +3044,7 @@ 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); - +-} -------------------------------------------------------------------------------- -- SMT Array From 3801677383ba67f7bae9a9bc948a536e66a41549 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Tue, 3 Oct 2023 14:53:14 -0700 Subject: [PATCH 103/305] renamed arithmetic kinds to expression kinds --- saw-core/prelude/Prelude.sawcore | 291 +++++++++++++++++-------------- 1 file changed, 156 insertions(+), 135 deletions(-) diff --git a/saw-core/prelude/Prelude.sawcore b/saw-core/prelude/Prelude.sawcore index a75e349db6..d9b2488089 100644 --- a/saw-core/prelude/Prelude.sawcore +++ b/saw-core/prelude/Prelude.sawcore @@ -2195,79 +2195,82 @@ nth_default1 a d l = -------------------------------------------------------------------------------- -- Type descriptions --- Arithmetic kinds -- - --- The kinds for objects that can be used in type-level arithmetic expressions -data ArithKind : sort 0 where { - Kind_nat : ArithKind; - Kind_bv : (w:Nat) -> ArithKind; +-- 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_bv : (w:Nat) -> ExprKind; } --- The type of an element of an ArithKind -arithKindElem : ArithKind -> sort 0; -arithKindElem AK = - ArithKind#rec (\ (_:ArithKind) -> sort 0) Nat (\ (w:Nat) -> Vec w Bool) AK; +-- The type of an element of an ExprKind +exprKindElem : ExprKind -> sort 0; +exprKindElem EK = + ExprKind#rec (\ (_:ExprKind) -> sort 0) + #() Bool Nat (\ (w:Nat) -> Vec w Bool) EK; --- The unary operations for type-level arithmetic expressions -data ArithUnOp : ArithKind -> ArithKind -> sort 0 where { - UnOp_BVToNat : (w:Nat) -> ArithUnOp (Kind_bv w) Kind_nat; - UnOp_NatToBV : (w:Nat) -> ArithUnOp Kind_nat (Kind_bv w); +-- 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); } --- Evaluate a unary operation to a function on elements of its ArithKinds -evalUnOp : (AK1 AK2:ArithKind) -> ArithUnOp AK1 AK2 -> arithKindElem AK1 -> - arithKindElem AK2; -evalUnOp AK1 AK2 op = - ArithUnOp#rec (\ (AK1 AK2:ArithKind) (_:ArithUnOp AK1 AK2) -> - arithKindElem AK1 -> arithKindElem AK2) +-- 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) - AK1 AK2 op; - --- The binary operations for type-level arithmetic expressions -data ArithBinOp : ArithKind -> ArithKind -> ArithKind -> sort 0 where { - BinOp_AddNat : ArithBinOp Kind_nat Kind_nat Kind_nat; - BinOp_MulNat : ArithBinOp Kind_nat Kind_nat Kind_nat; - BinOp_AddBV : (w:Nat) -> ArithBinOp (Kind_bv w) (Kind_bv w) (Kind_bv w); - BinOp_MulBV : (w:Nat) -> ArithBinOp (Kind_bv w) (Kind_bv w) (Kind_bv w); + 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); } --- Evaluate a binary operation to a function on elements of its ArithKinds -evalBinOp : (AK1 AK2 AK3:ArithKind) -> ArithBinOp AK1 AK2 AK3 -> - arithKindElem AK1 -> arithKindElem AK2 -> arithKindElem AK3; -evalBinOp AK1 AK2 AK3 op = - ArithBinOp#rec (\ (AK1 AK2 AK3:ArithKind) (_:ArithBinOp AK1 AK2 AK3) -> - arithKindElem AK1 -> arithKindElem AK2 -> arithKindElem AK3) +-- 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 - AK1 AK2 AK3 op; + EK1 EK2 EK3 op; -- Kind and type descriptions -- --- The kinds used for type descriptions, which can either be arithmetic or the --- kind of type descriptions themselves +-- 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_Arith : ArithKind -> KindDesc; + Kind_Expr : ExprKind -> KindDesc; Kind_Tp : KindDesc; } --- Type-level arithmetic expressions -data ArithExpr : ArithKind -> sort 0 where { - Arith_Const : (AK:ArithKind) -> arithKindElem AK -> ArithExpr AK; - Arith_Var : (AK:ArithKind) -> Nat -> ArithExpr AK; - Arith_UnOp : (AK1 AK2:ArithKind) -> ArithUnOp AK1 AK2 -> - ArithExpr AK1 -> ArithExpr AK2; - Arith_BinOp : (AK1 AK2 AK3:ArithKind) -> ArithBinOp AK1 AK2 AK3 -> - ArithExpr AK1 -> ArithExpr AK2 -> ArithExpr AK3; +-- 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 an ArithExpr -ArithN : Nat -> ArithExpr Kind_nat; -ArithN n = Arith_Const Kind_nat n; +-- The natural number N as a TpExpr +TpExprN : Nat -> TpExpr Kind_nat; +TpExprN n = TpExpr_Const Kind_nat n; --- The natural number 0 as an ArithExpr -ArithZ : ArithExpr Kind_nat; -ArithZ = Arith_Const Kind_nat 0; +-- 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 @@ -2300,7 +2303,7 @@ data TpDesc : sort 0 where { Tp_Sigma : KindDesc -> TpDesc -> TpDesc; -- Vector types - Tp_Vec : TpDesc -> ArithExpr Kind_nat -> TpDesc; + Tp_Vec : TpDesc -> TpExpr Kind_nat -> TpDesc; -- Inductive types, where Kind_Ind A is equivalent to [Kind_Ind A/x]A Tp_Ind : TpDesc -> TpDesc; @@ -2315,57 +2318,75 @@ data TpDesc : sort 0 where { -- Type-level environments -- --- Decide equality for arithmetic kinds -proveEqArithKind : (AK1 AK2 : ArithKind) -> Maybe (Eq ArithKind AK1 AK2); -proveEqArithKind AK1_top = - ArithKind#rec - (\ (AK1:ArithKind) -> (AK2:ArithKind) -> Maybe (Eq ArithKind AK1 AK2)) - (\ (AK2_top:ArithKind) -> - ArithKind#rec (\ (AK2:ArithKind) -> Maybe (Eq ArithKind Kind_nat AK2)) - (Just (Eq ArithKind Kind_nat Kind_nat) (Refl ArithKind Kind_nat)) - (\ (w:Nat) -> Nothing (Eq ArithKind Kind_nat (Kind_bv w))) - AK2_top) - (\ (w1:Nat) (AK2_top:ArithKind) -> - ArithKind#rec (\ (AK2:ArithKind) -> Maybe (Eq ArithKind (Kind_bv w1) AK2)) - (Nothing (Eq ArithKind (Kind_bv w1) Kind_nat)) +-- 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)) + (\ (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)) + (\ (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)) + (\ (w:Nat) -> Nothing (Eq ExprKind Kind_nat (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)) (\ (w2:Nat) -> Maybe__rec (Eq Nat w1 w2) (\ (_:Maybe (Eq Nat w1 w2)) -> - Maybe (Eq ArithKind (Kind_bv w1) (Kind_bv w2))) - (Nothing (Eq ArithKind (Kind_bv w1) (Kind_bv 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 ArithKind (Kind_bv w1) (Kind_bv w2)) - (eq_cong Nat w1 w2 e ArithKind (\ (w:Nat) -> Kind_bv w))) + Just (Eq ExprKind (Kind_bv w1) (Kind_bv w2)) + (eq_cong Nat w1 w2 e ExprKind (\ (w:Nat) -> Kind_bv w))) (proveEqNat w1 w2)) - AK2_top) - AK1_top; + 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)) - (\ (AK1:ArithKind) (K2_top:KindDesc) -> + (\ (EK1:ExprKind) (K2_top:KindDesc) -> KindDesc#rec - (\ (K2:KindDesc) -> Maybe (Eq KindDesc (Kind_Arith AK1) K2)) - (\ (AK2:ArithKind) -> + (\ (K2:KindDesc) -> Maybe (Eq KindDesc (Kind_Expr EK1) K2)) + (\ (EK2:ExprKind) -> Maybe__rec - (Eq ArithKind AK1 AK2) - (\ (_:Maybe (Eq ArithKind AK1 AK2)) -> - Maybe (Eq KindDesc (Kind_Arith AK1) (Kind_Arith AK2))) - (Nothing (Eq KindDesc (Kind_Arith AK1) (Kind_Arith AK2))) - (\ (e:Eq ArithKind AK1 AK2) -> - Just (Eq KindDesc (Kind_Arith AK1) (Kind_Arith AK2)) - (eq_cong ArithKind AK1 AK2 e KindDesc - (\ (AK:ArithKind) -> Kind_Arith AK))) - (proveEqArithKind AK1 AK2)) - (Nothing (Eq KindDesc (Kind_Arith AK1) Kind_Tp)) + (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)) - (\ (AK2:ArithKind) -> Nothing (Eq KindDesc Kind_Tp (Kind_Arith AK2))) + (\ (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; @@ -2374,17 +2395,17 @@ proveEqKindDesc K1_top = kindElem : KindDesc -> sort 0; kindElem K = KindDesc#rec (\ (_:KindDesc) -> sort 0) - (\ (AK:ArithKind) -> arithKindElem AK) + (\ (EK:ExprKind) -> exprKindElem EK) TpDesc K; --- The default element of an arithmetic kind -defaultAKElem : (AK:ArithKind) -> arithKindElem AK; -defaultAKElem AK = ArithKind#rec arithKindElem 0 (\ (w:Nat) -> bvNat w 0) AK; +-- The default element of an expression kind +defaultEKElem : (EK:ExprKind) -> exprKindElem EK; +defaultEKElem EK = ExprKind#rec exprKindElem () False 0 (\ (w:Nat) -> bvNat w 0) EK; -- The default element of a kind defaultKindElem : (K:KindDesc) -> kindElem K; -defaultKindElem K = KindDesc#rec kindElem defaultAKElem Tp_Void K; +defaultKindElem K = KindDesc#rec kindElem defaultEKElem Tp_Void K; -- An element of an environment is a value, i.e., an element of some kind TpEnvElem : sort 0; @@ -2504,41 +2525,41 @@ evalVar n env K var = (\ (_:Nat) -> defaultKindElem K) (substVar n env K var); --- Substitute an environment at lifting level n into arithmetic expression e -substArithExpr : Nat -> TpEnv -> (AK:ArithKind) -> ArithExpr AK -> ArithExpr AK; -substArithExpr n env AK_top e = - ArithExpr#rec (\ (AK:ArithKind) (_:ArithExpr AK) -> ArithExpr AK) - (\ (AK:ArithKind) (v:arithKindElem AK) -> Arith_Const AK v) - (\ (AK:ArithKind) (ix:Nat) -> - Either__rec (arithKindElem AK) Nat - (\ (_:Either (arithKindElem AK) Nat) -> ArithExpr AK) - (\ (v:arithKindElem AK) -> Arith_Const AK v) - (\ (ix':Nat) -> Arith_Var AK ix') - (substVar n env (Kind_Arith AK) ix)) - (\ (AK1 AK2:ArithKind) (op:ArithUnOp AK1 AK2) - (_:ArithExpr AK1) (rec:ArithExpr AK1) -> - Arith_UnOp AK1 AK2 op rec) - (\ (AK1 AK2 AK3:ArithKind) (op:ArithBinOp AK1 AK2 AK3) - (_:ArithExpr AK1) (rec1:ArithExpr AK1) - (_:ArithExpr AK2) (rec2:ArithExpr AK2) -> - Arith_BinOp AK1 AK2 AK3 op rec1 rec2) - AK_top +-- 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 an arithmetic expression to a value -evalArithExpr : TpEnv -> (AK:ArithKind) -> ArithExpr AK -> arithKindElem AK; -evalArithExpr env AK_top e = - ArithExpr#rec (\ (AK:ArithKind) (_:ArithExpr AK) -> arithKindElem AK) - (\ (AK:ArithKind) (v:arithKindElem AK) -> v) - (\ (AK:ArithKind) (ix:Nat) -> evalVar 0 env (Kind_Arith AK) ix) - (\ (AK1 AK2:ArithKind) (op:ArithUnOp AK1 AK2) - (_:ArithExpr AK1) (rec:arithKindElem AK1) -> - evalUnOp AK1 AK2 op rec) - (\ (AK1 AK2 AK3:ArithKind) (op:ArithBinOp AK1 AK2 AK3) - (_:ArithExpr AK1) (rec1:arithKindElem AK1) - (_:ArithExpr AK2) (rec2:arithKindElem AK2) -> - evalBinOp AK1 AK2 AK3 op rec1 rec2) - AK_top +-- 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 @@ -2562,9 +2583,9 @@ tpSubst n_top env_top T_top = 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)) - (\ (_:TpDesc) (rec:Nat -> TpEnv -> TpDesc) (len:ArithExpr Kind_nat) + (\ (_:TpDesc) (rec:Nat -> TpEnv -> TpDesc) (len:TpExpr Kind_nat) (n:Nat) (env:TpEnv) -> - Tp_Vec (rec n env) (substArithExpr n env Kind_nat len)) + Tp_Vec (rec n env) (substTpExpr n env Kind_nat len)) (\ (_:TpDesc) (rec:Nat -> TpEnv -> TpDesc) (n:Nat) (env:TpEnv) -> Tp_Ind (rec (Succ n) env)) (\ (ix:Nat) (n:Nat) (env:TpEnv) -> @@ -2625,13 +2646,13 @@ data indElem : TpEnv -> TpDesc -> sort 0 where { -- Elements of vector types are built using nil and cons constructors, to -- build a vector of elements with a concrete size, along with a final cast -- constructor, to cast the size to an expression equal to that concrete size - Elem_VecNil : (env:TpEnv) -> (T:TpDesc) -> indElem env (Tp_Vec T ArithZ); + Elem_VecNil : (env:TpEnv) -> (T:TpDesc) -> indElem env (Tp_Vec T TpExprZ); Elem_VecCons : (env:TpEnv) -> (T:TpDesc) -> (n:Nat) -> - indElem env T -> indElem env (Tp_Vec T (ArithN n)) -> - indElem env (Tp_Vec T (ArithN (Succ n))); - Elem_VecCast : (env:TpEnv) -> (T:TpDesc) -> (e1 e2:ArithExpr Kind_nat) -> - Eq Nat (evalArithExpr env Kind_nat e1) - (evalArithExpr env Kind_nat e2) -> + indElem env T -> indElem env (Tp_Vec T (TpExprN n)) -> + indElem env (Tp_Vec T (TpExprN (Succ n))); + Elem_VecCast : (env:TpEnv) -> (T:TpDesc) -> (e1 e2:TpExpr Kind_nat) -> + Eq Nat (evalTpExpr env Kind_nat e1) + (evalTpExpr env Kind_nat e2) -> indElem env (Tp_Vec T e1) -> indElem env (Tp_Vec T e2); -- An element of inductive type Tp_Ind T is an element of the one-step @@ -2673,8 +2694,8 @@ tpElemEnv env_top T_top = Either (recT env) (recU env)) (\ (K:KindDesc) (T:TpDesc) (rec:TpEnv -> sort 0) (env:TpEnv) -> Sigma (kindElem K) (\ (v:kindElem K) -> rec (envConsElem K v env))) - (\ (_:TpDesc) (rec:TpEnv -> sort 0) (len:ArithExpr Kind_nat) (env:TpEnv) -> - Vec (evalArithExpr env Kind_nat len) (rec env)) + (\ (_:TpDesc) (rec:TpEnv -> sort 0) (len:TpExpr Kind_nat) (env:TpEnv) -> + Vec (evalTpExpr env Kind_nat len) (rec env)) (\ (T:TpDesc) (rec:TpEnv -> sort 0) (env:TpEnv) -> indElem nilTpEnv (unfoldIndTpDesc env T)) (\ (var:Nat) (env:TpEnv) -> @@ -2810,7 +2831,7 @@ specFun E env_top T_top = (\ (T:TpDesc) (_:TpEnv -> sort 0) (U:TpDesc) (_:TpEnv -> sort 0) (env:TpEnv) -> #()) (\ (K:KindDesc) (T:TpDesc) (_:TpEnv -> sort 0) (env:TpEnv) -> #()) - (\ (_:TpDesc) (_:TpEnv -> sort 0) (_:ArithExpr Kind_nat) (env:TpEnv) -> #()) + (\ (_:TpDesc) (_:TpEnv -> sort 0) (_:TpExpr Kind_nat) (env:TpEnv) -> #()) (\ (T:TpDesc) (_:TpEnv -> sort 0) (env:TpEnv) -> #()) (\ (var:Nat) (env:TpEnv) -> #()) (\ (_:TpEnv) -> #()) From 7b5e3e42752d65ce1772ac1be22d23380dded95e Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 4 Oct 2023 09:28:14 -0700 Subject: [PATCH 104/305] fixed a comment; added Tp_BVVec --- saw-core/prelude/Prelude.sawcore | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/saw-core/prelude/Prelude.sawcore b/saw-core/prelude/Prelude.sawcore index d9b2488089..ef573972b5 100644 --- a/saw-core/prelude/Prelude.sawcore +++ b/saw-core/prelude/Prelude.sawcore @@ -2305,7 +2305,7 @@ data TpDesc : sort 0 where { -- Vector types Tp_Vec : TpDesc -> TpExpr Kind_nat -> TpDesc; - -- Inductive types, where Kind_Ind A is equivalent to [Kind_Ind A/x]A + -- 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 @@ -2315,6 +2315,11 @@ data TpDesc : sort 0 where { Tp_Void : TpDesc; } +-- The type description for the type BVVec n len d +Tp_BVVec : TpDesc -> (n:Nat) -> TpExpr (Kind_bv n) -> TpDesc; +Tp_BVVec d n len = + Tp_Vec d (TpExpr_UnOp (Kind_bv n) Kind_nat (UnOp_BVToNat n) len); + -- Type-level environments -- From ca8549429c4153de305600942b52710e22df9f44 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 4 Oct 2023 10:00:22 -0700 Subject: [PATCH 105/305] whoops, fixed the type of FixS --- saw-core/prelude/Prelude.sawcore | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/saw-core/prelude/Prelude.sawcore b/saw-core/prelude/Prelude.sawcore index ef573972b5..e02f9cc97e 100644 --- a/saw-core/prelude/Prelude.sawcore +++ b/saw-core/prelude/Prelude.sawcore @@ -2852,7 +2852,7 @@ primitive LambdaS : (E:EvType) -> (T:TpDesc) -> specFun E nilTpEnv T -> FunIx T; -- f, FunIx T -> specFun E nil T, is the same as specFun E nil (Tp_Arr T T) when -- T is a monadic function type. primitive FixS : (E:EvType) -> (T:TpDesc) -> - (FunIx T -> specFun E nilTpEnv T) -> FunIx T; + (FunIx T -> specFun E nilTpEnv T) -> SpecM E (FunIx T); -- The multi-arity function type from FunIxs to a given output type From ea161033f666f407f2b9c2354a6e883c210b7a87 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Thu, 12 Oct 2023 15:27:43 -0400 Subject: [PATCH 106/305] fix defaultMonTable entry for PZeroMSeq, add PZeroMSeqBool --- cryptol-saw-core/saw/CryptolM.sawcore | 6 ++++++ cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs | 3 ++- 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/cryptol-saw-core/saw/CryptolM.sawcore b/cryptol-saw-core/saw/CryptolM.sawcore index 7c458c6b86..efe89cd500 100644 --- a/cryptol-saw-core/saw/CryptolM.sawcore +++ b/cryptol-saw-core/saw/CryptolM.sawcore @@ -525,6 +525,12 @@ PZeroMSeq E stack n_top a pa = (seqConst TCInf (SpecM E stack a) (retS E stack a pa)) n_top; +PZeroMSeqBool : (E:EvType) -> (stack:FunStack) -> + (n : Num) -> isFinite n -> PZero (mseq E stack n Bool); +PZeroMSeqBool E stack = + Num_rec_fin (\ (n:Num) -> PZero (mseq E stack n Bool)) + (\ (n:Nat) -> bvNat n 0); + -- PLogic PLogicSpecM : (E:EvType) -> (stack:FunStack) -> (a : sort 0) -> PLogic a -> PLogic (SpecM E stack a); diff --git a/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs b/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs index 39b32169d9..5832b5d4f3 100644 --- a/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs +++ b/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs @@ -1432,7 +1432,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 From 3e9685096648fc96278ed021e2510f125a15fc32 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Thu, 12 Oct 2023 15:32:36 -0400 Subject: [PATCH 107/305] add missing takeCryM and dropCryM defns, VWord cases in MRSolver/SMT.hs --- cryptol-saw-core/saw/CryptolM.sawcore | 10 ++++++++-- src/SAWScript/Prover/MRSolver/SMT.hs | 11 +++++++++++ 2 files changed, 19 insertions(+), 2 deletions(-) diff --git a/cryptol-saw-core/saw/CryptolM.sawcore b/cryptol-saw-core/saw/CryptolM.sawcore index efe89cd500..a9fc71b85b 100644 --- a/cryptol-saw-core/saw/CryptolM.sawcore +++ b/cryptol-saw-core/saw/CryptolM.sawcore @@ -14,6 +14,12 @@ atCryM = at; -- Alternate versions of Prelude functions, changed to use genCryM and atCryM +takeCryM : (a : isort 0) -> (m n : Nat) -> Vec (addNat m n) a -> Vec m a; +takeCryM a m n v = genCryM m a (\ (i : Nat) -> at (addNat m n) a v i); + +dropCryM : (a : isort 0) -> (m n : Nat) -> Vec (addNat m n) a -> Vec n a; +dropCryM a m n v = genCryM n a (\ (i : Nat) -> at (addNat m n) a v (addNat m i)); + joinCryM : (m n : Nat) -> (a : isort 0) -> Vec m (Vec n a) -> Vec (mulNat m n) a; joinCryM m n a v = @@ -678,7 +684,7 @@ ecTakeM E stack = SpecM E stack (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 stack (Vec m a) (takeCryM 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))) @@ -702,7 +708,7 @@ ecDropM E stack = Num_rec (\ (n:Num) -> (a:isort 0) -> mseq E stack (tcAdd (TCNum m) n) a -> mseq E stack n a) -- The case (TCNum m, TCNum n) - (\ (n:Nat) -> \ (a:isort 0) -> drop a m n) + (\ (n:Nat) -> \ (a:isort 0) -> dropCryM a m n) -- The case (TCNum m, infinity) (\ (a:isort 0) -> streamDrop (SpecM E stack a) m)); diff --git a/src/SAWScript/Prover/MRSolver/SMT.hs b/src/SAWScript/Prover/MRSolver/SMT.hs index 5856d252d3..55f822e474 100644 --- a/src/SAWScript/Prover/MRSolver/SMT.hs +++ b/src/SAWScript/Prover/MRSolver/SMT.hs @@ -117,6 +117,7 @@ primGenBVVec sc n = PrimFilterFun "primGenBVVec" $ \case VExtra (VExtraTerm _ t) -> primGenBVVecFilter sc n t + VWord (Left (_, t)) -> primGenBVVecFilter sc n t _ -> mzero -- | The filter function for 'primGenBVVec', and one case of 'primGenCryM' @@ -148,9 +149,14 @@ primGenCryM sc = (\case VExtra (VExtraTerm _ (asGenCryMTerm -> Just (_, _, f))) -> return (Nothing, f) + VWord (Left (_, asGenCryMTerm -> Just (_, _, f))) -> + return (Nothing, f) VExtra (VExtraTerm _ (asGenFromBVVecTerm -> Just (asNat -> Just n, _, _, v, _, _))) -> (Just n,) <$> primGenBVVecFilter sc n v + VWord (Left (_, asGenFromBVVecTerm -> Just (asNat -> Just n, _, _, + v, _, _))) -> + (Just n,) <$> primGenBVVecFilter sc n v _ -> mzero ) . uncurry @@ -189,8 +195,13 @@ primBVVecFromVecArg sc a = VExtra (VExtraTerm _ (asGenFromBVVecTerm -> Just (asNat -> Just n, len, _, v, _, _))) -> return $ FromBVVec n len v + VWord (Left (_, asGenFromBVVecTerm -> Just (asNat -> Just n, len, _, + v, _, _))) -> + return $ FromBVVec n len v VExtra (VExtraTerm _ (asGenCryMTerm -> Just (_, _, body))) -> return $ GenCryM body + VWord (Left (_, asGenCryMTerm -> Just (_, _, body))) -> + return $ GenCryM body VVector vs -> lift $ BVVecLit <$> traverse (readBackValueNoConfig "primFromBVVecOrLit" sc a <=< force) From b1147650c869026705d8d3d71a29b5c5b9f6f4c3 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Thu, 12 Oct 2023 15:33:37 -0400 Subject: [PATCH 108/305] allow Integer in monadifyType (for Cryptol prelude fns like abs, sext) --- cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs b/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs index 5832b5d4f3..f730af09e6 100644 --- a/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs +++ b/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs @@ -490,6 +490,9 @@ monadifyType ctx (asApp -> Just ((asGlobalDef -> Just f), arg)) monadifyType _ (asGlobalDef -> Just bool_id) | bool_id == "Prelude.Bool" = mkMonType0 (globalOpenTerm "Prelude.Bool") +monadifyType _ (asGlobalDef -> Just integer_id) + | integer_id == "Prelude.Integer" = + mkMonType0 (globalOpenTerm "Prelude.Integer") {- monadifyType ctx (asApplyAll -> (f, args)) | Just glob <- asTypedGlobalDef f From 5035480e57768300c332565a50fb2fe152573691 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Thu, 12 Oct 2023 15:34:05 -0400 Subject: [PATCH 109/305] include info about the errorS in ReturnNotError --- src/SAWScript/Prover/MRSolver/Monad.hs | 7 ++++--- src/SAWScript/Prover/MRSolver/Solver.hs | 4 ++-- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/Monad.hs b/src/SAWScript/Prover/MRSolver/Monad.hs index f7b4663444..1ee53ddbf6 100644 --- a/src/SAWScript/Prover/MRSolver/Monad.hs +++ b/src/SAWScript/Prover/MRSolver/Monad.hs @@ -76,7 +76,7 @@ data MRFailure = TermsNotRel Bool Term Term | TypesNotRel Bool Type Type | CompsDoNotRefine NormComp NormComp - | ReturnNotError Term + | ReturnNotError (Either Term Term) Term | FunsNotEq FunName FunName | CannotLookupFunDef FunName | RecursiveUnfold FunName @@ -149,8 +149,9 @@ instance PrettyInCtx MRFailure where ppWithPrefixSep "Types not heterogeneously related:" tp1 "and" tp2 prettyInCtx (CompsDoNotRefine m1 m2) = ppWithPrefixSep "Could not prove refinement: " m1 "|=" m2 - prettyInCtx (ReturnNotError t) = - ppWithPrefix "errorS computation not equal to:" (RetS t) + prettyInCtx (ReturnNotError eith_terr t) = + let (lr_s, terr) = either ("left",) ("right",) eith_terr in + ppWithPrefixSep "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] diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index 20f2d2254f..1989f21f62 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -892,8 +892,8 @@ mrRefines' :: NormComp -> NormComp -> MRM t () mrRefines' (RetS e1) (RetS e2) = mrAssertProveRel True e1 e2 mrRefines' (ErrorS _) (ErrorS _) = return () -mrRefines' (RetS e) (ErrorS _) = throwMRFailure (ReturnNotError e) -mrRefines' (ErrorS _) (RetS e) = throwMRFailure (ReturnNotError e) +mrRefines' (RetS e) (ErrorS err) = throwMRFailure (ReturnNotError (Right err) e) +mrRefines' (ErrorS err) (RetS e) = throwMRFailure (ReturnNotError (Left err) e) -- maybe elimination on equality types mrRefines' (MaybeElim (Type cond_tp@(asEq -> Just (tp,e1,e2))) m1 f1 _) m2 = From 2fcba4071ca40f58685a074f69772132b1173496 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Thu, 12 Oct 2023 15:48:04 -0400 Subject: [PATCH 110/305] check whether assumptions and assertions are provable or not in mrRefines --- src/SAWScript/Prover/MRSolver/Solver.hs | 20 ++++++++++++++++++-- 1 file changed, 18 insertions(+), 2 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index 1989f21f62..cf42449adb 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -147,6 +147,7 @@ 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) @@ -1019,10 +1020,25 @@ 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 <- flip showInCtx cond1 <$> mrUVars + 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 From 539afa00f4fe1ab37ce0b558fdc953c11e61fead Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 13 Oct 2023 14:51:30 -0700 Subject: [PATCH 111/305] fixed indentation --- saw-core/src/Verifier/SAW/OpenTerm.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/saw-core/src/Verifier/SAW/OpenTerm.hs b/saw-core/src/Verifier/SAW/OpenTerm.hs index e014565041..80e482beaf 100644 --- a/saw-core/src/Verifier/SAW/OpenTerm.hs +++ b/saw-core/src/Verifier/SAW/OpenTerm.hs @@ -445,7 +445,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 [] From 702ef825a8e951192edf4e1f5b846bb72f47e4b7 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 13 Oct 2023 14:51:40 -0700 Subject: [PATCH 112/305] added the Sigmas type --- saw-core/prelude/Prelude.sawcore | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) diff --git a/saw-core/prelude/Prelude.sawcore b/saw-core/prelude/Prelude.sawcore index e02f9cc97e..18f8a6f3f3 100644 --- a/saw-core/prelude/Prelude.sawcore +++ b/saw-core/prelude/Prelude.sawcore @@ -1843,6 +1843,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) From 4cd2921333ab4d3b6677fcadf780ce3f920f9a11 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 13 Oct 2023 14:52:56 -0700 Subject: [PATCH 113/305] Working on rewriting SAWTranslation.hs to work with the new definition of SpecM --- .../src/Verifier/SAW/Heapster/Permissions.hs | 85 +- .../Verifier/SAW/Heapster/SAWTranslation.hs | 3263 ++++++++--------- 2 files changed, 1596 insertions(+), 1752 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs index e88f4ec60d..df9ec21ce9 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs @@ -375,7 +375,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) -> @@ -658,17 +658,19 @@ data NamedShapeBody b args w where NamedShapeBody 'True args w -- | An opaque shape has no body, just a length and a translation to a type + -- description given by an identifier OpaqueShapeBody :: Mb args (PermExpr (BVType w)) -> 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 an + -- identifier for a function that takes in translations of the @args@ and + -- returns the type description that is the translation of substituting those + -- translations of the @args@ into the given shape. Note that this is just an + -- optimization to make it more concise to expression this substitution + -- instance. RecShapeBody :: Mb (args :> LLVMShapeType w) (PermExpr (LLVMShapeType w)) -> - Ident -> Maybe (Ident, Ident) -> - NamedShapeBody 'True args w + Ident -> NamedShapeBody 'True args w -- | An offset that is added to a permission. Only makes sense for llvm -- permissions (at least for now...?) @@ -853,16 +855,19 @@ data SomeNamedShape where SomeNamedShape :: (1 <= w, KnownNat w) => NamedShape b args w -> SomeNamedShape --- | The result of translating a global symbol to a SAW core term +-- | The result of translating a global symbol to SAW core terms data GlobalTrans -- | A translation to a list of terms, as defined in @SAWTranslation.hs@ = GlobalTransTerms [OpenTerm] - -- | A translation to a spec definition, i.e., a term of type @SpecDef@; - -- note that this is only applicable to function permissions - | GlobalTransDef OpenTerm - -- | A translation to a locally-defined closure, i.e., a term of type - -- @LRTClos@; note that this is only applicable to function permissions - | GlobalTransClos SpecTerm + -- | A translation to a list of specification functions, i.e., to SAW core + -- terms of type @specFun E T@ for some type description @T@. This case is + -- here because this is different than the normal translation of a function, + -- which is to a SAW core term of type @FunIx T@. Accordingly, this is only + -- applicable to function permissions. The reason this is a list of terms + -- instead of just a single term is to support a single symbol having + -- multiple different function permissions, each with its own specification + -- function + | GlobalTransFuns [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 @@ -897,9 +902,16 @@ data BlockHint blocks init ret args where data Hint where Hint_Block :: BlockHint blocks init ret args -> Hint +-- | A SAW core identifier that indicates an event type for the @SpecM@ monad +newtype EventType = EventType { evTypeToIdent :: Ident } + +-- | Convert an 'EventType' to a SAW core term +evTypeTerm :: EventType -> OpenTerm +evTypeTerm = globalOpenTerm . evTypeToIdent + -- | The default event type uses the @Void@ type for events -defaultSpecMEventType :: Ident -defaultSpecMEventType = fromString "Prelude.VoidEv" +defaultSpecMEventType :: EventType +defaultSpecMEventType = EventType $ fromString "Prelude.VoidEv" -- | A permission environment that maps function names, permission names, and -- 'GlobalSymbols' to their respective permission structures @@ -909,9 +921,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 @@ -975,6 +991,7 @@ $(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... @@ -3036,7 +3053,7 @@ deriving instance Eq (NamedShapeBody b args w) -- | Test if a 'NamedShape' is recursive namedShapeIsRecursive :: NamedShape b args w -> Bool -namedShapeIsRecursive (NamedShape _ _ (RecShapeBody _ _ _)) = True +namedShapeIsRecursive (NamedShape _ _ (RecShapeBody _ _)) = True namedShapeIsRecursive _ = False -- | Test if a 'NamedShape' in a binding is recursive @@ -3049,7 +3066,7 @@ mbNamedShapeIsRecursive = namedShapeCanUnfoldRepr :: NamedShape b args w -> BoolRepr b namedShapeCanUnfoldRepr (NamedShape _ _ (DefinedShapeBody _)) = TrueRepr namedShapeCanUnfoldRepr (NamedShape _ _ (OpaqueShapeBody _ _)) = FalseRepr -namedShapeCanUnfoldRepr (NamedShape _ _ (RecShapeBody _ _ _)) = TrueRepr +namedShapeCanUnfoldRepr (NamedShape _ _ (RecShapeBody _ _)) = TrueRepr -- | Get a 'BoolRepr' for the Boolean flag for whether a named shape in a -- binding can be unfolded @@ -4349,7 +4366,7 @@ findEqVarFieldsInShapeH (PExpr_NamedShape _ _ nmsh args) -- the variable fields findEqVarFieldsInShapeH (unfoldNamedShape nmsh args) findEqVarFieldsInShapeH (PExpr_NamedShape _ _ nmsh args) - | RecShapeBody _ _ _ <- namedShapeBody nmsh = + | RecShapeBody _ _ <- namedShapeBody nmsh = do seen_names <- ask if Set.member (namedShapeName nmsh) seen_names then return NameSet.empty @@ -4385,7 +4402,7 @@ llvmShapeLength (PExpr_NamedShape _ _ (NamedShape _ _ (OpaqueShapeBody mb_len _)) args) = Just $ subst (substOfExprs args) mb_len llvmShapeLength (PExpr_NamedShape _ _ nmsh@(NamedShape _ _ - (RecShapeBody _ _ _)) args) = + (RecShapeBody _ _)) args) = -- FIXME: if the recursive shape contains itself *not* under a pointer, then -- this could diverge llvmShapeLength (unfoldNamedShape nmsh args) @@ -4710,7 +4727,7 @@ instance AbstractModalities (AtomicPerm a) where namedShapeBodyShape :: KnownNat w => NamedShape 'True args w -> Mb args (PermExpr (LLVMShapeType w)) namedShapeBodyShape (NamedShape _ _ (DefinedShapeBody mb_sh)) = mb_sh -namedShapeBodyShape sh@(NamedShape _ _ (RecShapeBody mb_sh _ _)) = +namedShapeBodyShape sh@(NamedShape _ _ (RecShapeBody mb_sh _)) = let (prxs :>: _) = mbToProxy mb_sh in nuMulti prxs $ \ns -> subst (substOfExprs (namesToExprs ns :>: @@ -4722,7 +4739,7 @@ unfoldNamedShape :: KnownNat w => NamedShape 'True args w -> PermExprs args -> PermExpr (LLVMShapeType w) unfoldNamedShape (NamedShape _ _ (DefinedShapeBody mb_sh)) args = subst (substOfExprs args) mb_sh -unfoldNamedShape sh@(NamedShape _ _ (RecShapeBody mb_sh _ _)) args = +unfoldNamedShape sh@(NamedShape _ _ (RecShapeBody mb_sh _)) args = subst (substOfExprs (args :>: PExpr_NamedShape Nothing Nothing sh args)) mb_sh -- | Unfold a named shape and apply 'modalize' to the result @@ -6122,7 +6139,7 @@ shapeIsCopyable rw (PExpr_NamedShape maybe_rw' _ nmsh args) = -- HACK: the real computation we want to perform is to assume nmsh is copyable -- and prove it is under that assumption; to accomplish this, we substitute -- the empty shape for the recursive shape - RecShapeBody mb_sh _ _ -> + RecShapeBody mb_sh _ -> shapeIsCopyable rw $ subst (substOfExprs (args :>: PExpr_EmptyShape)) mb_sh shapeIsCopyable _ (PExpr_EqShape _ _) = True shapeIsCopyable rw (PExpr_PtrShape maybe_rw' _ sh) = @@ -6506,7 +6523,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 (RecShapeBody mb_sh _ _) = freeVars mb_sh + freeVars (RecShapeBody mb_sh _) = freeVars mb_sh -- | Find all equality permissions @eq(e)@ contained in another permission @@ -6543,7 +6560,7 @@ instance ContainedEqVars (PermExpr (LLVMShapeType w)) where (OpaqueShapeBody _ _)) _) = NameSet.empty containedEqVars (PExpr_NamedShape _ _ (NamedShape _ _ - (RecShapeBody mb_sh _ _)) args) = + (RecShapeBody mb_sh _)) args) = -- NOTE: we unfold the shape with the empty shape substituted for recursive -- occurrences of the shape name, to avoid an infinite loop containedEqVars $ subst (substOfExprs (args :>: PExpr_EmptyShape)) mb_sh @@ -6955,10 +6972,9 @@ genSubstNSB px s mb_body = case mbMatch mb_body of DefinedShapeBody <$> genSubstMb px s mb_sh [nuMP| OpaqueShapeBody mb_len trans_id |] -> OpaqueShapeBody <$> genSubstMb px s mb_len <*> return (mbLift trans_id) - [nuMP| RecShapeBody mb_sh trans_id fold_ids |] -> + [nuMP| RecShapeBody mb_sh trans_id |] -> RecShapeBody <$> genSubstMb (px :>: Proxy) s mb_sh <*> return (mbLift trans_id) - <*> return (mbLift fold_ids) instance SubstVar s m => Substable s (NamedPermName ns args a) m where genSubst _ mb_rpn = return $ mbLift mb_rpn @@ -7905,11 +7921,10 @@ instance AbstractVars (NamedShapeBody b args w) where absVarsReturnH ns1 ns2 ($(mkClosed [| \i l -> OpaqueShapeBody l i |]) `clApply` toClosed trans_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) = absVarsReturnH ns1 ns2 ($(mkClosed - [| \i1 i2 l -> RecShapeBody l i1 i2 |]) - `clApply` toClosed trans_id - `clApply` toClosed fold_ids) + [| \i l -> RecShapeBody l i |]) + `clApply` toClosed trans_id) `clMbMbApplyM` abstractPEVars ns1 ns2 mb_sh instance AbstractVars (NamedPermName ns args a) where @@ -8280,14 +8295,14 @@ permEnvAddOpaqueShape env nm args mb_len tp_id = OpaqueShapeBody mb_len tp_id) : permEnvNamedShapes env } -- | Add a global symbol with a function permission along with its translation --- to a spec definition to a 'PermEnv' +-- 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 (GlobalTransDef t) + PermEnvGlobalEntry sym p (GlobalTransFuns [t]) : permEnvGlobalSyms env } -- | Add a global symbol with 0 or more function permissions to a 'PermEnv' @@ -8297,7 +8312,7 @@ 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 (GlobalTransTerms $ map snd ps_ts) + PermEnvGlobalEntry sym p (GlobalTransFuns $ map snd ps_ts) : permEnvGlobalSyms env } -- | Add some 'PermEnvGlobalEntry's to a 'PermEnv' diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 9407f9aef4..55bac6c3c2 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -42,6 +42,7 @@ import GHC.TypeLits import Data.BitVector.Sized (BV) import qualified Data.BitVector.Sized as BV import Data.Functor.Compose +import Data.Functor.Constant import Control.Applicative import Control.Lens hiding ((:>), Index, ix, op, getting) import qualified Control.Monad as Monad @@ -74,8 +75,8 @@ 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 @@ -101,10 +102,212 @@ weakenMemberR :: RAssign any ctx2 -> Member ctx1 a -> Member (ctx1 :++: ctx2) a weakenMemberR MNil memb = memb weakenMemberR (ctx1 :>: _) memb = Member_Step (weakenMemberR ctx1 memb) --- | Apply the @LRT_SpecM@ combinator to turn a @LetRecType@ for a return value --- into a monadic type -specLRTOpenTerm :: OpenTerm -> OpenTerm -specLRTOpenTerm lrt = ctorTermLike "Prelude.LRT_SpecM" [lrt] +-- | 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 + + +-- FIXME HERE NOWNOW: move these to OpenTerm.hs + +-- | 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 the type @FunIx T@ from a type description @T@ +funIxTypeOpenTerm :: OpenTerm -> OpenTerm +funIxTypeOpenTerm t = applyGlobalOpenTerm "Prelude.FunIx" [t] + +-- | Build the type @Sigma a (\ (x:a) -> b)@ from variable name @x@, type @a@, +-- and type-level function @b@ +sigmaTypeOpenTerm :: String -> 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 :: String -> [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 :: String -> 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 :: String -> [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 :: String -> [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 (\x -> sigmaTypeOpenTermMulti x tps (tp_f . (x:))) + 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:)) + +-- | The kind description for the unit type +unitKindDesc :: OpenTerm +unitKindDesc = ctorOpenTerm "Prelude.Kind_Expr" [ctorOpenTerm + "Prelude.Kind_unit" []] + +-- | The @ExprKind@ for the bitvector type with width @w@ +bvExprKind :: Natural -> OpenTerm +bvExprKind w = ctorOpenTerm "Prelude.Kind_bv" [natOpenTerm w] + +-- | The type @TpDesc@ of type descriptions +tpDescTypeOpenTerm :: OpenTerm +tpDescTypeOpenTerm = dataTypeOpenTerm "Prelude.TpDesc" [] + +-- | The type description for the unit type +unitTpDesc :: OpenTerm +unitTpDesc = ctorOpenTerm "Prelude.Tp_Kind" [unitKindDesc] + +-- | The kind description for the Boolean type +boolKindDesc :: OpenTerm +boolKindDesc = ctorOpenTerm "Prelude.Kind_Expr" [ctorOpenTerm + "Prelude.Kind_bool" []] + +-- | The kind description for the Nat type +natKindDesc :: OpenTerm +natKindDesc = ctorOpenTerm "Prelude.Kind_Expr" [ctorOpenTerm + "Prelude.Kind_nat" []] + +-- | The kind description for the type @bitvector w@ +bvKindDesc :: Natural -> OpenTerm +bvKindDesc w = ctorOpenTerm "Prelude.Kind_Expr" [bvExprKind w] + +-- | The kind description for the type of type descriptions +tpKindDesc :: OpenTerm +tpKindDesc = ctorOpenTerm "Prelude.Kind_Tp" [] + +-- | Build a pair type description from two type descriptions +pairTpDesc :: OpenTerm -> OpenTerm -> OpenTerm +pairTpDesc d1 d2 = ctorOpenTerm "Prelude.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 "Prelude.Tp_Sum" [d1,d2] + +-- | Build a type description for the type @BVVec n len d@ +bvVecTpDesc :: OpenTerm -> OpenTerm -> OpenTerm -> OpenTerm +bvVecTpDesc w_term len_term elem_d = + applyGlobalOpenTerm "Prelude.Tp_BVVec" [elem_d, w_term, len_term] + +-- | Build a type description expression from a bitvector value of a given width +bvConstTpExpr :: Natural -> OpenTerm -> OpenTerm +bvConstTpExpr w bv = ctorOpenTerm "Prelude.TpExpr_Const" [bvExprKind w, bv] + +-- | 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 w [bv] = bv +bvSumTpExprs w (bv:bvs) = + ctorOpenTerm "Prelude.TpExpr_BinOp" + [bvExprKind w, bvExprKind w, bvExprKind w, + ctorOpenTerm "Prelude.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 "Prelude.TpExpr_BinOp" + [bvExprKind w, bvExprKind w, bvExprKind w, + ctorOpenTerm "Prelude.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 "Prelude.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 the type description for a function index of arrow type +arrowTpDesc :: OpenTerm -> OpenTerm -> OpenTerm +arrowTpDesc d_in d_out = ctorOpenTerm "Prelude.Tp_Arr" [d_in, d_out] + +-- | Build the type description for a function index of multi-arity arrow type +arrowTpDescMulti :: [OpenTerm] -> OpenTerm -> OpenTerm +arrowTpDescMulti tps_in tp_out = foldr arrowTpDesc tp_out tps_in + +-- | Build the type description for a pi-abstraction over a kind description +piTpDesc :: OpenTerm -> OpenTerm -> OpenTerm +piTpDesc kd tpd = ctorOpenTerm "Prelude.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 + +-- | Build a type description for a free deBruijn index +varTpDesc :: Natural -> OpenTerm +varTpDesc ix = ctorOpenTerm "Prelude.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 "Prelude.TpExpr_Var" [ek, natOpenTerm ix] + +-- | Map from type description @T@ to the type @T@ describes +tpElemTypeOpenTerm :: OpenTerm -> OpenTerm +tpElemTypeOpenTerm d = + -- FIXME HERE NOWNOW: this should normalize the returned term + applyGlobalOpenTerm "Prelude.tpElem" [d] + +-- | Build a @SpecM@ computation using a bind +bindSOpenTerm :: EventType -> OpenTerm -> OpenTerm -> OpenTerm -> OpenTerm -> + OpenTerm +bindSOpenTerm ev a b m f = + applyGlobalOpenTerm "Prelude.bindS" [evTypeTerm ev, a, b, m, f] + +-- | Build a @SpecM@ computation that calls a function index +callSOpenTerm :: EventType -> OpenTerm -> OpenTerm -> [OpenTerm] -> OpenTerm +callSOpenTerm ev d ix args = + applyGlobalOpenTerm "Prelude.CallS" ([evTypeTerm ev, d, ix] ++ args) ---------------------------------------------------------------------- @@ -115,118 +318,54 @@ specLRTOpenTerm lrt = ctorTermLike "Prelude.LRT_SpecM" [lrt] nlPrettyCallStack :: CallStack -> String nlPrettyCallStack = ("\n" ++) . prettyCallStack --- | A description of a type as either a "pure" type containg no corecursive --- closure types (i.e., no @LRTClos@ types) or as an 'OpenTerm' of type --- @LetRecType@ along with the SAW core type it decodes to as a 'SpecTerm' -data TypeDesc - = TypeDescPure OpenTerm - | TypeDescLRT OpenTerm SpecTerm - --- | Test if a 'TypeDesc' is pure -typeDescIsPure :: TypeDesc -> Bool -typeDescIsPure (TypeDescPure _) = True -typeDescIsPure (TypeDescLRT _ _) = False - --- | Get the type described by a 'TypeDesc' -typeDescType :: TypeDesc -> SpecTerm -typeDescType (TypeDescPure tp) = openTermLike tp -typeDescType (TypeDescLRT _ tp) = tp - --- | Get the pure type described by a 'TypeDesc', if there is one -typeDescPureType :: TypeDesc -> Maybe OpenTerm -typeDescPureType (TypeDescPure tp) = Just tp -typeDescPureType (TypeDescLRT _ _) = Nothing - --- | Get the @LetRecType@ that encodes the type of a 'TypeDesc' -typeDescLRT :: TypeDesc -> OpenTerm -typeDescLRT (TypeDescPure tp) = ctorOpenTerm "Prelude.LRT_Type" [tp] -typeDescLRT (TypeDescLRT lrt _) = lrt - --- | Return the pair of the @LetRecType@ of a 'TypeDesc' and the type it encodes -typeDescTypeLRT :: TypeDesc -> (OpenTerm,SpecTerm) -typeDescTypeLRT d = (typeDescLRT d, typeDescType d) - --- | Build an impure 'TypeDesc' from a term of type @LetRecType@ -typeDescFromLRT :: OpenTerm -> TypeDesc -typeDescFromLRT lrt = TypeDescLRT lrt (lrtToTypeSpecTerm lrt) - --- | If all the type descriptions in a list are pure, return their pure types as --- a list; otherwise, convert them all to impure LRT types -typeDescsPureOrLRT :: [TypeDesc] -> Either [OpenTerm] [(OpenTerm,SpecTerm)] -typeDescsPureOrLRT = - foldr (\d descs -> case d of - TypeDescPure tp | Left tps <- descs -> Left (tp:tps) - _ | Right lrt_tps <- descs -> Right (typeDescTypeLRT d : lrt_tps) - _ | Left tps <- descs -> - Right (typeDescTypeLRT d : - map (typeDescTypeLRT . TypeDescPure) tps)) (Left []) - --- | Apply a binary type-forming operation to two type descriptions, using the --- 'OpenTerm' function if the type descriptions are both pure and otherwise --- using the supplied 'Ident' to combine @LetRecType@s and the 'SpecTerm' --- function to combine impure types -typeDescBinOp :: (OpenTerm -> OpenTerm -> OpenTerm) -> Ident -> - (SpecTerm -> SpecTerm -> SpecTerm) -> - TypeDesc -> TypeDesc -> TypeDesc -typeDescBinOp f _ _ (TypeDescPure tp_l) (TypeDescPure tp_r) = - TypeDescPure $ f tp_l tp_r -typeDescBinOp _ lrt_op f d_l d_r = - TypeDescLRT - (applyGlobalOpenTerm lrt_op [typeDescLRT d_l, typeDescLRT d_r]) - (f (typeDescType d_l) (typeDescType d_r)) - --- | Build a type description for the type @BVVec w len a@ -bvVecTypeDesc :: OpenTerm -> OpenTerm -> TypeDesc -> TypeDesc -bvVecTypeDesc w_term len_term (TypeDescPure elem_tp) = - TypeDescPure (applyGlobalOpenTerm "Prelude.BVVec" - [w_term, len_term, elem_tp]) -bvVecTypeDesc w_term len_term (TypeDescLRT lrt elem_tp) = - TypeDescLRT - (applyGlobalOpenTerm "Prelude.LRT_BVVec" [w_term, len_term, lrt]) - (applyGlobalTermLike "Prelude.BVVec" [openTermLike w_term, - openTermLike len_term, elem_tp]) - --- | The 'TypeDesc' for the unit type -typeDescUnit :: TypeDesc -typeDescUnit = TypeDescPure unitTypeOpenTerm - --- | Build a type description for the pair of two type descriptions -typeDescPair :: TypeDesc -> TypeDesc -> TypeDesc -typeDescPair = - typeDescBinOp pairTypeOpenTerm "Prelude.LRT_Pair" pairTypeTermLike - --- | Build a type description for the @Either@ of two type descriptions -typeDescEither :: TypeDesc -> TypeDesc -> TypeDesc -typeDescEither = - typeDescBinOp - (\tp1 tp2 -> dataTypeOpenTerm "Prelude.Either" [tp1,tp2]) - "Prelude.LRT_Either" - (\tp1 tp2 -> dataTypeTermLike "Prelude.Either" [tp1,tp2]) - --- | Build a type description for a @Sigma@ type from a pure type for the first --- projection and a function to a type description for the second projection. --- The Boolean flag indicates whether this function is expected to return a pure --- type, in which case the returned dependent pair type is pure, or not, in --- which case it isn't. It is an error if the Boolean flag is 'True' but the --- function returns an impure type description. -typeDescSigma :: LocalName -> OpenTerm -> Bool -> (OpenTerm -> TypeDesc) -> - TypeDesc -typeDescSigma x tp_l True tp_r_f = - let tp_f_trm = - lambdaOpenTerm x tp_l $ \tr -> - case tp_r_f tr of - TypeDescPure tp_r -> tp_r - TypeDescLRT _ _ -> - panic "typeDescSigma" - ["Expected a pure type description but got an impure one"] in - TypeDescPure $ dataTypeOpenTerm "Prelude.Sigma" [tp_l, tp_f_trm] -typeDescSigma x tp_l False tp_r_f = - TypeDescLRT - (ctorOpenTerm "Prelude.LRT_Sigma" - [tp_l, lambdaOpenTerm x tp_l (typeDescLRT . tp_r_f)]) - (dataTypeTermLike "Prelude.Sigma" - [openTermLike tp_l, - lambdaPureSpecTerm x (openTermLike tp_l) (typeDescType . tp_r_f)]) +-- | The result of translating a type-like construct such as a 'TypeRepr' or a +-- permission, parameterized by the (Haskell) type of the translations of the +-- elements of that type. This are translated to 0 or more SAW types, along with +-- a (Haskell) function for mapping elements of those types their translation +-- construct in Haskell. +data TypeTrans tr = TypeTrans + { typeTransTypes :: [OpenTerm], + typeTransFun :: [OpenTerm] -> tr } + +-- | Apply the 'typeTransFun' of a 'TypeTrans' to a list of SAW core terms +typeTransF :: HasCallStack => TypeTrans tr -> [OpenTerm] -> tr +typeTransF (TypeTrans tps f) ts | length tps == length ts = f ts +typeTransF (TypeTrans tps _) ts = + error ("Type translation expected " ++ show (length tps) ++ + " arguments, but got " ++ show (length ts)) + +instance Functor TypeTrans where + fmap f (TypeTrans ts tp_f) = TypeTrans ts (f . tp_f) + +instance Applicative TypeTrans where + pure = mkTypeTrans0 + liftA2 f (TypeTrans tps1 f1) (TypeTrans tps2 f2) = + TypeTrans (tps1 ++ tps2) + (\ts -> f (f1 $ take (length tps1) ts) (f2 $ drop (length tps1) ts)) + +-- | Build a 'TypeTrans' represented by 0 SAW types +mkTypeTrans0 :: tr -> TypeTrans tr +mkTypeTrans0 tr = TypeTrans [] $ \case + [] -> tr + _ -> error "mkTypeTrans0: incorrect number of terms" + +-- | Build a 'TypeTrans' represented by 1 SAW type +mkTypeTrans1 :: OpenTerm -> (OpenTerm -> tr) -> TypeTrans tr +mkTypeTrans1 tp f = TypeTrans [tp] $ \case + [t] -> f t + _ -> error "mkTypeTrans1: incorrect number of terms" + +-- | Build a 'TypeTrans' for an 'OpenTerm' of a given type +openTermTypeTrans :: OpenTerm -> TypeTrans OpenTerm +openTermTypeTrans tp = mkTypeTrans1 tp id + +-- | Extract out the single SAW type associated with a 'TypeTrans', or the unit +-- type if it has 0 SAW types. It is an error if it has 2 or more SAW types. +typeTransType1 :: HasCallStack => TypeTrans tr -> OpenTerm +typeTransType1 (TypeTrans [] _) = unitTypeOpenTerm +typeTransType1 (TypeTrans [tp] _) = tp +typeTransType1 _ = + panic "typeTransType1" ["found multiple types where at most 1 was expected"] -- | 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 @@ -237,33 +376,14 @@ tupleOfTypes [] = unitTypeOpenTerm tupleOfTypes [tp] = tp tupleOfTypes (tp:tps) = pairTypeOpenTerm tp $ tupleOfTypes tps --- | Like 'tupleOfTypes' but applied to type descriptions -tupleOfTypeDescs :: [TypeDesc] -> TypeDesc -tupleOfTypeDescs [] = TypeDescPure unitTypeOpenTerm -tupleOfTypeDescs [tp] = tp -tupleOfTypeDescs (TypeDescPure tp_l : ds) - | TypeDescPure tp_r <- tupleOfTypeDescs ds - = TypeDescPure $ pairTypeOpenTerm tp_l tp_r -tupleOfTypeDescs (d : ds) = - let d_r = tupleOfTypeDescs ds in - TypeDescLRT - (applyGlobalOpenTerm "Prelude.LRT_Pair" [typeDescLRT d, typeDescLRT d_r]) - (pairTypeTermLike (typeDescType d) (typeDescType d_r)) - --- | Build the type description for the type @SpecM a@ for one of @a@ -specMTypeDesc :: TypeDesc -> TypeDesc -specMTypeDesc d = - TypeDescLRT (ctorOpenTerm "LRT_SpecM" [typeDescLRT d]) - (specMTypeSpecTerm $ typeDescType d) - -- | 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 :: OpenTermLike tm => [tm] -> tm -tupleOfTerms [] = unitTermLike +tupleOfTerms :: [OpenTerm] -> OpenTerm +tupleOfTerms [] = unitOpenTerm tupleOfTerms [t] = t -tupleOfTerms (t:ts) = pairTermLike t $ tupleOfTerms ts +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@. @@ -275,166 +395,24 @@ projTupleOfTypes (_:_) 0 tup = pairLeftOpenTerm tup projTupleOfTypes (_:tps) i tup = projTupleOfTypes tps (i-1) $ pairRightOpenTerm tup --- | Impure version of 'projTupleOfTypes' -projTupleOfTypesI :: [TypeDesc] -> Integer -> SpecTerm -> SpecTerm -projTupleOfTypesI [] _ _ = - panic "projTupleOfTypesI" ["projection of empty tuple!"] -projTupleOfTypesI [_] 0 tup = tup -projTupleOfTypesI (_:_) 0 tup = pairLeftTermLike tup -projTupleOfTypesI (_:tps) i tup = - projTupleOfTypesI tps (i-1) $ pairRightTermLike tup - --- | The result of translating a type-like construct such as a 'TypeRepr' or a --- permission, parameterized by the (Haskell) type of the translations of the --- elements of that type. This are translated to 0 or more type descriptions, --- along with a (Haskell) function for mapping elements of the types they --- describe to the corresponding translation construct in Haskell. Type --- translations can either be pure, meaning they do not depend on the event type --- and function stack of the current @SpecM@ computation and so are represented --- with 'OpenTerm's, or impure, meaning they can depend on these objects and so --- are represented with 'SpecTerm's. The @p@ type parameter is 'True' for pure --- type translations and 'False' for impure ones. -data TypeTrans p tr where - TypeTransPure :: [OpenTerm] -> ([OpenTerm] -> tr) -> TypeTrans 'True tr - TypeTransImpure :: [TypeDesc] -> ([SpecTerm] -> tr) -> TypeTrans 'False tr - --- | A pure 'TypeTrans' -type PureTypeTrans = TypeTrans 'True - --- | An impure 'TypeTrans' -type ImpTypeTrans = TypeTrans 'False - --- | A term that is either pure, meaning it does not depend on the event type --- and function stack of the current @SpecM@ computation and so is represented --- as an 'OpenTerm', or impure, meaning they it depend on these objects and so --- is represented as a 'SpecTerm' -type family PurityTerm p where - PurityTerm 'True = OpenTerm - PurityTerm 'False = SpecTerm - --- | Get the types in a 'TypeTrans' -typeTransTypes :: TypeTrans p tr -> [PurityTerm p] -typeTransTypes (TypeTransPure tps _) = tps -typeTransTypes (TypeTransImpure ds _) = map typeDescType ds - --- | Get the type descriptions of the types in a 'TypeTrans' -typeTransDescs :: TypeTrans p tr -> [TypeDesc] -typeTransDescs (TypeTransPure tps _) = map TypeDescPure tps -typeTransDescs (TypeTransImpure ds _) = ds - --- | Apply the function of a 'TypeTrans' -typeTransF :: HasCallStack => TypeTrans p tr -> [PurityTerm p] -> tr -typeTransF (TypeTransPure tps f) ts | length tps == length ts = f ts -typeTransF (TypeTransImpure tps f) ts | length tps == length ts = f ts -typeTransF tp_trans ts = - error ("Type translation expected " - ++ show (length $ typeTransTypes tp_trans) ++ - " arguments, but got " ++ show (length ts)) - -instance Functor (TypeTrans p) where - fmap f (TypeTransPure ts tp_f) = TypeTransPure ts (f . tp_f) - fmap f (TypeTransImpure ts tp_f) = TypeTransImpure ts (f . tp_f) - -instance Applicative (TypeTrans 'True) where - pure = mkPureTypeTrans0 - liftA2 f (TypeTransPure tps1 f1) (TypeTransPure tps2 f2) = - TypeTransPure (tps1 ++ tps2) - (\ts -> f (f1 $ take (length tps1) ts) (f2 $ drop (length tps1) ts)) - -instance Applicative (TypeTrans 'False) where - pure = mkImpTypeTrans0 - liftA2 f (TypeTransImpure tps1 f1) (TypeTransImpure tps2 f2) = - TypeTransImpure (tps1 ++ tps2) - (\ts -> f (f1 $ take (length tps1) ts) (f2 $ drop (length tps1) ts)) - --- | Build a pure 'TypeTrans' represented by 0 SAW types -mkPureTypeTrans0 :: tr -> TypeTrans 'True tr -mkPureTypeTrans0 tr = TypeTransPure [] $ \case - [] -> tr - _ -> panic "mkPureTypeTrans0" ["incorrect number of terms"] - --- | Build an impure 'TypeTrans' represented by 0 SAW types -mkImpTypeTrans0 :: tr -> TypeTrans 'False tr -mkImpTypeTrans0 tr = TypeTransImpure [] $ \case - [] -> tr - _ -> panic "mkImpTypeTrans0" ["incorrect number of terms"] - --- | Build a 'TypeTrans' represented by a "pure" (see 'TypeDesc') SAW type -mkPureTypeTrans1 :: OpenTerm -> (OpenTerm -> tr) -> TypeTrans 'True tr -mkPureTypeTrans1 tp f = TypeTransPure [tp] $ \case - [t] -> f t - _ -> panic "mkPureTypeTrans1" ["incorrect number of terms"] - --- | Build a 'TypeTrans' represented by a SAW type with the given description -mkImpTypeTrans1 :: TypeDesc -> (SpecTerm -> tr) -> TypeTrans 'False tr -mkImpTypeTrans1 d f = TypeTransImpure [d] $ \case - [t] -> f t - _ -> panic "mkImpTypeTrans1" ["incorrect number of terms"] - --- | Build a type translation whose representation type is just SAW core terms --- of the supplied type -mkTermImpTypeTrans :: TypeDesc -> ImpTypeTrans SpecTerm -mkTermImpTypeTrans d = mkImpTypeTrans1 d 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 p tr -> PurityTerm p -typeTransType1 (TypeTransPure [] _) = unitTypeOpenTerm -typeTransType1 (TypeTransImpure [] _) = unitTypeTermLike -typeTransType1 (TypeTransPure [tp] _) = tp -typeTransType1 (TypeTransImpure [tp] _) = typeDescType tp -typeTransType1 _ = - panic "typeTransType1" ["More than one type when at most one expected"] - --- | 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. The --- term is always impure, i.e., returned as a 'SpecTerm'. -typeTransType1Imp :: HasCallStack => TypeTrans p tr -> SpecTerm -typeTransType1Imp (TypeTransPure [] _) = unitTypeTermLike -typeTransType1Imp (TypeTransImpure [] _) = unitTypeTermLike -typeTransType1Imp (TypeTransPure [tp] _) = openTermLike tp -typeTransType1Imp (TypeTransImpure [tp] _) = typeDescType tp -typeTransType1Imp _ = - panic "typeTransType1Imp" ["More than one type when at most one 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 p tr -> PurityTerm p -typeTransTupleType (TypeTransPure tps _) = tupleOfTypes tps -typeTransTupleType (TypeTransImpure tps _) = - typeDescType $ tupleOfTypeDescs tps +typeTransTupleType :: TypeTrans tr -> OpenTerm +typeTransTupleType = tupleOfTypes . typeTransTypes -- | Convert a 'TypeTrans' over 0 or more types to one over the one type --- returned by 'typeTransTupleType' -tupleTypeTrans :: TypeTrans p tr -> TypeTrans p tr -tupleTypeTrans (TypeTransPure tps f) = - TypeTransPure [tupleOfTypes tps] - (\case - [t] -> - f $ map (\i -> projTupleOfTypes tps i t) $ take (length tps) [0..] - _ -> panic "tupleTypeTrans" ["incorrect number of terms"]) -tupleTypeTrans (TypeTransImpure tps f) = - TypeTransImpure [tupleOfTypeDescs tps] +-- returned by 'tupleOfTypes' +tupleTypeTrans :: TypeTrans tr -> TypeTrans tr +tupleTypeTrans ttrans = + let tps = typeTransTypes ttrans in + TypeTrans [tupleOfTypes tps] (\case [t] -> - f $ map (\i -> projTupleOfTypesI tps i t) $ take (length tps) [0..] + typeTransF ttrans $ map (\i -> projTupleOfTypes tps i t) $ + take (length $ typeTransTypes ttrans) [0..] _ -> panic "tupleTypeTrans" ["incorrect number of terms"]) --- | Form the 'TypeDesc' of the tuple of all the SAW core types in a 'TypeTrans' -typeTransTupleDesc :: TypeTrans b tr -> TypeDesc -typeTransTupleDesc = tupleOfTypeDescs . typeTransDescs - --- | Form the pure SAW core type that is the tuple of all the SAW core types in --- a 'TypeTrans', if those types are all pure; it is an error if they are not -typeTransPureTupleType :: TypeTrans p tr -> OpenTerm -typeTransPureTupleType (TypeTransPure tps _) = tupleOfTypes tps -typeTransPureTupleType (TypeTransImpure tps _) = - case typeDescPureType $ tupleOfTypeDescs tps of - Just tp -> tp - Nothing -> panic "typeTransPureTupleType" - ["Expected pure type but found impure type"] - {- -- | 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 @@ -450,13 +428,13 @@ strictTupleTypeTrans ttrans = -} -- | Build a type translation for a list of translations -listTypeTrans :: [TypeTrans 'False tr] -> TypeTrans 'False [tr] +listTypeTrans :: [TypeTrans tr] -> TypeTrans [tr] listTypeTrans [] = pure [] listTypeTrans (trans:transs) = liftA2 (:) trans $ listTypeTrans transs ---------------------------------------------------------------------- --- * Translation Monads +-- * Expression Translations ---------------------------------------------------------------------- -- | The result of translating a 'PermExpr' at 'CrucibleType' @a@. This is a @@ -491,11 +469,11 @@ 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 a type description - ETrans_Shape :: TypeDesc -> ExprTrans (LLVMShapeType w) + -- | The translation of a shape is a tuple of 0 or more type descriptions + ETrans_Shape :: [OpenTerm] -> ExprTrans (LLVMShapeType w) - -- | The translation of a permission is a type description - ETrans_Perm :: TypeDesc -> ExprTrans (ValuePermType a) + -- | The translation of a permission is a tuple of 0 or more type descriptions + ETrans_Perm :: [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. @@ -505,35 +483,29 @@ data ExprTrans (a :: CrucibleType) where type ExprTransCtx = RAssign ExprTrans --- | Destruct an 'ExprTrans' of shape type to a type description -unETransShape :: ExprTrans (LLVMShapeType w) -> TypeDesc +-- | Destruct an 'ExprTrans' of shape type to a list of type descriptions +unETransShape :: ExprTrans (LLVMShapeType w) -> [OpenTerm] unETransShape (ETrans_Shape d) = d unETransShape (ETrans_Term _) = panic "unETransShape" ["Incorrect translation of a shape expression"] --- | Destruct an 'ExprTrans' of permission type to a type description -unETransPerm :: ExprTrans (ValuePermType a) -> TypeDesc +-- | Destruct an 'ExprTrans' of permission type to a list of type descriptions +unETransPerm :: ExprTrans (ValuePermType a) -> [OpenTerm] unETransPerm (ETrans_Perm d) = d unETransPerm (ETrans_Term _) = panic "unETransPerm" ["Incorrect translation of a shape expression"] + -- | Describes a Haskell type that represents the translation of a term-like -- construct that corresponds to 0 or more SAW terms class IsTermTrans tr where - transTerms :: HasCallStack => tr -> [SpecTerm] - --- | Describes a Haskell type that represents the translation of a term-like --- construct that corresponds to 0 or more SAW terms that are "pure", meaning --- they are 'OpenTerm's instead of 'SpecTerm's, i.e., they do not depend on the --- function stack or event type -class IsPureTrans tr where - transPureTerms :: HasCallStack => tr -> [OpenTerm] + transTerms :: HasCallStack => tr -> [OpenTerm] -- | Build a tuple of the terms contained in a translation, with 0 terms mapping -- to the unit term and one term mapping to itself. If @ttrans@ is a 'TypeTrans' -- describing the SAW types associated with a @tr@ translation, then this -- function returns an element of the type @'tupleTypeTrans' ttrans@. -transTupleTerm :: IsTermTrans tr => tr -> SpecTerm +transTupleTerm :: IsTermTrans tr => tr -> OpenTerm transTupleTerm (transTerms -> [t]) = t transTupleTerm tr = tupleOfTerms $ transTerms tr @@ -548,106 +520,149 @@ strictTransTupleTerm tr = tupleOpenTerm $ transTerms tr -} -- | Like 'transTupleTerm' but raise an error if there are more than 1 terms -transTerm1 :: HasCallStack => IsTermTrans tr => tr -> SpecTerm -transTerm1 (transTerms -> []) = unitTermLike +transTerm1 :: HasCallStack => IsTermTrans tr => tr -> OpenTerm +transTerm1 (transTerms -> []) = unitOpenTerm transTerm1 (transTerms -> [t]) = t transTerm1 tr = panic "transTerm1" ["Expected at most one term, but found " ++ show (length $ transTerms tr)] --- | Like 'transTerm1' but for pure terms -transPureTerm1 :: HasCallStack => IsPureTrans tr => tr -> OpenTerm -transPureTerm1 (transPureTerms -> []) = unitOpenTerm -transPureTerm1 (transPureTerms -> [t]) = t -transPureTerm1 tr = panic "transPureTerm1" ["Expected at most one term, but found " - ++ show (length $ transPureTerms tr)] - instance IsTermTrans tr => IsTermTrans [tr] where transTerms = concatMap transTerms -instance IsPureTrans tr => IsPureTrans [tr] where - transPureTerms = concatMap transPureTerms - -instance IsPureTrans (TypeTrans 'True tr) where - transPureTerms = typeTransTypes - -instance IsTermTrans (TypeTrans 'True tr) where - transTerms = map openTermLike . transPureTerms - -instance IsTermTrans (TypeTrans 'False tr) where +instance IsTermTrans (TypeTrans tr) where transTerms = typeTransTypes -instance IsPureTrans (ExprTrans tp) where - transPureTerms ETrans_LLVM = [] - transPureTerms ETrans_LLVMBlock = [] - transPureTerms ETrans_LLVMFrame = [] - transPureTerms ETrans_Lifetime = [] - transPureTerms ETrans_RWModality = [] - transPureTerms (ETrans_Struct etranss) = - concat $ RL.mapToList transPureTerms etranss - transPureTerms ETrans_Fun = [] - transPureTerms ETrans_Unit = [] - transPureTerms ETrans_AnyVector = [] - transPureTerms (ETrans_Shape d) = [typeDescLRT d] - transPureTerms (ETrans_Perm d) = [typeDescLRT d] - transPureTerms (ETrans_Term t) = [t] - instance IsTermTrans (ExprTrans tp) where - transTerms = map openTermLike . transPureTerms - -instance IsPureTrans (ExprTransCtx ctx) where - transPureTerms MNil = [] - transPureTerms (ctx :>: etrans) = transPureTerms ctx ++ transPureTerms etrans + transTerms ETrans_LLVM = [] + transTerms ETrans_LLVMBlock = [] + transTerms ETrans_LLVMFrame = [] + transTerms ETrans_Lifetime = [] + transTerms ETrans_RWModality = [] + transTerms (ETrans_Struct etranss) = + concat $ RL.mapToList transTerms etranss + transTerms ETrans_Fun = [] + transTerms ETrans_Unit = [] + transTerms ETrans_AnyVector = [] + transTerms (ETrans_Shape ds) = [tupleTpDesc ds] + transTerms (ETrans_Perm ds) = [tupleTpDesc ds] + transTerms (ETrans_Term t) = [t] instance IsTermTrans (ExprTransCtx ctx) where - transTerms = map openTermLike . transPureTerms + transTerms MNil = [] + transTerms (ctx :>: etrans) = transTerms ctx ++ transTerms etrans --- | Map a context of expression translations to a list of 'SpecTerm's -exprCtxToTerms :: ExprTransCtx tps -> [SpecTerm] -exprCtxToTerms = concat . RL.mapToList transTerms -- | Map a context of expression translations to a list of 'OpenTerm's -exprCtxToPureTerms :: ExprTransCtx tps -> [OpenTerm] -exprCtxToPureTerms = concat . RL.mapToList transPureTerms +exprCtxToTerms :: ExprTransCtx tps -> [OpenTerm] +exprCtxToTerms = concat . RL.mapToList transTerms -- | Map an 'ExprTrans' to its type translation -exprTransType :: ExprTrans tp -> PureTypeTrans (ExprTrans tp) -exprTransType ETrans_LLVM = mkPureTypeTrans0 ETrans_LLVM -exprTransType ETrans_LLVMBlock = mkPureTypeTrans0 ETrans_LLVMBlock -exprTransType ETrans_LLVMFrame = mkPureTypeTrans0 ETrans_LLVMFrame -exprTransType ETrans_Lifetime = mkPureTypeTrans0 ETrans_Lifetime -exprTransType ETrans_RWModality = mkPureTypeTrans0 ETrans_RWModality +exprTransType :: 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 = mkPureTypeTrans0 ETrans_Fun -exprTransType ETrans_Unit = mkPureTypeTrans0 ETrans_Unit -exprTransType ETrans_AnyVector = mkPureTypeTrans0 ETrans_AnyVector +exprTransType ETrans_Fun = mkTypeTrans0 ETrans_Fun +exprTransType ETrans_Unit = mkTypeTrans0 ETrans_Unit +exprTransType ETrans_AnyVector = mkTypeTrans0 ETrans_AnyVector exprTransType (ETrans_Shape _) = - mkPureTypeTrans1 (dataTypeOpenTerm "Prelude.LetRecType" []) - (ETrans_Shape . typeDescFromLRT) + mkTypeTrans1 tpDescTypeOpenTerm (\d -> ETrans_Shape [d]) exprTransType (ETrans_Perm _) = - mkPureTypeTrans1 (dataTypeOpenTerm "Prelude.LetRecType" []) - (ETrans_Perm . typeDescFromLRT) -exprTransType (ETrans_Term t) = mkPureTypeTrans1 (openTermType t) ETrans_Term + mkTypeTrans1 tpDescTypeOpenTerm (\d -> ETrans_Perm [d]) +exprTransType (ETrans_Term t) = mkTypeTrans1 (openTermType t) ETrans_Term -- | Map a context of expression translation to a list of the SAW core types of -- all the terms it contains -exprCtxType :: ExprTransCtx ctx -> PureTypeTrans (ExprTransCtx ctx) -exprCtxType MNil = mkPureTypeTrans0 MNil +exprCtxType :: ExprTransCtx ctx -> TypeTrans (ExprTransCtx ctx) +exprCtxType MNil = mkTypeTrans0 MNil exprCtxType (ectx :>: e) = (:>:) <$> exprCtxType ectx <*> exprTransType e --- | Map an 'ExprTrans' to the SAW core terms it contains, similarly to --- 'transPureTerms', except that all type descriptions are mapped to pure types, --- not terms of type @LetRecType@. Return 'Nothing' if this is not possible. -exprTransPureTypeTerms :: ExprTrans tp -> Maybe [OpenTerm] -exprTransPureTypeTerms (ETrans_Shape d) = (:[]) <$> typeDescPureType d -exprTransPureTypeTerms (ETrans_Perm d) = (:[]) <$> typeDescPureType d -exprTransPureTypeTerms etrans = Just $ transPureTerms etrans - --- | Map an 'ExprTransCtx' to the SAW core terms it contains, similarly to --- 'transPureTerms', except that all type descriptions are mapped to pure types, --- not terms of type @LetRecType@. Return 'Nothing' if this is not possible. -exprCtxPureTypeTerms :: ExprTransCtx tps -> Maybe [OpenTerm] -exprCtxPureTypeTerms = - fmap concat . sequence . RL.mapToList exprTransPureTypeTerms + +-- | 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 + + +-- FIXME: ExprCtxExt should no longer be needed... + +-- | An extension of type 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 :: CtxExt ctx1 ctx2 -> Mb ctx1 a -> Mb ctx2 a +extMbExt (CtxExt 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 @@ -657,6 +672,10 @@ class TransInfo info where infoChecksFlag :: info ctx -> ChecksFlag extTransInfo :: ExprTrans tp -> info ctx -> info (ctx :> tp) +-- | 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 = @@ -692,35 +711,34 @@ 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; --- the type must be pure as well, even though it is a 'SpecTerm' -sawLetTransM :: String -> SpecTerm -> SpecTerm -> SpecTerm -> - (OpenTerm -> TransM info ctx SpecTerm) -> - TransM info ctx SpecTerm +-- | 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 $ - sawLetPureSpecTerm (pack x) tp tp_ret rhs $ \x' -> + 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 -> [SpecTerm] -> SpecTerm -> [SpecTerm] -> - ([OpenTerm] -> TransM info ctx SpecTerm) -> - TransM info ctx SpecTerm +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 _ _ _ _ _ = - error "sawLetTransMultiM: numbers of types and right-hand sides disagree" + 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 => PureTypeTrans (ExprTrans tp) -> - SpecTerm -> ExprTrans tp -> - TransM info (ctx :> tp) SpecTerm -> - TransM info ctx SpecTerm +inExtTransSAWLetBindM :: TransInfo info => TypeTrans (ExprTrans tp) -> + OpenTerm -> ExprTrans tp -> + TransM info (ctx :> tp) OpenTerm -> + TransM info ctx OpenTerm inExtTransSAWLetBindM tp_trans tp_ret etrans m = sawLetTransMultiM "z" (map openTermLike $ typeTransTypes tp_trans) tp_ret (transTerms etrans) $ @@ -749,43 +767,21 @@ nuMultiTransM f = do info <- ask return $ nuMulti (RL.map (\_ -> Proxy) (infoCtx info)) f --- | Apply the result of a pure translation to that of another -applyPureTransM :: TransM info ctx OpenTerm -> TransM info ctx OpenTerm -> - TransM info ctx OpenTerm -applyPureTransM m1 m2 = applyOpenTerm <$> m1 <*> m2 - --- | Apply the result of an impure translation to that of another -applyImpTransM :: TransM info ctx SpecTerm -> TransM info ctx SpecTerm -> - TransM info ctx SpecTerm -applyImpTransM m1 m2 = applyTermLike <$> m1 <*> m2 - --- | Apply the result of a pure translation to that of multiple translations -applyMultiPureTransM :: TransM info ctx OpenTerm -> - [TransM info ctx OpenTerm] -> - TransM info ctx OpenTerm -applyMultiPureTransM m ms = foldl applyPureTransM m ms - --- | Apply the result of an impure translation to that of multiple translations -applyGlobalImpTransM :: Ident -> [TransM info ctx SpecTerm] -> - TransM info ctx SpecTerm -applyGlobalImpTransM ident ms = - foldl applyImpTransM (return $ globalTermLike ident) ms - --- | Build a lambda-abstraction as an 'OpenTerm' 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 the result of a translation to that of another +applyTransM :: TransM info ctx OpenTerm -> TransM info ctx OpenTerm -> + TransM info ctx OpenTerm +applyTransM m1 m2 = applyOpenTerm <$> m1 <*> m2 --- | Build a lambda-abstraction as a 'SpecTerm' inside the 'TransM' monad -lambdaSpecTermTransM :: String -> SpecTerm -> - (SpecTerm -> TransM info ctx SpecTerm) -> - TransM info ctx SpecTerm -lambdaSpecTermTransM x tp body_f = - ask >>= \info -> - return (lambdaTermLike (pack x) tp $ \t -> runTransM (body_f t) info) +-- | Apply the result of a translation to the results of multiple translations +applyMultiTransM :: TransM info ctx OpenTerm -> + [TransM info ctx OpenTerm] -> + TransM info ctx OpenTerm +applyMultiTransM m ms = foldl applyTransM m ms + +-- | Apply an identifier to the results of multiple translations +applyGlobalTransM :: Ident -> [TransM info ctx OpenTerm] -> + TransM info ctx OpenTerm +applyGlobalTransM ident ms = applyGlobalOpenTerm ident <$> sequence ms -- | Build a nested lambda-abstraction -- @@ -793,26 +789,8 @@ lambdaSpecTermTransM x tp body_f = -- -- over the types in a 'TypeTrans', using the 'String' as a variable name prefix -- for the @xi@ variables -lambdaTrans :: String -> TypeTrans p tr -> (tr -> SpecTerm) -> SpecTerm -lambdaTrans x (TypeTransPure tps tr_f) body_f = - lambdaPureSpecTermMulti - (zipWith (\i tp -> (pack (x ++ show (i :: Integer)), tp)) [0..] $ - map openTermLike tps) - (body_f . tr_f) -lambdaTrans x (TypeTransImpure tps tr_f) body_f = - lambdaTermLikeMulti - (zipWith (\i tp -> (pack (x ++ show (i :: Integer)), - typeDescType tp)) [0..] tps) - (body_f . tr_f) - --- | Build a nested lambda-abstraction --- --- > \x1:tp1 -> ... -> \xn:tpn -> body --- --- over the types in a pure 'TypeTrans', using the 'String' as a variable name --- prefix for the @xi@ variables, returning a pure term -lambdaPureTrans :: String -> PureTypeTrans tr -> (tr -> OpenTerm) -> OpenTerm -lambdaPureTrans x (TypeTransPure tps tr_f) body_f = +lambdaTrans :: String -> TypeTrans tr -> (tr -> OpenTerm) -> OpenTerm +lambdaTrans x (TypeTrans tps tr_f) body_f = lambdaOpenTermMulti (zipWith (\i tp -> (pack (x ++ show (i :: Integer)), tp)) [0..] tps) (body_f . tr_f) @@ -823,77 +801,25 @@ lambdaPureTrans x (TypeTransPure tps tr_f) body_f = -- -- over the types in a 'TypeTrans' inside a translation monad, using the -- 'String' as a variable name prefix for the @xi@ variables -lambdaTransM :: String -> TypeTrans p tr -> (tr -> TransM info ctx SpecTerm) -> - TransM info ctx SpecTerm +lambdaTransM :: String -> TypeTrans tr -> (tr -> TransM info ctx OpenTerm) -> + TransM info ctx OpenTerm lambdaTransM x tp body_f = ask >>= \info -> return (lambdaTrans x tp (flip runTransM info . body_f)) --- | Build a nested lambda-abstraction --- --- > \x1:tp1 -> ... -> \xn:tpn -> body --- --- over the types in a pure 'TypeTrans' inside a translation monad, using the --- 'String' as a variable name prefix for the @xi@ variables, returning a pure --- term -lambdaPureTransM :: String -> PureTypeTrans tr -> - (tr -> TransM info ctx OpenTerm) -> TransM info ctx OpenTerm -lambdaPureTransM x tp body_f = - ask >>= \info -> return (lambdaPureTrans x tp (flip runTransM info . body_f)) - -- | Build a lambda-abstraction -- -- > \x1:(tp1, ..., tpn) -> body -- -- over a tuple of the types in a 'TypeTrans'. Note that this always builds -- exactly one lambda-abstraction, even if there are 0 types. -lambdaTupleTransM :: String -> TypeTrans p tr -> (tr -> TransM info ctx SpecTerm) -> - TransM info ctx SpecTerm +lambdaTupleTransM :: String -> TypeTrans tr -> (tr -> TransM info ctx OpenTerm) -> + TransM info ctx OpenTerm lambdaTupleTransM x ttrans body_f = lambdaTransM x (tupleTypeTrans ttrans) body_f --- | Construct a @LetRecType@ inductive description --- --- > LRT_FunDep tp1 \(x1 : tp1) -> ... -> LRT_FunDep tpn \(xn : tpn) -> --- > body x1 ... xn --- --- of a pi abstraction over the types @tpi@ in a pure 'TypeTrans', passing the --- abstracted variables to the supplied @body@ function, which should itself --- return a @LetRecType@ -piLRTTrans :: String -> PureTypeTrans tr -> (tr -> OpenTerm) -> OpenTerm -piLRTTrans x tps body_f = - foldr (\(i,tp) rest_f vars -> - let nm = pack (x ++ show (i :: Integer)) - t = lambdaOpenTerm nm tp (\var -> rest_f (vars ++ [var])) in - ctorOpenTerm "Prelude.LRT_FunDep" [tp, t]) - (body_f . typeTransF tps) (zip [0..] $ typeTransTypes tps) [] - --- | Perform 'piLRTTrans' inside a translation monad -piLRTTransM :: String -> TypeTrans 'True tr -> - (tr -> TransM info ctx OpenTerm) -> TransM info ctx OpenTerm -piLRTTransM x tps body_f = - ask >>= \info -> return (piLRTTrans x tps (flip runTransM info . body_f)) - --- | Construct a @LetRecType@ inductive description --- --- > LRT_FunClos lrt1 (LRT_FunClos lrt2 (... body ...)) --- --- of monadic arrow types over the @LetRecType@ type descriptions @lrti@ in a --- 'TypeTrans' -arrowLRTTrans :: ImpTypeTrans tr -> OpenTerm -> OpenTerm -arrowLRTTrans tps body_top = - foldr (\d body -> - ctorOpenTerm "Prelude.LRT_FunClos" [typeDescLRT d, body]) - body_top (typeTransDescs tps) - --- | Perform 'arrowLRTTrans' inside a translation monad -arrowLRTTransM :: ImpTypeTrans tr -> - TransM info ctx OpenTerm -> TransM info ctx OpenTerm -arrowLRTTransM tps body = - ask >>= \info -> return (arrowLRTTrans tps (runTransM body info)) - -- | Build a pi-abstraction over the types in a 'TypeTrans' inside a -- translation monad, using the 'String' as a variable name prefix -piTransM :: String -> PureTypeTrans tr -> (tr -> TransM info ctx OpenTerm) -> +piTransM :: String -> TypeTrans tr -> (tr -> TransM info ctx OpenTerm) -> TransM info ctx OpenTerm piTransM x tps body_f = ask >>= \info -> @@ -913,51 +839,51 @@ piOpenTermTransM x tp body_f = -} -- | Build a let-binding in a translation monad -letTransM :: String -> SpecTerm -> TransM info ctx SpecTerm -> - (SpecTerm -> TransM info ctx SpecTerm) -> - TransM info ctx SpecTerm +letTransM :: String -> OpenTerm -> TransM info ctx OpenTerm -> + (OpenTerm -> TransM info ctx OpenTerm) -> + TransM info ctx OpenTerm letTransM x tp rhs_m body_m = do r <- ask return $ - letTermLike (pack x) tp (runTransM rhs_m r) (\x' -> runTransM (body_m x') r) + 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 = - applyMultiPureTransM (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 :: ImpTypeTrans trL -> ImpTypeTrans trR -> TypeDesc +eitherTypeTrans :: TypeTrans trL -> TypeTrans trR -> OpenTerm eitherTypeTrans tp_l tp_r = - typeDescEither (typeTransTupleDesc tp_l) (typeTransTupleDesc tp_r) + dataTypeOpenTerm "Prelude.Either" + [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 => ImpTypeTrans trL -> ImpTypeTrans trR -> trL -> - SpecTerm +leftTrans :: IsTermTrans trL => TypeTrans trL -> TypeTrans trR -> trL -> + OpenTerm leftTrans tp_l tp_r tr = - ctorTermLike "Prelude.Left" + ctorOpenTerm "Prelude.Left" [typeTransTupleType tp_l, typeTransTupleType tp_r, transTupleTerm tr] -- | Apply the @Right@ constructor of the @Either@ type in SAW to the -- 'transTupleTerm' of the input -rightTrans :: IsTermTrans trR => ImpTypeTrans trL -> ImpTypeTrans trR -> trR -> - SpecTerm +rightTrans :: IsTermTrans trR => TypeTrans trL -> TypeTrans trR -> trR -> + OpenTerm rightTrans tp_l tp_r tr = - ctorTermLike "Prelude.Right" + ctorOpenTerm "Prelude.Right" [typeTransTupleType tp_l, typeTransTupleType tp_r, transTupleTerm tr] -- | Eliminate a SAW @Either@ type -eitherElimTransM :: ImpTypeTrans trL -> ImpTypeTrans trR -> - ImpTypeTrans tr -> (trL -> TransM info ctx SpecTerm) -> - (trR -> TransM info ctx SpecTerm) -> SpecTerm -> - TransM info ctx SpecTerm +eitherElimTransM :: TypeTrans trL -> TypeTrans trR -> + TypeTrans tr -> (trL -> TransM info ctx OpenTerm) -> + (trR -> TransM info ctx OpenTerm) -> OpenTerm -> + TransM info ctx OpenTerm eitherElimTransM tp_l tp_r tp_ret fl fr eith = do fl_trans <- lambdaTupleTransM "x_left" tp_l fl fr_trans <- lambdaTupleTransM "x_right" tp_r fr - return $ applyTermLikeMulti (globalTermLike "Prelude.either") + return $ applyGlobalOpenTerm "Prelude.either" [ typeTransTupleType tp_l, typeTransTupleType tp_r, typeTransTupleType tp_ret, fl_trans, fr_trans, eith ] @@ -965,140 +891,143 @@ eitherElimTransM tp_l tp_r tp_ret fl fr eith = -- translations of the types in the @Eithers@ type; the translation of the -- output type; a list of functions for the branches of the @Eithers@ -- elimination; and the term of @Eithers@ type being eliminated -eithersElimTransM :: [ImpTypeTrans tr_in] -> ImpTypeTrans tr_out -> - [tr_in -> TransM info ctx SpecTerm] -> SpecTerm -> - TransM info ctx SpecTerm +eithersElimTransM :: [TypeTrans tr_in] -> TypeTrans tr_out -> + [tr_in -> TransM info ctx OpenTerm] -> OpenTerm -> + TransM info ctx OpenTerm eithersElimTransM tps tp_ret fs eith = foldr (\(tp,f) restM -> do f_trans <- lambdaTupleTransM "x_eith_elim" tp f rest <- restM - return (ctorTermLike "Prelude.FunsTo_Cons" + return (ctorOpenTerm "Prelude.FunsTo_Cons" [typeTransTupleType tp_ret, typeTransTupleType tp, f_trans, rest])) - (return $ ctorTermLike "Prelude.FunsTo_Nil" [typeTransTupleType tp_ret]) + (return $ ctorOpenTerm "Prelude.FunsTo_Nil" [typeTransTupleType tp_ret]) (zip tps fs) >>= \elims_trans -> - return (applyGlobalTermLike "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 given by the type translation returned by the supplied monadic function. --- The Boolean flag indicates whether this monadic function is expected to --- return a pure type, in which case the returned dependent pair type is pure, --- or not, in which case it isn't. It is an error if the Boolean flag is 'True' --- but the monadic function returns an impure type description. -sigmaTypeTransM :: LocalName -> PureTypeTrans trL -> Bool -> - (trL -> TransM info ctx TypeDesc) -> - TransM info ctx TypeDesc -sigmaTypeTransM _ ttrans@(typeTransTypes -> []) _ tp_f = - tp_f (typeTransF ttrans []) -sigmaTypeTransM x ttrans pure_p tp_f = - do info <- ask - return $ typeDescSigma x (typeTransTupleType ttrans) pure_p $ \e_tup -> - runTransM (tp_f $ typeTransF (tupleTypeTrans ttrans) [e_tup]) info --- | Like `sigmaTypeTransM`, but translates `exists x.eq(y)` into just `x` -sigmaTypePermTransM :: TransInfo info => LocalName -> - PureTypeTrans (ExprTrans 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 :: String -> TypeTrans trL -> + (trL -> TransM info ctx (TypeTrans trR)) -> + TransM info ctx OpenTerm +sigmaTypeTransM x tptrans tp_f = + ask >>= \info -> + return (sigmaTypeOpenTermMulti x (typeTransTypes tptrans) + (typeTransTupleType . flip runTransM info . tp_f . typeTransF tptrans)) + +-- | Like 'sigmaTypeTransM', but translates 'exists x.eq(y)' into the tuple of +-- types of 'x', omitting the right-hand projection type +sigmaTypePermTransM :: TransInfo info => String -> + TypeTrans (ExprTrans trL) -> Mb (ctx :> trL) (ValuePerm trR) -> - TransM info ctx TypeDesc + TransM info ctx OpenTerm sigmaTypePermTransM x ttrans mb_p = case mbMatch mb_p of - [nuMP| ValPerm_Eq _ |] -> return $ TypeDescPure $ typeTransTupleType ttrans + [nuMP| ValPerm_Eq _ |] -> return $ typeTransTupleType ttrans _ -> - sigmaTypeTransM x ttrans (hasPureTrans mb_p) $ \etrans -> - inExtTransM etrans (typeTransTupleDesc <$> translate mb_p) + sigmaTypeTransM x ttrans $ \etrans -> + inExtTransM etrans (translate mb_p) --- | 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. +-- | 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) => - String -> PureTypeTrans trL -> - (trL -> TransM info ctx (ImpTypeTrans trR1)) -> + String -> TypeTrans trL -> + (trL -> TransM info ctx (TypeTrans trR1)) -> trL -> TransM info ctx trR2 -> - TransM info ctx SpecTerm + 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 (ctorTermLike "Prelude.exists" - [openTermLike (typeTransTupleType tp_l), tp_r_trm, - transTupleTerm lhs, rhs]) + ask >>= \info -> + return (sigmaOpenTermMulti x (typeTransTypes tp_l) + (typeTransTupleType . flip runTransM info . tp_r . typeTransF tp_l) + (transTerms lhs) + (transTupleTerm $ runTransM rhs_m info)) -- | Like `sigmaTransM`, but translates `exists x.eq(y)` into just `x` -sigmaPermTransM :: TransInfo info => String -> PureTypeTrans (ExprTrans a) -> - Mb (ctx :> a) (ValuePerm b) -> ExprTrans a -> - TransM info ctx (PermTrans ctx b) -> - TransM info ctx SpecTerm +sigmaPermTransM :: (TransInfo info, IsTermTrans trR2) => + String -> TypeTrans (ExprTrans trL) -> + Mb (ctx :> trL) (ValuePerm trR1) -> + ExprTrans trL -> TransM info ctx trR2 -> + TransM info ctx OpenTerm sigmaPermTransM x ttrans mb_p etrans rhs_m = case mbMatch mb_p of [nuMP| ValPerm_Eq _ |] -> return $ transTupleTerm etrans _ -> sigmaTransM x ttrans (flip inExtTransM $ translate mb_p) etrans rhs_m + -- | Eliminate a dependent pair of the type returned by 'sigmaTypeTransM' sigmaElimTransM :: (IsTermTrans trL, IsTermTrans trR) => - String -> PureTypeTrans trL -> - (trL -> TransM info ctx (ImpTypeTrans trR)) -> - TransM info ctx (ImpTypeTrans trRet) -> - (trL -> trR -> TransM info ctx SpecTerm) -> - SpecTerm -> - TransM info ctx SpecTerm + String -> TypeTrans trL -> + (trL -> TransM info ctx (TypeTrans trR)) -> + TransM info ctx (TypeTrans trRet) -> + (trL -> trR -> TransM info ctx OpenTerm) -> + OpenTerm -> + TransM info ctx OpenTerm sigmaElimTransM _ tp_l@(typeTransTypes -> []) tp_r _ f sigma = do let proj_l = typeTransF tp_l [] proj_r <- flip (typeTransF . tupleTypeTrans) [sigma] <$> tp_r proj_l f proj_l proj_r -sigmaElimTransM x tp_l tp_r tp_ret_m f sigma = - do let tp_l_trm = openTermLike $ typeTransTupleType tp_l - tp_r_trm <- lambdaTupleTransM x tp_l (\tr -> - typeTransTupleType <$> tp_r tr) - let proj_l_trm = - applyGlobalTermLike "Prelude.Sigma_proj1" [tp_l_trm, tp_r_trm, sigma] - tp_ret <- typeTransTupleType <$> tp_ret_m - sawLetTransM x tp_l_trm tp_ret proj_l_trm $ \proj_l_pure -> - do let proj_l = typeTransF (tupleTypeTrans tp_l) [proj_l_pure] - tp_r_app <- tp_r proj_l - let proj_r_trm = - applyGlobalTermLike "Prelude.Sigma_proj2" [tp_l_trm, - tp_r_trm, sigma] - let proj_r = typeTransF (tupleTypeTrans tp_r_app) [proj_r_trm] - 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)) -- | Like `sigmaElimTransM`, but translates `exists x.eq(y)` into just `x` sigmaElimPermTransM :: (TransInfo info) => - String -> PureTypeTrans (ExprTrans trL) -> + String -> TypeTrans (ExprTrans trL) -> Mb (ctx :> trL) (ValuePerm trR) -> - TransM info ctx (ImpTypeTrans trRet) -> + TransM info ctx (TypeTrans trRet) -> (ExprTrans trL -> PermTrans (ctx :> trL) trR -> - TransM info ctx SpecTerm) -> - SpecTerm -> - TransM info ctx SpecTerm + TransM info ctx OpenTerm) -> + OpenTerm -> + TransM info ctx OpenTerm sigmaElimPermTransM x tp_l mb_p tp_ret_m f sigma = case mbMatch mb_p of [nuMP| ValPerm_Eq e |] -> - do let tp_l_trm = openTermLike $ typeTransTupleType tp_l - tp_ret <- typeTransTupleType <$> tp_ret_m - sawLetTransM x tp_l_trm tp_ret sigma $ \sigma_pure -> - f (typeTransF (tupleTypeTrans tp_l) [sigma_pure]) (PTrans_Eq e) - _ -> sigmaElimTransM x tp_l (flip inExtTransM $ translate mb_p) - tp_ret_m f sigma + f (typeTransF (tupleTypeTrans tp_l) [sigma]) (PTrans_Eq e) + _ -> + sigmaElimTransM x tp_l (flip inExtTransM $ translate mb_p) tp_ret_m f sigma + +-- | Apply an 'OpenTerm' to the current event type @E@ and to a +-- list of other arguments +applyEventOpM :: TransInfo info => OpenTerm -> [OpenTerm] -> + TransM info ctx OpenTerm +applyEventOpM f args = + do evType <- evTypeTerm <$> infoEvType <$> ask + return $ applyOpenTermMulti f (evType : args) + +-- | Apply a named operator to the current event type @E@ and to a list of other +-- arguments +applyNamedEventOpM :: TransInfo info => Ident -> [OpenTerm] -> + TransM info ctx OpenTerm +applyNamedEventOpM f args = applyEventOpM (globalOpenTerm f) args + +-- | 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 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 pure SAW term, raising an --- error if the result has 0 or more than 1 terms -translate1Pure :: (IsPureTrans tr, Translate info ctx a tr, HasCallStack) => - Mb ctx a -> TransM info ctx OpenTerm -translate1Pure a = translate a >>= \tr -> case transPureTerms tr of - [t] -> return t - ts -> panic "translate1" ["expected 1 term, found " ++ show (length ts)] - -- | Translate to SAW and then convert to a single SAW term, raising an error if -- the result has 0 or more than 1 terms translate1 :: (IsTermTrans tr, Translate info ctx a tr, HasCallStack) => - Mb ctx a -> TransM info ctx SpecTerm + Mb ctx a -> TransM info ctx OpenTerm translate1 a = translate a >>= \tr -> case transTerms tr of [t] -> return t ts -> error ("translate1: expected 1 term, found " ++ show (length ts) @@ -1113,17 +1042,6 @@ instance (Translate info ctx a tr, NuMatching a) => Translate info ctx [a] [tr] where translate = mapM translate . mbList --- | Generic function for testing if a particular constuct translates to a pure --- term in the sense of not depending on the current @FunStack@ or event type, --- meaning it is an 'OpenTerm', and also that it only contains pure 'TypeDesc's, --- i.e., ones that do not contain closures. This is used as an optimization for --- translating sigma types to pure types when their right-hand sides are pure. -class HasPureTrans a where - hasPureTrans :: Mb (ctx :: RList CrucibleType) a -> Bool - -instance (HasPureTrans a, NuMatching a) => HasPureTrans [a] where - hasPureTrans = and . map hasPureTrans . mbList - ---------------------------------------------------------------------- -- * Translating Types @@ -1150,8 +1068,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 @@ -1191,184 +1107,239 @@ inEmptyCtxTransM = instance TransInfo info => Translate info ctx (NatRepr n) OpenTerm where translate mb_n = return $ natOpenTerm $ mbLift $ fmap natValue mb_n --- | Return a pure type translation that uses a single term of the given type -returnType1 :: OpenTerm -> TransM info ctx (PureTypeTrans (ExprTrans a)) -returnType1 tp = return $ mkPureTypeTrans1 tp ETrans_Term - --- | Translate a pure 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. The 'Bool' flag indicates --- whether the translation should be only to pure types, meaning that shapes and --- permissions are translated to SAW core types; otherwise, they are translated --- to terms of SAW core type @LetRecType@, which can only be used for describing --- monadic computations. -translateType :: TransInfo info => Bool -> TypeRepr a -> - TransM info ctx (PureTypeTrans (ExprTrans a)) -translateType _ AnyRepr = - return $ error "Translate: Any" -translateType _ UnitRepr = - return $ mkPureTypeTrans0 ETrans_Unit -translateType _ BoolRepr = - returnType1 $ globalOpenTerm "Prelude.Bool" -translateType _ NatRepr = - returnType1 $ dataTypeOpenTerm "Prelude.Nat" [] -translateType _ IntegerRepr = - return $ error "translate: IntegerRepr" -translateType _ RealValRepr = - return $ error "translate: RealValRepr" -translateType _ ComplexRealRepr = - return $ error "translate: ComplexRealRepr" -translateType _ (SequenceRepr{}) = - return $ error "translate: SequenceRepr" -translateType _ (BVRepr w) = - returnType1 =<< bitvectorTransM (translateClosed w) -translateType _ (VectorRepr AnyRepr) = - return $ mkPureTypeTrans0 ETrans_AnyVector +-- | Make a type translation that uses a single term of the given type +mkTermType1 :: OpenTerm -> TypeTrans (ExprTrans a) +mkTermType1 tp = mkTypeTrans1 tp ETrans_Term + + +-- | Translate a permission expression type to a 'TypeTrans' and to a list of +-- kind descriptions that describe the types in the 'TypeTrans' +translateType :: 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) = + (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 _) = - return $ mkPureTypeTrans0 ETrans_LLVM -translateType _ (LLVMBlockRepr _) = - return $ mkPureTypeTrans0 ETrans_LLVMBlock -translateType _ (LLVMFrameRepr _) = - return $ mkPureTypeTrans0 ETrans_LLVMFrame -translateType _ LifetimeRepr = - return $ mkPureTypeTrans0 ETrans_Lifetime -translateType _ PermListRepr = - returnType1 (sortOpenTerm $ mkSort 0) -translateType _ RWModalityRepr = - return $ mkPureTypeTrans0 ETrans_RWModality - --- Permissions and LLVM shapes translate to types (for the pure translation) or --- LetRecTypes (for the impure translation) -translateType False (ValuePermRepr _) = - return $ mkPureTypeTrans1 (dataTypeOpenTerm "Prelude.LetRecType" []) - (ETrans_Perm . typeDescFromLRT) -translateType True (ValuePermRepr _) = - return $ mkPureTypeTrans1 (sortOpenTerm $ mkSort 0) - (ETrans_Perm . TypeDescPure) -translateType False (LLVMShapeRepr _) = - return $ mkPureTypeTrans1 (dataTypeOpenTerm "Prelude.LetRecType" []) - (ETrans_Shape . typeDescFromLRT) -translateType True (LLVMShapeRepr _) = - return $ mkPureTypeTrans1 (sortOpenTerm $ mkSort 0) - (ETrans_Shape . TypeDescPure) - --- We can't handle any other special-purpose types -translateType _ (IntrinsicRepr _ _) = - return $ error "translate: IntrinsicRepr" - -translateType _ (RecursiveRepr _ _) = - return $ error "translate: RecursiveRepr" -translateType _ (FloatRepr _) = - returnType1 $ dataTypeOpenTerm "Prelude.Float" [] -translateType _ (IEEEFloatRepr _) = - return $ error "translate: IEEEFloatRepr" -translateType _ CharRepr = - return $ error "translate: CharRepr" -translateType _ (StringRepr UnicodeRepr) = - returnType1 stringTypeOpenTerm -translateType _ (StringRepr _) = - return $ error "translate: StringRepr non-unicode" -translateType _ (FunctionHandleRepr _ _) = +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]), + [tpKindDesc]) +translateType (LLVMShapeRepr _) = + (mkTypeTrans1 tpDescTypeOpenTerm (\d -> ETrans_Shape [d]), + [tpKindDesc]) + +translateType (FloatRepr _) = + (mkTermType1 $ 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 - return $ mkPureTypeTrans0 ETrans_Fun -translateType _ (MaybeRepr _) = - return $ error "translate: MaybeRepr" -translateType _ (VectorRepr _) = - return $ error "translate: VectorRepr (can't map to Vec without size)" -translateType b (StructRepr tps) = - fmap ETrans_Struct <$> combineCtxTranss <$> translateCtx b (mkCruCtx tps) -translateType _ (VariantRepr _) = - return $ error "translate: VariantRepr" -translateType _ (ReferenceRepr _) = - return $ error "translate: ReferenceRepr" -translateType _ (WordMapRepr _ _) = - return $ error "translate: WordMapRepr" -translateType _ (StringMapRepr _) = - return $ error "translate: StringMapRepr" -translateType _ (SymbolicArrayRepr _ _) = - return $ error "translate: SymbolicArrayRepr" -translateType _ (SymbolicStructRepr _) = - return $ error "translate: SymbolicStructRepr" + (mkTypeTrans0 ETrans_Fun, []) -instance TransInfo info => - Translate info ctx (TypeRepr a) (PureTypeTrans (ExprTrans a)) where - translate mb_tp = translateType False $ mbLift mb_tp - -newtype ExprTypeTrans a = ExprTypeTrans (PureTypeTrans (ExprTrans a)) - --- | Translate a context of types to a type translation using 'translateType' -translateCtx :: TransInfo info => Bool -> CruCtx tps -> - TransM info ctx (RAssign ExprTypeTrans tps) -translateCtx b ctx = - traverseRAssign (\tp -> ExprTypeTrans <$> - translateType b tp) (cruCtxToTypes ctx) - --- | Combine the translations of each type in a context into a single type --- translation for the entire context -combineCtxTranss :: RAssign ExprTypeTrans tps -> - PureTypeTrans (ExprTransCtx tps) -combineCtxTranss MNil = mkPureTypeTrans0 MNil -combineCtxTranss (transs :>: ExprTypeTrans trans) = - (:>:) <$> combineCtxTranss transs <*> trans +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 :: 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 :: 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 (CruCtx as) (PureTypeTrans (ExprTransCtx as)) where - translate mb_ctx = - combineCtxTranss <$> translateCtx False (mbLift mb_ctx) + Translate info ctx (TypeRepr a) (TypeTrans (ExprTrans a)) where + translate = return . fst . translateType . mbLift --- | Translate all types in a 'CruCtx' to their pure types, meaning specifically --- that permissions and shapes are translated to types and not @LetRecType@s -translateCtxPure :: TransInfo info => CruCtx ctx -> - TransM info ctx' (PureTypeTrans (ExprTransCtx ctx)) -translateCtxPure ctx = combineCtxTranss <$> translateCtx True ctx +instance TransInfo info => + Translate info ctx (CruCtx as) (TypeTrans (ExprTransCtx as)) where + translate = return . fst . translateCruCtx . mbLift -- | Translate all types in a Crucible context and lambda-abstract over them -lambdaExprCtx :: TransInfo info => CruCtx ctx -> TransM info ctx SpecTerm -> - TransM info RNil SpecTerm +lambdaExprCtx :: TransInfo info => CruCtx ctx -> TransM info ctx OpenTerm -> + TransM info RNil OpenTerm lambdaExprCtx ctx m = translateClosed ctx >>= \tptrans -> lambdaTransM "e" tptrans (\ectx -> inCtxTransM ectx m) --- | Translate all types in a Crucible context to pure types and lambda-abstract --- over those types -lambdaExprCtxPure :: TransInfo info => CruCtx ctx -> TransM info ctx OpenTerm -> - TransM info RNil OpenTerm -lambdaExprCtxPure ctx m = - translateCtxPure ctx >>= \tptrans -> - lambdaPureTransM "e" tptrans (\ectx -> inCtxTransM ectx m) - -- | Translate all types in a Crucible context and pi-abstract over them -piExprCtxPure :: TransInfo info => CruCtx ctx -> TransM info ctx OpenTerm -> - TransM info RNil OpenTerm -piExprCtxPure ctx m = - translateCtxPure ctx >>= \tptrans -> - piTransM "e" tptrans (\ectx -> inCtxTransM ectx m) - --- | Translate all types in a Crucible context and pi-abstract over them, --- building the resulting type as a @LetRecType@ -piLRTExprCtx :: TransInfo info => CruCtx ctx -> - TransM info ctx OpenTerm -> - TransM info RNil OpenTerm -piLRTExprCtx ctx m = +piExprCtx :: TransInfo info => CruCtx ctx -> TransM info ctx OpenTerm -> + TransM info RNil OpenTerm +piExprCtx ctx m = translateClosed ctx >>= \tptrans -> - piLRTTransM "e" tptrans (\ectx -> inCtxTransM ectx m) + piTransM "e" tptrans (\ectx -> inCtxTransM ectx m) --- | Like 'piLRTExprCtx' but append the newly bound variables to the current +-- | Like 'piExprCtx' but append the newly bound variables to the current -- context, rather than running in the empty context -piLRTExprCtxApp :: TransInfo info => CruCtx ctx2 -> - TransM info (ctx :++: ctx2) OpenTerm -> - TransM info ctx OpenTerm -piLRTExprCtxApp ctx m = +piExprCtxApp :: TransInfo info => CruCtx ctx2 -> + TransM info (ctx1 :++: ctx2) OpenTerm -> + TransM info ctx1 OpenTerm +piExprCtxApp ctx m = translateClosed ctx >>= \tptrans -> - piLRTTransM "e" tptrans (\ectx -> inExtMultiTransM ectx m) + piTransM "e" tptrans (\ectx -> inExtMultiTransM ectx m) + + +---------------------------------------------------------------------- +-- * Translating to Type Descriptions +---------------------------------------------------------------------- + +-- | Translation info for translating to type descriptions, which contains an +-- 'ExprTransCtx' for some prefix of @ctx@. The remainder of @ctx@ are variables +-- that each translate to zero or more deBruijn indices in type-level +-- expressions of the given kind descriptions. Note that this type does not +-- satisfy 'TransInfo', because that class requires an 'ExprTransCtx' for all of +-- @ctx@. +data DescTransInfo ctx where + DescTransInfo :: + ExprTransCtx ctx1 -> RAssign (Constant [OpenTerm]) ctx2 -> PermEnv -> + ChecksFlag -> DescTransInfo (ctx1 :++: ctx2) + +-- | 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 = + let kdesc_ctx = RL.map (Constant . translateKindDescs) $ cruCtxToTypes ctx + kdescs = concat $ RL.toList kdesc_ctx in + inExtDescTransMultiM kdesc_ctx $ m kdescs + +-- | 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. 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. +class TranslateDescs a where + translateDescs :: Mb ctx a -> DescTransM ctx [OpenTerm] + +-- | 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 a variable to either a SAW core value or a natural number +-- deBruijn index, depending on the current description context +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 (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 = + arrowTpDescMulti (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 Pure Expressions +-- * Translating Permission Expressions ---------------------------------------------------------------------- -- FIXME HERE: move these OpenTerm operations to OpenTerm.hs @@ -1412,7 +1383,7 @@ bvConcatOpenTerm LittleEndian sz1 sz2 e1 e2 = -- 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 @@ -1440,7 +1411,7 @@ 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 |] -> @@ -1472,67 +1443,44 @@ instance TransInfo info => [nuMP| PExpr_PermListNil |] -> return $ ETrans_Term unitTypeOpenTerm [nuMP| PExpr_PermListCons _ _ p l |] -> ETrans_Term <$> (pairTypeOpenTerm <$> - (typeDescLRT <$> typeTransTupleDesc <$> translate p) <*> - (translate1Pure l)) + (typeTransTupleType <$> translate p) <*> + (translate1 l)) [nuMP| PExpr_RWModality _ |] -> return ETrans_RWModality - -- LLVM shapes are translated to types - [nuMP| PExpr_EmptyShape |] -> return $ ETrans_Shape typeDescUnit - [nuMP| PExpr_NamedShape _ _ nmsh args |] -> - case mbMatch $ fmap namedShapeBody nmsh of - [nuMP| DefinedShapeBody _ |] -> - translate (mbMap2 unfoldNamedShape nmsh args) - [nuMP| OpaqueShapeBody _ trans_id |] -> - exprCtxPureTypeTerms <$> translate args >>= \case - Just args_trans -> - return $ ETrans_Shape $ TypeDescPure $ - applyOpenTermMulti (globalOpenTerm $ mbLift trans_id) args_trans - Nothing -> - panic "translate" - ["Heapster cannot yet handle opaque shapes over impure types"] - [nuMP| RecShapeBody _ trans_id _ |] -> - exprCtxPureTypeTerms <$> translate args >>= \case - Just args_trans -> - return $ ETrans_Shape $ TypeDescPure $ - applyOpenTermMulti (globalOpenTerm $ mbLift trans_id) args_trans - Nothing -> - panic "translate" - ["Heapster cannot yet handle recursive shapes over impure types"] - [nuMP| PExpr_EqShape _ _ |] -> return $ ETrans_Shape typeDescUnit - [nuMP| PExpr_PtrShape _ _ sh |] -> translate sh - [nuMP| PExpr_FieldShape fsh |] -> - ETrans_Shape <$> tupleOfTypeDescs <$> translate fsh - [nuMP| PExpr_ArrayShape mb_len _ mb_sh |] -> - do let w = natVal4 mb_len - let w_term = natOpenTerm w - len_term <- translate1Pure mb_len - elem_d <- translateShape mb_sh - return $ ETrans_Shape $ bvVecTypeDesc w_term len_term elem_d - [nuMP| PExpr_SeqShape sh1 sh2 |] -> - ETrans_Shape <$> (typeDescPair <$> translateShape sh1 - <*> translateShape sh2) - [nuMP| PExpr_OrShape sh1 sh2 |] -> - ETrans_Shape <$> (typeDescEither - <$> translateShape sh1 <*> translateShape sh2) - [nuMP| PExpr_ExShape mb_sh |] -> - do tp_trans <- translate $ fmap bindingType mb_sh - ETrans_Shape <$> - (sigmaTypeTransM "x_exsh" tp_trans - (hasPureTrans $ mbCombine RL.typeCtxProxies mb_sh) $ \e -> - inExtTransM e (translateShape $ mbCombine RL.typeCtxProxies mb_sh)) + -- LLVM shapes are translated to type descriptions by translateDescs + [nuMP| PExpr_EmptyShape |] -> + ETrans_Shape <$> descTransM (translateDescs mb_e) + [nuMP| PExpr_NamedShape _ _ _ _ |] -> + ETrans_Shape <$> descTransM (translateDescs mb_e) + [nuMP| PExpr_EqShape _ _ |] -> + ETrans_Shape <$> descTransM (translateDescs mb_e) + [nuMP| PExpr_PtrShape _ _ _ |] -> + ETrans_Shape <$> descTransM (translateDescs mb_e) + [nuMP| PExpr_FieldShape _ |] -> + ETrans_Shape <$> descTransM (translateDescs mb_e) + [nuMP| PExpr_ArrayShape _ _ _ |] -> + ETrans_Shape <$> descTransM (translateDescs mb_e) + [nuMP| PExpr_SeqShape _ _ |] -> + ETrans_Shape <$> descTransM (translateDescs mb_e) + [nuMP| PExpr_OrShape _ _ |] -> + ETrans_Shape <$> descTransM (translateDescs mb_e) + [nuMP| PExpr_ExShape _ |] -> + ETrans_Shape <$> descTransM (translateDescs mb_e) [nuMP| PExpr_FalseShape |] -> - return $ ETrans_Shape $ TypeDescPure $ globalOpenTerm "Prelude.FalseProp" + ETrans_Shape <$> descTransM (translateDescs mb_e) [nuMP| PExpr_ValPerm p |] -> - ETrans_Perm <$> typeTransTupleDesc <$> translate p + ETrans_Perm <$> descTransM (translateDescs 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) [TypeDesc] where + Translate info ctx (LLVMFieldShape w) [OpenTerm] where translate (mbMatch -> [nuMP| LLVMFieldShape p |]) = - typeTransDescs <$> translate p + descTransM (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 @@ -1540,61 +1488,99 @@ 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 |] -> translate1Pure (fmap PExpr_Var x) + [nuMP| BVFactor (BV.BV 1) x |] -> translate1 (fmap PExpr_Var x) [nuMP| BVFactor i x |] -> let w = natRepr4 x in bvMulOpenTerm (natValue w) (bvBVOpenTerm w $ mbLift i) <$> - translate1Pure (fmap PExpr_Var x) - -translateShape :: (TransInfo info, HasCallStack) => - Mb ctx (PermExpr (LLVMShapeType w)) -> - TransM info ctx TypeDesc -translateShape mb_e = unETransShape <$> translate mb_e - -instance HasPureTrans (PermExpr a) where - hasPureTrans mb_e = case mbMatch mb_e of - [nuMP| PExpr_Var _ |] -> - -- Variables of shape or permission type always have to quantify over - -- arbitrary @LetRecType@s, and so are considered impure - -- FIXME: should be type-based; only shape or perm variable are impure! - False - [nuMP| PExpr_Struct mb_es |] -> hasPureTrans mb_es - [nuMP| PExpr_PermListCons _ _ p rest |] -> - hasPureTrans p && hasPureTrans rest - [nuMP| PExpr_EmptyShape |] -> True + 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 :: 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_fs mb_i |] -> + do fs_exprs <- mapM translateBVFactorDesc $ mbList mb_fs + let i_expr = translateBVConstDesc w $ mbLift mb_i + return $ bvSumTpExprs (natValue w) (fs_exprs ++ [i_expr]) + +-- Expressions of shape type translate to a list of type descriptions +instance TranslateDescs (PermExpr (LLVMShapeType w)) where + translateDescs mb_e = case mbMatch mb_e of + [nuMP| PExpr_Var mb_x |] -> + translateVarDesc mb_x >>= \case + Left d -> return $ unETransShape d + Right (ix, [_]) -> return [varTpDesc ix] + Right (_, ds) -> + panic "translateDescs" ["Expected one kind for variable, found " + ++ show (length ds)] + [nuMP| PExpr_EmptyShape |] -> return [] [nuMP| PExpr_NamedShape _ _ nmsh args |] -> case mbMatch $ fmap namedShapeBody nmsh of [nuMP| DefinedShapeBody _ |] -> - hasPureTrans (mbMap2 unfoldNamedShape nmsh args) - [nuMP| OpaqueShapeBody _ _ |] -> hasPureTrans args - [nuMP| RecShapeBody _ _ _ |] -> hasPureTrans args - [nuMP| PExpr_EqShape _ _ |] -> True - [nuMP| PExpr_PtrShape _ _ sh |] -> hasPureTrans sh - [nuMP| PExpr_FieldShape fsh |] -> hasPureTrans fsh - [nuMP| PExpr_ArrayShape _ _ sh |] -> hasPureTrans sh + translateDescs (mbMap2 unfoldNamedShape nmsh args) + [nuMP| OpaqueShapeBody _ trans_id |] -> + (:[]) <$> applyGlobalOpenTerm (mbLift trans_id) <$> + transTerms <$> translate args + [nuMP| RecShapeBody _ trans_id |] -> + (:[]) <$> applyGlobalOpenTerm (mbLift trans_id) <$> + transTerms <$> translate args + [nuMP| PExpr_EqShape _ _ |] -> return [] + [nuMP| PExpr_PtrShape _ _ sh |] -> translateDescs sh + [nuMP| PExpr_FieldShape fsh |] -> translate 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_SeqShape sh1 sh2 |] -> - hasPureTrans sh1 && hasPureTrans sh2 + do ds1 <- translateDescs sh1 + ds2 <- translateDescs sh2 + return (ds1 ++ ds2) [nuMP| PExpr_OrShape sh1 sh2 |] -> - hasPureTrans sh1 && hasPureTrans sh2 + (\d -> [d]) <$> (sumTpDesc <$> translateDesc sh1 <*> translateDesc sh2) [nuMP| PExpr_ExShape mb_sh |] -> - hasPureTrans $ mbCombine RL.typeCtxProxies mb_sh - [nuMP| PExpr_FalseShape |] -> True - [nuMP| PExpr_ValPerm p |] -> hasPureTrans p - [nuMP| _ |] -> True - -instance HasPureTrans (PermExprs as) where - hasPureTrans e = case mbMatch e of - [nuMP| MNil |] -> True - [nuMP| es :>: e' |] -> hasPureTrans es && hasPureTrans e' - -instance HasPureTrans (LLVMFieldShape w) where - hasPureTrans (mbMatch -> [nuMP| LLVMFieldShape p |]) = hasPureTrans p + 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 [ctorOpenTerm "Prelude.Tp_Void" []] ---------------------------------------------------------------------- --- * Translating Permissions to Types +-- * Permission Translations ---------------------------------------------------------------------- -- | The result of translating a "proof element" of a permission of type @@ -1622,7 +1608,7 @@ data PermTrans (ctx :: RList CrucibleType) (a :: CrucibleType) where PermTrans ctx a -> PermTrans ctx a -- | The translation for disjunctive, existential, and named permissions - PTrans_Term :: Mb ctx (ValuePerm a) -> SpecTerm -> PermTrans ctx a + PTrans_Term :: Mb ctx (ValuePerm a) -> OpenTerm -> PermTrans ctx a -- | The 'PermTrans' type for atomic permissions @@ -1640,10 +1626,10 @@ data AtomicPermTrans ctx a where LLVMArrayPermTrans ctx w -> AtomicPermTrans ctx (LLVMPointerType w) - -- | The translation of an LLVM block permission is an element of the - -- translation of its shape to a type + -- | The translation of an LLVM block permission is a sequence of elements of + -- the translations of its shapes to types APTrans_LLVMBlock :: (1 <= w, KnownNat w) => - Mb ctx (LLVMBlockPerm w) -> SpecTerm -> + Mb ctx (LLVMBlockPerm w) -> [OpenTerm] -> AtomicPermTrans ctx (LLVMPointerType w) -- | LLVM free permissions have no computational content @@ -1662,16 +1648,16 @@ data AtomicPermTrans ctx a where APTrans_IsLLVMPtr :: (1 <= w, KnownNat w) => AtomicPermTrans ctx (LLVMPointerType w) - -- | The translation of an LLVMBlockShape permission is an element of the - -- translation of its shape to a type + -- | The translation of an LLVMBlockShape permission is a sequence of elements + -- of the translations of its shape to types APTrans_LLVMBlockShape :: (1 <= w, KnownNat w) => - Mb ctx (PermExpr (LLVMShapeType w)) -> SpecTerm -> + Mb ctx (PermExpr (LLVMShapeType w)) -> [OpenTerm] -> AtomicPermTrans ctx (LLVMBlockType w) -- | Perm_NamedConj permissions are a permission + a term APTrans_NamedConj :: NameSortIsConj ns ~ 'True => NamedPermName ns args a -> Mb ctx (PermExprs args) -> - Mb ctx (PermOffset a) -> SpecTerm -> + Mb ctx (PermOffset a) -> OpenTerm -> AtomicPermTrans ctx a -- | Defined Perm_NamedConj permissions are just a wrapper around the @@ -1712,7 +1698,7 @@ data AtomicPermTrans ctx a where APTrans_Struct :: PermTransCtx ctx (CtxToRList args) -> AtomicPermTrans ctx (StructType args) - -- | The translation of functional permission is a SAW term of closure type + -- | The translation of functional permission is a SAW term of @FunIx@ type APTrans_Fun :: Mb ctx (FunPerm ghosts (CtxToRList cargs) gouts ret) -> FunTransTerm -> AtomicPermTrans ctx (FunctionHandleType cargs ret) @@ -1726,7 +1712,7 @@ data AtomicPermTrans ctx a where -- | The translation of a proof of a 'BVProp' -data BVPropTrans ctx w = BVPropTrans (Mb ctx (BVProp w)) SpecTerm +data BVPropTrans ctx w = BVPropTrans (Mb ctx (BVProp w)) OpenTerm -- | Build the translation of a 'BVProp' permission from a proof of it bvPropPerm :: (1 <= w, KnownNat w) => BVPropTrans ctx w -> @@ -1746,440 +1732,55 @@ 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 'False (AtomicPermTrans ctx (LLVMPointerType w)), - -- llvmArrayTransBorrows :: [LLVMArrayBorrowTrans ctx w], - llvmArrayTransTerm :: SpecTerm - } +-- | The translation of the vacuously true permission +pattern PTrans_True :: PermTrans ctx a +pattern PTrans_True = PTrans_Conj [] --- | Get the SAW type of the cells of the translation of an array permission -llvmArrayTransCellType :: LLVMArrayPermTrans ctx w -> SpecTerm -llvmArrayTransCellType = typeTransType1Imp . llvmArrayTransHeadCell +-- | 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) -> + FunTransTerm -> PermTrans ctx a +pattern PTrans_Fun mb_fun_perm tr = PTrans_Conj [APTrans_Fun mb_fun_perm tr] --- | 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 a function permission to a term +data FunTransTerm + -- | A function represented as a corecursive function index, i.e., a term + -- of type @FunIx T@, where @T@ is a type description of the type of the + -- function. The first term is the event type, the second is @T@, and the + -- third is the function index. + = FunTransIx EventType OpenTerm OpenTerm + -- | A monadic function represented as a monadic function, i.e., a term of + -- type @specFun E nil T@, where @E@ is the current event type and @T@ is a + -- type description of the type of the function + | FunTransFun EventType OpenTerm OpenTerm --- | FIXME HERE NOW: document all of this! -data LOwnedInfo ps ctx = - LOwnedInfo { lownedInfoECtx :: ExprTransCtx ctx, - lownedInfoPCtx :: PermTransCtx ctx ps, - lownedInfoPVars :: RAssign (Member ctx) ps, - lownedInfoRetType :: TypeDesc } - --- | 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, - lownedInfoRetType = itiReturnType } - --- | Convert an 'LOwnedInfo' to an 'ImpTransInfo' using an existing '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) - , lownedInfoRetType = lownedInfoRetType info1 } - --- | An extension of type 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') - -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) --} - -extExprTransCtx :: ExprCtxExt ctx1 ctx2 -> ExprTransCtx ctx1 -> - ExprTransCtx ctx2 -extExprTransCtx (ExprCtxExt ectx2) ectx1 = RL.append ectx1 ectx2 - -unextExprTransCtx :: ExprCtxExt ctx1 ctx2 -> ExprTransCtx ctx2 -> - ExprTransCtx ctx1 -unextExprTransCtx ((ExprCtxExt ectx3) :: ExprCtxExt ctx1 ctx2) ectx2 = - fst $ RL.split (Proxy :: Proxy ctx1) ectx3 ectx2 - --- | Extend the context of a permission translation using an 'ExprCtxExt' -extPermTransExt :: ExprCtxExt ctx1 ctx2 -> PermTrans ctx1 a -> - PermTrans ctx2 a -extPermTransExt (ExprCtxExt ectx) ptrans = extPermTransMulti ectx ptrans - --- | Extend the context of a permission translation context using an --- 'ExprCtxExt' -extPermTransCtxExt :: ExprCtxExt ctx1 ctx2 -> PermTransCtx ctx1 ps -> - PermTransCtx ctx2 ps -extPermTransCtxExt cext = RL.map (extPermTransExt cext) - -extLOwnedInfoExt :: ExprCtxExt ctx1 ctx2 -> LOwnedInfo ps ctx1 -> - LOwnedInfo ps ctx2 -extLOwnedInfoExt cext@(ExprCtxExt ectx3) (LOwnedInfo {..}) = - LOwnedInfo { lownedInfoECtx = extExprTransCtx cext lownedInfoECtx, - lownedInfoPCtx = extPermTransCtxExt cext lownedInfoPCtx, - lownedInfoPVars = RL.map (weakenMemberR ectx3) lownedInfoPVars, - .. } - - --- | FIXME HERE NOW: docs; explain that it's as if the input LOwnedInfo is --- relative to ctx_in and the output is relative to ctx_out except this ensures --- that those are extensions of what they are supposed to be -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 -> SpecTerm) -> - SpecTerm } - -(>>>=) :: 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'') - -(>>>) :: 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 - (>>=) = (>>>=) - -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 --} - -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' - -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) - -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') - -type LOwnedTransTerm ctx ps_in ps_out = LOwnedTransM ps_in ps_out ctx () - -mkLOwnedTransTermFromTerm :: ExprTransCtx ctx -> RelPermsTypeTrans ctx ps_in -> - RelPermsTypeTrans ctx ps_out -> - RAssign (Member ctx) ps_out -> SpecTerm -> - LOwnedTransTerm ctx ps_in ps_out -mkLOwnedTransTermFromTerm ectx ttr_inF ttr_outF vars_out t = - LOwnedTransM $ \(ExprCtxExt ectx') loInfo k -> - let lrt = piExprPermLRT (exprCtxType ectx) ttr_inF ttr_outF - t_app = applyCallClosSpecTerm lrt t (transTerms $ lownedInfoPCtx loInfo) - t_ret_trans = tupleTypeTrans $ ttr_outF ectx - t_ret_tp = typeTransTupleType $ ttr_outF ectx in - bindSpecTerm t_ret_tp (typeDescType $ lownedInfoRetType loInfo) t_app $ - lambdaTermLike "lowned_ret" t_ret_tp $ \lowned_ret -> - let pctx_out' = - extPermTransCtxMulti ectx' $ typeTransF t_ret_trans [lowned_ret] - vars_out' = RL.map (weakenMemberR ectx') vars_out in - k reflExprCtxExt (loInfoSetPerms pctx_out' vars_out' loInfo) () - -lownedTransTermTerm :: PureTypeTrans (ExprTransCtx ctx) -> - RAssign (Member ctx) ps_in -> - RelPermsTypeTrans ctx ps_in -> - RelPermsTypeTrans ctx ps_out -> - LOwnedTransTerm ctx ps_in ps_out -> SpecTerm -lownedTransTermTerm ectx vars_in ps_inF ps_outF t = - lambdaTrans "e" ectx $ \exprs -> - lambdaTrans "p" (ps_inF exprs) $ \ps_in -> - let ret_tp = typeTransTupleDesc $ ps_outF exprs in - let loInfo = - LOwnedInfo { lownedInfoECtx = exprs, lownedInfoPCtx = ps_in, - lownedInfoPVars = vars_in, lownedInfoRetType = ret_tp } in - runLOwnedTransM t reflExprCtxExt loInfo $ \_ loInfo_out () -> - transTupleTerm (lownedInfoPCtx loInfo_out) - -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 :: RelPermsTypeTrans ctx ps_out -> - RAssign (Member ctx) ps_out -> - LOwnedTransTerm ctx ps_in ps_out -idLOwnedTransTerm ttr_outF vars_out = - gmodify $ \(ExprCtxExt ectx') loInfo -> - let ttr_out = - extRelPermsTypeTransMulti ectx' ttr_outF $ lownedInfoECtx loInfo - vars_out' = RL.map (weakenMemberR ectx') vars_out in - loInfo { lownedInfoPVars = vars_out', - lownedInfoPCtx = - typeTransF ttr_out (transTerms (lownedInfoPCtx loInfo)) } - -weakenLOwnedTransTerm :: ImpTypeTrans (PermTrans ctx tp) -> - LOwnedTransTerm ctx ps_in ps_out -> - LOwnedTransTerm ctx (ps_in :> tp) (ps_out :> tp) -weakenLOwnedTransTerm ttr_out 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 $ typeTransF ttr_out $ - transTerms $ lownedInfoPCtx 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 { - lotrECtx :: ExprTransCtx ctx, - lotrPsExtra :: PermTransCtx ctx ps_extra, - lotrVarsExtra :: RAssign (Member ctx) ps_extra, - lotrRelTransIn :: RelPermsTypeTrans ctx ps_in, - lotrRelTransOut :: RelPermsTypeTrans ctx ps_out, - lotrRelTransExtra :: RelPermsTypeTrans ctx ps_extra, - lotrTerm :: LOwnedTransTerm ctx (ps_extra :++: ps_in) ps_out } - --- | Build an initial 'LOwnedTrans' with an empty @ps_extra@ -mkLOwnedTrans :: ExprTransCtx ctx -> RelPermsTypeTrans ctx ps_in -> - RelPermsTypeTrans ctx ps_out -> RAssign (Member ctx) ps_out -> - SpecTerm -> LOwnedTrans ctx RNil ps_in ps_out -mkLOwnedTrans ectx ps_inF ps_outF vars_out t = - LOwnedTrans ectx MNil MNil ps_inF ps_outF (const $ pure MNil) - (mkLOwnedTransTermFromTerm ectx (preNilRelPermsTypeTrans ps_inF) - ps_outF vars_out t) - --- | Build an initial 'LOwnedTrans' with an empty @ps_extra@ and an identity --- function on SAW core terms -mkLOwnedTransId :: ExprTransCtx ctx -> RelPermsTypeTrans ctx ps -> - RelPermsTypeTrans ctx ps -> RAssign (Member ctx) ps -> - LOwnedTrans ctx RNil ps ps -mkLOwnedTransId ectx ps_inF ps_outF vars_out = - LOwnedTrans ectx MNil MNil ps_inF ps_outF (const $ pure MNil) - (idLOwnedTransTerm ps_outF 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 ectx2 (LOwnedTrans ectx1 ps_extra vars_extra ptrans_in - ptrans_out ptrans_extra t) = - LOwnedTrans - (RL.append ectx1 ectx2) (extPermTransCtxMulti ectx2 ps_extra) - (RL.map (weakenMemberR ectx2) vars_extra) - (extRelPermsTypeTransMulti ectx2 ptrans_in) - (extRelPermsTypeTransMulti ectx2 ptrans_out) - (extRelPermsTypeTransMulti ectx2 ptrans_extra) - (extLOwnedTransTerm ectx2 t) - -weakenLOwnedTrans :: - Rel1PermTypeTrans ctx tp -> - Rel1PermTypeTrans 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 { lotrRelTransIn = app1RelPermsTypeTrans lotrRelTransIn tp_in, - lotrRelTransOut = app1RelPermsTypeTrans lotrRelTransOut tp_out, - lotrTerm = weakenLOwnedTransTerm (tp_out lotrECtx) lotrTerm, .. } - --- | Convert an 'LOwnedTrans' to a closure that gets added to the list of --- closures for the current spec definition, and partially apply that closure to --- the current expression context and its @ps_extra@ terms -lownedTransTerm :: Mb ctx (ExprPerms ps_in) -> - LOwnedTrans ctx ps_extra ps_in ps_out -> SpecTerm -lownedTransTerm (mbExprPermsMembers -> - Just vars_in) (LOwnedTrans - ectx ps_extra vars_extra - tps_in tps_out tps_extra lott) = - let etps = exprCtxType ectx - tps_extra_in = appRelPermsTypeTrans tps_extra tps_in - vars_extra_in = RL.append vars_extra vars_in - lrt = piExprPermLRT etps tps_extra_in tps_out - fun_tm = - lownedTransTermTerm etps vars_extra_in tps_extra_in tps_out lott in - applyClosSpecTerm lrt (mkFreshClosSpecTerm lrt (const fun_tm)) - (transTerms ectx ++ transTerms ps_extra) -lownedTransTerm _ _ = - failTermLike "FIXME HERE NOW: write this error message" - --- | Apply the 'SImpl_MapLifetime' rule to an 'LOwnedTrans' -mapLtLOwnedTrans :: - PermTransCtx ctx ps1 -> RAssign (Member ctx) ps1 -> - RelPermsTypeTrans ctx ps1 -> - PermTransCtx ctx ps2 -> RAssign (Member ctx) ps2 -> - RelPermsTypeTrans ctx ps2 -> - RAssign any ps_in' -> RelPermsTypeTrans ctx ps_in' -> - RelPermsTypeTrans 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 ttr1F pctx2 vars2 ttr2F - prx_in' ttr_inF' ttr_outF' t1 t2 - (LOwnedTrans {..}) = - LOwnedTrans - { lotrECtx = lotrECtx - , lotrPsExtra = RL.append (RL.append pctx1 lotrPsExtra) pctx2 - , lotrVarsExtra = RL.append (RL.append vars1 lotrVarsExtra) vars2 - , lotrRelTransIn = ttr_inF' , lotrRelTransOut = ttr_outF' - , lotrRelTransExtra = - appRelPermsTypeTrans (appRelPermsTypeTrans ttr1F lotrRelTransExtra) ttr2F - , lotrTerm = - mapLtLOwnedTransTerm (RL.append pctx1 lotrPsExtra) pctx2 prx_in' - (mapLtLOwnedTransTerm pctx1 lotrPsExtra prx_in' t1 lotrTerm) - t2 - } - - --- | The translation of a function permission to a term -data FunTransTerm - -- | A monadic function represented as a closure, i.e., a term of type - -- @LRTClos stk lrt@, where @stk@ is the current stack and @lrt@ is the - -- supplied 'OpenTerm' - = FunTransClos OpenTerm SpecTerm - -- | A monadic function represented as a monadic function, i.e., a term of - -- type @SpecFun E stk lrt@, where @E@ is the current event type, @stk@ is - -- the current stack, and @lrt@ is the supplied 'OpenTerm' - | FunTransFun OpenTerm SpecTerm - --- | Convert a 'FunTransTerm' to a closure, i.e., term of type @LRTClos stk lrt@ -funTransTermToClos :: FunTransTerm -> SpecTerm -funTransTermToClos (FunTransClos _ clos) = clos -funTransTermToClos (FunTransFun lrt f) = mkFreshClosSpecTerm lrt (const f) +-- | Convert a 'FunTransTerm' to an index, i.e., term of type @FunIx T@ +funTransTermToIx :: FunTransTerm -> OpenTerm +funTransTermToIx (FunTransIx _ _ funix) = funix +funTransTermToIx (FunTransFun ev d f) = + applyGlobalOpenTerm "Prelude.LambdaS" [evTypeTerm ev, d, f] -- | Apply a 'FunTransTerm' to a list of arguments -applyFunTransTerm :: FunTransTerm -> [SpecTerm] -> SpecTerm -applyFunTransTerm (FunTransClos lrt clos) = applyCallClosSpecTerm lrt clos -applyFunTransTerm (FunTransFun _ f) = applyTermLikeMulti f - - --- | 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] +applyFunTransTerm :: FunTransTerm -> [OpenTerm] -> OpenTerm +applyFunTransTerm (FunTransIx ev d funix) = callSOpenTerm ev d funix +applyFunTransTerm (FunTransFun _ _ f) = applyOpenTermMulti f --- | A single function permission -pattern PTrans_Fun :: () => (a ~ FunctionHandleType cargs ret) => - Mb ctx (FunPerm ghosts (CtxToRList cargs) gouts ret) -> - FunTransTerm -> PermTrans ctx a -pattern PTrans_Fun mb_fun_perm tr = PTrans_Conj [APTrans_Fun mb_fun_perm tr] -- | Build a type translation for a disjunctive, existential, or named -- permission that uses the 'PTrans_Term' constructor -mkPermTypeTrans1 :: Mb ctx (ValuePerm a) -> TypeDesc -> - ImpTypeTrans (PermTrans ctx a) -mkPermTypeTrans1 mb_p tp = mkImpTypeTrans1 tp (PTrans_Term mb_p) +mkPermTypeTrans1 :: Mb ctx (ValuePerm a) -> OpenTerm -> + TypeTrans (PermTrans ctx a) +mkPermTypeTrans1 mb_p tp = mkTypeTrans1 tp (PTrans_Term mb_p) -- | Extract the body of a conjunction or raise an error unPTransConj :: String -> PermTrans ctx a -> [AtomicPermTrans ctx a] @@ -2237,34 +1838,19 @@ unPTransLOwned _ tps_in tps_out unPTransLOwned fname _ _ _ = panic fname ["Expected lowned permission"] --- | Add a borrow translation to the translation of an array permission - -- | A context mapping bound names to their perm translations type PermTransCtx ctx ps = RAssign (PermTrans ctx) ps --- | A 'TypeTrans' for a 'PermTrans' that is relative to an expr context -type Rel1PermTypeTrans ctx a = - ExprTransCtx ctx -> ImpTypeTrans (PermTrans ctx a) - --- | A 'TypeTrans' for a 'PermTransCtx' that is relative to an expr context -type RelPermsTypeTrans ctx ps = - ExprTransCtx ctx -> ImpTypeTrans (PermTransCtx ctx ps) +-- | A 'DescTypeTrans' yielding a single 'PermTrans' +type Desc1PermTpTrans ctx a = DescTypeTrans (PermTrans ctx a) --- | Append two 'RelPermsTypeTrans's -appRelPermsTypeTrans :: RelPermsTypeTrans ctx ps1 -> - RelPermsTypeTrans ctx ps2 -> - RelPermsTypeTrans ctx (ps1 :++: ps2) -appRelPermsTypeTrans tps1 tps2 = \ectx -> RL.append <$> tps1 ectx <*> tps2 ectx +-- | A 'DescTypeTrans' yielding a 'PermTransCtx' +type DescPermsTpTrans ctx ps = DescTypeTrans (PermTransCtx ctx ps) -app1RelPermsTypeTrans :: RelPermsTypeTrans ctx ps -> - Rel1PermTypeTrans ctx tp -> - RelPermsTypeTrans ctx (ps :> tp) -app1RelPermsTypeTrans tps1 tps2 = \ectx -> (:>:) <$> tps1 ectx <*> tps2 ectx - --- | Prepend an 'RNil' list of permissions to a 'RelPermsTypeTrans' -preNilRelPermsTypeTrans :: RelPermsTypeTrans ctx ps -> - RelPermsTypeTrans ctx (RNil :++: ps) -preNilRelPermsTypeTrans = appRelPermsTypeTrans (const $ pure MNil) +-- | Prepand an empty list of permissions to a 'DescPermsTpTrans' +preNilDescPermsTpTrans :: DescPermsTpTrans ctx ps -> + DescPermsTpTrans ctx (RNil :++: ps) +preNilDescPermsTpTrans = liftA2 RL.append (pure MNil) -- | Build a permission translation context with just @true@ permissions truePermTransCtx :: CruCtx ps -> PermTransCtx ctx ps @@ -2292,11 +1878,11 @@ instance IsTermTrans (PermTransCtx ctx ps) where 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) = ts transTerms (APTrans_LLVMFree _) = [] transTerms (APTrans_LLVMFunPtr _ trans) = transTerms trans transTerms APTrans_IsLLVMPtr = [] - transTerms (APTrans_LLVMBlockShape _ t) = [t] + transTerms (APTrans_LLVMBlockShape _ ts) = ts transTerms (APTrans_NamedConj _ _ _ t) = [t] transTerms (APTrans_DefinedNamedConj _ _ _ ptrans) = transTerms ptrans transTerms (APTrans_LLVMFrame _) = [] @@ -2306,7 +1892,7 @@ instance IsTermTrans (AtomicPermTrans ctx a) where transTerms (APTrans_LCurrent _) = [] transTerms APTrans_LFinished = [] transTerms (APTrans_Struct pctx) = transTerms pctx - transTerms (APTrans_Fun _ t) = [funTransTermToClos t] + transTerms (APTrans_Fun _ t) = [funTransTermToIx t] transTerms (APTrans_BVProp prop) = transTerms prop transTerms APTrans_Any = [] @@ -2327,9 +1913,9 @@ instance IsTermTrans (LLVMArrayBorrowTrans ctx w) where -} --- | Map a context of perm translations to a list of 'SpecTerm's, dropping the +-- | 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 -> [SpecTerm] +permCtxToTerms :: PermTransCtx ctx tps -> [OpenTerm] permCtxToTerms = concat . RL.mapToList transTerms -- | Extract out the permission of a permission translation result @@ -2392,16 +1978,24 @@ 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 => prx tp -> f ctx a -> f (ctx :> tp) a +extPermTrans e = extPermTransMulti (MNil :>: e) -extMbAny :: RAssign any ctx2 -> Mb ctx1 a -> Mb (ctx1 :++: ctx2) a -extMbAny ctx2 = extMbMulti (RL.map (const Proxy) ctx2) +-- | Extend the context of a permission translation using a 'CtxExt' +extPermTransExt :: CtxExt ctx1 ctx2 -> PermTrans ctx1 a -> + PermTrans ctx2 a +extPermTransExt (CtxExt ctx) ptrans = extPermTransMulti ctx ptrans + +-- | Extend the context of a 'PermTransCtx' using a 'CtxExt' +extPermTransCtxExt :: CtxExt ctx1 ctx2 -> PermTransCtx ctx1 ps -> + PermTransCtx ctx2 ps +extPermTransCtxExt cext = RL.map (extPermTransExt cext) -extPermTrans :: ExtPermTrans f => ExprTrans tp -> f ctx a -> f (ctx :> tp) a -extPermTrans e = extPermTransMulti (MNil :>: e) -- | Generic function to extend the context of the translation of a permission class ExtPermTrans f where - extPermTransMulti :: ExprTransCtx ctx2 -> f ctx1 a -> f (ctx1 :++: ctx2) a + extPermTransMulti :: RAssign prx ctx2 -> f ctx1 a -> f (ctx1 :++: ctx2) a instance ExtPermTrans PermTrans where extPermTransMulti ectx (PTrans_Eq e) = @@ -2418,15 +2012,15 @@ instance ExtPermTrans AtomicPermTrans where 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 t) = - APTrans_LLVMBlock (extMbAny ectx mb_bp) t + 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 t) = - APTrans_LLVMBlockShape (extMbAny ectx mb_sh) t + 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) = @@ -2471,24 +2065,15 @@ instance ExtPermTrans BVRangeTrans where BVRangeTrans (extMbAny ectx rng) t1 t2 -- | Extend the context of a permission translation context -extPermTransCtx :: ExprTrans tp -> PermTransCtx ctx ps -> +extPermTransCtx :: prx tp -> PermTransCtx ctx ps -> PermTransCtx (ctx :> tp) ps extPermTransCtx e = RL.map (extPermTrans e) -- | Extend the context of a permission translation context -extPermTransCtxMulti :: ExprTransCtx ctx2 -> PermTransCtx ctx1 ps -> +extPermTransCtxMulti :: RAssign prx ctx2 -> PermTransCtx ctx1 ps -> PermTransCtx (ctx1 :++: ctx2) ps extPermTransCtxMulti ectx2 = RL.map (extPermTransMulti ectx2) --- | Extend the context of a 'RelPermsTypeTrans' -extRelPermsTypeTransMulti :: ExprTransCtx ctx2 -> RelPermsTypeTrans ctx1 ps -> - RelPermsTypeTrans (ctx1 :++: ctx2) ps -extRelPermsTypeTransMulti ectx2 (rel_tp :: RelPermsTypeTrans ctx1 ps) = - \ectx12 -> - let (ectx1, _) = RL.split (Proxy :: Proxy ctx1) ectx2 ectx12 in - fmap (extPermTransCtxMulti ectx2) $ rel_tp ectx1 - - -- | Add another permission translation to a permission translation context consPermTransCtx :: PermTransCtx ctx ps -> PermTrans ctx a -> PermTransCtx ctx (ps :> a) @@ -2507,12 +2092,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 @@ -2541,12 +2126,43 @@ offsetLLVMPermTrans mb_off (PTrans_Defined n args off ptrans) = offsetLLVMPermTrans mb_off (PTrans_Term mb_p t) = PTrans_Term (mbMap2 offsetLLVMPerm mb_off mb_p) t --- | Apply 'offsetPerm' to the permissions associated with a permission --- translation -offsetPermTrans :: Mb ctx (PermOffset a) -> PermTrans ctx a -> PermTrans ctx a -offsetPermTrans mb_off = case mbMatch mb_off of - [nuMP| NoPermOffset |] -> id - [nuMP| LLVMPermOffset off |] -> offsetLLVMPermTrans off +-- | Apply 'offsetPerm' to the permissions associated with a permission +-- translation +offsetPermTrans :: Mb ctx (PermOffset a) -> PermTrans ctx a -> PermTrans ctx a +offsetPermTrans mb_off = case mbMatch mb_off of + [nuMP| NoPermOffset |] -> id + [nuMP| LLVMPermOffset off |] -> offsetLLVMPermTrans off + + +---------------------------------------------------------------------- +-- * Translations of Array Permissions +---------------------------------------------------------------------- + +-- | The translation of an LLVM array permission is a SAW term of @BVVec@ type, +-- along with a SAW term for its length as a bitvector and the type translation +-- for a @memblock@ permission to its head cell, which can be offset to get a +-- @memblock@ permission for any of its cells. +data LLVMArrayPermTrans ctx w = LLVMArrayPermTrans { + llvmArrayTransPerm :: Mb ctx (LLVMArrayPerm w), + llvmArrayTransLen :: OpenTerm, + llvmArrayTransHeadCell :: TypeTrans (AtomicPermTrans ctx (LLVMPointerType w)), + -- llvmArrayTransBorrows :: [LLVMArrayBorrowTrans ctx w], + llvmArrayTransTerm :: OpenTerm + } + +-- | Get the SAW type of the cells of the translation of an array permission +llvmArrayTransCellType :: LLVMArrayPermTrans ctx w -> OpenTerm +llvmArrayTransCellType = 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] } +-} {- -- | Add a borrow to an LLVM array permission translation @@ -2590,7 +2206,7 @@ llvmArrayTransRemBorrow b_trans arr_trans = -- as returned by 'llvmArrayIndexInArray'. Note that the first proposition -- should always be that the cell number is <= the array length. getLLVMArrayTransCell :: (1 <= w, KnownNat w) => LLVMArrayPermTrans ctx w -> - Mb ctx (PermExpr (BVType w)) -> SpecTerm -> + Mb ctx (PermExpr (BVType w)) -> OpenTerm -> [BVPropTrans ctx w] -> AtomicPermTrans ctx (LLVMPointerType w) getLLVMArrayTransCell arr_trans mb_cell cell_tm (BVPropTrans _ in_rng_pf:_) = @@ -2602,8 +2218,8 @@ getLLVMArrayTransCell arr_trans mb_cell cell_tm (BVPropTrans _ in_rng_pf:_) = offsetLLVMAtomicPermTrans (mbMap2 llvmArrayCellToOffset (llvmArrayTransPerm arr_trans) mb_cell) $ typeTransF (llvmArrayTransHeadCell arr_trans) - [applyGlobalTermLike "Prelude.atBVVec" - [natTermLike w, openTermLike (llvmArrayTransLen arr_trans), + [applyGlobalOpenTerm "Prelude.atBVVec" + [natOpenTerm w, llvmArrayTransLen arr_trans, llvmArrayTransCellType arr_trans, llvmArrayTransTerm arr_trans, cell_tm, in_rng_pf]] getLLVMArrayTransCell _ _ _ _ = @@ -2613,14 +2229,14 @@ 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 -> - SpecTerm -> AtomicPermTrans ctx (LLVMPointerType w) -> + OpenTerm -> AtomicPermTrans ctx (LLVMPointerType w) -> LLVMArrayPermTrans ctx w setLLVMArrayTransCell arr_trans cell_tm cell_value = let w = fromInteger $ natVal arr_trans in arr_trans { llvmArrayTransTerm = - applyGlobalTermLike "Prelude.updBVVec" - [natTermLike w, openTermLike (llvmArrayTransLen arr_trans), + applyGlobalOpenTerm "Prelude.updBVVec" + [natOpenTerm w, llvmArrayTransLen arr_trans, llvmArrayTransCellType arr_trans, llvmArrayTransTerm arr_trans, cell_tm, transTerm1 cell_value] } @@ -2631,13 +2247,13 @@ setLLVMArrayTransCell arr_trans cell_tm cell_value = -- by 'llvmArrayCellsInArray'. Note that the first two of these propositions are -- those returned by 'bvPropRangeSubset'. getLLVMArrayTransSlice :: (1 <= w, KnownNat w) => LLVMArrayPermTrans ctx w -> - ImpTypeTrans (LLVMArrayPermTrans ctx w) -> + TypeTrans (LLVMArrayPermTrans ctx w) -> BVRangeTrans ctx w -> [BVPropTrans ctx w] -> LLVMArrayPermTrans ctx w getLLVMArrayTransSlice arr_trans sub_arr_tp rng_trans prop_transs = let w = fromInteger $ natVal arr_trans elem_tp = llvmArrayTransCellType arr_trans - len_tm = openTermLike $ llvmArrayTransLen arr_trans + len_tm = llvmArrayTransLen arr_trans v_tm = llvmArrayTransTerm arr_trans off_tm = transTerm1 $ bvRangeTransOff rng_trans len'_tm = transTerm1 $ bvRangeTransLen rng_trans @@ -2645,109 +2261,388 @@ getLLVMArrayTransSlice arr_trans sub_arr_tp rng_trans prop_transs = BVPropTrans _ p1_tm = p1_trans BVPropTrans _ p2_tm = p2_trans in typeTransF sub_arr_tp - [applyGlobalTermLike "Prelude.sliceBVVec" - [natTermLike w, len_tm, elem_tp, off_tm, len'_tm, p1_tm, p2_tm, v_tm]] + [applyGlobalOpenTerm "Prelude.sliceBVVec" + [natOpenTerm w, len_tm, elem_tp, off_tm, len'_tm, p1_tm, p2_tm, v_tm]] -- | Write a slice (= a sub-array) of the translation of an LLVM array -- permission given the translation of the slice and of the offset of that slice -- in the larger array setLLVMArrayTransSlice :: (1 <= w, KnownNat w) => LLVMArrayPermTrans ctx w -> - LLVMArrayPermTrans ctx w -> SpecTerm -> + LLVMArrayPermTrans ctx w -> OpenTerm -> LLVMArrayPermTrans ctx w setLLVMArrayTransSlice arr_trans sub_arr_trans off_tm = let w = fromInteger $ natVal arr_trans elem_tp = llvmArrayTransCellType arr_trans - len_tm = openTermLike $ llvmArrayTransLen arr_trans + len_tm = llvmArrayTransLen arr_trans arr_tm = llvmArrayTransTerm arr_trans - len'_tm = openTermLike $ llvmArrayTransLen sub_arr_trans + len'_tm = llvmArrayTransLen sub_arr_trans sub_arr_tm = llvmArrayTransTerm sub_arr_trans in arr_trans { llvmArrayTransTerm = - applyGlobalTermLike "Prelude.updSliceBVVec" - [natTermLike w, len_tm, elem_tp, arr_tm, off_tm, len'_tm, sub_arr_tm] } + applyGlobalOpenTerm "Prelude.updSliceBVVec" + [natOpenTerm w, len_tm, elem_tp, arr_tm, off_tm, len'_tm, sub_arr_tm] } + + +---------------------------------------------------------------------- +-- * Translations of Lifetime Ownership Permissions +---------------------------------------------------------------------- + +-- | An 'LOwnedInfo' is essentially a set of translations of "proof objects" of +-- permission list @ps@, in a variable context @ctx@, along with additional +-- information (the @SpecM@ event type and the eventual return type of the +-- overall computation) required to apply @bindS@ +data LOwnedInfo ps ctx = + LOwnedInfo { lownedInfoPCtx :: PermTransCtx ctx ps, + lownedInfoPVars :: RAssign (Member ctx) ps, + lownedInfoEvType :: EventType, + lownedInfoRetType :: OpenTerm } + +-- | Convert an 'ImpTransInfo' to an 'LOwnedInfo' +impInfoToLOwned :: ImpTransInfo ext blocks tops rets ps ctx -> LOwnedInfo ps ctx +impInfoToLOwned (ImpTransInfo {..}) = + LOwnedInfo { 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 { itiPermStack = lownedInfoPCtx, + itiPermStackVars = lownedInfoPVars, + itiPermCtx = RL.map (const PTrans_True) itiPermCtx, + 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 { lownedInfoPCtx = + RL.append (lownedInfoPCtx info1) (lownedInfoPCtx info2) + , lownedInfoPVars = + RL.append (lownedInfoPVars info1) (lownedInfoPVars info2) + , lownedInfoEvType = lownedInfoEvType info1 + , lownedInfoRetType = lownedInfoRetType info1 } + +extLOwnedInfoExt :: CtxExt ctx1 ctx2 -> LOwnedInfo ps ctx1 -> + LOwnedInfo ps ctx2 +extLOwnedInfoExt cext@(CtxExt ectx3) (LOwnedInfo {..}) = + LOwnedInfo { lownedInfoPCtx = extPermTransCtxExt cext lownedInfoPCtx, + lownedInfoPVars = RL.map (weakenMemberR ectx3) lownedInfoPVars, + .. } + + +-- | 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. CtxExt ctx ctx_in -> LOwnedInfo ps_in ctx_in -> + (forall ctx_out. CtxExt 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) (transCtxExt cext cext') s2 $ \cext'' -> + k (transCtxExt 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 reflCtxExt 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 reflCtxExt (extLOwnedInfoExt cext loInfo) () {- --- | 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 +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'. CtxExt 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) reflCtxExt s $ \cext' -> + k cext' + +-- | Modify the current permission stack relative to its extended expression +-- context @ctx'@ +gmodify :: (forall ctx'. CtxExt 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 :: CtxExt ctx ctx' -> LOwnedTransM ps_in ps_out ctx a -> + LOwnedTransM ps_in ps_out ctx' a +extLOwnedTransM cext m = + LOwnedTransM $ \cext' -> runLOwnedTransM m (transCtxExt 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 term of type @FunIx T@ as the +-- transformation, where type description @T@ is defined by 'arrowDescTrans'. +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 $ \(CtxExt ctx') loInfo k -> + let ev = lownedInfoEvType loInfo + d = arrowDescTrans trans_in trans_out + t_app = callSOpenTerm ev d t (transTerms $ lownedInfoPCtx 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 reflCtxExt (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 -> RAssign (Member ctx) ps_in -> + DescPermsTpTrans ctx ps_in -> + DescPermsTpTrans ctx ps_out -> + LOwnedTransTerm ctx ps_in ps_out -> OpenTerm +lownedTransTermFun ev vars_in tps_in tps_out t = + lambdaTrans "p" (descTypeTrans tps_in) $ \ps_in -> + let ret_tp = typeTransTupleType $ descTypeTrans tps_out in + let loInfo = + LOwnedInfo { lownedInfoPCtx = ps_in, lownedInfoPVars = vars_in, + lownedInfoEvType = ev, lownedInfoRetType = ret_tp } in + runLOwnedTransM t reflCtxExt loInfo $ \_ loInfo_out () -> + transTupleTerm (lownedInfoPCtx loInfo_out) + +-- | Extend the expression context of an 'LOwnedTransTerm' +extLOwnedTransTerm :: RAssign prx ctx2 -> + LOwnedTransTerm ctx1 ps_in ps_out -> + LOwnedTransTerm (ctx1 :++: ctx2) ps_in ps_out +extLOwnedTransTerm ectx2 = extLOwnedTransM (mkCtxExt 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 $ \(CtxExt ctx') loInfo -> + loInfo { lownedInfoPVars = RL.map (weakenMemberR ctx') vars_out, + lownedInfoPCtx = + descTypeTransF (fmap (extPermTransCtxMulti ctx') dtr_out) + (transTerms (lownedInfoPCtx loInfo)) } + +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 $ + transTerms $ lownedInfoPCtx 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, + 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 -> DescPermsTpTrans ctx ps_in -> + DescPermsTpTrans ctx ps_out -> RAssign (Member ctx) ps_out -> + OpenTerm -> LOwnedTrans ctx RNil ps_in ps_out +mkLOwnedTrans ev tps_in tps_out vars_out t = + LOwnedTrans ev 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 -> DescPermsTpTrans ctx ps -> + DescPermsTpTrans ctx ps -> RAssign (Member ctx) ps -> + LOwnedTrans ctx RNil ps ps +mkLOwnedTransId ev tps_in tps_out vars_out = + LOwnedTrans ev MNil MNil tps_in tps_out (pure MNil) + (idLOwnedTransTerm tps_out vars_out) + +-- | Extend the context of an 'LOwnedTrans' +extLOwnedTransMulti :: RAssign any ctx2 -> + LOwnedTrans ctx1 ps_extra ps_in ps_out -> + LOwnedTrans (ctx1 :++: ctx2) ps_extra ps_in ps_out +extLOwnedTransMulti ctx2 (LOwnedTrans ev ps_extra vars_extra ptrans_in + ptrans_out ptrans_extra t) = + LOwnedTrans + ev (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 = liftA2 (:>:) lotrTpTransIn tp_in, + lotrTpTransOut = liftA2 (:>:) lotrTpTransOut tp_out, + lotrTerm = weakenLOwnedTransTerm tp_out lotrTerm, .. } + +-- | Convert an 'LOwnedTrans' to a closure that gets added to the list of +-- closures for the current spec definition, and partially apply that closure to +-- the current expression context and its @ps_extra@ terms +lownedTransTerm :: Mb ctx (ExprPerms ps_in) -> + LOwnedTrans ctx ps_extra ps_in ps_out -> OpenTerm +lownedTransTerm (mbExprPermsMembers -> Just vars_in) lotr = + let tps_extra_in = + liftA2 RL.append (lotrTpTransExtra lotr) (lotrTpTransIn lotr) + vars_extra_in = RL.append (lotrVarsExtra lotr) vars_in + d = arrowDescTrans tps_extra_in (lotrTpTransOut lotr) in + applyGlobalOpenTerm "Prelude.LambdaS" + [evTypeTerm (lotrEvType lotr), d, + lownedTransTermFun (lotrEvType lotr) vars_extra_in tps_extra_in + (lotrTpTransOut lotr) (lotrTerm lotr)] +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 + , lotrPsExtra = RL.append (RL.append pctx1 lotrPsExtra) pctx2 + , lotrVarsExtra = RL.append (RL.append vars1 lotrVarsExtra) vars2 + , lotrTpTransIn = dtr_in' , lotrTpTransOut = dtr_out' + , lotrTpTransExtra = + liftA2 RL.append (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 'False (BVPropTrans ctx w) -mkBVPropTrans prop tp = - mkImpTypeTrans1 (TypeDescPure tp) $ BVPropTrans prop + TypeTrans (BVPropTrans ctx w) +mkBVPropTrans prop tp = mkTypeTrans1 tp $ BVPropTrans prop instance (1 <= w, KnownNat w, TransInfo info) => - Translate info ctx (BVProp w) (ImpTypeTrans (BVPropTrans ctx w)) where + Translate info ctx (BVProp w) (TypeTrans (BVPropTrans ctx w)) where translate prop = case mbMatch prop of [nuMP| BVProp_Eq e1 e2 |] -> do let w = natVal4 e1 - t1 <- translate1Pure e1 - t2 <- translate1Pure e2 + t1 <- translate1 e1 + t2 <- translate1 e2 return $ mkBVPropTrans prop $ dataTypeOpenTerm "Prelude.Eq" [applyOpenTermMulti (globalOpenTerm "Prelude.Vec") @@ -2762,8 +2657,8 @@ instance (1 <= w, KnownNat w, TransInfo info) => [nuMP| BVProp_ULt e1 e2 |] -> do let w = natVal4 e1 - t1 <- translate1Pure e1 - t2 <- translate1Pure e2 + t1 <- translate1 e1 + t2 <- translate1 e2 return $ mkBVPropTrans prop $ dataTypeOpenTerm "Prelude.Eq" [globalOpenTerm "Prelude.Bool", @@ -2772,8 +2667,8 @@ instance (1 <= w, KnownNat w, TransInfo info) => [nuMP| BVProp_ULeq e1 e2 |] -> do let w = natVal4 e1 - t1 <- translate1Pure e1 - t2 <- translate1Pure e2 + t1 <- translate1 e1 + t2 <- translate1 e2 return $ mkBVPropTrans prop $ dataTypeOpenTerm "Prelude.Eq" [globalOpenTerm "Prelude.Bool", @@ -2782,9 +2677,9 @@ instance (1 <= w, KnownNat w, TransInfo info) => [nuMP| BVProp_ULeq_Diff e1 e2 e3 |] -> do let w = natVal4 e1 - t1 <- translate1Pure e1 - t2 <- translate1Pure e2 - t3 <- translate1Pure e3 + t1 <- translate1 e1 + t2 <- translate1 e2 + t3 <- translate1 e3 return $ mkBVPropTrans prop $ dataTypeOpenTerm "Prelude.Eq" [globalOpenTerm "Prelude.Bool", @@ -2803,9 +2698,9 @@ instance (1 <= w, KnownNat w, TransInfo info) => -- [| p :: ValuePerm |] = type of the impl translation of reg with perms p instance TransInfo info => - Translate info ctx (ValuePerm a) (ImpTypeTrans (PermTrans ctx a)) where + Translate info ctx (ValuePerm a) (TypeTrans (PermTrans ctx a)) where translate p = case mbMatch p of - [nuMP| ValPerm_Eq e |] -> return $ mkImpTypeTrans0 $ PTrans_Eq e + [nuMP| ValPerm_Eq e |] -> return $ mkTypeTrans0 $ PTrans_Eq e [nuMP| ValPerm_Or p1 p2 |] -> do tp1 <- translate p1 tp2 <- translate p2 @@ -2819,35 +2714,44 @@ instance TransInfo info => do env <- infoEnv <$> ask case lookupNamedPerm env (mbLift npn) of Just (NamedPerm_Opaque op) -> + error "FIXME HERE NOWNOW: translate opaque named permissions" + {- exprCtxPureTypeTerms <$> translate args >>= \case Just args_exprs -> return $ mkPermTypeTrans1 p $ TypeDescPure $ applyGlobalOpenTerm (opaquePermTrans op) args_exprs Nothing -> panic "translate" - ["Heapster cannot yet handle opaque permissions over impure types"] + ["Heapster cannot yet handle opaque permissions over impure types"] -} Just (NamedPerm_Rec rp) -> + error "FIXME HERE NOWNOW: translate recursive named permissions" + {- exprCtxPureTypeTerms <$> translate args >>= \case Just args_exprs -> return $ mkPermTypeTrans1 p $ TypeDescPure $ applyOpenTermMulti (globalOpenTerm $ recPermTransType rp) args_exprs Nothing -> panic "translate" - ["Heapster cannot yet handle recursive permissions over impure types"] + ["Heapster cannot yet handle recursive permissions over impure types"] -} 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 <$> unETransPerm <$> translate x + do d <- tupleTpDesc <$> unETransPerm <$> translate x + return $ mkTypeTrans1 (tpElemTypeOpenTerm d) (PTrans_Term p) [nuMP| ValPerm_False |] -> - return $ mkPermTypeTrans1 p $ - TypeDescPure $ globalOpenTerm "Prelude.FalseProp" + return $ mkPermTypeTrans1 p $ globalOpenTerm "Prelude.FalseProp" + + +instance TranslateDescs (ValuePerm a) where + translateDescs mb_p = error "FIXME HERE NOWNOW" + instance TransInfo info => - Translate info ctx (AtomicPerm a) (TypeTrans 'False + Translate info ctx (AtomicPerm a) (TypeTrans (AtomicPermTrans ctx a)) where translate mb_p = case mbMatch mb_p of [nuMP| Perm_LLVMField fld |] -> @@ -2857,19 +2761,19 @@ instance TransInfo info => fmap APTrans_LLVMArray <$> translate ap [nuMP| Perm_LLVMBlock bp |] -> - do tp <- translateShape (fmap llvmBlockShape bp) - return $ mkImpTypeTrans1 tp (APTrans_LLVMBlock bp) + do ds <- descTransM $ translateDescs (fmap llvmBlockShape bp) + return $ TypeTrans (map tpElemTypeOpenTerm ds) (APTrans_LLVMBlock bp) [nuMP| Perm_LLVMFree e |] -> - return $ mkImpTypeTrans0 $ APTrans_LLVMFree e + return $ mkTypeTrans0 $ APTrans_LLVMFree e [nuMP| Perm_LLVMFunPtr tp p |] -> translate p >>= \tp_ptrans -> return $ fmap (APTrans_LLVMFunPtr $ mbLift tp) tp_ptrans [nuMP| Perm_IsLLVMPtr |] -> - return $ mkImpTypeTrans0 APTrans_IsLLVMPtr + return $ mkTypeTrans0 APTrans_IsLLVMPtr [nuMP| Perm_LLVMBlockShape sh |] -> - do tp <- translateShape sh - return $ mkImpTypeTrans1 tp (APTrans_LLVMBlockShape sh) + do ds <- descTransM $ translateDescs sh + return $ TypeTrans (map tpElemTypeOpenTerm ds) (APTrans_LLVMBlockShape sh) [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 @@ -2885,35 +2789,36 @@ instance TransInfo info => APTrans_NamedConj (mbLift npn) args off t _ -> error "translateSimplImpl: Perm_NamedConj") ptrans [nuMP| Perm_LLVMFrame fp |] -> - return $ mkImpTypeTrans0 $ APTrans_LLVMFrame fp + return $ mkTypeTrans0 $ APTrans_LLVMFrame fp [nuMP| Perm_LOwned ls tps_in tps_out ps_in ps_out |] -> case mbExprPermsMembers ps_out of Just vars_out -> - do ectx <- infoCtx <$> ask - let etps = exprCtxType ectx - ttr_inF <- tpTransM $ ctxFunTypeTransM $ translate ps_in - ttr_outF <- tpTransM $ ctxFunTypeTransM $ translate ps_out - let tp = typeDescFromLRT $ piExprPermLRT etps ttr_inF ttr_outF - return $ mkImpTypeTrans1 tp $ \t -> + do ev <- infoEvType <$> ask + dtr_in <- tpTransM $ translateDescType ps_in + dtr_out <- tpTransM $ translateDescType ps_out + let d = arrowDescTrans dtr_in dtr_out + return $ mkTypeTrans1 (funIxTypeOpenTerm d) $ \t -> (APTrans_LOwned ls (mbLift tps_in) (mbLift tps_out) ps_in ps_out $ - mkLOwnedTrans ectx ttr_inF ttr_outF vars_out t) + mkLOwnedTrans ev dtr_in dtr_out vars_out t) Nothing -> error "FIXME HERE NOWNOW: handle this error!" [nuMP| Perm_LOwnedSimple tps lops |] -> - return $ mkImpTypeTrans0 $ APTrans_LOwnedSimple (mbLift tps) lops + return $ mkTypeTrans0 $ APTrans_LOwnedSimple (mbLift tps) lops [nuMP| Perm_LCurrent l |] -> - return $ mkImpTypeTrans0 $ APTrans_LCurrent l + return $ mkTypeTrans0 $ APTrans_LCurrent l [nuMP| Perm_LFinished |] -> - return $ mkImpTypeTrans0 APTrans_LFinished + return $ mkTypeTrans0 APTrans_LFinished [nuMP| Perm_Struct ps |] -> fmap APTrans_Struct <$> translate ps [nuMP| Perm_Fun fun_perm |] -> - translate fun_perm >>= \tp_desc -> - return $ mkImpTypeTrans1 tp_desc (APTrans_Fun fun_perm . - FunTransClos (typeDescLRT tp_desc)) + do tp_desc <- descTransM (translateDesc fun_perm) + ev <- infoEvType <$> ask + return $ + mkTypeTrans1 (funIxTypeOpenTerm tp_desc) + (APTrans_Fun fun_perm . FunTransIx ev tp_desc) [nuMP| Perm_BVProp prop |] -> fmap APTrans_BVProp <$> translate prop - [nuMP| Perm_Any |] -> return $ mkImpTypeTrans0 APTrans_Any + [nuMP| Perm_Any |] -> return $ mkTypeTrans0 APTrans_Any -- | Translate an array permission to a 'TypeTrans' for an array permission -- translation, also returning the translations of the bitvector width as a @@ -2921,26 +2826,28 @@ instance TransInfo info => -- of the translation of the array translateLLVMArrayPerm :: (1 <= w, KnownNat w, TransInfo info) => Mb ctx (LLVMArrayPerm w) -> - TransM info ctx (OpenTerm,OpenTerm,SpecTerm, - ImpTypeTrans (LLVMArrayPermTrans ctx w)) + TransM info ctx (OpenTerm,OpenTerm,OpenTerm, + TypeTrans (LLVMArrayPermTrans ctx w)) translateLLVMArrayPerm mb_ap = do let w = natVal2 mb_ap let w_term = natOpenTerm w - sh_trans <- translate $ mbMapCl $(mkClosed [| Perm_LLVMBlock . - llvmArrayPermHead |]) mb_ap - let elem_tp = typeTransType1Imp sh_trans - len_term <- translate1Pure $ mbLLVMArrayLen mb_ap + -- 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 = bvVecTypeDesc w_term len_term $ typeTransTupleDesc sh_trans + let arr_tp = bvVecTypeOpenTerm w_term len_term elem_tp return (w_term, len_term, elem_tp, - mkImpTypeTrans1 arr_tp - ({- flip $ -} LLVMArrayPermTrans mb_ap len_term sh_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) (ImpTypeTrans + Translate info ctx (LLVMArrayPerm w) (TypeTrans (LLVMArrayPermTrans ctx w)) where translate mb_ap = (\(_,_,_,tp_trans) -> tp_trans) <$> translateLLVMArrayPerm mb_ap @@ -2961,26 +2868,26 @@ translateLLVMArrayBorrow mb_ap mb_b = -} instance TransInfo info => - Translate info ctx (ValuePerms ps) (ImpTypeTrans + Translate info ctx (ValuePerms ps) (TypeTrans (PermTransCtx ctx ps)) where translate mb_ps = case mbMatch mb_ps of - [nuMP| ValPerms_Nil |] -> return $ mkImpTypeTrans0 MNil + [nuMP| ValPerms_Nil |] -> return $ mkTypeTrans0 MNil [nuMP| ValPerms_Cons ps p |] -> liftA2 (:>:) <$> translate ps <*> translate p -- Translate a DistPerms by translating its corresponding ValuePerms instance TransInfo info => - Translate info ctx (DistPerms ps) (ImpTypeTrans + Translate info ctx (DistPerms ps) (TypeTrans (PermTransCtx ctx ps)) where translate = translate . mbDistPermsToValuePerms instance TransInfo info => - Translate info ctx (TypedDistPerms ps) (ImpTypeTrans + Translate info ctx (TypedDistPerms ps) (TypeTrans (PermTransCtx ctx ps)) where translate = translate . mbDistPermsToValuePerms . fmap unTypeDistPerms instance TransInfo info => - Translate info ctx (ExprPerms ps) (ImpTypeTrans + Translate info ctx (ExprPerms ps) (TypeTrans (PermTransCtx ctx ps)) where translate mb_eps | Just mb_ps <- mbExprPermsToValuePerms mb_eps = translate mb_ps @@ -2988,128 +2895,77 @@ instance TransInfo info => error ("Translating expression permissions that could not be converted " ++ "to variable permissions:" ++ permPrettyString emptyPPInfo mb_ps) - -instance HasPureTrans (ValuePerm a) where - hasPureTrans p = case mbMatch p of - [nuMP| ValPerm_Eq _ |] -> True - [nuMP| ValPerm_Or p1 p2 |] -> hasPureTrans p1 && hasPureTrans p2 - [nuMP| ValPerm_Exists mb_p |] -> - hasPureTrans (mbCombine RL.typeCtxProxies mb_p) - [nuMP| ValPerm_Named _ args _ |] -> - -- FIXME: this is technically incorrect, since a defined permission could - -- unfold to an impure permission - hasPureTrans args - [nuMP| ValPerm_Conj ps |] -> hasPureTrans ps - [nuMP| ValPerm_Var _ _ |] -> False - [nuMP| ValPerm_False |] -> True - -instance HasPureTrans (AtomicPerm a) where - hasPureTrans mb_p = case mbMatch mb_p of - [nuMP| Perm_LLVMField fld |] -> hasPureTrans fld - [nuMP| Perm_LLVMArray ap |] -> hasPureTrans $ mbLLVMArrayCellShape ap - [nuMP| Perm_LLVMBlock bp |] -> hasPureTrans $ mbLLVMBlockShape bp - [nuMP| Perm_LLVMFree _ |] -> True - [nuMP| Perm_LLVMFunPtr _ _ |] -> False - [nuMP| Perm_IsLLVMPtr |] -> True - [nuMP| Perm_LLVMBlockShape sh |] -> hasPureTrans sh - [nuMP| Perm_NamedConj _ args _ |] -> - -- FIXME: this is technically incorrect, since a defined permission could - -- unfold to an impure permission - hasPureTrans args - [nuMP| Perm_LLVMFrame _ |] -> True - [nuMP| Perm_LOwned _ _ _ _ _ |] -> False - [nuMP| Perm_LOwnedSimple _ _ |] -> True - [nuMP| Perm_LCurrent _ |] -> True - [nuMP| Perm_LFinished |] -> True - [nuMP| Perm_Struct ps |] -> hasPureTrans ps - [nuMP| Perm_Fun _ |] -> False - [nuMP| Perm_BVProp _ |] -> True - [nuMP| Perm_Any |] -> True - -instance HasPureTrans (ValuePerms ps) where - hasPureTrans p = case mbMatch p of - [nuMP| MNil |] -> True - [nuMP| ps :>: p' |] -> hasPureTrans ps && hasPureTrans p' - -instance HasPureTrans (DistPerms ps) where - hasPureTrans p = case mbMatch p of - [nuMP| MNil |] -> True - [nuMP| ps :>: VarAndPerm _ p' |] -> hasPureTrans ps && hasPureTrans p' - -instance HasPureTrans (LLVMFieldPerm w sz) where - hasPureTrans (mbMatch -> [nuMP| LLVMFieldPerm { llvmFieldContents = p } |]) = - hasPureTrans p - -emptyStackOpenTerm :: OpenTerm -emptyStackOpenTerm = globalOpenTerm "Prelude.emptyFunStack" - -- Translate a FunPerm to a pi-abstraction (FIXME HERE NOW: document translation) instance TransInfo info => - Translate info ctx (FunPerm ghosts args gouts ret) TypeDesc where + Translate info ctx (FunPerm ghosts args gouts ret) OpenTerm where translate (mbMatch -> [nuMP| FunPerm ghosts args gouts ret perms_in perms_out |]) = let tops = appendCruCtx (mbLift ghosts) (mbLift args) tops_prxs = cruCtxProxies tops rets = CruCtxCons (mbLift gouts) (mbLift ret) rets_prxs = cruCtxProxies rets in - (infoCtx <$> ask) >>= \ctx -> + (RL.map (const Proxy) <$> infoCtx <$> ask) >>= \ctx -> case RL.appendAssoc ctx tops_prxs rets_prxs of Refl -> - fmap typeDescFromLRT $ piLRTExprCtxApp tops $ - arrowLRTPermCtx (mbCombine tops_prxs perms_in) $ - fmap (specLRTOpenTerm . typeDescLRT) $ - translateRetType rets (mbCombine - (RL.append tops_prxs rets_prxs) perms_out) + piExprCtxApp tops $ + do tptrans_in <- translate (mbCombine tops_prxs perms_in) + piTransM "p" tptrans_in $ \_ -> + translateRetType rets (mbCombine + (RL.append tops_prxs rets_prxs) perms_out) + +instance TranslateDescs (FunPerm ghosts args gouts ret) where + translateDescs (mbMatch -> + [nuMP| FunPerm ghosts args gouts ret perms_in perms_out |]) = + do let tops = appendCruCtx (mbLift ghosts) (mbLift args) + tops_prxs = cruCtxProxies tops + rets = CruCtxCons (mbLift gouts) (mbLift ret) + rets_prxs = cruCtxProxies rets + ds_in <- translateDescs perms_in + ctx <- dtiProxies <$> ask + case RL.appendAssoc ctx tops_prxs rets_prxs of + Refl -> + inExtCtxDescTransM tops $ \kdescs -> + (\d -> [d]) <$> piTpDescMulti kdescs <$> + translateRetTpDesc rets (mbCombine + (RL.append tops_prxs rets_prxs) perms_out) -- | Lambda-abstraction over a permission lambdaPermTrans :: TransInfo info => String -> Mb ctx (ValuePerm a) -> - (PermTrans ctx a -> TransM info ctx SpecTerm) -> - TransM info ctx SpecTerm + (PermTrans ctx a -> TransM info ctx OpenTerm) -> + TransM info ctx OpenTerm lambdaPermTrans str p f = translate p >>= \tptrans -> lambdaTransM str tptrans f -- | Lambda-abstraction over a sequence of permissions lambdaPermCtx :: TransInfo info => Mb ctx (ValuePerms ps) -> - (PermTransCtx ctx ps -> TransM info ctx SpecTerm) -> - TransM info ctx SpecTerm + (PermTransCtx ctx ps -> TransM info ctx OpenTerm) -> + TransM info ctx OpenTerm lambdaPermCtx ps f = translate ps >>= \tptrans -> lambdaTransM "p" tptrans f --- | Build a @LetRecType@ that abstracts the SAW terms for a sequence of value --- permissions -arrowLRTPermCtx :: TransInfo info => Mb ctx (ValuePerms ps) -> - TransM info ctx OpenTerm -> - TransM info ctx OpenTerm -arrowLRTPermCtx ps body = - translate ps >>= \tptrans -> arrowLRTTransM tptrans body - --- | Build a @LetRecType@ describing a monadic SAW core function that takes in: --- values for all the expression types in an 'ExprTransCtx' as dependent --- arguments using @LRT_FunDep@; and values for all the permissions described by --- a 'PermTransCtx' relative to the expressions using @LRT_FunClos@. The return --- type is described by a 'PermTransCtx' as well. -piExprPermLRT :: PureTypeTrans (ExprTransCtx ctx) -> - RelPermsTypeTrans ctx ps_in -> RelPermsTypeTrans ctx ps_out -> - OpenTerm -piExprPermLRT etps ptps_in_F ptps_out_F = - piLRTTrans "e" etps $ \ectx -> - arrowLRTTrans (ptps_in_F ectx) $ - specLRTOpenTerm $ typeDescLRT $ typeTransTupleDesc (ptps_out_F ectx) - --- | 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 TypeDesc + TransM info ctx OpenTerm translateRetType rets ret_perms = do tptrans <- translateClosed rets - sigmaTypeTransM "ret" tptrans (hasPureTrans ret_perms) - (\ectx -> inExtMultiTransM ectx (typeTransTupleDesc <$> - translate ret_perms)) + 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 return type for the function resulting from an entrypoint translateEntryRetType :: TransInfo info => TypedEntry phase ext blocks tops rets args ghosts -> - TransM info ((tops :++: args) :++: ghosts) TypeDesc + TransM info ((tops :++: args) :++: ghosts) OpenTerm translateEntryRetType (TypedEntry {..} :: TypedEntry phase ext blocks tops rets args ghosts) = let mb_perms_out = @@ -3124,13 +2980,15 @@ translateEntryRetType (TypedEntry {..} -- * The Implication Translation Monad ---------------------------------------------------------------------- --- | A mapping from a block entrypoint to a corresponding SAW closure that is --- bound to its translation if it has one: only those entrypoints marked as the --- heads of strongly-connect components have translations as closures +-- | A mapping from a block entrypoint to a corresponding SAW function index +-- (including the type description @T@ and the SAW core term of type @FunIx T@) +-- 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, - typedEntryTransClos :: Maybe (OpenTerm, SpecTerm) } + typedEntryTransClos :: Maybe (OpenTerm, OpenTerm) } -- | A mapping from a block to the SAW functions for each entrypoint data TypedBlockTrans ext blocks tops rets args = @@ -3199,7 +3057,7 @@ data ImpTransInfo ext blocks tops rets ps ctx = itiPermStackVars :: RAssign (Member ctx) ps, itiPermEnv :: PermEnv, itiBlockMapTrans :: TypedBlockMapTrans ext blocks tops rets, - itiReturnType :: TypeDesc, + itiReturnType :: OpenTerm, itiChecksFlag :: ChecksFlag } @@ -3215,7 +3073,6 @@ instance TransInfo (ImpTransInfo ext blocks tops rets ps) where , itiPermStackVars = RL.map Member_Step itiPermStackVars , .. } - -- | The monad for impure translations type ImpTransM ext blocks tops rets ps = TransM (ImpTransInfo ext blocks tops rets ps) @@ -3224,7 +3081,7 @@ 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 -> TypeDesc -> + TypedBlockMapTrans ext blocks tops rets -> OpenTerm -> ImpTransM ext blocks tops rets ps ctx a -> TypeTransM ctx a impTransM pvars pctx mapTrans retType = @@ -3391,50 +3248,51 @@ clearVarPermsM = local $ \info -> info { itiPermCtx = RL.map (const PTrans_True) $ itiPermCtx info } - -- | 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 :: SpecTerm -> ImpTypeTrans tr -> String -> - (tr -> ImpTransM ext blocks tops rets ps ctx SpecTerm) -> - ImpTransM ext blocks tops rets ps ctx SpecTerm -bindSpecMTransM m m_tp str f = - do ret_tp <- returnTypeM - k_tm <- lambdaTransM str m_tp f - return $ bindSpecTerm (typeTransType1Imp m_tp) ret_tp m k_tm - --- | The current non-monadic return type as a type description -returnTypeDescM :: ImpTransM ext blocks tops rets ps_out ctx TypeDesc -returnTypeDescM = itiReturnType <$> ask - --- | The current non-monadic return type as a term -returnTypeM :: ImpTransM ext blocks tops rets ps_out ctx SpecTerm -returnTypeM = typeDescType <$> returnTypeDescM - --- | Build the monadic return type @SpecM E evRetType stack ret@ as a type --- description, where @ret@ is the current return type in 'itiReturnType' -compReturnTypeDescM :: ImpTransM ext blocks tops rets ps_out ctx TypeDesc -compReturnTypeDescM = specMTypeDesc <$> returnTypeDescM - --- | 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 SpecTerm -compReturnTypeM = typeDescType <$> compReturnTypeDescM +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_tptrans str f = + do ev <- infoEvType <$> ask + ret_tp <- returnTypeM + k_tm <- lambdaTransM str m_tptrans f + let m_tp = typeTransTupleType m_tptrans + return $ bindSOpenTerm ev 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 + +-- | Build the monadic return type @SpecM E ret@, where @ret@ is the current +-- return type in 'itiReturnType' +compReturnTypeM :: ImpTransM ext blocks tops rets ps_out ctx OpenTerm +compReturnTypeM = + do ev <- infoEvType <$> ask + ret_tp <- returnTypeM + return $ applyGlobalOpenTerm "Prelude.SpecM" [evTypeTerm ev, ret_tp] -- | Like 'compReturnTypeM' but build a 'TypeTrans' compReturnTypeTransM :: - ImpTransM ext blocks tops rets ps_out ctx (ImpTypeTrans SpecTerm) -compReturnTypeTransM = mkTermImpTypeTrans <$> compReturnTypeDescM + ImpTransM ext blocks tops rets ps_out ctx (TypeTrans OpenTerm) +compReturnTypeTransM = openTermTypeTrans <$> compReturnTypeM -- | Build an @errorS@ computation with the given error message -mkErrorComp :: String -> ImpTransM ext blocks tops rets ps_out ctx SpecTerm +mkErrorComp :: String -> ImpTransM ext blocks tops rets ps_out ctx OpenTerm mkErrorComp msg = - do ret_tp <- returnTypeM - return $ errorSpecTerm ret_tp (pack msg) + do ev <- infoEvType <$> ask + ret_tp <- returnTypeM + return $ applyGlobalOpenTerm "Prelude.errorS" + [evTypeTerm ev, ret_tp, stringLitOpenTerm (pack 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 SpecTerm + translateF :: Mb ctx (f ps) -> ImpTransM ext blocks tops rets ps ctx OpenTerm + +{- +FIXME HERE NOWNOW: check block rules to make sure they respect the new +translation of blocks to a list of terms ---------------------------------------------------------------------- @@ -3512,24 +3370,6 @@ instance Semigroup HasFailures where instance Monoid HasFailures where mempty = NoFailures --- | FIXME HERE NOW: docs! -data CtxExt ctx1 ctx2 where - CtxExt :: RAssign Proxy ctx3 -> CtxExt ctx1 (ctx1 :++: ctx3) - -reflCtxExt :: CtxExt ctx ctx -reflCtxExt = CtxExt MNil - -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 - -- | A function for translating an @r@ newtype ImpRTransFun r ext blocks tops rets ctx = ImpRTransFun { appImpTransFun :: @@ -3667,20 +3507,20 @@ pimplHandleFailM m m_catch = -- | Translate the output permissions of a 'SimplImpl' translateSimplImplOut :: Mb ctx (SimplImpl ps_in ps_out) -> ImpTransM ext blocks tops rets ps ctx - (ImpTypeTrans (PermTransCtx ctx ps_out)) + (TypeTrans (PermTransCtx ctx ps_out)) translateSimplImplOut = translate . mbSimplImplOut -- | Translate the head output permission of a 'SimplImpl' translateSimplImplOutHead :: Mb ctx (SimplImpl ps_in (ps_out :> a)) -> ImpTransM ext blocks tops rets ps ctx - (ImpTypeTrans (PermTrans ctx a)) + (TypeTrans (PermTrans ctx a)) translateSimplImplOutHead = translate . mbMapCl $(mkClosed [| varAndPermPerm . RL.head |]) . mbSimplImplOut -- | Translate the head of the tail of the output permission of a 'SimplImpl' translateSimplImplOutTailHead :: Mb ctx (SimplImpl ps_in (ps_out :> a :> b)) -> ImpTransM ext blocks tops rets ps ctx - (ImpTypeTrans (PermTrans ctx a)) + (TypeTrans (PermTrans ctx a)) translateSimplImplOutTailHead = translate . mbMapCl $(mkClosed [| varAndPermPerm . RL.head . RL.tail |]) . mbSimplImplOut @@ -4253,7 +4093,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of ptrans_arr <- getTopPermM let arr_out_comp_tm = applyTermLikeMulti (monadicSpecOp "Prelude.mapBVVecS") - [elem_tp, typeTransType1Imp cell_out_trans, impl_tm, + [elem_tp, typeTransType1 cell_out_trans, impl_tm, openTermLike w_term, openTermLike len_term, transTerm1 ptrans_arr] -- Now use bindS to bind the result of arr_out_comp_tm in the remaining @@ -4286,8 +4126,8 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of 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 $ ctxFunTypeTransM $ translate f_l_args - f_l2_min_trans <- tpTransM $ ctxFunTypeTransM $ translate f_l2_min + f_l_args_trans <- tpTransM $ translateDescType f_l_args + f_l2_min_trans <- tpTransM $ translateDescType f_l2_min withPermStackM (\(ns :>: x :>: _ :>: l2) -> ns :>: x :>: l2) (\case @@ -4351,10 +4191,10 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of [nuMP| SImpl_MapLifetime _ mb_ls tps_in tps_out _ _ tps_in' tps_out' ps_in' ps_out' ps1 ps2 impl_in impl_out |] -> -- First, translate the various permissions and implications - do ttr_inF' <- tpTransM $ ctxFunTypeTransM $ translate ps_in' - ttr_outF' <- tpTransM $ ctxFunTypeTransM $ translate ps_out' - ttr1F <- tpTransM $ ctxFunTypeTransM $ translate ps1 - ttr2F <- tpTransM $ ctxFunTypeTransM $ translate ps2 + 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 <- @@ -4439,15 +4279,15 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of [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 ectx <- infoCtx <$> ask - ttr_inF <- tpTransM $ ctxFunTypeTransM $ translate mb_ps' - ttr_outF <- tpTransM $ ctxFunTypeTransM $ translate mb_ps + do ev <- infoEvType <$> 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 ectx ttr_inF ttr_outF vars)) + (mkLOwnedTransId ev dtr_in dtr_out vars)) m _ -> panic "translateSimplImpl" @@ -4625,7 +4465,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of do ttrans <- translateSimplImplOutHead mb_simpl withPermStackM id (\(pctx :>: ptrans) -> - pctx :>: typeTransF (tupleTypeTrans ttrans) [transTerm1 ptrans]) + pctx :>: typeTransF ttrans (transTerms ptrans)) m [nuMP| SImpl_IntroLLVMBlockArray _ _ |] -> @@ -4999,7 +4839,7 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o do let mb_e = case mbLLVMFieldContents mb_fp of [nuP| ValPerm_Eq (PExpr_LLVMWord e) |] -> e _ -> error "translatePermImpl1: Impl1_SplitLLVMWordField" - e_tm <- translate1Pure mb_e + e_tm <- translate1 mb_e sz1_tm <- translate mb_sz1 sz2_tm <- translateClosed $ mbLLVMFieldSize mb_fp let sz2m1_tm = applyGlobalOpenTerm "Prelude.subNat" [sz2_tm, sz1_tm] @@ -5027,7 +4867,7 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o do let mb_e = case mbLLVMFieldContents mb_fp of [nuP| ValPerm_Eq (PExpr_LLVMWord e) |] -> e _ -> error "translatePermImpl1: Impl1_TruncateLLVMWordField" - e_tm <- translate1Pure mb_e + e_tm <- translate1 mb_e sz1_tm <- translate mb_sz1 sz2_tm <- translateClosed $ mbLLVMFieldSize mb_fp let sz2m1_tm = applyGlobalOpenTerm "Prelude.subNat" [sz2_tm, sz1_tm] @@ -5053,8 +4893,8 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o do let mb_e1 = case mbLLVMFieldContents mb_fp1 of [nuP| ValPerm_Eq (PExpr_LLVMWord e1) |] -> e1 _ -> error "translatePermImpl1: Impl1_ConcatLLVMWordFields" - e1_tm <- translate1Pure mb_e1 - e2_tm <- translate1Pure mb_e2 + e1_tm <- translate1 mb_e1 + e2_tm <- translate1 mb_e2 sz1_tm <- translateClosed $ mbLLVMFieldSize mb_fp1 sz2_tm <- translateClosed $ mbExprBVTypeWidth mb_e2 let endianness = mbLift mb_endianness @@ -5075,15 +4915,15 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o ([nuMP| Impl1_BeginLifetime |], _) -> translatePermImplUnary mb_impls $ \m -> inExtTransM ETrans_Lifetime $ - do ectx <- itiExprCtx <$> ask + do ev <- infoEvType <$> ask let prxs = RL.map (const Proxy) ectx let mb_ps = (nuMulti prxs (const MNil)) - let ttr = const $ pure MNil + let ttr = pure MNil withPermStackM (:>: Member_Base) (:>: PTrans_LOwned (nuMulti prxs (const [])) CruCtxNil CruCtxNil mb_ps mb_ps - (mkLOwnedTransId ectx ttr ttr MNil)) + (mkLOwnedTransId ev ttr ttr MNil)) m -- If e1 and e2 are already equal, short-circuit the proof construction and then @@ -5091,7 +4931,7 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o ([nuMP| Impl1_TryProveBVProp x prop@(BVProp_Eq e1 e2) _ |], _) | mbLift (mbMap2 bvEq e1 e2) -> translatePermImplUnary mb_impls $ \m -> - do bv_tp <- typeTransType1Imp <$> translateClosed (mbExprType e1) + do bv_tp <- typeTransType1 <$> translateClosed (mbExprType e1) e1_trans <- translate1 e1 let pf = ctorTermLike "Prelude.Refl" [bv_tp, e1_trans] withPermStackM (:>: translateVar x) @@ -5115,7 +4955,7 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o do prop_tp_trans <- translate prop ret_tp <- compReturnTypeM applyGlobalImpTransM "Prelude.maybe" - [ return (typeTransType1Imp prop_tp_trans), return ret_tp + [ return (typeTransType1 prop_tp_trans), return ret_tp , return (implFailAltContTerm ret_tp (mbLift prop_str) k) , lambdaTransM "eq_pf" prop_tp_trans (\prop_trans -> @@ -5171,7 +5011,7 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o do prop_tp_trans <- translate prop ret_tp <- compReturnTypeM applyGlobalImpTransM "Prelude.maybe" - [ return (typeTransType1Imp prop_tp_trans), return ret_tp + [ return (typeTransType1 prop_tp_trans), return ret_tp , return (implFailAltContTerm ret_tp (mbLift prop_str) k) , lambdaTransM "ult_pf" prop_tp_trans (\prop_trans -> @@ -5205,7 +5045,7 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o do prop_tp_trans <- translate prop ret_tp <- compReturnTypeM applyGlobalImpTransM "Prelude.maybe" - [ return (typeTransType1Imp prop_tp_trans), return ret_tp + [ return (typeTransType1 prop_tp_trans), return ret_tp , return (implFailAltContTerm ret_tp (mbLift prop_str) k) , lambdaTransM "ule_pf" prop_tp_trans (\prop_trans -> @@ -5241,7 +5081,7 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o do prop_tp_trans <- translate prop ret_tp <- compReturnTypeM applyGlobalImpTransM "Prelude.maybe" - [ return (typeTransType1Imp prop_tp_trans), return ret_tp + [ return (typeTransType1 prop_tp_trans), return ret_tp , return (implFailAltContTerm ret_tp (mbLift prop_str) k) , lambdaTransM "ule_diff_pf" prop_tp_trans (\prop_trans -> @@ -5309,8 +5149,8 @@ translateLocalPermImpl err (mbMatch -> [nuMP| LocalPermImpl impl |]) = translateCurryLocalPermImpl :: String -> Mb ctx (LocalPermImpl (ps1 :++: ps2) ps_out) -> PermTransCtx ctx ps1 -> RAssign (Member ctx) ps1 -> - ImpTypeTrans (PermTransCtx ctx ps2) -> RAssign (Member ctx) ps2 -> - ImpTypeTrans (PermTransCtx ctx ps_out) -> + TypeTrans (PermTransCtx ctx ps2) -> RAssign (Member ctx) ps2 -> + TypeTrans (PermTransCtx ctx ps_out) -> ImpTransM ext blocks tops rets ps ctx SpecTerm translateCurryLocalPermImpl err impl pctx1 vars1 tp_trans2 vars2 tp_trans_out = lambdaTransM "x_local" tp_trans2 $ \pctx2 -> @@ -5765,15 +5605,17 @@ translateStmt loc mb_stmt m = case mbMatch mb_stmt of let (pctx_ghosts_args, _) = RL.split (RL.append ectx_gexprs ectx_args) ectx_gexprs pctx_in fret_tp <- - mkTermImpTypeTrans <$> + mkTermTypeTrans <$> sigmaTypeTransM "ret" rets_trans (hasPureTrans perms_out) (\ectx -> inExtMultiTransM ectx (typeTransTupleDesc <$> translate perms_out)) let all_args = exprCtxToTerms ectx_gexprs ++ exprCtxToTerms ectx_args ++ permCtxToTerms pctx_ghosts_args - let fapp_trm = case f_trans of - PTrans_Fun _ f_trm -> applyFunTransTerm f_trm all_args + fun_tp_desc <- descTransM (translateDesc fun_perm) + fapp_trm <- case f_trans of + PTrans_Fun _ f_trm -> + applyEvOpM "Prelude.CallS" [fun_tp_desc, f_trm] _ -> panic "translateStmt" ["TypedCall: unexpected function permission"] @@ -5925,42 +5767,28 @@ translateLLVMStmt mb_stmt m = case mbMatch mb_stmt of withKnownNat ?ptrWidth $ inExtTransM ETrans_LLVM $ do env <- infoEnv <$> ask + ev <- infoEvType <$> 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 (_, GlobalTransDef spec_def) - | [nuP| ValPerm_LLVMFunPtr fun_tp (ValPerm_Fun fun_perm) |] <- p -> - do lrt <- typeDescLRT <$> translate (extMb fun_perm) - let ptrans = - PTrans_Conj [APTrans_LLVMFunPtr (mbLift fun_tp) $ - PTrans_Fun fun_perm $ FunTransFun lrt $ - importDefSpecTerm lrt spec_def] - withPermStackM (:>: Member_Base) - (:>: extPermTrans ETrans_LLVM ptrans) m - Just (_, GlobalTransDef _) -> + Nothing -> panic "translateLLVMStmt" - ["TypedLLVMResolveGlobal: " - ++ " unexpected recursive function translation for symbol " + ["TypedLLVMResolveGlobal: no translation of symbol " ++ globalSymbolName (mbLift gsym)] - Just (_, GlobalTransClos clos) + Just (_, GlobalTransFuns [f]) | [nuP| ValPerm_LLVMFunPtr fun_tp (ValPerm_Fun fun_perm) |] <- p -> - do lrt <- typeDescLRT <$> translate (extMb fun_perm) + do d <- descTransM <$> translateDesc (extMb fun_perm) let ptrans = PTrans_Conj [APTrans_LLVMFunPtr (mbLift fun_tp) $ - PTrans_Fun fun_perm $ FunTransClos lrt clos] + PTrans_Fun fun_perm $ FunTransFun ev d f] withPermStackM (:>: Member_Base) (:>: extPermTrans ETrans_LLVM ptrans) m - Just (_, GlobalTransClos _) -> + Just (_, GlobalTransFun _) -> panic "translateLLVMStmt" - ["TypedLLVMResolveGlobal: " - ++ " unexpected recursive function translation for symbol " + ["TypedLLVMResolveGlobal: unexpected function translation for symbol " ++ globalSymbolName (mbLift gsym)] Just (_, GlobalTransTerms ts) -> do ptrans <- translate (extMb p) - let ts_imp = map openTermLike ts - withPermStackM (:>: Member_Base) (:>: typeTransF ptrans ts_imp) m + withPermStackM (:>: Member_Base) (:>: typeTransF ptrans ts) m [nuMP| TypedLLVMIte _ mb_r1 _ _ |] -> inExtTransM ETrans_LLVM $ @@ -6317,7 +6145,7 @@ translateCFGsToDefs env checks some_cfgs = map (\cfg_trans -> let lrt = cfgTransLRT cfg_trans in (lrt, - defineSpecOpenTerm (identOpenTerm $ permEnvSpecMEventType env) closs + defineSpecOpenTerm (permEnvEventTypeTerm env) closs lrt (cfgTransBody cfg_trans))) cfg_transs @@ -6358,7 +6186,7 @@ someCFGAndPermLRT env (SomeCFGAndPerm _ _ _ fun_perm) = permEnvSpecDefOpenTerm :: PermEnv -> OpenTerm -> OpenTerm permEnvSpecDefOpenTerm env lrt = applyGlobalOpenTerm "Prelude.SpecDef" - [identOpenTerm (permEnvSpecMEventType env), lrt] + [permEnvEventTypeTerm env, lrt] -- | 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, @@ -6456,3 +6284,4 @@ translateCompletePureFun sc env ctx ps_in p_out = mapM typeDescPureType (typeTransDescs ps_in_trans) <*> typeDescPureType (tupleOfTypeDescs $ typeTransDescs p_out_trans)) return $ piOpenTermMulti (map ("_",) tps_in) (const tp_out) +-} From 488adaa228d6d013f6768177fea59dcd9a7fba14 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 13 Oct 2023 15:38:39 -0700 Subject: [PATCH 114/305] Got the first portion of SAWTranslation.hs to compile with the new version of SpecM --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 90 ++++++++++++------- 1 file changed, 60 insertions(+), 30 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 55bac6c3c2..0d34975298 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -139,12 +139,12 @@ funIxTypeOpenTerm t = applyGlobalOpenTerm "Prelude.FunIx" [t] -- | Build the type @Sigma a (\ (x:a) -> b)@ from variable name @x@, type @a@, -- and type-level function @b@ -sigmaTypeOpenTerm :: String -> OpenTerm -> (OpenTerm -> OpenTerm) -> OpenTerm +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 :: String -> [OpenTerm] -> ([OpenTerm] -> OpenTerm) -> +sigmaTypeOpenTermMulti :: LocalName -> [OpenTerm] -> ([OpenTerm] -> OpenTerm) -> OpenTerm sigmaTypeOpenTermMulti _ [] f = f [] sigmaTypeOpenTermMulti x (tp:tps) f = @@ -153,14 +153,14 @@ sigmaTypeOpenTermMulti x (tp:tps) f = -- | Build the dependent pair @exists a (\ (x:a) -> b) x y@ whose type is given -- by 'sigmaTypeOpenTerm' -sigmaOpenTerm :: String -> OpenTerm -> (OpenTerm -> OpenTerm) -> +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 :: String -> [OpenTerm] -> ([OpenTerm] -> OpenTerm) -> +sigmaOpenTermMulti :: LocalName -> [OpenTerm] -> ([OpenTerm] -> OpenTerm) -> [OpenTerm] -> OpenTerm -> OpenTerm sigmaOpenTermMulti _ [] _ [] trm = trm sigmaOpenTermMulti x (tp:tps) tp_f (trm_l:trms_l) trm_r = @@ -171,11 +171,11 @@ sigmaOpenTermMulti _ _ _ _ _ = -- | Take a nested dependent pair (of the type returned by -- 'sigmaTypeOpenTermMulti') and apply a function @f@ to all of its projections -sigmaElimOpenTermMulti :: String -> [OpenTerm] -> ([OpenTerm] -> OpenTerm) -> +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 (\x -> sigmaTypeOpenTermMulti x tps (tp_f . (x:))) + 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:)) @@ -277,7 +277,7 @@ arrowTpDescMulti tps_in tp_out = foldr arrowTpDesc tp_out tps_in -- | Build the type description for a pi-abstraction over a kind description piTpDesc :: OpenTerm -> OpenTerm -> OpenTerm -piTpDesc kd tpd = ctorOpenTerm "Prelude.Tp_Pi" kd tpd +piTpDesc kd tpd = ctorOpenTerm "Prelude.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@ @@ -911,7 +911,7 @@ eithersElimTransM tps tp_ret fs eith = -- | Build the right-nested dependent pair type whose sequence of left-hand -- projections have the types of the supplied 'TypeTrans' and whose right-hand -- projection is the 'typeTransTupleType' of the supplied monadic function -sigmaTypeTransM :: String -> TypeTrans trL -> +sigmaTypeTransM :: LocalName -> TypeTrans trL -> (trL -> TransM info ctx (TypeTrans trR)) -> TransM info ctx OpenTerm sigmaTypeTransM x tptrans tp_f = @@ -921,7 +921,7 @@ sigmaTypeTransM x tptrans tp_f = -- | Like 'sigmaTypeTransM', but translates 'exists x.eq(y)' into the tuple of -- types of 'x', omitting the right-hand projection type -sigmaTypePermTransM :: TransInfo info => String -> +sigmaTypePermTransM :: TransInfo info => LocalName -> TypeTrans (ExprTrans trL) -> Mb (ctx :> trL) (ValuePerm trR) -> TransM info ctx OpenTerm @@ -936,7 +936,7 @@ sigmaTypePermTransM x ttrans mb_p = case mbMatch mb_p of -- 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) => - String -> TypeTrans trL -> + LocalName -> TypeTrans trL -> (trL -> TransM info ctx (TypeTrans trR1)) -> trL -> TransM info ctx trR2 -> TransM info ctx OpenTerm @@ -950,7 +950,7 @@ sigmaTransM x tp_l tp_r lhs rhs_m = -- | 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 @@ -961,7 +961,7 @@ sigmaPermTransM x ttrans mb_p etrans rhs_m = case mbMatch mb_p of -- | Eliminate a dependent pair of the type returned by 'sigmaTypeTransM' sigmaElimTransM :: (IsTermTrans trL, IsTermTrans trR) => - String -> TypeTrans trL -> + LocalName -> TypeTrans trL -> (trL -> TransM info ctx (TypeTrans trR)) -> TransM info ctx (TypeTrans trRet) -> (trL -> trR -> TransM info ctx OpenTerm) -> @@ -986,7 +986,7 @@ sigmaElimTransM x tp_l tp_r_mF _tp_ret_m f 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 -> @@ -1163,7 +1163,7 @@ translateType (StructRepr tps) = -- Default case is to panic for unsupported types translateType tp = - panic "translateType" ["Type not supported: " show tp] + panic "translateType" ["Type not supported: " ++ show tp] -- | Translate a 'CruCtx' to a 'TypeTrans' and to a list of kind descriptions @@ -1480,6 +1480,10 @@ instance TransInfo info => translate (mbMatch -> [nuMP| LLVMFieldShape p |]) = descTransM (translateDescs p) +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 @@ -1524,7 +1528,8 @@ translateBVFactorDesc mb_f = translateBVVarDesc w mb_x -- | Translate an expression of bitvector type to a type-level expression -translateBVDesc :: Mb ctx (PermExpr (BVType w)) -> DescTransM ctx OpenTerm +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 @@ -1550,14 +1555,18 @@ instance TranslateDescs (PermExpr (LLVMShapeType w)) where [nuMP| DefinedShapeBody _ |] -> translateDescs (mbMap2 unfoldNamedShape nmsh args) [nuMP| OpaqueShapeBody _ trans_id |] -> + {- (:[]) <$> applyGlobalOpenTerm (mbLift trans_id) <$> - transTerms <$> translate args + transTerms <$> translate args -} + error "FIXME HERE NOWNOW: translate opaque shapes to descs (how to handle args?)" [nuMP| RecShapeBody _ trans_id |] -> + {- (:[]) <$> applyGlobalOpenTerm (mbLift trans_id) <$> - transTerms <$> translate args + transTerms <$> translate args -} + error "FIXME HERE NOWNOW: translate rec shapes to descs (how to handle args?)" [nuMP| PExpr_EqShape _ _ |] -> return [] [nuMP| PExpr_PtrShape _ _ sh |] -> translateDescs sh - [nuMP| PExpr_FieldShape fsh |] -> translate fsh + [nuMP| PExpr_FieldShape fsh |] -> translateDescs fsh [nuMP| PExpr_ArrayShape mb_len _ mb_sh |] -> do let w = natVal4 mb_len let w_term = natOpenTerm w @@ -2820,6 +2829,11 @@ instance TransInfo info => fmap APTrans_BVProp <$> translate prop [nuMP| Perm_Any |] -> return $ mkTypeTrans0 APTrans_Any + +instance TranslateDescs (AtomicPerm a) where + translateDescs mb_p = error "FIXME HERE NOWNOW" + + -- | 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 @@ -2875,6 +2889,13 @@ instance TransInfo info => [nuMP| ValPerms_Cons ps p |] -> 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 @@ -2895,6 +2916,14 @@ instance TransInfo info => error ("Translating expression permissions that could not be converted " ++ "to variable permissions:" ++ permPrettyString emptyPPInfo mb_ps) +instance TranslateDescs (ExprPerms ps) where + translateDescs mb_eps + | Just mb_ps <- mbExprPermsToValuePerms mb_eps = translateDescs mb_ps + translateDescs mb_ps = + error ("Translating expression permissions that could not be converted " ++ + "to variable permissions:" ++ permPrettyString emptyPPInfo mb_ps) + + -- Translate a FunPerm to a pi-abstraction (FIXME HERE NOW: document translation) instance TransInfo info => Translate info ctx (FunPerm ghosts args gouts ret) OpenTerm where @@ -2916,18 +2945,19 @@ instance TransInfo info => instance TranslateDescs (FunPerm ghosts args gouts ret) where translateDescs (mbMatch -> [nuMP| FunPerm ghosts args gouts ret perms_in perms_out |]) = - do let tops = appendCruCtx (mbLift ghosts) (mbLift args) - tops_prxs = cruCtxProxies tops - rets = CruCtxCons (mbLift gouts) (mbLift ret) - rets_prxs = cruCtxProxies rets - ds_in <- translateDescs perms_in - ctx <- dtiProxies <$> ask - case RL.appendAssoc ctx tops_prxs rets_prxs of - Refl -> - inExtCtxDescTransM tops $ \kdescs -> - (\d -> [d]) <$> piTpDescMulti kdescs <$> - translateRetTpDesc rets (mbCombine - (RL.append tops_prxs rets_prxs) 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) + arrowTpDescMulti 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) -> From 556f95db8b69da2a7f15eca911d9aecbe1a3e413 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 16 Oct 2023 17:05:31 -0700 Subject: [PATCH 115/305] updated the translation of the implication rules to work with the new SpecM monad --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 371 ++++++++++-------- 1 file changed, 203 insertions(+), 168 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 0d34975298..1cf6714bdf 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -298,12 +298,23 @@ tpElemTypeOpenTerm d = -- FIXME HERE NOWNOW: this should normalize the returned term applyGlobalOpenTerm "Prelude.tpElem" [d] +-- | Build a @SpecM@ computation that returns a value +retSOpenTerm :: EventType -> OpenTerm -> OpenTerm -> OpenTerm +retSOpenTerm ev tp x = + applyGlobalOpenTerm "Prelude.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 "Prelude.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 "Prelude.errorS" + [evTypeTerm ev, ret_tp, stringLitOpenTerm (pack msg)] + -- | Build a @SpecM@ computation that calls a function index callSOpenTerm :: EventType -> OpenTerm -> OpenTerm -> [OpenTerm] -> OpenTerm callSOpenTerm ev d ix args = @@ -612,10 +623,8 @@ ctxExtToExprExt ((CtxExt ctx3) :: CtxExt ctx1 ctx2) ectx = ExprCtxExt $ snd $ RL.split (Proxy :: Proxy ctx1) ctx3 ectx --- FIXME: ExprCtxExt should no longer be needed... - --- | An extension of type context @ctx1@ to @ctx2@, which is --- just an 'ExprTransCtx' for the suffix @ctx3@ such that @ctx1:++:ctx3 = ctx2@ +-- | 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) @@ -636,8 +645,8 @@ 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 :: CtxExt ctx1 ctx2 -> Mb ctx1 a -> Mb ctx2 a -extMbExt (CtxExt ctx2) = extMbAny ctx2 +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 @@ -1988,23 +1997,24 @@ permTransPermEq ptrans mb_p = permTransPerm (mbToProxy mb_p) ptrans == mb_p -- | Extend the context of a 'PermTrans' with a single type -extPermTrans :: ExtPermTrans f => prx tp -> f ctx a -> f (ctx :> tp) a +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 :: CtxExt ctx1 ctx2 -> PermTrans ctx1 a -> - PermTrans ctx2 a -extPermTransExt (CtxExt ctx) ptrans = extPermTransMulti ctx ptrans +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 :: CtxExt ctx1 ctx2 -> PermTransCtx ctx1 ps -> - PermTransCtx ctx2 ps +extPermTransCtxExt :: ExprCtxExt ctx1 ctx2 -> + PermTransCtx ctx1 ps -> PermTransCtx ctx2 ps extPermTransCtxExt cext = RL.map (extPermTransExt cext) -- | Generic function to extend the context of the translation of a permission class ExtPermTrans f where - extPermTransMulti :: RAssign prx ctx2 -> f ctx1 a -> f (ctx1 :++: ctx2) a + extPermTransMulti :: ExprTransCtx ctx2 -> f ctx1 a -> f (ctx1 :++: ctx2) a instance ExtPermTrans PermTrans where extPermTransMulti ectx (PTrans_Eq e) = @@ -2074,12 +2084,12 @@ instance ExtPermTrans BVRangeTrans where BVRangeTrans (extMbAny ectx rng) t1 t2 -- | Extend the context of a permission translation context -extPermTransCtx :: prx tp -> PermTransCtx ctx ps -> +extPermTransCtx :: ExprTrans tp -> PermTransCtx ctx ps -> PermTransCtx (ctx :> tp) ps extPermTransCtx e = RL.map (extPermTrans e) -- | Extend the context of a permission translation context -extPermTransCtxMulti :: RAssign prx ctx2 -> PermTransCtx ctx1 ps -> +extPermTransCtxMulti :: ExprTransCtx ctx2 -> PermTransCtx ctx1 ps -> PermTransCtx (ctx1 :++: ctx2) ps extPermTransCtxMulti ectx2 = RL.map (extPermTransMulti ectx2) @@ -2301,7 +2311,8 @@ setLLVMArrayTransSlice arr_trans sub_arr_trans off_tm = -- information (the @SpecM@ event type and the eventual return type of the -- overall computation) required to apply @bindS@ data LOwnedInfo ps ctx = - LOwnedInfo { lownedInfoPCtx :: PermTransCtx ctx ps, + LOwnedInfo { lownedInfoECtx :: ExprTransCtx ctx, + lownedInfoPCtx :: PermTransCtx ctx ps, lownedInfoPVars :: RAssign (Member ctx) ps, lownedInfoEvType :: EventType, lownedInfoRetType :: OpenTerm } @@ -2309,7 +2320,8 @@ data LOwnedInfo ps ctx = -- | Convert an 'ImpTransInfo' to an 'LOwnedInfo' impInfoToLOwned :: ImpTransInfo ext blocks tops rets ps ctx -> LOwnedInfo ps ctx impInfoToLOwned (ImpTransInfo {..}) = - LOwnedInfo { lownedInfoPCtx = itiPermStack, + LOwnedInfo { lownedInfoECtx = itiExprCtx, + lownedInfoPCtx = itiPermStack, lownedInfoPVars = itiPermStackVars, lownedInfoEvType = permEnvEventType itiPermEnv, lownedInfoRetType = itiReturnType } @@ -2317,12 +2329,12 @@ impInfoToLOwned (ImpTransInfo {..}) = -- | 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' -> ImpTransInfo ext blocks tops rets ps ctx lownedInfoToImp (LOwnedInfo {..}) (ImpTransInfo {..}) = - ImpTransInfo { itiPermStack = lownedInfoPCtx, + ImpTransInfo { itiExprCtx = lownedInfoECtx, itiPermStack = lownedInfoPCtx, itiPermStackVars = lownedInfoPVars, - itiPermCtx = RL.map (const PTrans_True) itiPermCtx, + itiPermCtx = RL.map (const PTrans_True) lownedInfoECtx, itiReturnType = lownedInfoRetType, .. } loInfoSetPerms :: PermTransCtx ctx ps' -> RAssign (Member ctx) ps' -> @@ -2343,17 +2355,19 @@ loInfoSplit (_ :: prx ps1) prx2 (LOwnedInfo {..}) = loInfoAppend :: LOwnedInfo ps1 ctx -> LOwnedInfo ps2 ctx -> LOwnedInfo (ps1 :++: ps2) ctx loInfoAppend info1 info2 = - LOwnedInfo { lownedInfoPCtx = + 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 :: CtxExt ctx1 ctx2 -> LOwnedInfo ps ctx1 -> +extLOwnedInfoExt :: ExprCtxExt ctx1 ctx2 -> LOwnedInfo ps ctx1 -> LOwnedInfo ps ctx2 -extLOwnedInfoExt cext@(CtxExt ectx3) (LOwnedInfo {..}) = - LOwnedInfo { lownedInfoPCtx = extPermTransCtxExt cext lownedInfoPCtx, +extLOwnedInfoExt cext@(ExprCtxExt ectx3) (LOwnedInfo {..}) = + LOwnedInfo { lownedInfoECtx = RL.append lownedInfoECtx ectx3, + lownedInfoPCtx = extPermTransCtxExt cext lownedInfoPCtx, lownedInfoPVars = RL.map (weakenMemberR ectx3) lownedInfoPVars, .. } @@ -2372,8 +2386,8 @@ extLOwnedInfoExt cext@(CtxExt ectx3) (LOwnedInfo {..}) = newtype LOwnedTransM ps_in ps_out ctx a = LOwnedTransM { runLOwnedTransM :: - forall ctx_in. CtxExt ctx ctx_in -> LOwnedInfo ps_in ctx_in -> - (forall ctx_out. CtxExt ctx_in ctx_out -> LOwnedInfo ps_out ctx_out -> + 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 } @@ -2382,8 +2396,8 @@ newtype LOwnedTransM ps_in ps_out ctx a = LOwnedTransM ps_in ps_out ctx b m >>>= f = LOwnedTransM $ \cext s1 k -> runLOwnedTransM m cext s1 $ \cext' s2 x -> - runLOwnedTransM (f x) (transCtxExt cext cext') s2 $ \cext'' -> - k (transCtxExt cext' cext'') + 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 -> @@ -2394,7 +2408,7 @@ 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 reflCtxExt s x + pure x = LOwnedTransM $ \_ s k -> k reflExprCtxExt s x (<*>) = Monad.ap instance Monad (LOwnedTransM ps ps ctx) where @@ -2403,7 +2417,8 @@ 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 reflCtxExt (extLOwnedInfoExt cext loInfo) () + LOwnedTransM $ \cext _ k -> + k reflExprCtxExt (extLOwnedInfoExt cext loInfo) () {- data ExtLOwnedInfo ps ctx where @@ -2418,26 +2433,26 @@ instance ps_in ~ ps_out => -- | Get the current permission stack, with the additional complexity that it -- could be in an extended expression context @ctx'@ -ggetting :: (forall ctx'. CtxExt ctx 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) reflCtxExt s $ \cext' -> + runLOwnedTransM (f cext s) reflExprCtxExt s $ \cext' -> k cext' -- | Modify the current permission stack relative to its extended expression -- context @ctx'@ -gmodify :: (forall ctx'. CtxExt ctx 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 :: CtxExt ctx ctx' -> LOwnedTransM ps_in ps_out ctx a -> +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 (transCtxExt cext cext') + 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@ @@ -2451,7 +2466,7 @@ mkLOwnedTransTermFromTerm :: DescPermsTpTrans ctx ps_in -> RAssign (Member ctx) ps_out -> OpenTerm -> LOwnedTransTerm ctx ps_in ps_out mkLOwnedTransTermFromTerm trans_in trans_out vars_out t = - LOwnedTransM $ \(CtxExt ctx') loInfo k -> + LOwnedTransM $ \(ExprCtxExt ctx') loInfo k -> let ev = lownedInfoEvType loInfo d = arrowDescTrans trans_in trans_out t_app = callSOpenTerm ev d t (transTerms $ lownedInfoPCtx loInfo) @@ -2462,29 +2477,31 @@ mkLOwnedTransTermFromTerm trans_in trans_out vars_out t = let pctx_out' = extPermTransCtxMulti ctx' $ typeTransF t_ret_trans [lowned_ret] vars_out' = RL.map (weakenMemberR ctx') vars_out in - k reflCtxExt (loInfoSetPerms pctx_out' vars_out' loInfo) () + 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 -> RAssign (Member ctx) ps_in -> +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 vars_in tps_in tps_out t = +lownedTransTermFun ev ectx vars_in tps_in tps_out t = lambdaTrans "p" (descTypeTrans tps_in) $ \ps_in -> let ret_tp = typeTransTupleType $ descTypeTrans tps_out in let loInfo = - LOwnedInfo { lownedInfoPCtx = ps_in, lownedInfoPVars = vars_in, + LOwnedInfo { lownedInfoECtx = ectx, + lownedInfoPCtx = ps_in, lownedInfoPVars = vars_in, lownedInfoEvType = ev, lownedInfoRetType = ret_tp } in - runLOwnedTransM t reflCtxExt loInfo $ \_ loInfo_out () -> + runLOwnedTransM t reflExprCtxExt loInfo $ \_ loInfo_out () -> transTupleTerm (lownedInfoPCtx loInfo_out) -- | Extend the expression context of an 'LOwnedTransTerm' -extLOwnedTransTerm :: RAssign prx ctx2 -> +extLOwnedTransTerm :: ExprTransCtx ctx2 -> LOwnedTransTerm ctx1 ps_in ps_out -> LOwnedTransTerm (ctx1 :++: ctx2) ps_in ps_out -extLOwnedTransTerm ectx2 = extLOwnedTransM (mkCtxExt ectx2) +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 @@ -2494,7 +2511,7 @@ idLOwnedTransTerm :: DescPermsTpTrans ctx ps_out -> RAssign (Member ctx) ps_out -> LOwnedTransTerm ctx ps_in ps_out idLOwnedTransTerm dtr_out vars_out = - gmodify $ \(CtxExt ctx') loInfo -> + gmodify $ \(ExprCtxExt ctx') loInfo -> loInfo { lownedInfoPVars = RL.map (weakenMemberR ctx') vars_out, lownedInfoPCtx = descTypeTransF (fmap (extPermTransCtxMulti ctx') dtr_out) @@ -2535,6 +2552,7 @@ mapLtLOwnedTransTerm prx_extra1 prx_extra2 prx_in t1 t2 = 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, @@ -2543,30 +2561,30 @@ data LOwnedTrans ctx ps_extra ps_in ps_out = lotrTerm :: LOwnedTransTerm ctx (ps_extra :++: ps_in) ps_out } -- | Build an initial 'LOwnedTrans' with an empty @ps_extra@ -mkLOwnedTrans :: EventType -> DescPermsTpTrans ctx ps_in -> +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 tps_in tps_out vars_out t = - LOwnedTrans ev MNil MNil tps_in tps_out (pure MNil) +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 -> DescPermsTpTrans ctx ps -> +mkLOwnedTransId :: EventType -> ExprTransCtx ctx -> DescPermsTpTrans ctx ps -> DescPermsTpTrans ctx ps -> RAssign (Member ctx) ps -> LOwnedTrans ctx RNil ps ps -mkLOwnedTransId ev tps_in tps_out vars_out = - LOwnedTrans ev MNil MNil tps_in tps_out (pure MNil) +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 :: RAssign any ctx2 -> +extLOwnedTransMulti :: ExprTransCtx ctx2 -> LOwnedTrans ctx1 ps_extra ps_in ps_out -> LOwnedTrans (ctx1 :++: ctx2) ps_extra ps_in ps_out -extLOwnedTransMulti ctx2 (LOwnedTrans ev ps_extra vars_extra ptrans_in +extLOwnedTransMulti ctx2 (LOwnedTrans ev ectx ps_extra vars_extra ptrans_in ptrans_out ptrans_extra t) = LOwnedTrans - ev (extPermTransCtxMulti ctx2 ps_extra) + 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) @@ -2602,8 +2620,8 @@ lownedTransTerm (mbExprPermsMembers -> Just vars_in) lotr = d = arrowDescTrans tps_extra_in (lotrTpTransOut lotr) in applyGlobalOpenTerm "Prelude.LambdaS" [evTypeTerm (lotrEvType lotr), d, - lownedTransTermFun (lotrEvType lotr) vars_extra_in tps_extra_in - (lotrTpTransOut lotr) (lotrTerm lotr)] + lownedTransTermFun (lotrEvType lotr) (lotrECtx lotr) + vars_extra_in tps_extra_in (lotrTpTransOut lotr) (lotrTerm lotr)] lownedTransTerm _ _ = failOpenTerm "FIXME HERE NOW: write this error message" @@ -2803,12 +2821,13 @@ instance TransInfo info => case mbExprPermsMembers ps_out of Just vars_out -> do ev <- infoEvType <$> ask + ectx <- infoCtx <$> ask dtr_in <- tpTransM $ translateDescType ps_in dtr_out <- tpTransM $ translateDescType ps_out let d = arrowDescTrans dtr_in dtr_out return $ mkTypeTrans1 (funIxTypeOpenTerm d) $ \t -> (APTrans_LOwned ls (mbLift tps_in) (mbLift tps_out) ps_in ps_out $ - mkLOwnedTrans ev dtr_in dtr_out vars_out t) + mkLOwnedTrans ev ectx dtr_in dtr_out vars_out t) Nothing -> error "FIXME HERE NOWNOW: handle this error!" [nuMP| Perm_LOwnedSimple tps lops |] -> @@ -2902,6 +2921,10 @@ instance TransInfo info => (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 @@ -3312,18 +3335,13 @@ mkErrorComp :: String -> ImpTransM ext blocks tops rets ps_out ctx OpenTerm mkErrorComp msg = do ev <- infoEvType <$> ask ret_tp <- returnTypeM - return $ applyGlobalOpenTerm "Prelude.errorS" - [evTypeTerm ev, ret_tp, stringLitOpenTerm (pack msg)] + 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 -{- -FIXME HERE NOWNOW: check block rules to make sure they respect the new -translation of blocks to a list of terms - ---------------------------------------------------------------------- -- * Translating Permission Implication Constructs @@ -3334,26 +3352,27 @@ translation of blocks to a list of terms -- a catch) or an error message (meaning there is not) data ImplFailCont -- | A continuation that calls a term on failure - = ImplFailContTerm SpecTerm - -- | An error message to print on failure - | ImplFailContMsg String + = ImplFailContTerm OpenTerm + -- | An error message to print on failure, along with the event type needed + -- to build an @errorS@ spec term + | ImplFailContMsg EventType String -- | Convert an 'ImplFailCont' to an error, which should have the given type -implFailContTerm :: SpecTerm -> ImplFailCont -> SpecTerm +implFailContTerm :: OpenTerm -> ImplFailCont -> OpenTerm implFailContTerm _ (ImplFailContTerm t) = t -implFailContTerm tp (ImplFailContMsg msg) = errorSpecTerm tp (pack msg) +implFailContTerm tp (ImplFailContMsg ev msg) = errorSOpenTerm ev tp msg -- | Convert an 'ImplFailCont' to an error as in 'implFailContTerm', but use an -- alternate error message in the case of 'ImplFailContMsg' -implFailAltContTerm :: SpecTerm -> String -> ImplFailCont -> SpecTerm +implFailAltContTerm :: OpenTerm -> String -> ImplFailCont -> OpenTerm implFailAltContTerm _ _ (ImplFailContTerm t) = t -implFailAltContTerm tp msg (ImplFailContMsg _) = errorSpecTerm tp (pack msg) +implFailAltContTerm tp msg (ImplFailContMsg ev _) = errorSOpenTerm ev tp 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 SpecTerm } + ImplFailCont -> ImpTransM ext blocks tops rets ps ctx OpenTerm } deriving OpenTermLike -- | Build a 'PImplTerm' from the first 'PImplTerm' that uses the second as the @@ -3378,7 +3397,7 @@ failPImplTermAlt :: String -> PImplTerm ext blocks tops rets ps ctx failPImplTermAlt msg = PImplTerm $ \k -> compReturnTypeM >>= \tp -> return (implFailContTerm tp (case k of - ImplFailContMsg _ -> ImplFailContMsg msg + ImplFailContMsg ev _ -> ImplFailContMsg ev msg _ -> k)) -- | "Force" an optional 'PImplTerm' to a 'PImplTerm' by converting a 'Nothing' @@ -3404,7 +3423,7 @@ instance Monoid HasFailures where 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' SpecTerm } + ImpTransM ext blocks tops rets ps ctx' OpenTerm } extImpRTransFun :: RAssign Proxy ctx' -> ImpRTransFun r ext blocks tops rets ctx -> @@ -3558,8 +3577,8 @@ translateSimplImplOutTailHead = -- | Translate a 'SimplImpl' to a function on translation computations translateSimplImpl :: Proxy ps -> Mb ctx (SimplImpl ps_in ps_out) -> - ImpTransM ext blocks tops rets (ps :++: ps_out) ctx SpecTerm -> - ImpTransM ext blocks tops rets (ps :++: ps_in) ctx SpecTerm + ImpTransM ext blocks tops rets (ps :++: ps_out) ctx OpenTerm -> + ImpTransM ext blocks tops rets (ps :++: ps_in) ctx OpenTerm translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of [nuMP| SImpl_Drop _ _ |] -> withPermStackM (\(xs :>: _) -> xs) (\(ps :>: _) -> ps) m @@ -3772,7 +3791,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of do tptrans <- translateSimplImplOutHead mb_simpl withPermStackM id (\(pctx :>: _) -> - pctx :>: typeTransF tptrans [globalTermLike $ mbLift ident]) + pctx :>: typeTransF tptrans [globalOpenTerm $ mbLift ident]) m [nuMP| SImpl_CastLLVMWord _ _ _ |] -> @@ -3948,7 +3967,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 <- @@ -3959,9 +3979,8 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of fmap distPermsHeadPerm $ mbSimplImplOut mb_simpl (_ :>: ptrans1 :>: ptrans2) <- itiPermStack <$> ask let arr_out_comp_tm = - applyTermLikeMulti (monadicSpecOp "Prelude.appendCastBVVecS") - [openTermLike w_term, openTermLike len1_tm, - openTermLike len2_tm, len3_tm, elem_tp, + applyGlobalOpenTerm "Prelude.appendCastBVVecS" + [evTypeTerm ev, 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' -> withPermStackM RL.tail (\(pctx :>: _ :>: _) -> @@ -3983,16 +4002,16 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of [nuMP| SImpl_LLVMArrayEmpty x mb_ap |] -> do (w_tm, _, elem_tp, ap_tp_trans) <- translateLLVMArrayPerm mb_ap -- First we build a term of type Vec 0 elem_tp using EmptyVec - let vec_tm = applyGlobalTermLike "Prelude.EmptyVec" [elem_tp] + let vec_tm = applyGlobalOpenTerm "Prelude.EmptyVec" [elem_tp] -- Next, we build a computation that casts it to BVVec w 0x0 elem_tp let w = fromIntegral $ natVal2 mb_ap let bvZero_nat_tm = - openTermLike $ applyGlobalOpenTerm "Prelude.bvToNat" [w_tm, bvLitOpenTerm (replicate w False)] + ev <- infoEvType <$> ask let vec_cast_m = - applyTermLikeMulti (monadicSpecOp "Prelude.castVecS") - [elem_tp, natTermLike 0, bvZero_nat_tm, vec_tm] + applyGlobalOpenTerm "Prelude.castVecS" + [evTypeTerm ev, elem_tp, natOpenTerm 0, bvZero_nat_tm, vec_tm] bindSpecMTransM vec_cast_m ap_tp_trans "empty_vec" $ \ptrans_arr -> withPermStackM (:>: translateVar x) (\pctx -> pctx :>: PTrans_Conj [APTrans_LLVMArray ptrans_arr]) @@ -4004,9 +4023,8 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of withPermStackM (:>: translateVar x) (\(pctx :>: ptrans_block) -> let arr_term = - applyGlobalTermLike "Prelude.repeatBVVec" - [openTermLike w_tm, openTermLike len_tm, - elem_tp, transTerm1 ptrans_block] in + applyGlobalOpenTerm "Prelude.repeatBVVec" + [w_tm, len_tm, elem_tp, transTerm1 ptrans_block] in pctx :>: PTrans_Conj [APTrans_LLVMArray $ typeTransF ap_tp_trans [arr_term]] :>: ptrans_block) @@ -4029,9 +4047,8 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of applyOpenTermMulti (globalOpenTerm "Prelude.singletonBVVec") [w_tm, elem_tp, transTerm1 ptrans_cell] -} - applyGlobalTermLike "Prelude.repeatBVVec" - [openTermLike w_tm, openTermLike len_tm, - elem_tp, transTerm1 ptrans_cell] in + applyGlobalOpenTerm "Prelude.repeatBVVec" + [w_tm, len_tm, elem_tp, transTerm1 ptrans_cell] in pctx :>: PTrans_Conj [APTrans_LLVMArray $ typeTransF ap_tp_trans [arr_term]]) m @@ -4121,11 +4138,11 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of -- Build the computation that maps impl_tm over the input array using the -- mapBVVecM monadic combinator ptrans_arr <- getTopPermM + ev <- infoEvType <$> ask let arr_out_comp_tm = - applyTermLikeMulti (monadicSpecOp "Prelude.mapBVVecS") - [elem_tp, typeTransType1 cell_out_trans, impl_tm, - openTermLike w_term, openTermLike len_term, - transTerm1 ptrans_arr] + applyGlobalOpenTerm "Prelude.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' -> @@ -4260,7 +4277,9 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of m [nuMP| SImpl_EndLifetime _ tps_in tps_out ps_in ps_out |] -> + error "FIXME HERE NOWNOW" -- First, translate the in and out permissions of the lowned permission + {- do ps_in_trans <- translate ps_in ps_out_trans <- tupleTypeTrans <$> translate ps_out let prxs_in = mbRAssignProxies ps_in :>: Proxy @@ -4295,7 +4314,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of (\(_ :>: 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 @@ -4310,6 +4329,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of 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 @@ -4317,7 +4337,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of pctx :>: PTrans_LOwned (fmap (const []) mb_l) (mbLift mb_tps) (mbLift mb_tps) mb_ps' mb_ps - (mkLOwnedTransId ev dtr_in dtr_out vars)) + (mkLOwnedTransId ev ectx dtr_in dtr_out vars)) m _ -> panic "translateSimplImpl" @@ -4341,25 +4361,25 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of [nuMP| SImpl_IntroLLVMBlockEmpty x _ |] -> do ttrans <- translateSimplImplOutHead mb_simpl withPermStackM (:>: translateVar x) - (\pctx -> pctx :>: typeTransF ttrans [unitTermLike]) + (\pctx -> pctx :>: typeTransF ttrans []) m [nuMP| SImpl_CoerceLLVMBlockEmpty _ _ |] -> do ttrans <- translateSimplImplOutHead mb_simpl withPermStackM id - (\(pctx :>: _) -> pctx :>: typeTransF ttrans [unitTermLike]) + (\(pctx :>: _) -> pctx :>: typeTransF ttrans []) m [nuMP| SImpl_ElimLLVMBlockToBytes _ mb_bp |] -> do let w = natVal2 mb_bp - let w_term = natTermLike w + let w_term = natOpenTerm w len_term <- translate1 $ fmap llvmBlockLen mb_bp ttrans <- translateSimplImplOutHead mb_simpl withPermStackM id (\(pctx :>: _) -> let arr_term = - applyGlobalTermLike "Prelude.repeatBVVec" - [w_term, len_term, unitTypeTermLike, unitTermLike] in + applyGlobalOpenTerm "Prelude.repeatBVVec" + [w_term, len_term, unitTypeOpenTerm, unitOpenTerm] in pctx :>: typeTransF ttrans [arr_term]) m @@ -4367,30 +4387,29 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of do ttrans <- translateSimplImplOutHead mb_simpl withPermStackM id (\(pctx :>: ptrans) -> - pctx :>: typeTransF ttrans [pairTermLike (transTerm1 ptrans) - unitTermLike]) + pctx :>: typeTransF ttrans (transTerms ptrans)) m [nuMP| SImpl_ElimLLVMBlockSeqEmpty _ _ |] -> do ttrans <- translateSimplImplOutHead mb_simpl withPermStackM id (\(pctx :>: ptrans) -> - pctx :>: typeTransF ttrans [pairLeftTermLike (transTerm1 ptrans)]) + pctx :>: typeTransF ttrans (transTerms ptrans)) m [nuMP| SImpl_SplitLLVMBlockEmpty _ _ _ |] -> do ttrans <- translateSimplImplOutHead mb_simpl withPermStackM id - (\(pctx :>: _) -> - pctx :>: typeTransF ttrans [unitTermLike, unitTermLike]) + (\(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 [nuMP| SImpl_IntroLLVMBlockNamed _ bp nmsh |] - | [nuMP| RecShapeBody _ _ fold_ids |] <- mbMatch $ fmap namedShapeBody nmsh + | [nuMP| RecShapeBody _ _ |] <- mbMatch $ fmap namedShapeBody nmsh , [nuMP| PExpr_NamedShape _ _ _ args |] <- mbMatch $ fmap llvmBlockShape bp -> + {- do ttrans <- translateSimplImplOutHead mb_simpl args_trans <- translate args let args_tms = case exprCtxPureTypeTerms args_trans of @@ -4405,24 +4424,28 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of (\(pctx :>: ptrans_x) -> pctx :>: typeTransF ttrans [applyGlobalTermLike (mbLift fold_id) (args_tms ++ transTerms ptrans_x)]) - m + m -} + error "FIXME HERE NOWNOW: how to translate recursive named permissions" -- 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]) + pctx :>: typeTransF ttrans (transTerms ptrans)) m - | otherwise -> fail "translateSimplImpl: SImpl_IntroLLVMBlockNamed, unknown named shape" + | otherwise -> + panic "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 [nuMP| SImpl_ElimLLVMBlockNamed _ bp nmsh |] - | [nuMP| RecShapeBody _ _ fold_ids |] <- mbMatch $ fmap namedShapeBody nmsh + | [nuMP| RecShapeBody _ sh_id |] <- mbMatch $ fmap namedShapeBody nmsh , [nuMP| PExpr_NamedShape _ _ _ args |] <- mbMatch $ fmap llvmBlockShape bp -> + {- do ttrans <- translateSimplImplOutHead mb_simpl args_trans <- translate args let args_tms = case exprCtxPureTypeTerms args_trans of @@ -4437,7 +4460,8 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of (\(pctx :>: ptrans_x) -> pctx :>: typeTransF ttrans [applyGlobalTermLike (mbLift unfold_id) (args_tms ++ transTerms ptrans_x)]) - m + m -} + error "FIXME HERE NOWNOW: how to translate recursive named permissions" -- Intro for a defined named shape (the other case) is a no-op | [nuMP| DefinedShapeBody _ |] <- mbMatch $ fmap namedShapeBody nmsh -> @@ -4447,7 +4471,8 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of pctx :>: typeTransF ttrans [transTerm1 ptrans]) m - | otherwise -> fail "translateSimplImpl: ElimLLVMBlockNamed, unknown named shape" + | otherwise -> + panic "translateSimplImpl" ["ElimLLVMBlockNamed, unknown named shape"] [nuMP| SImpl_IntroLLVMBlockNamedMods _ _ |] -> do ttrans <- translateSimplImplOutHead mb_simpl @@ -4467,7 +4492,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of do ttrans <- translateSimplImplOutHead mb_simpl withPermStackM RL.tail (\(pctx :>: _ :>: ptrans) -> - pctx :>: typeTransF ttrans [transTerm1 ptrans]) + pctx :>: typeTransF ttrans (transTerms ptrans)) m [nuMP| SImpl_IntroLLVMBlockPtr _ _ |] -> @@ -4488,7 +4513,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of do ttrans <- translateSimplImplOutHead mb_simpl withPermStackM id (\(pctx :>: ptrans) -> - pctx :>: typeTransF ttrans [transTupleTerm ptrans]) + pctx :>: typeTransF ttrans (transTerms ptrans)) m [nuMP| SImpl_ElimLLVMBlockField _ _ |] -> @@ -4516,17 +4541,15 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of do ttrans <- translateSimplImplOutHead mb_simpl withPermStackM RL.tail (\(pctx :>: ptrans1 :>: ptrans2) -> - let pair_term = - pairTermLike (transTerm1 ptrans1) (transTerm1 ptrans2) in - pctx :>: typeTransF ttrans [pair_term]) + pctx :>: typeTransF ttrans (transTerms ptrans1 + ++ transTerms ptrans2)) m [nuMP| SImpl_ElimLLVMBlockSeq _ _ _ |] -> do ttrans <- translateSimplImplOutHead mb_simpl withPermStackM id (\(pctx :>: ptrans) -> - pctx :>: typeTransF ttrans [pairLeftTermLike (transTerm1 ptrans), - pairRightTermLike (transTerm1 ptrans)]) + pctx :>: typeTransF ttrans (transTerms ptrans)) m [nuMP| SImpl_IntroLLVMBlockOr _ _ _ |] -> @@ -4560,6 +4583,8 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of m [nuMP| SImpl_FoldNamed _ (NamedPerm_Rec rp) args _ |] -> + error "FIXME HERE NOWNOW: how to handle recursive perms" + {- do args_trans <- translate args let args_tms = case exprCtxPureTypeTerms args_trans of Just tms -> map openTermLike tms @@ -4571,9 +4596,11 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of (\(pctx :>: ptrans_x) -> pctx :>: typeTransF ttrans [applyGlobalTermLike fold_ident (args_tms ++ transTerms ptrans_x)]) - m + m -} [nuMP| SImpl_UnfoldNamed _ (NamedPerm_Rec rp) args _ |] -> + error "FIXME HERE NOWNOW: how to handle recursive perms" + {- do args_trans <- translate args let args_tms = case exprCtxPureTypeTerms args_trans of Just tms -> map openTermLike tms @@ -4586,21 +4613,25 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of pctx :>: typeTransF ttrans [applyGlobalTermLike unfold_ident (args_tms ++ [transTerm1 ptrans_x])]) - m + m -} [nuMP| SImpl_FoldNamed _ (NamedPerm_Defined _) _ _ |] -> + error "FIXME HERE NOWNOW: how to handle recursive perms" + {- do ttrans <- translateSimplImplOutHead mb_simpl withPermStackM id (\(pctx :>: ptrans) -> pctx :>: typeTransF ttrans (transTerms ptrans)) - m + m -} [nuMP| SImpl_UnfoldNamed _ (NamedPerm_Defined _) _ _ |] -> + error "FIXME HERE NOWNOW: how to handle recursive perms" + {- do ttrans <- translateSimplImplOutHead mb_simpl withPermStackM id (\(pctx :>: ptrans) -> pctx :>: typeTransF ttrans (transTerms ptrans)) - m + m -} {- [nuMP| SImpl_Mu _ _ _ _ |] -> @@ -4652,7 +4683,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of withPermStackM RL.tail (\(pctx :>: ptrans_x :>: ptrans_y) -> pctx :>: - typeTransF (tupleTypeTrans ttrans) [applyGlobalTermLike trans_ident + typeTransF (tupleTypeTrans ttrans) [applyGlobalOpenTerm trans_ident (transTerms args_trans ++ transTerms e_trans ++ transTerms y_trans @@ -4692,8 +4723,8 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of translatePermImplUnary :: NuMatchingAny1 r => RL.TypeCtx bs => Mb ctx (MbPermImpls r (RNil :> '(bs,ps_out))) -> - (ImpTransM ext blocks tops rets ps_out (ctx :++: bs) SpecTerm -> - ImpTransM ext blocks tops rets ps ctx SpecTerm) -> + (ImpTransM ext blocks tops rets ps_out (ctx :++: bs) OpenTerm -> + ImpTransM ext blocks tops rets ps ctx OpenTerm) -> PImplTransMTerm r ext blocks tops rets ps ctx translatePermImplUnary (mbMatch -> [nuMP| MbPermImpls_Cons _ _ mb_impl |]) f = let bs = RL.typeCtxProxies in @@ -4783,7 +4814,7 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o do mb_false <- nuMultiTransM $ const ValPerm_False () <- assertTopPermM "Impl1_ElimFalse" mb_x mb_false top_ptrans <- getTopPermM - applyGlobalImpTransM "Prelude.efq" + applyGlobalTransM "Prelude.efq" [compReturnTypeM, return $ transTerm1 top_ptrans] -- A SimplImpl is translated using translateSimplImpl @@ -4860,8 +4891,8 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o tp_trans2 <- translate mb_p_out2 withPermStackM (:>: Member_Base) (\(pctx :>: ptrans) -> - pctx :>: typeTransF tp_trans1 [unitTermLike] :>: - typeTransF tp_trans2 [transTerm1 ptrans]) + pctx :>: typeTransF tp_trans1 [] :>: + typeTransF tp_trans2 (transTerms ptrans)) m ([nuMP| Impl1_SplitLLVMWordField _ mb_fp mb_sz1 mb_endianness |], _) -> @@ -4946,6 +4977,7 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o translatePermImplUnary mb_impls $ \m -> inExtTransM ETrans_Lifetime $ do ev <- infoEvType <$> ask + ectx <- infoCtx <$> ask let prxs = RL.map (const Proxy) ectx let mb_ps = (nuMulti prxs (const MNil)) let ttr = pure MNil @@ -4953,7 +4985,7 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o (:>: PTrans_LOwned (nuMulti prxs (const [])) CruCtxNil CruCtxNil mb_ps mb_ps - (mkLOwnedTransId ev ttr ttr MNil)) + (mkLOwnedTransId ev ectx ttr ttr MNil)) m -- If e1 and e2 are already equal, short-circuit the proof construction and then @@ -4963,7 +4995,7 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o translatePermImplUnary mb_impls $ \m -> do bv_tp <- typeTransType1 <$> translateClosed (mbExprType e1) e1_trans <- translate1 e1 - let pf = ctorTermLike "Prelude.Refl" [bv_tp, e1_trans] + let pf = ctorOpenTerm "Prelude.Refl" [bv_tp, e1_trans] withPermStackM (:>: translateVar x) (:>: PTrans_Conj [APTrans_BVProp (BVPropTrans prop pf)]) m @@ -4984,22 +5016,22 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o return $ PImplTerm $ \k -> do prop_tp_trans <- translate prop ret_tp <- compReturnTypeM - applyGlobalImpTransM "Prelude.maybe" + applyGlobalTransM "Prelude.maybe" [ return (typeTransType1 prop_tp_trans), return ret_tp , return (implFailAltContTerm ret_tp (mbLift prop_str) k) , lambdaTransM "eq_pf" prop_tp_trans (\prop_trans -> withPermStackM (:>: translateVar x) (:>: bvPropPerm prop_trans) $ popPImplTerm trans k) - , applyGlobalImpTransM "Prelude.bvEqWithProof" - [ return (natTermLike $ natVal2 prop) , translate1 e1, translate1 e2]] + , applyGlobalTransM "Prelude.bvEqWithProof" + [ return (natOpenTerm $ natVal2 prop) , translate1 e1, translate1 e2]] -- If e1 and e2 are already unequal, short-circuit and do nothing ([nuMP| Impl1_TryProveBVProp x prop@(BVProp_Neq e1 e2) _ |], _) | not $ mbLift (mbMap2 bvCouldEqual e1 e2) -> translatePermImplUnary mb_impls $ withPermStackM (:>: translateVar x) - (:>: PTrans_Conj [APTrans_BVProp (BVPropTrans prop unitTermLike)]) + (:>: PTrans_Conj [APTrans_BVProp (BVPropTrans prop unitOpenTerm)]) -- For an inequality test, we don't need a proof, so just insert an if ([nuMP| Impl1_TryProveBVProp x prop@(BVProp_Neq e1 e2) prop_str |], @@ -5007,14 +5039,14 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o translatePermImpl (mbCombine RL.typeCtxProxies mb_impl') >>= \trans -> return $ PImplTerm $ \k -> let w = natVal2 prop in - applyGlobalImpTransM "Prelude.ite" + applyGlobalTransM "Prelude.ite" [ compReturnTypeM - , applyGlobalImpTransM "Prelude.bvEq" - [ return (natTermLike w), translate1 e1, translate1 e2 ] + , applyGlobalTransM "Prelude.bvEq" + [ return (natOpenTerm w), translate1 e1, translate1 e2 ] , (\ret_tp -> implFailAltContTerm ret_tp (mbLift prop_str) k) <$> compReturnTypeM , withPermStackM (:>: translateVar x) - (:>: PTrans_Conj [APTrans_BVProp (BVPropTrans prop unitTermLike)]) $ + (:>: PTrans_Conj [APTrans_BVProp (BVPropTrans prop unitOpenTerm)]) $ popPImplTerm trans k] -- If we know e1 < e2 statically, translate to unsafeAssert @@ -5027,8 +5059,8 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o t1 <- translate1 e1 t2 <- translate1 e2 let pf_tm = - applyGlobalTermLike "Prelude.unsafeAssertBVULt" - [natTermLike w, t1, t2] + applyGlobalOpenTerm "Prelude.unsafeAssertBVULt" + [natOpenTerm w, t1, t2] withPermStackM (:>: translateVar x) (:>: bvPropPerm (BVPropTrans prop pf_tm)) (popPImplTerm trans k) @@ -5040,15 +5072,15 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o return $ PImplTerm $ \k -> do prop_tp_trans <- translate prop ret_tp <- compReturnTypeM - applyGlobalImpTransM "Prelude.maybe" + applyGlobalTransM "Prelude.maybe" [ return (typeTransType1 prop_tp_trans), return ret_tp , return (implFailAltContTerm ret_tp (mbLift prop_str) k) , lambdaTransM "ult_pf" prop_tp_trans (\prop_trans -> withPermStackM (:>: translateVar x) (:>: bvPropPerm prop_trans) $ popPImplTerm trans k) - , applyGlobalImpTransM "Prelude.bvultWithProof" - [ return (natTermLike $ natVal2 prop), translate1 e1, translate1 e2] + , applyGlobalTransM "Prelude.bvultWithProof" + [ return (natOpenTerm $ natVal2 prop), translate1 e1, translate1 e2] ] -- If we know e1 <= e2 statically, translate to unsafeAssert @@ -5061,8 +5093,8 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o t1 <- translate1 e1 t2 <- translate1 e2 let pf_tm = - applyGlobalTermLike "Prelude.unsafeAssertBVULe" - [natTermLike w, t1, t2] + applyGlobalOpenTerm "Prelude.unsafeAssertBVULe" + [natOpenTerm w, t1, t2] withPermStackM (:>: translateVar x) (:>: bvPropPerm (BVPropTrans prop pf_tm)) (popPImplTerm trans k) @@ -5074,15 +5106,15 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o return $ PImplTerm $ \k -> do prop_tp_trans <- translate prop ret_tp <- compReturnTypeM - applyGlobalImpTransM "Prelude.maybe" + applyGlobalTransM "Prelude.maybe" [ return (typeTransType1 prop_tp_trans), return ret_tp , return (implFailAltContTerm ret_tp (mbLift prop_str) k) , lambdaTransM "ule_pf" prop_tp_trans (\prop_trans -> withPermStackM (:>: translateVar x) (:>: bvPropPerm prop_trans) $ popPImplTerm trans k) - , applyGlobalImpTransM "Prelude.bvuleWithProof" - [ return (natTermLike $ natVal2 prop), translate1 e1, translate1 e2] + , applyGlobalTransM "Prelude.bvuleWithProof" + [ return (natOpenTerm $ natVal2 prop), translate1 e1, translate1 e2] ] -- If we know e1 <= e2-e3 statically, translate to unsafeAssert @@ -5096,9 +5128,9 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o t2 <- translate1 e2 t3 <- translate1 e3 let pf_tm = - applyGlobalTermLike "Prelude.unsafeAssertBVULe" - [natTermLike w, t1, - applyGlobalTermLike "Prelude.bvSub" [natTermLike w, t2, t3]] + applyGlobalOpenTerm "Prelude.unsafeAssertBVULe" + [natOpenTerm w, t1, + applyGlobalOpenTerm "Prelude.bvSub" [natOpenTerm w, t2, t3]] withPermStackM (:>: translateVar x) (:>: bvPropPerm (BVPropTrans prop pf_tm)) (popPImplTerm trans k) @@ -5110,17 +5142,17 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o return $ PImplTerm $ \k -> do prop_tp_trans <- translate prop ret_tp <- compReturnTypeM - applyGlobalImpTransM "Prelude.maybe" + applyGlobalTransM "Prelude.maybe" [ return (typeTransType1 prop_tp_trans), return ret_tp , return (implFailAltContTerm ret_tp (mbLift prop_str) k) , lambdaTransM "ule_diff_pf" prop_tp_trans (\prop_trans -> withPermStackM (:>: translateVar x) (:>: bvPropPerm prop_trans) $ popPImplTerm trans k) - , applyGlobalImpTransM "Prelude.bvuleWithProof" - [ return (natTermLike $ natVal2 prop), translate1 e1, - applyGlobalImpTransM "Prelude.bvSub" - [return (natTermLike $ natVal2 prop), translate1 e2, translate1 e3]] + , applyGlobalTransM "Prelude.bvuleWithProof" + [ return (natOpenTerm $ natVal2 prop), translate1 e1, + applyGlobalTransM "Prelude.bvSub" + [return (natOpenTerm $ natVal2 prop), translate1 e2, translate1 e3]] ] ([nuMP| Impl1_TryProveBVProp _ _ _ |], _) -> @@ -5141,18 +5173,19 @@ translatePermImpl mb_impl = case mbMatch mb_impl of translatePermImplToTerm :: NuMatchingAny1 r => String -> Mb ctx (PermImpl r ps) -> ImpRTransFun r ext blocks tops rets ctx -> - ImpTransM ext blocks tops rets ps ctx SpecTerm + 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 (err ++ "\n\n" - ++ concat (intersperse - "\n\n--------------------\n\n" errs)) + 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) SpecTerm where + ctx (AnnotPermImpl r ps) OpenTerm where translate (mbMatch -> [nuMP| AnnotPermImpl err mb_impl |]) = translatePermImplToTerm (mbLift err) mb_impl (ImpRTransFun $ const translateF) @@ -5161,12 +5194,13 @@ instance ImplTranslateF r ext blocks tops rets => instance ImplTranslateF (LocalImplRet ps) ext blocks ps_in rets where translateF _ = do pctx <- itiPermStack <$> ask + ev <- infoEvType <$> ask ret_tp <- returnTypeM - return $ returnSpecTerm 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) -> - ImpTransM ext blocks tops rets ps_in ctx SpecTerm + ImpTransM ext blocks tops rets ps_in ctx OpenTerm translateLocalPermImpl err (mbMatch -> [nuMP| LocalPermImpl impl |]) = clearVarPermsM $ translate $ fmap (AnnotPermImpl err) impl @@ -5181,10 +5215,10 @@ translateCurryLocalPermImpl :: PermTransCtx ctx ps1 -> RAssign (Member ctx) ps1 -> TypeTrans (PermTransCtx ctx ps2) -> RAssign (Member ctx) ps2 -> TypeTrans (PermTransCtx ctx ps_out) -> - ImpTransM ext blocks tops rets ps ctx SpecTerm + 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 = typeTransTupleDesc tp_trans_out }) $ + local (\info -> info { itiReturnType = typeTransTupleType tp_trans_out }) $ withPermStackM (const (RL.append vars1 vars2)) (const (RL.append pctx1 pctx2)) @@ -5207,6 +5241,7 @@ translateLOwnedPermImpl err (mbMatch -> [nuMP| LocalPermImpl mb_impl |]) = return $ k e_ext' (impInfoToLOwned info_out) () +{- ---------------------------------------------------------------------- -- * Translating Typed Crucible Expressions ---------------------------------------------------------------------- @@ -5667,7 +5702,7 @@ translateStmt loc mb_stmt m = case mbMatch mb_stmt of -- FIXME HERE: figure out why these asserts always translate to ite True [nuMP| TypedAssert e _ |] -> - applyGlobalImpTransM "Prelude.ite" + applyGlobalTransM "Prelude.ite" [compReturnTypeM, translate1 e, m, mkErrorComp ("Failed Assert at " ++ renderDoc (ppShortFileName (plSourceLoc loc)))] @@ -5867,7 +5902,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 |] -> - applyGlobalImpTransM "Prelude.ite" + applyGlobalTransM "Prelude.ite" [compReturnTypeM, translate1 reg, translate impl_tgt1, translate impl_tgt2] [nuMP| TypedReturn impl_ret |] -> translate impl_ret From 648ef60eb75baeb8f2da3051ff78cc6ca2af99e4 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 16 Oct 2023 17:56:33 -0700 Subject: [PATCH 116/305] updated the translation of the EndLifetime rule --- .../src/Verifier/SAW/Heapster/SAWTranslation.hs | 17 +++++++---------- 1 file changed, 7 insertions(+), 10 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 1cf6714bdf..837d043f22 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -4277,14 +4277,11 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of m [nuMP| SImpl_EndLifetime _ tps_in tps_out ps_in ps_out |] -> - error "FIXME HERE NOWNOW" -- First, translate the in and out permissions of the lowned permission - {- - do ps_in_trans <- translate ps_in - ps_out_trans <- tupleTypeTrans <$> translate ps_out + do dtr_in <- tpTransM $ translateDescType ps_in + dtr_out <- tpTransM $ translateDescType ps_out let prxs_in = mbRAssignProxies ps_in :>: Proxy - let lrt_out = typeDescLRT $ typeTransTupleDesc ps_out_trans - let lrt = arrowLRTTrans ps_in_trans lrt_out + let d = arrowDescTrans dtr_in dtr_out -- Next, split out the ps_in permissions from the rest of the pctx pctx <- itiPermStack <$> ask @@ -4302,19 +4299,19 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of -- Now we apply the lifetime ownerhip function to ps_in and bind its output -- in the rest of the computation + ev <- infoEvType <$> ask case some_lotr of SomeLOwnedTrans lotr -> bindSpecMTransM - (applyCallClosSpecTerm - lrt (lownedTransTerm ps_in lotr) (transTerms pctx_in)) - ps_out_trans + (callSOpenTerm ev d (lownedTransTerm ps_in lotr) (transTerms pctx_in)) + (descTypeTrans dtr_out) "endl_ps" (\pctx_out -> withPermStackM (\(_ :>: l) -> RL.append ps_vars vars_out :>: l) (\_ -> RL.append pctx_ps pctx_out :>: PTrans_Conj [APTrans_LFinished]) - m) -} + m) [nuMP| SImpl_IntroLOwnedSimple _ _ _ |] -> do let prx_ps_l = mbRAssignProxies $ mbSimplImplIn mb_simpl From 93e5207e1c4cf3ef30de726d2cd019be9f253faa Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Tue, 17 Oct 2023 11:20:20 -0700 Subject: [PATCH 117/305] Started translating recursive and opaque shapes --- .../src/Verifier/SAW/Heapster/Permissions.hs | 101 +++--- .../Verifier/SAW/Heapster/SAWTranslation.hs | 295 ++++++++++++------ 2 files changed, 247 insertions(+), 149 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs index df9ec21ce9..6d52f4c12d 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs @@ -657,20 +657,20 @@ 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 - -- description given by an identifier - 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 an - -- identifier for a function that takes in translations of the @args@ and - -- returns the type description that is the translation of substituting those - -- translations of the @args@ into the given shape. Note that this is just an - -- optimization to make it more concise to expression this substitution - -- instance. + -- 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@ as free variables. RecShapeBody :: Mb (args :> LLVMShapeType w) (PermExpr (LLVMShapeType w)) -> - 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...?) @@ -693,7 +693,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. @@ -729,6 +730,7 @@ data ReachMethods reach args a where data RecPerm b reach args a = RecPerm { recPermName :: NamedPermName (RecursiveSort b reach) args a, recPermTransType :: Ident, + recPermTransDesc :: Ident, recPermFoldFun :: Ident, recPermUnfoldFun :: Ident, recPermReachMethods :: ReachMethods args a reach, @@ -3053,7 +3055,7 @@ deriving instance Eq (NamedShapeBody b args w) -- | Test if a 'NamedShape' is recursive namedShapeIsRecursive :: NamedShape b args w -> Bool -namedShapeIsRecursive (NamedShape _ _ (RecShapeBody _ _)) = True +namedShapeIsRecursive (NamedShape _ _ (RecShapeBody _ _ _)) = True namedShapeIsRecursive _ = False -- | Test if a 'NamedShape' in a binding is recursive @@ -3065,8 +3067,8 @@ mbNamedShapeIsRecursive = -- unfolded namedShapeCanUnfoldRepr :: NamedShape b args w -> BoolRepr b namedShapeCanUnfoldRepr (NamedShape _ _ (DefinedShapeBody _)) = TrueRepr -namedShapeCanUnfoldRepr (NamedShape _ _ (OpaqueShapeBody _ _)) = FalseRepr -namedShapeCanUnfoldRepr (NamedShape _ _ (RecShapeBody _ _)) = TrueRepr +namedShapeCanUnfoldRepr (NamedShape _ _ (OpaqueShapeBody _ _ _)) = FalseRepr +namedShapeCanUnfoldRepr (NamedShape _ _ (RecShapeBody _ _ _)) = TrueRepr -- | Get a 'BoolRepr' for the Boolean flag for whether a named shape in a -- binding can be unfolded @@ -4366,7 +4368,7 @@ findEqVarFieldsInShapeH (PExpr_NamedShape _ _ nmsh args) -- the variable fields findEqVarFieldsInShapeH (unfoldNamedShape nmsh args) findEqVarFieldsInShapeH (PExpr_NamedShape _ _ nmsh args) - | RecShapeBody _ _ <- namedShapeBody nmsh = + | RecShapeBody _ _ _ <- namedShapeBody nmsh = do seen_names <- ask if Set.member (namedShapeName nmsh) seen_names then return NameSet.empty @@ -4399,10 +4401,10 @@ 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) = + (RecShapeBody _ _ _)) args) = -- FIXME: if the recursive shape contains itself *not* under a pointer, then -- this could diverge llvmShapeLength (unfoldNamedShape nmsh args) @@ -4727,7 +4729,7 @@ instance AbstractModalities (AtomicPerm a) where namedShapeBodyShape :: KnownNat w => NamedShape 'True args w -> Mb args (PermExpr (LLVMShapeType w)) namedShapeBodyShape (NamedShape _ _ (DefinedShapeBody mb_sh)) = mb_sh -namedShapeBodyShape sh@(NamedShape _ _ (RecShapeBody mb_sh _)) = +namedShapeBodyShape sh@(NamedShape _ _ (RecShapeBody mb_sh _ _)) = let (prxs :>: _) = mbToProxy mb_sh in nuMulti prxs $ \ns -> subst (substOfExprs (namesToExprs ns :>: @@ -4739,7 +4741,7 @@ unfoldNamedShape :: KnownNat w => NamedShape 'True args w -> PermExprs args -> PermExpr (LLVMShapeType w) unfoldNamedShape (NamedShape _ _ (DefinedShapeBody mb_sh)) args = subst (substOfExprs args) mb_sh -unfoldNamedShape sh@(NamedShape _ _ (RecShapeBody mb_sh _)) args = +unfoldNamedShape sh@(NamedShape _ _ (RecShapeBody mb_sh _ _)) args = subst (substOfExprs (args :>: PExpr_NamedShape Nothing Nothing sh args)) mb_sh -- | Unfold a named shape and apply 'modalize' to the result @@ -6134,12 +6136,12 @@ 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 -- the empty shape for the recursive shape - RecShapeBody mb_sh _ -> + RecShapeBody mb_sh _ _ -> shapeIsCopyable rw $ subst (substOfExprs (args :>: PExpr_EmptyShape)) mb_sh shapeIsCopyable _ (PExpr_EqShape _ _) = True shapeIsCopyable rw (PExpr_PtrShape maybe_rw' _ sh) = @@ -6522,8 +6524,8 @@ 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 (RecShapeBody mb_sh _) = freeVars mb_sh + freeVars (OpaqueShapeBody mb_len _ _) = freeVars mb_len + freeVars (RecShapeBody mb_sh _ _) = freeVars mb_sh -- | Find all equality permissions @eq(e)@ contained in another permission @@ -6557,10 +6559,10 @@ 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) = + (RecShapeBody mb_sh _ _)) args) = -- NOTE: we unfold the shape with the empty shape substituted for recursive -- occurrences of the shape name, to avoid an infinite loop containedEqVars $ subst (substOfExprs (args :>: PExpr_EmptyShape)) mb_sh @@ -6970,11 +6972,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 |] -> + <*> return (mbLift desc_id) + [nuMP| RecShapeBody mb_sh trans_id desc_id |] -> RecShapeBody <$> genSubstMb (px :>: Proxy) s mb_sh <*> return (mbLift trans_id) + <*> return (mbLift desc_id) instance SubstVar s m => Substable s (NamedPermName ns args a) m where genSubst _ mb_rpn = return $ mbLift mb_rpn @@ -6991,12 +6995,12 @@ 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) + genSubst s (mbMatch -> [nuMP| RecPerm rpn dt_i d_i f_i u_i reachMeths cases |]) = + RecPerm (mbLift rpn) (mbLift dt_i) (mbLift d_i) (mbLift f_i) (mbLift u_i) (mbLift reachMeths) <$> mapM (genSubstMb (cruCtxProxies (mbLift (fmap namedPermNameArgs rpn))) s) (mbList cases) instance SubstVar s m => Substable s (DefinedPerm ns args a) m where @@ -7917,14 +7921,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) = + abstractPEVars ns1 ns2 (RecShapeBody mb_sh trans_id desc_id) = absVarsReturnH ns1 ns2 ($(mkClosed - [| \i l -> RecShapeBody l i |]) - `clApply` toClosed trans_id) + [| \i1 i2 l -> RecShapeBody l i1 i2 |]) + `clApply` toClosed trans_id + `clApply` toClosed desc_id) `clMbMbApplyM` abstractPEVars ns1 ns2 mb_sh instance AbstractVars (NamedPermName ns args a) where @@ -8204,11 +8210,11 @@ 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 + permEnvAddNamedPerm env $ NamedPerm_Opaque $ OpaquePerm n trans_id d_id -- | Add a recursive named permission to a 'PermEnv', assuming that the -- 'recPermCases' and the fold and unfold functions depend recursively on the @@ -8223,7 +8229,7 @@ permEnvAddOpaquePerm env str args tp i = -- 'recPermCases' can be called multiple times, so should not perform any -- non-idempotent mutation in the monad @m@. permEnvAddRecPermM :: Monad m => PermEnv -> String -> CruCtx args -> - TypeRepr a -> Ident -> + TypeRepr a -> Ident -> Ident -> (forall b. NameReachConstr (RecursiveSort b reach) args a) -> (forall b. NamedPermName (RecursiveSort b reach) args a -> PermEnv -> m [Mb args (ValuePerm a)]) -> @@ -8232,14 +8238,14 @@ permEnvAddRecPermM :: Monad m => PermEnv -> String -> CruCtx args -> (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 = +permEnvAddRecPermM env nm args tp trans_ident d_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 + RecPerm npn trans_ident d_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!") @@ -8254,7 +8260,7 @@ permEnvAddRecPermM env nm args tp trans_ident reachC casesF foldIdentsF reachMet (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 + RecPerm npn trans_ident d_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 @@ -8288,11 +8294,12 @@ 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 along with its translation -- to a spec function to a 'PermEnv' diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 837d043f22..8e2c94b9b1 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -234,15 +234,20 @@ bvVecTpDesc :: OpenTerm -> OpenTerm -> OpenTerm -> OpenTerm bvVecTpDesc w_term len_term elem_d = applyGlobalOpenTerm "Prelude.Tp_BVVec" [elem_d, w_term, len_term] +-- | 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 "Prelude.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 = ctorOpenTerm "Prelude.TpExpr_Const" [bvExprKind w, bv] +bvConstTpExpr w bv = constTpExpr (bvExprKind w) bv -- | 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 w [bv] = bv +bvSumTpExprs _ [bv] = bv bvSumTpExprs w (bv:bvs) = ctorOpenTerm "Prelude.TpExpr_BinOp" [bvExprKind w, bvExprKind w, bvExprKind w, @@ -285,13 +290,31 @@ piTpDescMulti :: [OpenTerm] -> OpenTerm -> OpenTerm piTpDescMulti ks tp = foldr piTpDesc tp ks -- | Build a type description for a free deBruijn index -varTpDesc :: Natural -> OpenTerm -varTpDesc ix = ctorOpenTerm "Prelude.Tp_Var" [natOpenTerm ix] +varTpDesc :: OpenTerm -> Natural -> OpenTerm +varTpDesc d ix = ctorOpenTerm "Prelude.Tp_Var" [d, natOpenTerm ix] -- | Build a type-level expression with a given @ExprKind@ for a free variable varTpExpr :: OpenTerm -> Natural -> OpenTerm varTpExpr ek ix = ctorOpenTerm "Prelude.TpExpr_Var" [ek, natOpenTerm ix] +-- | 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 "Prelude.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 +-- from a type description given by an identifier +substIdTpDescMulti :: Ident -> [OpenTerm] -> [OpenTerm] -> OpenTerm +substIdTpDescMulti i = substTpDescMulti (globalOpenTerm i) + -- | Map from type description @T@ to the type @T@ describes tpElemTypeOpenTerm :: OpenTerm -> OpenTerm tpElemTypeOpenTerm d = @@ -488,7 +511,7 @@ data ExprTrans (a :: CrucibleType) where -- | 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 @@ -497,13 +520,13 @@ type ExprTransCtx = RAssign ExprTrans -- | Destruct an 'ExprTrans' of shape type to a list of type descriptions unETransShape :: ExprTrans (LLVMShapeType w) -> [OpenTerm] unETransShape (ETrans_Shape d) = d -unETransShape (ETrans_Term _) = +unETransShape (ETrans_Term _ _) = panic "unETransShape" ["Incorrect translation of a shape expression"] -- | Destruct an 'ExprTrans' of permission type to a list of type descriptions unETransPerm :: ExprTrans (ValuePermType a) -> [OpenTerm] unETransPerm (ETrans_Perm d) = d -unETransPerm (ETrans_Term _) = +unETransPerm (ETrans_Term _ _) = panic "unETransPerm" ["Incorrect translation of a shape expression"] @@ -556,7 +579,7 @@ instance IsTermTrans (ExprTrans tp) where transTerms ETrans_AnyVector = [] transTerms (ETrans_Shape ds) = [tupleTpDesc ds] transTerms (ETrans_Perm ds) = [tupleTpDesc ds] - transTerms (ETrans_Term t) = [t] + transTerms (ETrans_Term _ t) = [t] instance IsTermTrans (ExprTransCtx ctx) where transTerms MNil = [] @@ -582,7 +605,8 @@ exprTransType (ETrans_Shape _) = mkTypeTrans1 tpDescTypeOpenTerm (\d -> ETrans_Shape [d]) exprTransType (ETrans_Perm _) = mkTypeTrans1 tpDescTypeOpenTerm (\d -> ETrans_Perm [d]) -exprTransType (ETrans_Term t) = mkTypeTrans1 (openTermType t) ETrans_Term +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 @@ -591,6 +615,27 @@ 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 :: 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 ds) = ds +exprTransDescs (ETrans_Perm ds) = ds +exprTransDescs (ETrans_Term tp t) = + case translateKindDescs tp of + [d] -> [ctorOpenTerm "Prelude.TpExpr_Const" [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 @@ -1117,8 +1162,13 @@ instance TransInfo info => Translate info ctx (NatRepr n) OpenTerm where translate mb_n = return $ natOpenTerm $ mbLift $ fmap natValue mb_n -- | Make a type translation that uses a single term of the given type -mkTermType1 :: OpenTerm -> TypeTrans (ExprTrans a) -mkTermType1 tp = mkTypeTrans1 tp ETrans_Term +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 @@ -1130,6 +1180,7 @@ translateType BoolRepr = 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, []) @@ -1152,8 +1203,8 @@ translateType (LLVMShapeRepr _) = (mkTypeTrans1 tpDescTypeOpenTerm (\d -> ETrans_Shape [d]), [tpKindDesc]) -translateType (FloatRepr _) = - (mkTermType1 $ dataTypeOpenTerm "Prelude.Float" [], +translateType tp@(FloatRepr _) = + (mkTermType1Repr tp $ dataTypeOpenTerm "Prelude.Float" [], panic "translateType" ["Type descriptions of floats not yet supported"]) translateType (StringRepr UnicodeRepr) = @@ -1296,12 +1347,15 @@ descTransM = withInfoM $ \info -> DescTransInfo (infoCtx info) MNil (infoEnv info) (infoChecksFlag info) --- | The class for translating to type descriptions. 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. +-- | 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] @@ -1310,8 +1364,18 @@ class TranslateDescs a where translateDesc :: TranslateDescs a => Mb ctx a -> DescTransM ctx OpenTerm translateDesc mb_a = tupleTpDesc <$> translateDescs mb_a --- | Translate a variable to either a SAW core value or a natural number --- deBruijn index, depending on the current description context +-- | 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 @@ -1424,23 +1488,23 @@ instance TransInfo info => [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 @@ -1449,11 +1513,11 @@ 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 type descriptions by translateDescs @@ -1548,31 +1612,48 @@ translateBVDesc mb_e = let i_expr = translateBVConstDesc w $ mbLift mb_i return $ bvSumTpExprs (natValue w) (fs_exprs ++ [i_expr]) --- Expressions of shape type translate to a list of type descriptions -instance TranslateDescs (PermExpr (LLVMShapeType w)) where +-- translateDescs on permission expressions yield a list of SAW core terms of +-- type @kindExpr K@, 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 |] -> translateVarDesc mb_x >>= \case - Left d -> return $ unETransShape d - Right (ix, [_]) -> return [varTpDesc ix] - Right (_, ds) -> - panic "translateDescs" ["Expected one kind for variable, found " - ++ show (length ds)] + Left etrans -> return $ exprTransDescs etrans + Right (ix, ds) -> return $ zipWith varTpDesc ds [ix..] + [nuMP| PExpr_Unit |] -> return [] + [nuMP| PExpr_Bool b |] -> + return [constTpExpr boolKindDesc $ boolOpenTerm $ mbLift b] + [nuMP| PExpr_Nat n |] -> + return [constTpExpr natKindDesc $ 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 [] + [nuMP| PExpr_EmptyShape |] -> return [] [nuMP| PExpr_NamedShape _ _ nmsh args |] -> case mbMatch $ fmap namedShapeBody nmsh of [nuMP| DefinedShapeBody _ |] -> translateDescs (mbMap2 unfoldNamedShape nmsh args) - [nuMP| OpaqueShapeBody _ trans_id |] -> - {- - (:[]) <$> applyGlobalOpenTerm (mbLift trans_id) <$> - transTerms <$> translate args -} - error "FIXME HERE NOWNOW: translate opaque shapes to descs (how to handle args?)" - [nuMP| RecShapeBody _ trans_id |] -> - {- - (:[]) <$> applyGlobalOpenTerm (mbLift trans_id) <$> - transTerms <$> translate args -} - error "FIXME HERE NOWNOW: translate rec shapes to descs (how to handle args?)" + [nuMP| OpaqueShapeBody _ _ desc_id |] -> + do let (_, k_ds) = translateCruCtx (mbLift $ fmap namedShapeArgs nmsh) + args_ds <- translateDescs args + return [substIdTpDescMulti (mbLift desc_id) k_ds args_ds] + [nuMP| RecShapeBody _ _ desc_id |] -> + do let (_, k_ds) = translateCruCtx (mbLift $ fmap namedShapeArgs nmsh) + args_ds <- translateDescs args + return [substIdTpDescMulti (mbLift desc_id) k_ds args_ds] [nuMP| PExpr_EqShape _ _ |] -> return [] [nuMP| PExpr_PtrShape _ _ sh |] -> translateDescs sh [nuMP| PExpr_FieldShape fsh |] -> translateDescs fsh @@ -1596,6 +1677,14 @@ instance TranslateDescs (PermExpr (LLVMShapeType w)) where [nuMP| PExpr_FalseShape |] -> return [ctorOpenTerm "Prelude.Tp_Void" []] + [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 + ---------------------------------------------------------------------- -- * Permission Translations @@ -4404,7 +4493,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of -- translations of the arguments plus the translations of the proofs of the -- permissions [nuMP| SImpl_IntroLLVMBlockNamed _ bp nmsh |] - | [nuMP| RecShapeBody _ _ |] <- mbMatch $ fmap namedShapeBody nmsh + | [nuMP| RecShapeBody _ _ _ |] <- mbMatch $ fmap namedShapeBody nmsh , [nuMP| PExpr_NamedShape _ _ _ args |] <- mbMatch $ fmap llvmBlockShape bp -> {- do ttrans <- translateSimplImplOutHead mb_simpl @@ -4440,7 +4529,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of -- translations of the arguments plus the translations of the proofs of the -- permissions [nuMP| SImpl_ElimLLVMBlockNamed _ bp nmsh |] - | [nuMP| RecShapeBody _ sh_id |] <- mbMatch $ fmap namedShapeBody nmsh + | [nuMP| RecShapeBody _ _ desc_id |] <- mbMatch $ fmap namedShapeBody nmsh , [nuMP| PExpr_NamedShape _ _ _ args |] <- mbMatch $ fmap llvmBlockShape bp -> {- do ttrans <- translateSimplImplOutHead mb_simpl @@ -4903,7 +4992,8 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o 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 @@ -4931,7 +5021,7 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o 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 @@ -4957,7 +5047,7 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o 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) @@ -5271,7 +5361,7 @@ 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 <$> applyMultiPureTransM (return $ globalOpenTerm "Prelude.boolEq") [translateRWV e1, translateRWV e2] -- [nuMP| BaseIsEq BaseNatRepr e1 e2 |] -> @@ -5279,7 +5369,7 @@ instance (PermCheckExtC ext exprExt, TransInfo info) => -- applyMultiPureTransM (return $ globalOpenTerm "Prelude.equalNat") -- [translateRWV e1, translateRWV e2] [nuMP| BaseIsEq (BaseBVRepr w) e1 e2 |] -> - ETrans_Term <$> + ETrans_Term knownRepr <$> applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvEq") [translate w, translateRWV e1, translateRWV e2] @@ -5287,56 +5377,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 <$> applyMultiPureTransM (return $ globalOpenTerm "Prelude.not") [translateRWV e] [nuMP| And e1 e2 |] -> - ETrans_Term <$> + ETrans_Term knownRepr <$> applyMultiPureTransM (return $ globalOpenTerm "Prelude.and") [translateRWV e1, translateRWV e2] [nuMP| Or e1 e2 |] -> - ETrans_Term <$> + ETrans_Term knownRepr <$> applyMultiPureTransM (return $ globalOpenTerm "Prelude.or") [translateRWV e1, translateRWV e2] [nuMP| BoolXor e1 e2 |] -> - ETrans_Term <$> + ETrans_Term knownRepr <$> applyMultiPureTransM (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 <$> applyMultiPureTransM (return $ globalOpenTerm "Prelude.ltNat") [translateRWV e1, translateRWV e2] -- [nuMP| NatLe _ _ |] -> [nuMP| NatEq e1 e2 |] -> - ETrans_Term <$> + ETrans_Term knownRepr <$> applyMultiPureTransM (return $ globalOpenTerm "Prelude.equalNat") [translateRWV e1, translateRWV e2] [nuMP| NatAdd e1 e2 |] -> - ETrans_Term <$> + ETrans_Term knownRepr <$> applyMultiPureTransM (return $ globalOpenTerm "Prelude.addNat") [translateRWV e1, translateRWV e2] [nuMP| NatSub e1 e2 |] -> - ETrans_Term <$> + ETrans_Term knownRepr <$> applyMultiPureTransM (return $ globalOpenTerm "Prelude.subNat") [translateRWV e1, translateRWV e2] [nuMP| NatMul e1 e2 |] -> - ETrans_Term <$> + ETrans_Term knownRepr <$> applyMultiPureTransM (return $ globalOpenTerm "Prelude.mulNat") [translateRWV e1, translateRWV e2] [nuMP| NatDiv e1 e2 |] -> - ETrans_Term <$> + ETrans_Term knownRepr <$> applyMultiPureTransM (return $ globalOpenTerm "Prelude.divNat") [translateRWV e1, translateRWV e2] [nuMP| NatMod e1 e2 |] -> - ETrans_Term <$> + ETrans_Term knownRepr <$> applyMultiPureTransM (return $ globalOpenTerm "Prelude.modNat") [translateRWV e1, translateRWV e2] @@ -5348,130 +5438,131 @@ 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 knownRepr $ + bvBVOpenTerm (mbLift w) $ BV.zero (mbLift w) [nuMP| BVLit w mb_bv |] -> - return $ ETrans_Term $ bvBVOpenTerm (mbLift w) $ mbLift mb_bv + return $ ETrans_Term knownRepr $ bvBVOpenTerm (mbLift w) $ mbLift mb_bv [nuMP| BVConcat w1 w2 e1 e2 |] -> - ETrans_Term <$> + ETrans_Term knownRepr <$> applyMultiPureTransM (return $ globalOpenTerm "Prelude.join") [translate w1, translate w2, translateRWV e1, translateRWV e2] [nuMP| BVTrunc w1 w2 e |] -> - ETrans_Term <$> + ETrans_Term knownRepr <$> applyMultiPureTransM (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 knownRepr <$> applyMultiPureTransM (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 knownRepr <$> applyMultiPureTransM (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 knownRepr <$> applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvNot") [translate w, translateRWV e] [nuMP| BVAnd w e1 e2 |] -> - ETrans_Term <$> + ETrans_Term knownRepr <$> applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvAnd") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVOr w e1 e2 |] -> - ETrans_Term <$> + ETrans_Term knownRepr <$> applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvOr") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVXor w e1 e2 |] -> - ETrans_Term <$> + ETrans_Term knownRepr <$> applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvXor") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVNeg w e |] -> - ETrans_Term <$> + ETrans_Term knownRepr <$> applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvNeg") [translate w, translateRWV e] [nuMP| BVAdd w e1 e2 |] -> - ETrans_Term <$> + ETrans_Term knownRepr <$> applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvAdd") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVSub w e1 e2 |] -> - ETrans_Term <$> + ETrans_Term knownRepr <$> applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvSub") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVMul w e1 e2 |] -> - ETrans_Term <$> + ETrans_Term knownRepr <$> applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvMul") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVUdiv w e1 e2 |] -> - ETrans_Term <$> + ETrans_Term knownRepr <$> applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvUDiv") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVSdiv w e1 e2 |] -> - ETrans_Term <$> + ETrans_Term knownRepr <$> applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvSDiv") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVUrem w e1 e2 |] -> - ETrans_Term <$> + ETrans_Term knownRepr <$> applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvURem") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVSrem w e1 e2 |] -> - ETrans_Term <$> + ETrans_Term knownRepr <$> applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvSRem") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVUle w e1 e2 |] -> - ETrans_Term <$> + ETrans_Term knownRepr <$> applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvule") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVUlt w e1 e2 |] -> - ETrans_Term <$> + ETrans_Term knownRepr <$> applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvult") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVSle w e1 e2 |] -> - ETrans_Term <$> + ETrans_Term knownRepr <$> applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvsle") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVSlt w e1 e2 |] -> - ETrans_Term <$> + ETrans_Term knownRepr <$> applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvslt") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVCarry w e1 e2 |] -> - ETrans_Term <$> + ETrans_Term knownRepr <$> applyMultiPureTransM (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 <$> applyMultiPureTransM (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 <$> applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvSBorrow") [return w_minus_1, translateRWV e1, translateRWV e2] [nuMP| BVShl w e1 e2 |] -> - ETrans_Term <$> + ETrans_Term knownRepr <$> applyMultiPureTransM (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 knownRepr <$> applyMultiPureTransM (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 knownRepr <$> applyMultiPureTransM (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 knownRepr <$> applyMultiPureTransM (return $ globalOpenTerm "Prelude.ite") [bitvectorTransM (translate mb_w), translateRWV e, @@ -5479,7 +5570,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 <$> applyPureTransM (return $ globalOpenTerm "Prelude.not") (applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvEq") [translate mb_w, translateRWV e, @@ -5487,7 +5578,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 @@ -5719,7 +5810,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 From c15590f05081659f7fc36d734554d3c864b59747 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Tue, 17 Oct 2023 13:54:07 -0700 Subject: [PATCH 118/305] updated the translations of shapes and permissions to also contain the translation of shapes and permissions to types, not just type descriptions; also updated the translation of shape expressions to generate this information --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 162 ++++++++++++------ 1 file changed, 114 insertions(+), 48 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 8e2c94b9b1..f25c974ec5 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -137,6 +137,10 @@ bvVecTypeOpenTerm w_term len_term elem_tp = funIxTypeOpenTerm :: OpenTerm -> OpenTerm funIxTypeOpenTerm t = applyGlobalOpenTerm "Prelude.FunIx" [t] +-- | 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 @@ -318,7 +322,6 @@ substIdTpDescMulti i = substTpDescMulti (globalOpenTerm i) -- | Map from type description @T@ to the type @T@ describes tpElemTypeOpenTerm :: OpenTerm -> OpenTerm tpElemTypeOpenTerm d = - -- FIXME HERE NOWNOW: this should normalize the returned term applyGlobalOpenTerm "Prelude.tpElem" [d] -- | Build a @SpecM@ computation that returns a value @@ -393,6 +396,10 @@ 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 @@ -503,11 +510,13 @@ 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 a tuple of 0 or more type descriptions - ETrans_Shape :: [OpenTerm] -> ExprTrans (LLVMShapeType w) + -- | The translation of a shape is a list of 0 or more type descriptions along + -- with the translations to the types they represent, in that order + ETrans_Shape :: [OpenTerm] -> [OpenTerm] -> ExprTrans (LLVMShapeType w) - -- | The translation of a permission is a tuple of 0 or more type descriptions - ETrans_Perm :: [OpenTerm] -> ExprTrans (ValuePermType a) + -- | 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. @@ -517,15 +526,17 @@ data ExprTrans (a :: CrucibleType) where type ExprTransCtx = RAssign ExprTrans --- | Destruct an 'ExprTrans' of shape type to a list of type descriptions -unETransShape :: ExprTrans (LLVMShapeType w) -> [OpenTerm] -unETransShape (ETrans_Shape d) = d +-- | Destruct an 'ExprTrans' of shape type to a list of type descriptions and +-- the types they represent, in that order +unETransShape :: ExprTrans (LLVMShapeType w) -> ([OpenTerm], [OpenTerm]) +unETransShape (ETrans_Shape ds tps) = (ds, tps) unETransShape (ETrans_Term _ _) = panic "unETransShape" ["Incorrect translation of a shape expression"] -- | Destruct an 'ExprTrans' of permission type to a list of type descriptions -unETransPerm :: ExprTrans (ValuePermType a) -> [OpenTerm] -unETransPerm (ETrans_Perm d) = d +-- 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"] @@ -577,8 +588,8 @@ instance IsTermTrans (ExprTrans tp) where transTerms ETrans_Fun = [] transTerms ETrans_Unit = [] transTerms ETrans_AnyVector = [] - transTerms (ETrans_Shape ds) = [tupleTpDesc ds] - transTerms (ETrans_Perm ds) = [tupleTpDesc ds] + transTerms (ETrans_Shape ds _) = [tupleTpDesc ds] + transTerms (ETrans_Perm ds _) = [tupleTpDesc ds] transTerms (ETrans_Term _ t) = [t] instance IsTermTrans (ExprTransCtx ctx) where @@ -601,10 +612,11 @@ 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 [d]) -exprTransType (ETrans_Perm _) = - mkTypeTrans1 tpDescTypeOpenTerm (\d -> ETrans_Perm [d]) +exprTransType (ETrans_Shape _ _) = + mkTypeTrans1 tpDescTypeOpenTerm (\d -> + ETrans_Shape [d] [tpElemTypeOpenTerm d]) +exprTransType (ETrans_Perm _ _) = + mkTypeTrans1 tpDescTypeOpenTerm (\d -> ETrans_Perm [d] [tpElemTypeOpenTerm d]) exprTransType (ETrans_Term tp t) = mkTypeTrans1 (openTermType t) (ETrans_Term tp) @@ -629,8 +641,8 @@ exprTransDescs (ETrans_Struct etranss) = exprTransDescs ETrans_Fun = [] exprTransDescs ETrans_Unit = [] exprTransDescs ETrans_AnyVector = [] -exprTransDescs (ETrans_Shape ds) = ds -exprTransDescs (ETrans_Perm ds) = ds +exprTransDescs (ETrans_Shape ds _) = ds +exprTransDescs (ETrans_Perm ds _) = ds exprTransDescs (ETrans_Term tp t) = case translateKindDescs tp of [d] -> [ctorOpenTerm "Prelude.TpExpr_Const" [d, t]] @@ -910,8 +922,7 @@ bitvectorTransM m = bitvectorTypeOpenTerm <$> m -- 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 @@ -1197,10 +1208,12 @@ translateType RWModalityRepr = (mkTypeTrans0 ETrans_RWModality, []) -- Permissions and LLVM shapes translate to type descriptions translateType (ValuePermRepr _) = - (mkTypeTrans1 tpDescTypeOpenTerm (\d -> ETrans_Perm [d]), + (mkTypeTrans1 tpDescTypeOpenTerm (\d -> + ETrans_Perm [d] [tpElemTypeOpenTerm d]), [tpKindDesc]) translateType (LLVMShapeRepr _) = - (mkTypeTrans1 tpDescTypeOpenTerm (\d -> ETrans_Shape [d]), + (mkTypeTrans1 tpDescTypeOpenTerm (\d -> + ETrans_Shape [d] [tpElemTypeOpenTerm d]), [tpKindDesc]) translateType tp@(FloatRepr _) = @@ -1522,28 +1535,74 @@ instance TransInfo info => -- LLVM shapes are translated to type descriptions by translateDescs [nuMP| PExpr_EmptyShape |] -> - ETrans_Shape <$> descTransM (translateDescs mb_e) - [nuMP| PExpr_NamedShape _ _ _ _ |] -> - ETrans_Shape <$> descTransM (translateDescs mb_e) - [nuMP| PExpr_EqShape _ _ |] -> - ETrans_Shape <$> descTransM (translateDescs mb_e) - [nuMP| PExpr_PtrShape _ _ _ |] -> - ETrans_Shape <$> descTransM (translateDescs mb_e) - [nuMP| PExpr_FieldShape _ |] -> - ETrans_Shape <$> descTransM (translateDescs mb_e) - [nuMP| PExpr_ArrayShape _ _ _ |] -> - ETrans_Shape <$> descTransM (translateDescs mb_e) - [nuMP| PExpr_SeqShape _ _ |] -> - ETrans_Shape <$> descTransM (translateDescs mb_e) - [nuMP| PExpr_OrShape _ _ |] -> - ETrans_Shape <$> descTransM (translateDescs mb_e) - [nuMP| PExpr_ExShape _ |] -> - ETrans_Shape <$> descTransM (translateDescs mb_e) + return $ ETrans_Shape [] [] + [nuMP| PExpr_NamedShape _ _ nmsh args |] -> + case mbMatch $ fmap namedShapeBody nmsh of + [nuMP| DefinedShapeBody _ |] -> + translate (mbMap2 unfoldNamedShape nmsh args) + [nuMP| OpaqueShapeBody _ tp_id desc_id |] -> + do let (_, k_ds) = translateCruCtx (mbLift $ fmap namedShapeArgs nmsh) + args_terms <- transTerms <$> translate args + args_ds <- descTransM $ translateDescs args + return $ + ETrans_Shape [substIdTpDescMulti (mbLift desc_id) k_ds args_ds] + [applyGlobalOpenTerm (mbLift tp_id) args_terms] + [nuMP| RecShapeBody _ tp_id desc_id |] -> + do let (_, k_ds) = translateCruCtx (mbLift $ fmap namedShapeArgs nmsh) + args_terms <- transTerms <$> translate args + args_ds <- descTransM $ translateDescs args + return $ + ETrans_Shape [substIdTpDescMulti (mbLift desc_id) k_ds args_ds] + [applyGlobalOpenTerm (mbLift tp_id) args_terms] + [nuMP| PExpr_EqShape _ _ |] -> return $ ETrans_Shape [] [] + [nuMP| PExpr_PtrShape _ _ sh |] -> translate sh + [nuMP| PExpr_FieldShape fsh |] -> + ETrans_Shape <$> descTransM (translateDescs fsh) <*> translate fsh + [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_ds, elem_tps) <- unETransShape <$> translate mb_sh + return $ + ETrans_Shape [bvVecTpDesc w_term len_d (tupleTpDesc elem_ds)] + [bvVecTypeOpenTerm w_term len_term (tupleOfTypes elem_tps)] + [nuMP| PExpr_SeqShape sh1 sh2 |] -> + do (ds1, tps1) <- unETransShape <$> translate sh1 + (ds2, tps2) <- unETransShape <$> translate sh2 + return $ ETrans_Shape (ds1 ++ ds2) (tps1 ++ tps2) + [nuMP| PExpr_OrShape sh1 sh2 |] -> + do (ds1, tps1) <- unETransShape <$> translate sh1 + (ds2, tps2) <- unETransShape <$> translate sh2 + return $ + ETrans_Shape [sumTpDesc (tupleTpDesc ds1) (tupleTpDesc ds2)] + [eitherTypeOpenTerm (tupleOfTypes tps1) (tupleOfTypes tps2)] + [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 + let (tptrans, _) = 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 (openTermsTypeTrans <$> snd <$> + unETransShape <$> translate mb_sh) + return $ ETrans_Shape [d] [tp] [nuMP| PExpr_FalseShape |] -> - ETrans_Shape <$> descTransM (translateDescs mb_e) + return $ + ETrans_Shape [ctorOpenTerm "Prelude.Tp_Void" []] [dataTypeOpenTerm + "Prelude.Void" []] [nuMP| PExpr_ValPerm p |] -> - ETrans_Perm <$> descTransM (translateDescs p) + ETrans_Perm <$> descTransM (translateDescs p) <*> (typeTransTypes <$> + translate p) -- LLVM field shapes translate to the list of type descriptions that the @@ -1551,8 +1610,10 @@ instance TransInfo info => instance TransInfo info => Translate info ctx (LLVMFieldShape w) [OpenTerm] where translate (mbMatch -> [nuMP| LLVMFieldShape p |]) = - descTransM (translateDescs 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 @@ -1641,6 +1702,11 @@ instance TranslateDescs (PermExpr a) where 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 [nuMP| PExpr_EmptyShape |] -> return [] [nuMP| PExpr_NamedShape _ _ nmsh args |] -> case mbMatch $ fmap namedShapeBody nmsh of @@ -2856,8 +2922,8 @@ instance TransInfo info => [nuMP| ValPerm_Conj ps |] -> fmap PTrans_Conj <$> listTypeTrans <$> translate ps [nuMP| ValPerm_Var x _ |] -> - do d <- tupleTpDesc <$> unETransPerm <$> translate x - return $ mkTypeTrans1 (tpElemTypeOpenTerm d) (PTrans_Term p) + do (_, tps) <- unETransPerm <$> translate x + return $ mkTypeTrans1 (tupleOfTypes tps) (PTrans_Term p) [nuMP| ValPerm_False |] -> return $ mkPermTypeTrans1 p $ globalOpenTerm "Prelude.FalseProp" @@ -2877,8 +2943,8 @@ instance TransInfo info => fmap APTrans_LLVMArray <$> translate ap [nuMP| Perm_LLVMBlock bp |] -> - do ds <- descTransM $ translateDescs (fmap llvmBlockShape bp) - return $ TypeTrans (map tpElemTypeOpenTerm ds) (APTrans_LLVMBlock bp) + do (_, tps) <- unETransShape <$> translate (fmap llvmBlockShape bp) + return $ TypeTrans tps (APTrans_LLVMBlock bp) [nuMP| Perm_LLVMFree e |] -> return $ mkTypeTrans0 $ APTrans_LLVMFree e @@ -2888,8 +2954,8 @@ instance TransInfo info => [nuMP| Perm_IsLLVMPtr |] -> return $ mkTypeTrans0 APTrans_IsLLVMPtr [nuMP| Perm_LLVMBlockShape sh |] -> - do ds <- descTransM $ translateDescs sh - return $ TypeTrans (map tpElemTypeOpenTerm ds) (APTrans_LLVMBlockShape sh) + do (_, tps) <- unETransShape <$> translate sh + return $ TypeTrans tps (APTrans_LLVMBlockShape sh) [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 From d7d0397c1c7348be53a71d85e87c5b98bbe10da2 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Tue, 17 Oct 2023 18:37:22 -0700 Subject: [PATCH 119/305] added explicit substitutions to type descriptions, for use in translating named type descriptions --- saw-core/prelude/Prelude.sawcore | 50 ++++++++++++++++++++++++++++---- 1 file changed, 45 insertions(+), 5 deletions(-) diff --git a/saw-core/prelude/Prelude.sawcore b/saw-core/prelude/Prelude.sawcore index 18f8a6f3f3..29ec567cc0 100644 --- a/saw-core/prelude/Prelude.sawcore +++ b/saw-core/prelude/Prelude.sawcore @@ -2333,14 +2333,21 @@ data TpDesc : sort 0 where { -- Vector types Tp_Vec : TpDesc -> TpExpr Kind_nat -> 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; - -- The empty type - Tp_Void : 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 type BVVec n len d @@ -2348,6 +2355,23 @@ Tp_BVVec : TpDesc -> (n:Nat) -> TpExpr (Kind_bv n) -> TpDesc; Tp_BVVec d n len = Tp_Vec d (TpExpr_UnOp (Kind_bv n) Kind_nat (UnOp_BVToNat n) len); +-- 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; + +-- 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 -- @@ -2619,6 +2643,7 @@ tpSubst n_top env_top T_top = (\ (_:TpDesc) (rec:Nat -> TpEnv -> TpDesc) (len:TpExpr Kind_nat) (n:Nat) (env:TpEnv) -> Tp_Vec (rec n env) (substTpExpr n env Kind_nat len)) + (\ (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) -> @@ -2627,7 +2652,12 @@ tpSubst n_top env_top T_top = (\ (U:TpDesc) -> U) (\ (ix':Nat) -> Tp_Var ix') (substVar n env Kind_Tp ix)) - (\ (n:Nat) (env:TpEnv) -> Tp_Void) + (\ (_: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 @@ -2729,6 +2759,7 @@ tpElemEnv env_top T_top = Sigma (kindElem K) (\ (v:kindElem K) -> rec (envConsElem K v env))) (\ (_:TpDesc) (rec:TpEnv -> sort 0) (len:TpExpr Kind_nat) (env:TpEnv) -> Vec (evalTpExpr env Kind_nat len) (rec env)) + (\ (_:TpEnv) -> Void) (\ (T:TpDesc) (rec:TpEnv -> sort 0) (env:TpEnv) -> indElem nilTpEnv (unfoldIndTpDesc env T)) (\ (var:Nat) (env:TpEnv) -> @@ -2736,7 +2767,12 @@ tpElemEnv env_top T_top = -- would not be an inductively smaller recursive call to take tpElem of -- the substitution instance indElem nilTpEnv (evalVar 0 env Kind_Tp var)) - (\ (_:TpEnv) -> Void) + (\ (_:TpDesc) (rec:TpEnv -> sort 0) (U:TpDesc) (_:TpEnv -> sort 0) + (env:TpEnv) -> + rec (envConsElem Kind_Tp (tpSubst 0 env U) env)) + (\ (_:TpDesc) (rec:TpEnv -> sort 0) (EK:ExprKind) (e:TpExpr EK) + (env:TpEnv) -> + rec (envConsElem (Kind_Expr EK) (evalTpExpr env EK e) env)) T_top env_top; -- Elements of a type description = elements relative to the empty environment @@ -2865,9 +2901,13 @@ specFun E env_top T_top = (U:TpDesc) (_:TpEnv -> sort 0) (env:TpEnv) -> #()) (\ (K:KindDesc) (T:TpDesc) (_:TpEnv -> sort 0) (env:TpEnv) -> #()) (\ (_:TpDesc) (_:TpEnv -> sort 0) (_:TpExpr Kind_nat) (env:TpEnv) -> #()) + (\ (_:TpEnv) -> #()) (\ (T:TpDesc) (_:TpEnv -> sort 0) (env:TpEnv) -> #()) (\ (var:Nat) (env:TpEnv) -> #()) - (\ (_:TpEnv) -> #()) + (\ (_:TpDesc) (_:TpEnv -> sort 0) (_:TpDesc) (_:TpEnv -> sort 0) + (_:TpEnv) -> #()) + (\ (_:TpDesc) (_:TpEnv -> sort 0) (EK:ExprKind) (e:TpExpr EK) (_:TpEnv) -> + #()) T_top env_top; -- Call a function index in a specification From 07b70ee27fa40f817fdafe7cd5f7ae33e6286cc0 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Tue, 17 Oct 2023 18:37:56 -0700 Subject: [PATCH 120/305] updated the translation of Crucible expressions --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 137 +++++++++--------- 1 file changed, 69 insertions(+), 68 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index f25c974ec5..a666f73314 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -5394,7 +5394,6 @@ translateLOwnedPermImpl err (mbMatch -> [nuMP| LocalPermImpl mb_impl |]) = return $ k e_ext' (impInfoToLOwned info_out) () -{- ---------------------------------------------------------------------- -- * Translating Typed Crucible Expressions ---------------------------------------------------------------------- @@ -5417,10 +5416,10 @@ instance TransInfo info => [nuMP| RegWithVal _ e |] -> translate e [nuMP| RegNoVal x |] -> translate x --- | Translate a 'RegWithVal' to exactly one SAW term via 'transPureTerm1' +-- | Translate a 'RegWithVal' to exactly one SAW term via 'transTerm1' translateRWV :: TransInfo info => Mb ctx (RegWithVal a) -> TransM info ctx OpenTerm -translateRWV mb_rwv = transPureTerm1 <$> translate mb_rwv +translateRWV mb_rwv = translate1 mb_rwv -- translate for a TypedExpr yields an ExprTrans instance (PermCheckExtC ext exprExt, TransInfo info) => @@ -5428,15 +5427,15 @@ instance (PermCheckExtC ext exprExt, TransInfo info) => translate mb_e = case mbMatch mb_e of [nuMP| BaseIsEq BaseBoolRepr e1 e2 |] -> ETrans_Term knownRepr <$> - applyMultiPureTransM (return $ globalOpenTerm "Prelude.boolEq") + applyMultiTransM (return $ globalOpenTerm "Prelude.boolEq") [translateRWV e1, translateRWV e2] -- [nuMP| BaseIsEq BaseNatRepr e1 e2 |] -> -- ETrans_Term <$> - -- applyMultiPureTransM (return $ globalOpenTerm "Prelude.equalNat") + -- applyMultiTransM (return $ globalOpenTerm "Prelude.equalNat") -- [translateRWV e1, translateRWV e2] [nuMP| BaseIsEq (BaseBVRepr w) e1 e2 |] -> ETrans_Term knownRepr <$> - applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvEq") + applyMultiTransM (return $ globalOpenTerm "Prelude.bvEq") [translate w, translateRWV e1, translateRWV e2] [nuMP| EmptyApp |] -> return ETrans_Unit @@ -5448,19 +5447,19 @@ instance (PermCheckExtC ext exprExt, TransInfo info) => return $ ETrans_Term knownRepr $ globalOpenTerm "Prelude.False" [nuMP| Not e |] -> ETrans_Term knownRepr <$> - applyMultiPureTransM (return $ globalOpenTerm "Prelude.not") + applyMultiTransM (return $ globalOpenTerm "Prelude.not") [translateRWV e] [nuMP| And e1 e2 |] -> ETrans_Term knownRepr <$> - applyMultiPureTransM (return $ globalOpenTerm "Prelude.and") + applyMultiTransM (return $ globalOpenTerm "Prelude.and") [translateRWV e1, translateRWV e2] [nuMP| Or e1 e2 |] -> ETrans_Term knownRepr <$> - applyMultiPureTransM (return $ globalOpenTerm "Prelude.or") + applyMultiTransM (return $ globalOpenTerm "Prelude.or") [translateRWV e1, translateRWV e2] [nuMP| BoolXor e1 e2 |] -> ETrans_Term knownRepr <$> - applyMultiPureTransM (return $ globalOpenTerm "Prelude.xor") + applyMultiTransM (return $ globalOpenTerm "Prelude.xor") [translateRWV e1, translateRWV e2] -- Natural numbers @@ -5468,32 +5467,32 @@ instance (PermCheckExtC ext exprExt, TransInfo info) => return $ ETrans_Term knownRepr $ natOpenTerm $ mbLift n [nuMP| NatLt e1 e2 |] -> ETrans_Term knownRepr <$> - applyMultiPureTransM (return $ globalOpenTerm "Prelude.ltNat") + applyMultiTransM (return $ globalOpenTerm "Prelude.ltNat") [translateRWV e1, translateRWV e2] -- [nuMP| NatLe _ _ |] -> [nuMP| NatEq e1 e2 |] -> ETrans_Term knownRepr <$> - applyMultiPureTransM (return $ globalOpenTerm "Prelude.equalNat") + applyMultiTransM (return $ globalOpenTerm "Prelude.equalNat") [translateRWV e1, translateRWV e2] [nuMP| NatAdd e1 e2 |] -> ETrans_Term knownRepr <$> - applyMultiPureTransM (return $ globalOpenTerm "Prelude.addNat") + applyMultiTransM (return $ globalOpenTerm "Prelude.addNat") [translateRWV e1, translateRWV e2] [nuMP| NatSub e1 e2 |] -> ETrans_Term knownRepr <$> - applyMultiPureTransM (return $ globalOpenTerm "Prelude.subNat") + applyMultiTransM (return $ globalOpenTerm "Prelude.subNat") [translateRWV e1, translateRWV e2] [nuMP| NatMul e1 e2 |] -> ETrans_Term knownRepr <$> - applyMultiPureTransM (return $ globalOpenTerm "Prelude.mulNat") + applyMultiTransM (return $ globalOpenTerm "Prelude.mulNat") [translateRWV e1, translateRWV e2] [nuMP| NatDiv e1 e2 |] -> ETrans_Term knownRepr <$> - applyMultiPureTransM (return $ globalOpenTerm "Prelude.divNat") + applyMultiTransM (return $ globalOpenTerm "Prelude.divNat") [translateRWV e1, translateRWV e2] [nuMP| NatMod e1 e2 |] -> ETrans_Term knownRepr <$> - applyMultiPureTransM (return $ globalOpenTerm "Prelude.modNat") + applyMultiTransM (return $ globalOpenTerm "Prelude.modNat") [translateRWV e1, translateRWV e2] -- Function handles: the expression part of a function handle has no @@ -5504,132 +5503,133 @@ 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 knownRepr $ + return $ ETrans_Term (BVRepr $ mbLift w) $ bvBVOpenTerm (mbLift w) $ BV.zero (mbLift w) [nuMP| BVLit w mb_bv |] -> - return $ ETrans_Term knownRepr $ 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 knownRepr <$> - applyMultiPureTransM (return $ globalOpenTerm "Prelude.join") + 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 knownRepr <$> - applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvTrunc") + 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 knownRepr <$> - applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvUExt") + 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 knownRepr <$> - applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvSExt") + 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 knownRepr <$> - applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvNot") + ETrans_Term (BVRepr $ mbLift w) <$> + applyMultiTransM (return $ globalOpenTerm "Prelude.bvNot") [translate w, translateRWV e] [nuMP| BVAnd w e1 e2 |] -> - ETrans_Term knownRepr <$> - applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvAnd") + ETrans_Term (BVRepr $ mbLift w) <$> + applyMultiTransM (return $ globalOpenTerm "Prelude.bvAnd") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVOr w e1 e2 |] -> - ETrans_Term knownRepr <$> - applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvOr") + ETrans_Term (BVRepr $ mbLift w) <$> + applyMultiTransM (return $ globalOpenTerm "Prelude.bvOr") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVXor w e1 e2 |] -> - ETrans_Term knownRepr <$> - applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvXor") + ETrans_Term (BVRepr $ mbLift w) <$> + applyMultiTransM (return $ globalOpenTerm "Prelude.bvXor") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVNeg w e |] -> - ETrans_Term knownRepr <$> - applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvNeg") + ETrans_Term (BVRepr $ mbLift w) <$> + applyMultiTransM (return $ globalOpenTerm "Prelude.bvNeg") [translate w, translateRWV e] [nuMP| BVAdd w e1 e2 |] -> - ETrans_Term knownRepr <$> - applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvAdd") + ETrans_Term (BVRepr $ mbLift w) <$> + applyMultiTransM (return $ globalOpenTerm "Prelude.bvAdd") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVSub w e1 e2 |] -> - ETrans_Term knownRepr <$> - applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvSub") + ETrans_Term (BVRepr $ mbLift w) <$> + applyMultiTransM (return $ globalOpenTerm "Prelude.bvSub") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVMul w e1 e2 |] -> - ETrans_Term knownRepr <$> - applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvMul") + ETrans_Term (BVRepr $ mbLift w) <$> + applyMultiTransM (return $ globalOpenTerm "Prelude.bvMul") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVUdiv w e1 e2 |] -> - ETrans_Term knownRepr <$> - applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvUDiv") + ETrans_Term (BVRepr $ mbLift w) <$> + applyMultiTransM (return $ globalOpenTerm "Prelude.bvUDiv") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVSdiv w e1 e2 |] -> - ETrans_Term knownRepr <$> - applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvSDiv") + ETrans_Term (BVRepr $ mbLift w) <$> + applyMultiTransM (return $ globalOpenTerm "Prelude.bvSDiv") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVUrem w e1 e2 |] -> - ETrans_Term knownRepr <$> - applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvURem") + ETrans_Term (BVRepr $ mbLift w) <$> + applyMultiTransM (return $ globalOpenTerm "Prelude.bvURem") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVSrem w e1 e2 |] -> - ETrans_Term knownRepr <$> - applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvSRem") + ETrans_Term (BVRepr $ mbLift w) <$> + applyMultiTransM (return $ globalOpenTerm "Prelude.bvSRem") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVUle w e1 e2 |] -> ETrans_Term knownRepr <$> - applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvule") + applyMultiTransM (return $ globalOpenTerm "Prelude.bvule") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVUlt w e1 e2 |] -> ETrans_Term knownRepr <$> - applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvult") + applyMultiTransM (return $ globalOpenTerm "Prelude.bvult") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVSle w e1 e2 |] -> ETrans_Term knownRepr <$> - applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvsle") + applyMultiTransM (return $ globalOpenTerm "Prelude.bvsle") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVSlt w e1 e2 |] -> ETrans_Term knownRepr <$> - applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvslt") + applyMultiTransM (return $ globalOpenTerm "Prelude.bvslt") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVCarry w e1 e2 |] -> ETrans_Term knownRepr <$> - applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvCarry") + applyMultiTransM (return $ globalOpenTerm "Prelude.bvCarry") [translate w, translateRWV e1, translateRWV e2] [nuMP| BVSCarry w e1 e2 |] -> -- NOTE: bvSCarry adds 1 to the bitvector length let w_minus_1 = natOpenTerm (natValue (mbLift w) - 1) in ETrans_Term knownRepr <$> - applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvSCarry") + applyMultiTransM (return $ globalOpenTerm "Prelude.bvSCarry") [return w_minus_1, translateRWV e1, translateRWV e2] [nuMP| BVSBorrow w e1 e2 |] -> -- NOTE: bvSBorrow adds 1 to the bitvector length let w_minus_1 = natOpenTerm (natValue (mbLift w) - 1) in ETrans_Term knownRepr <$> - applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvSBorrow") + applyMultiTransM (return $ globalOpenTerm "Prelude.bvSBorrow") [return w_minus_1, translateRWV e1, translateRWV e2] [nuMP| BVShl w e1 e2 |] -> - ETrans_Term knownRepr <$> - applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvShiftL") + 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 knownRepr <$> - applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvShiftR") + 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 knownRepr <$> - applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvSShiftR") + 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 knownRepr <$> - applyMultiPureTransM (return $ globalOpenTerm "Prelude.ite") + ETrans_Term (BVRepr w) <$> + applyMultiTransM (return $ globalOpenTerm "Prelude.ite") [bitvectorTransM (translate mb_w), translateRWV e, return (bvBVOpenTerm w (BV.one w)), @@ -5637,8 +5637,8 @@ instance (PermCheckExtC ext exprExt, TransInfo info) => [nuMP| BVNonzero mb_w e |] -> let w = mbLift mb_w in ETrans_Term knownRepr <$> - applyPureTransM (return $ globalOpenTerm "Prelude.not") - (applyMultiPureTransM (return $ globalOpenTerm "Prelude.bvEq") + applyTransM (return $ globalOpenTerm "Prelude.not") + (applyMultiTransM (return $ globalOpenTerm "Prelude.bvEq") [translate mb_w, translateRWV e, return (bvBVOpenTerm w (BV.zero w))]) @@ -5669,6 +5669,7 @@ exprOutPerm mb_x = case mbMatch mb_x of [nuMP| TypedExpr _ Nothing |] -> PTrans_True +{- ---------------------------------------------------------------------- -- * Translating Typed Crucible Jump Targets ---------------------------------------------------------------------- From 6d2398ed72ed26bcac2ec1330de8e841e31970ac Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 18 Oct 2023 07:18:58 -0700 Subject: [PATCH 121/305] updated the translation of jump targets and statements --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 60 +++++++++---------- 1 file changed, 30 insertions(+), 30 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index a666f73314..06d8ebdd3b 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -5669,7 +5669,6 @@ exprOutPerm mb_x = case mbMatch mb_x of [nuMP| TypedExpr _ Nothing |] -> PTrans_True -{- ---------------------------------------------------------------------- -- * Translating Typed Crucible Jump Targets ---------------------------------------------------------------------- @@ -5716,7 +5715,7 @@ translateCallEntry :: forall ext exprExt tops args ghosts blocks ctx rets. Mb ctx (RAssign ExprVar (tops :++: args)) -> Mb ctx (RAssign ExprVar ghosts) -> ImpTransM ext blocks tops rets - ((tops :++: args) :++: ghosts) ctx SpecTerm + ((tops :++: args) :++: ghosts) ctx OpenTerm translateCallEntry nm entry_trans mb_tops_args mb_ghosts = -- First test that the stack == the required perms for entryID do let entry = typedEntryTransEntry entry_trans @@ -5730,17 +5729,18 @@ translateCallEntry nm entry_trans mb_tops_args mb_ghosts = typedEntryPermsIn entry) mb_s () <- assertPermStackEqM nm mb_perms - -- Now check if entryID has an associated recursive closure + -- Now check if entryID has an associated recursive function index case typedEntryTransClos entry_trans of - Just (lrt, clos_tm) -> - -- If so, build the associated CallS term, which applies the closure to - -- the expressions with permissions on the stack followed by the proofs - -- objects for those permissions - do expr_ctx <- itiExprCtx <$> ask + Just (d, funix) -> + -- If so, build the associated CallS term, which applies the function + -- index to the expressions with permissions on the stack followed by + -- the proof objects for those permissions + do ev <- infoEvType <$> ask + expr_ctx <- itiExprCtx <$> ask arg_membs <- itiPermStackVars <$> ask let e_args = RL.map (flip RL.get expr_ctx) arg_membs i_args <- itiPermStack <$> ask - return (applyCallClosSpecTerm lrt clos_tm + return (callSOpenTerm ev d funix (exprCtxToTerms e_args ++ permCtxToTerms i_args)) Nothing -> -- Otherwise, continue translating with the target entrypoint, with all @@ -5755,7 +5755,7 @@ translateCallEntry nm entry_trans mb_tops_args mb_ghosts = instance PermCheckExtC ext exprExt => Translate (ImpTransInfo ext blocks tops rets ps) ctx - (CallSiteImplRet blocks tops args ghosts ps) SpecTerm where + (CallSiteImplRet blocks tops args ghosts ps) OpenTerm where translate (mbMatch -> [nuMP| CallSiteImplRet entryID ghosts Refl mb_tavars mb_gvars |]) = do entry_trans <- @@ -5771,7 +5771,7 @@ instance PermCheckExtC ext exprExt => instance PermCheckExtC ext exprExt => Translate (ImpTransInfo ext blocks tops rets ps) ctx - (TypedJumpTarget blocks tops ps) SpecTerm where + (TypedJumpTarget blocks tops ps) OpenTerm where translate (mbMatch -> [nuMP| TypedJumpTarget siteID _ _ mb_perms_in |]) = do SomeTypedCallSite site <- lookupCallSite (mbLift siteID) <$> itiBlockMapTrans <$> ask @@ -5792,8 +5792,8 @@ instance PermCheckExtC ext exprExt => translateStmt :: PermCheckExtC ext exprExt => ProgramLoc -> Mb ctx (TypedStmt ext stmt_rets ps_in ps_out) -> - ImpTransM ext blocks tops rets ps_out (ctx :++: stmt_rets) SpecTerm -> - ImpTransM ext blocks tops rets ps_in ctx SpecTerm + ImpTransM ext blocks tops rets ps_out (ctx :++: stmt_rets) OpenTerm -> + ImpTransM ext blocks tops rets ps_in ctx OpenTerm translateStmt loc mb_stmt m = case mbMatch mb_stmt of [nuMP| TypedSetReg tp e |] -> do tp_trans <- translate tp @@ -5825,17 +5825,14 @@ translateStmt loc mb_stmt m = case mbMatch mb_stmt of let (pctx_ghosts_args, _) = RL.split (RL.append ectx_gexprs ectx_args) ectx_gexprs pctx_in fret_tp <- - mkTermTypeTrans <$> - sigmaTypeTransM "ret" rets_trans (hasPureTrans perms_out) - (\ectx -> inExtMultiTransM ectx (typeTransTupleDesc <$> - translate perms_out)) + openTermTypeTrans <$> + sigmaTypeTransM "ret" rets_trans + (\ectx -> inExtMultiTransM ectx (translate perms_out)) let all_args = exprCtxToTerms ectx_gexprs ++ exprCtxToTerms ectx_args ++ permCtxToTerms pctx_ghosts_args - fun_tp_desc <- descTransM (translateDesc fun_perm) - fapp_trm <- case f_trans of - PTrans_Fun _ f_trm -> - applyEvOpM "Prelude.CallS" [fun_tp_desc, f_trm] + let fapp_trm = case f_trans of + PTrans_Fun _ f_trm -> applyFunTransTerm f_trm all_args _ -> panic "translateStmt" ["TypedCall: unexpected function permission"] @@ -5868,8 +5865,8 @@ translateStmt loc mb_stmt m = case mbMatch mb_stmt of -- | Translate a 'TypedStmt' to a function on translation computations translateLLVMStmt :: Mb ctx (TypedLLVMStmt r ps_in ps_out) -> - ImpTransM ext blocks tops rets ps_out (ctx :> r) SpecTerm -> - ImpTransM ext blocks tops rets ps_in ctx SpecTerm + ImpTransM ext blocks tops rets ps_out (ctx :> r) OpenTerm -> + ImpTransM ext blocks tops rets ps_in ctx OpenTerm translateLLVMStmt mb_stmt m = case mbMatch mb_stmt of [nuMP| ConstructLLVMWord (TypedReg x) |] -> inExtTransM ETrans_LLVM $ @@ -5996,13 +5993,14 @@ translateLLVMStmt mb_stmt m = case mbMatch mb_stmt of ++ globalSymbolName (mbLift gsym)] Just (_, GlobalTransFuns [f]) | [nuP| ValPerm_LLVMFunPtr fun_tp (ValPerm_Fun fun_perm) |] <- p -> - do d <- descTransM <$> translateDesc (extMb fun_perm) + do d <- descTransM $ translateDesc (extMb fun_perm) let ptrans = PTrans_Conj [APTrans_LLVMFunPtr (mbLift fun_tp) $ PTrans_Fun fun_perm $ FunTransFun ev d f] withPermStackM (:>: Member_Base) (:>: extPermTrans ETrans_LLVM ptrans) m - Just (_, GlobalTransFun _) -> + Just (_, GlobalTransFuns _) -> + -- FIXME: make this handle multiple function translations panic "translateLLVMStmt" ["TypedLLVMResolveGlobal: unexpected function translation for symbol " ++ globalSymbolName (mbLift gsym)] @@ -6029,9 +6027,10 @@ translateLLVMStmt mb_stmt m = case mbMatch mb_stmt of instance PermCheckExtC ext exprExt => Translate (ImpTransInfo ext blocks tops rets ps) ctx - (TypedRet tops rets ps) SpecTerm where + (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 @@ -6045,7 +6044,7 @@ instance PermCheckExtC ext exprExt => (flip inExtMultiTransM $ translate $ mbCombine rets_prxs mb_perms) rets_ns_trans (itiPermStack <$> ask) - return $ returnSpecTerm ret_tp sigma_trm + return $ retSOpenTerm ev ret_tp sigma_trm instance PermCheckExtC ext exprExt => ImplTranslateF (TypedRet tops rets) ext blocks tops rets where @@ -6053,7 +6052,7 @@ instance PermCheckExtC ext exprExt => instance PermCheckExtC ext exprExt => Translate (ImpTransInfo ext blocks tops rets ps) ctx - (TypedTermStmt blocks tops rets ps) SpecTerm where + (TypedTermStmt blocks tops rets ps) OpenTerm where translate mb_x = case mbMatch mb_x of [nuMP| TypedJump impl_tgt |] -> translate impl_tgt [nuMP| TypedBr reg impl_tgt1 impl_tgt2 |] -> @@ -6069,7 +6068,7 @@ instance PermCheckExtC ext exprExt => instance PermCheckExtC ext exprExt => Translate (ImpTransInfo ext blocks tops rets ps) ctx - (TypedStmtSeq ext blocks tops rets ps) SpecTerm where + (TypedStmtSeq ext blocks tops rets ps) OpenTerm where translate mb_x = case mbMatch mb_x of [nuMP| TypedImplStmt impl_seq |] -> translate impl_seq [nuMP| TypedConsStmt loc stmt pxys mb_seq |] -> @@ -6082,6 +6081,7 @@ instance PermCheckExtC ext exprExt => translateF mb_seq = translate mb_seq +{- ---------------------------------------------------------------------- -- * Translating CFGs ---------------------------------------------------------------------- From efde48fea68e2b8f76fa23c205793ec3bae7fb36 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 18 Oct 2023 07:51:42 -0700 Subject: [PATCH 122/305] whoops, just realized that lownedTransTerm needs to partially apply its function to the existing ps_extra --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 33 ++++++++++++++----- 1 file changed, 25 insertions(+), 8 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 06d8ebdd3b..e62df07254 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -2672,6 +2672,24 @@ idLOwnedTransTerm dtr_out vars_out = descTypeTransF (fmap (extPermTransCtxMulti ctx') dtr_out) (transTerms (lownedInfoPCtx 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) @@ -2763,20 +2781,19 @@ weakenLOwnedTrans tp_in tp_out (LOwnedTrans {..}) = lotrTpTransOut = liftA2 (:>:) lotrTpTransOut tp_out, lotrTerm = weakenLOwnedTransTerm tp_out lotrTerm, .. } --- | Convert an 'LOwnedTrans' to a closure that gets added to the list of --- closures for the current spec definition, and partially apply that closure to --- the current expression context and its @ps_extra@ terms +-- | Convert an 'LOwnedTrans' to a function index from @ps_in@ to @ps_out@ by +-- partially applying its function to the @ps_extra@ permissions it already +-- contains and then applying the @LambdaS@ spec combinator lownedTransTerm :: Mb ctx (ExprPerms ps_in) -> LOwnedTrans ctx ps_extra ps_in ps_out -> OpenTerm lownedTransTerm (mbExprPermsMembers -> Just vars_in) lotr = - let tps_extra_in = - liftA2 RL.append (lotrTpTransExtra lotr) (lotrTpTransIn lotr) - vars_extra_in = RL.append (lotrVarsExtra lotr) vars_in - d = arrowDescTrans tps_extra_in (lotrTpTransOut lotr) in + let d = arrowDescTrans (lotrTpTransIn lotr) (lotrTpTransOut lotr) + f = applyLOwnedTransTerm Proxy + (lotrPsExtra lotr) (lotrVarsExtra lotr) (lotrTerm lotr) in applyGlobalOpenTerm "Prelude.LambdaS" [evTypeTerm (lotrEvType lotr), d, lownedTransTermFun (lotrEvType lotr) (lotrECtx lotr) - vars_extra_in tps_extra_in (lotrTpTransOut lotr) (lotrTerm lotr)] + vars_in (lotrTpTransIn lotr) (lotrTpTransOut lotr) f] lownedTransTerm _ _ = failOpenTerm "FIXME HERE NOW: write this error message" From 12f626f0fae14ded299cef4b97ec74e0fa6dcd33 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 18 Oct 2023 17:27:59 -0700 Subject: [PATCH 123/305] changed the MultiFixBodies type to a single function type over all the function indexes that returns a tuple of all the specFuns, instead of a tuple of functions over the function indexes --- saw-core/prelude/Prelude.sawcore | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/saw-core/prelude/Prelude.sawcore b/saw-core/prelude/Prelude.sawcore index 29ec567cc0..b9cbccdf4b 100644 --- a/saw-core/prelude/Prelude.sawcore +++ b/saw-core/prelude/Prelude.sawcore @@ -2930,18 +2930,18 @@ arrowIxs Ts_top a = (\ (T:TpDesc) (_:List TpDesc) (rec:sort 0) -> FunIx T -> rec) Ts_top; --- The type of a tuple of spec functions of types Us that take in FunIxs for Ts -arrowIxsSpecFuns : EvType -> List TpDesc -> List TpDesc -> sort 0; -arrowIxsSpecFuns E Ts Us = +-- 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) #() - (\ (U:TpDesc) (_:List TpDesc) (rec:sort 0) -> - arrowIxs Ts (specFun E nilTpEnv U) * rec) - Us; + (\ (T:TpDesc) (_:List TpDesc) (rec:sort 0) -> + specFun E nilTpEnv T * rec) + Ts; -- 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 = arrowIxsSpecFuns E Ts Ts; +MultiFixBodies E Ts = arrowIxs 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 From a533489b6be04fb29ad24fd442931ded9ff81df1 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 18 Oct 2023 18:38:45 -0700 Subject: [PATCH 124/305] small tweak to the type of LetRecS --- saw-core/prelude/Prelude.sawcore | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/saw-core/prelude/Prelude.sawcore b/saw-core/prelude/Prelude.sawcore index b9cbccdf4b..0b69477138 100644 --- a/saw-core/prelude/Prelude.sawcore +++ b/saw-core/prelude/Prelude.sawcore @@ -2949,10 +2949,9 @@ primitive MultiFixS : (E:EvType) -> (Ts:List TpDesc) -> MultiFixBodies E Ts -> SpecM E (FunIxs Ts); -- Perform a computation that can call a collection of corecursive functions -LetRecS : (E:EvType) -> (Ts:List TpDesc) -> (a:sort 0) -> - MultiFixBodies E Ts -> (FunIxs Ts -> SpecM E a) -> SpecM E a; -LetRecS E Ts a funs body = bindS E (FunIxs Ts) a (MultiFixS E Ts funs) body; - +primitive LetRecS : (E:EvType) -> (Ts:List TpDesc) -> (a:sort 0) -> + MultiFixBodies E Ts -> (arrowIxs Ts (SpecM E a)) -> + SpecM E a; -- -- Helper operations on SpecM From b615ddbffaab265ab29637657c439214f6c63a6d Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 18 Oct 2023 18:51:55 -0700 Subject: [PATCH 125/305] finished updating the translation of CFGs to the new SpecM monad --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 302 +++++++++--------- 1 file changed, 158 insertions(+), 144 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index e62df07254..60dd586c5b 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -133,6 +133,12 @@ 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 the type @FunIx T@ from a type description @T@ funIxTypeOpenTerm :: OpenTerm -> OpenTerm funIxTypeOpenTerm t = applyGlobalOpenTerm "Prelude.FunIx" [t] @@ -346,6 +352,14 @@ callSOpenTerm :: EventType -> OpenTerm -> OpenTerm -> [OpenTerm] -> OpenTerm callSOpenTerm ev d ix args = applyGlobalOpenTerm "Prelude.CallS" ([evTypeTerm ev, d, ix] ++ args) +-- | 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 "Prelude.LetRecS" + [evTypeTerm ev, listOpenTerm tpDescTypeOpenTerm ds, ret_tp, bodies, body] + ---------------------------------------------------------------------- -- * Type Translations @@ -1270,6 +1284,15 @@ lambdaExprCtx ctx m = translateClosed ctx >>= \tptrans -> lambdaTransM "e" tptrans (\ectx -> inCtxTransM ectx m) +-- | Translate all types in a Crucible context and lambda-abstract over them, +-- appending them to the existing context +lambdaExprCtxApp :: TransInfo info => CruCtx ctx2 -> + TransM info (ctx1 :++: ctx2) OpenTerm -> + TransM info ctx1 OpenTerm +lambdaExprCtxApp ctx m = + translateClosed ctx >>= \tptrans -> + lambdaTransM "e" tptrans (\ectx -> inExtMultiTransM ectx m) + -- | Translate all types in a Crucible context and pi-abstract over them piExprCtx :: TransInfo info => CruCtx ctx -> TransM info ctx OpenTerm -> TransM info RNil OpenTerm @@ -3119,7 +3142,10 @@ instance TranslateDescs (ExprPerms ps) where "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 -> @@ -3137,6 +3163,9 @@ instance TransInfo info => 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 |]) = @@ -3213,7 +3242,7 @@ translateEntryRetType (TypedEntry {..} data TypedEntryTrans ext blocks tops rets args ghosts = TypedEntryTrans { typedEntryTransEntry :: TypedEntry TransPhase ext blocks tops rets args ghosts, - typedEntryTransClos :: Maybe (OpenTerm, OpenTerm) } + typedEntryTransIx :: Maybe (OpenTerm, OpenTerm) } -- | A mapping from a block to the SAW functions for each entrypoint data TypedBlockTrans ext blocks tops rets args = @@ -5747,7 +5776,7 @@ translateCallEntry nm entry_trans mb_tops_args mb_ghosts = () <- assertPermStackEqM nm mb_perms -- Now check if entryID has an associated recursive function index - case typedEntryTransClos entry_trans of + case typedEntryTransIx entry_trans of Just (d, funix) -> -- If so, build the associated CallS term, which applies the function -- index to the expressions with permissions on the stack followed by @@ -6098,7 +6127,6 @@ instance PermCheckExtC ext exprExt => translateF mb_seq = translate mb_seq -{- ---------------------------------------------------------------------- -- * Translating CFGs ---------------------------------------------------------------------- @@ -6108,11 +6136,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 closures, --- which is all entrypoints with in-degree > 1 -typedBlockClosEntries :: TypedBlockMap TransPhase ext blocks tops rets -> - [SomeTypedEntry ext blocks tops rets] -typedBlockClosEntries = +-- | Get all entrypoints in a block map that will be translated to function +-- indices, which is all entrypoints with in-degree > 1 +typedBlockIxEntries :: TypedBlockMap TransPhase ext blocks tops rets -> + [SomeTypedEntry ext blocks tops rets] +typedBlockIxEntries = concat . RL.mapToList (map (\(Some entry) -> SomeTypedEntry entry) . filter (anyF typedEntryHasMultiInDegree) @@ -6120,145 +6148,163 @@ typedBlockClosEntries = -- | Fold a function over each 'TypedEntry' in a 'TypedBlockMap' that -- corresponds to a letrec-bound variable -foldBlockMapClos :: +foldBlockMapIx :: (forall args ghosts. TypedEntry TransPhase ext blocks tops rets args ghosts -> b -> b) -> b -> TypedBlockMap TransPhase ext blocks tops rets -> b -foldBlockMapClos f r = - foldr (\(SomeTypedEntry entry) -> f entry) r . typedBlockClosEntries +foldBlockMapIx f r = + foldr (\(SomeTypedEntry entry) -> f entry) r . typedBlockIxEntries -- | Map a function over each 'TypedEntry' in a 'TypedBlockMap' that -- corresponds to a letrec-bound variable -mapBlockMapClos :: +mapBlockMapIx :: (forall args ghosts. TypedEntry TransPhase ext blocks tops rets args ghosts -> b) -> TypedBlockMap TransPhase ext blocks tops rets -> [b] -mapBlockMapClos f = - map (\(SomeTypedEntry entry) -> f entry) . typedBlockClosEntries - --- | Build a @LetRecType@ that describes the type of the translation of a --- 'TypedEntry' to a closure -translateEntryLRT :: TypedEntry TransPhase ext blocks tops rets args ghosts -> - TypeTransM ctx OpenTerm -translateEntryLRT entry@(TypedEntry {..}) = - inEmptyCtxTransM $ - translateClosed (typedEntryAllArgs entry) >>= \arg_tps -> - piLRTTransM "arg" arg_tps $ \ectx -> - inCtxTransM ectx $ - translate typedEntryPermsIn >>= \perms_in_tps -> - arrowLRTTransM perms_in_tps $ - translateEntryRetType entry >>= \retType -> - return $ ctorOpenTerm "Prelude.LRT_Ret" [typeDescLRT retType] - --- | Build a list of @LetRecType@ values that describe the types of all of the --- entrypoints in a 'TypedBlockMap' that will be translated to closures -translateBlockMapLRTs :: TypedBlockMap TransPhase ext blocks tops rets -> - TypeTransM ctx [OpenTerm] -translateBlockMapLRTs blkMap = - sequence $ mapBlockMapClos translateEntryLRT blkMap - --- | Translate the function permission of a CFG to a @LetRecType@ -translateCFGLRT :: TypedCFG ext blocks ghosts inits gouts ret -> - TypeTransM ctx OpenTerm -translateCFGLRT cfg = - typeDescLRT <$> translateClosed (tpcfgFunPerm cfg) - --- | Translate a 'TypedEntry' to a 'TypedEntryTrans' by associating a closure --- term with it if it has one, i.e., if its in-degree is greater than 1. If it --- does need a closure, the 'Natural' state tracks the index to be used for the --- next closure, so use the current value and increment it. --- --- Note that the return type is a monad inside a monad. This is so that the --- caller can see the 'Natural' state without running the 'TypeTransM' --- computation, which is necessary later on for tying the knot +mapBlockMapIx f = + map (\(SomeTypedEntry entry) -> f entry) . typedBlockIxEntries + +-- | Build a type description for the type of the translation of a 'TypedEntry' +-- to a function. This type will pi-abstract over the real and ghost arguments +-- of the entrypoint, but should have exactly the top-level arguments +-- of the function free. +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) $ + arrowTpDescMulti ds_in d_out + +-- | Build a list of type descriptions that describe the types of all of the +-- entrypoints in a 'TypedBlockMap' that will be translated to functions +translateBlockMapDescs :: TypedBlockMap TransPhase ext blocks tops rets -> + TypeTransM tops [OpenTerm] +translateBlockMapDescs blkMap = + sequence $ mapBlockMapIx 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 function +-- index term with it if it has one, i.e., if its in-degree is greater than 1. +-- The state tracks all the @LetRecS@-bound function indexes for entrypoints +-- that have not already been used, so if this 'TypedEntry' does need a function +-- index, it should take it from the head of that list. translateTypedEntry :: Some (TypedEntry TransPhase ext blocks tops rets args) -> - State Natural (TypeTransM RNil (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 $ do lrt <- translateEntryLRT entry - return (Some (TypedEntryTrans entry $ - Just (lrt, mkBaseClosSpecTerm i))) - else return $ return $ Some (TypedEntryTrans entry Nothing) + do ixs <- get + let ix = + case ixs of + [] -> panic "translateTypedEntry" ["Ran out of function indices"] + _ -> head ixs + put $ tail ixs + d <- lift $ translateEntryDesc entry + return (Some (TypedEntryTrans entry $ Just (d, ix))) + else return $ Some (TypedEntryTrans entry Nothing) -- | Translate a 'TypedBlock' to a 'TypedBlockTrans' by translating each --- entrypoint in the block using 'translateTypedEntry'; see --- 'translateTypedEntry' for an explanation of the monad-in-monad type +-- entrypoint in the block using 'translateTypedEntry' translateTypedBlock :: TypedBlock TransPhase ext blocks tops rets args -> - State Natural (TypeTransM RNil (TypedBlockTrans ext blocks tops rets args)) + StateT [OpenTerm] (TypeTransM tops) (TypedBlockTrans ext blocks tops rets args) translateTypedBlock blk = - (TypedBlockTrans <$>) <$> sequence <$> - mapM translateTypedEntry (blk ^. typedBlockEntries) + TypedBlockTrans <$> mapM translateTypedEntry (blk ^. typedBlockEntries) -- | Helper function to translate a 'TypedBlockMap' to a 'TypedBlockMapTrans' by --- translating every entrypoint using 'translateTypedEntry'; see --- 'translateTypedEntry' for an explanation of the monad-in-monad type +-- translating every entrypoint using 'translateTypedEntry' translateTypedBlockMapH :: RAssign (TypedBlock TransPhase ext blocks tops rets) blks -> - State Natural (TypeTransM RNil - (RAssign (TypedBlockTrans ext blocks tops rets) blks)) -translateTypedBlockMapH MNil = return $ return MNil + StateT [OpenTerm] (TypeTransM tops) (RAssign + (TypedBlockTrans ext blocks tops rets) blks) +translateTypedBlockMapH MNil = return MNil translateTypedBlockMapH (blkMap :>: blk) = - do blkMapTransM <- translateTypedBlockMapH blkMap - blkTransM <- translateTypedBlock blk - return ((:>:) <$> blkMapTransM <*> blkTransM) + do blkMapTrans <- translateTypedBlockMapH blkMap + blkTrans <- translateTypedBlock blk + return (blkMapTrans :>: blkTrans) -- | Translate a 'TypedBlockMap' to a 'TypedBlockMapTrans' by translating every -- entrypoint using 'translateTypedEntry'; see 'translateTypedEntry' for an -- explanation of the monad-in-monad type translateTypedBlockMap :: - TypedBlockMap TransPhase ext blocks tops rets -> - State Natural (TypeTransM RNil (TypedBlockMapTrans ext blocks tops rets)) -translateTypedBlockMap = translateTypedBlockMapH + [OpenTerm] -> TypedBlockMap TransPhase ext blocks tops rets -> + TypeTransM tops (TypedBlockMapTrans ext blocks tops rets) +translateTypedBlockMap ixs blkMap = + runStateT (translateTypedBlockMapH blkMap) ixs >>= \case + (ret, []) -> return ret + (_, _) -> panic "translateTypedBlockMap" ["Unused function indices"] + +-- | Lambda-abstract over function indexes for all the entrypoints that have one +-- in a 'TypedBlockMap', whose type descriptions are given as the first +-- argument, and then use those function indexes 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_ds blkMap f = + lambdaTransM "f" (openTermsTypeTrans $ + map funIxTypeOpenTerm blk_ds) $ \funixs -> + translateTypedBlockMap funixs 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 => TypedBlockMapTrans ext blocks tops rets -> TypedEntry TransPhase ext blocks tops rets args ghosts -> - TypeTransM RNil SpecTerm + TypeTransM tops OpenTerm translateEntryBody mapTrans entry = - lambdaExprCtx (typedEntryAllArgs entry) $ + lambdaExprCtxApp (typedEntryArgs entry) $ + lambdaExprCtxApp (typedEntryGhosts entry) $ lambdaPermCtx (typedEntryPermsIn entry) $ \pctx -> do retType <- translateEntryRetType entry impTransM (RL.members pctx) pctx mapTrans retType $ translate $ _mbBinding $ typedEntryBody entry -- | Translate all the entrypoints in a 'TypedBlockMap' that translate to --- closures into the @LetRecType@s and bodies of those closures +-- 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, SpecTerm)] + TypeTransM tops [OpenTerm] translateBlockMapBodies mapTrans blkMap = - sequence $ mapBlockMapClos (\entry -> - (,) <$> translateEntryLRT entry <*> - translateEntryBody mapTrans entry) blkMap + sequence $ mapBlockMapIx (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; this monadic --- function is used as the body of one of the closures used to translate the CFG +-- 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 SpecTerm + TypeTransM (ghosts :++: inits) OpenTerm translateCFGInitBody mapTrans cfg = 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 -> -- Extend the expr context to contain another copy of the initial arguments @@ -6276,65 +6322,33 @@ translateCFGInitBody mapTrans cfg = translateCallEntry "CFG" init_entry (nuMulti all_px id) (nuMulti all_px $ const MNil) --- | Translate a CFG to a monadic function that passes all of its arguments to --- the closure with the given index, which is meant to be the closure whose body --- is defined by 'translateCFGInitBody' -translateCFGIxCall :: TypedCFG ext blocks ghosts inits gouts ret -> Natural -> - TypeTransM RNil SpecTerm -translateCFGIxCall cfg ix = - do let fun_perm = tpcfgFunPerm cfg - h = tpcfgHandle cfg - ctx = typedFnHandleAllArgs h - lrt <- translateCFGLRT cfg - lambdaExprCtx ctx $ lambdaPermCtx (funPermIns fun_perm) $ \pctx -> - (infoCtx <$> ask) >>= \ectx -> - return $ - applyCallClosSpecTerm lrt (mkBaseClosSpecTerm ix) (transTerms ectx ++ - transTerms pctx) - --- | The components of the spec definition that a CFG translates to. Note that, --- if the CFG is for a function that is mutually recursive with other functions, --- then it also needs the closures of those functions in its spec definition. -data CFGTrans = - CFGTrans { cfgTransLRT :: OpenTerm, - cfgTransCloss :: [(OpenTerm,SpecTerm)], - cfgTransBody :: SpecTerm } - --- | Translate a CFG to a list of closure definitions, represented as a pair of --- a @LetRecType@ and a monadic function of that @LetRecType@. These closures --- are for the CFG itself and for all of its entrypoints that are translated to --- closures, i.e., with in-degree > 1. Use the current 'Natural' in the 'State' --- monad as the starting index for these closures, and increment that 'Natural' --- state for each closure body returned. Also return the 'Natural' index used --- for the closure for the entire CFG. See 'translateTypedEntry' for an --- explanation of the monad-in-monad type. + +-- | 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 +-- function indices have been bound for the function itself and any other +-- functions it is mutually recursive with, and that these function indexes are +-- in the current permissions environment. translateCFG :: PermCheckExtC ext exprExt => TypedCFG ext blocks ghosts inits gouts ret -> - State Natural (Natural, TypeTransM RNil CFGTrans) + TypeTransM RNil OpenTerm translateCFG cfg = - do let blkMap = tpcfgBlockMap cfg - -- Get the natural number index for the top-level closure of the CFG - cfg_ix <- get - put (cfg_ix + 1) - -- Translate the block map of the CFG by generating calls to closures for - -- all the entrypoints with in-degree > 1 - mapTransM <- translateTypedBlockMap blkMap - -- Return the CFG index and the computation for creating the bodies - return - (cfg_ix, - do mapTrans <- mapTransM - -- Generate the actual closure bodies + LRTs for those entrypoints - closs <- translateBlockMapBodies mapTrans blkMap - -- Generate the closure body + LRT for the entire CFG - cfg_clos_body <- translateCFGInitBody mapTrans cfg - cfg_lrt <- translateCFGLRT cfg - let cfg_clos = (cfg_lrt,cfg_clos_body) - -- Generate the body of the CFG, that calls the cfg_body closure - cfg_body <- translateCFGIxCall cfg cfg_ix - -- Then, finally, return all the closure lrts and bodies - return $ CFGTrans cfg_lrt (cfg_clos : closs) cfg_body) + let fun_perm = tpcfgFunPerm cfg + blkMap = tpcfgBlockMap cfg in + piExprCtx (funPermTops fun_perm) $ + do ev <- infoEvType <$> ask + blk_ds <- translateBlockMapDescs $ tpcfgBlockMap cfg + ret_tp <- translateRetType (funPermRets fun_perm) (funPermOuts fun_perm) + bodies <- + lambdaBlockMap blk_ds blkMap $ \mapTrans -> + tupleOpenTerm <$> translateBlockMapBodies mapTrans blkMap + body <- + lambdaBlockMap blk_ds blkMap $ \mapTrans -> + translateCFGInitBody mapTrans cfg + return $ letRecSOpenTerm ev blk_ds ret_tp bodies body +{- ---------------------------------------------------------------------- -- * Translating Sets of CFGs ---------------------------------------------------------------------- From e0c14e02f8b744674cc3058a25c4f8d994ce1ff4 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Thu, 19 Oct 2023 17:03:34 -0400 Subject: [PATCH 126/305] always unfold assumingS, assertingS in normComp --- cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs | 2 +- src/SAWScript/Prover/MRSolver/Solver.hs | 8 +++++--- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs b/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs index f730af09e6..b6702e8dfb 100644 --- a/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs +++ b/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs @@ -1548,7 +1548,7 @@ 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)) $ + -- trace ("Monadifying " ++ T.unpack (toAbsoluteName nmi)) $ get >>= \env -> let ?specMParams = monEnvParams env in do let mtp = monadifyType [] tp nmi' <- lift $ monadifyName nmi diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index cf42449adb..ad55e148e0 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -441,11 +441,13 @@ normComp (CompTerm t) = >>= normCompTerm else throwMRFailure (MalformedComp t) - -- Always unfold: sawLet, multiArgFixM, invariantHint, Num_rec + -- Always unfold: sawLet, invariantHint, assumingS, assertingS, + -- multiArgFixS, lrtLambda, Num_rec (f@(asGlobalDef -> Just ident), args) | ident `elem` ["Prelude.sawLet", "Prelude.invariantHint", - "Cryptol.Num_rec", "Prelude.multiArgFixS", - "Prelude.lrtLambda"] + "Prelude.assumingS", "Prelude.assertingS", + "Prelude.multiArgFixS", "Prelude.lrtLambda", + "Cryptol.Num_rec"] , Just (_, Just body) <- asConstant f -> mrApplyAll body args >>= normCompTerm From 1fb9b98af3c3e43fae2232ca96085093c4d6f20d Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 19 Oct 2023 18:00:44 -0700 Subject: [PATCH 127/305] defined translateCFGs in the new SpecM monad --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 158 +++++++++++++----- 1 file changed, 119 insertions(+), 39 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 60dd586c5b..3898422e01 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -6251,6 +6251,14 @@ translateTypedBlockMap ixs blkMap = (ret, []) -> return ret (_, _) -> panic "translateTypedBlockMap" ["Unused function indices"] +-- | Build a nested lambda-abstraction over a sequence of function indexes of +-- the given type descriptions and pass them to the supplied function +lambdaFunIxsM :: String -> [OpenTerm] -> + ([OpenTerm] -> TypeTransM ctx OpenTerm) -> + TypeTransM ctx OpenTerm +lambdaFunIxsM nm ds f = + lambdaTransM nm (openTermsTypeTrans $ map funIxTypeOpenTerm ds) f + -- | Lambda-abstract over function indexes for all the entrypoints that have one -- in a 'TypedBlockMap', whose type descriptions are given as the first -- argument, and then use those function indexes to translate the block map to a @@ -6260,8 +6268,7 @@ lambdaBlockMap :: [OpenTerm] -> TypedBlockMap TransPhase ext blocks tops rets -> TypeTransM tops OpenTerm) -> TypeTransM tops OpenTerm lambdaBlockMap blk_ds blkMap f = - lambdaTransM "f" (openTermsTypeTrans $ - map funIxTypeOpenTerm blk_ds) $ \funixs -> + lambdaFunIxsM "f_loop" blk_ds $ \funixs -> translateTypedBlockMap funixs blkMap >>= f @@ -6298,8 +6305,9 @@ translateCFGInitBody :: PermCheckExtC ext exprExt => TypedBlockMapTrans ext blocks (ghosts :++: inits) (gouts :> ret) -> TypedCFG ext blocks ghosts inits gouts ret -> + PermTransCtx (ghosts :++: inits) (ghosts :++: inits) -> TypeTransM (ghosts :++: inits) OpenTerm -translateCFGInitBody mapTrans cfg = +translateCFGInitBody mapTrans cfg pctx = let fun_perm = tpcfgFunPerm cfg h = tpcfgHandle cfg inits = typedFnHandleArgs h @@ -6314,11 +6322,16 @@ translateCFGInitBody mapTrans cfg = -- 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_membs = RL.members pctx' + all_px = RL.map (\_ -> Proxy) pctx' init_entry = lookupEntryTransCast (tpcfgEntryID cfg) CruCtxNil mapTrans in - impTransM all_membs pctx mapTrans retTypeTrans $ + impTransM all_membs pctx' mapTrans retTypeTrans $ translateCallEntry "CFG" init_entry (nuMulti all_px id) (nuMulti all_px $ const MNil) @@ -6328,14 +6341,18 @@ translateCFGInitBody mapTrans cfg = -- returns a sigma of its output values and permissions. This assumes that -- function indices have been bound for the function itself and any other -- functions it is mutually recursive with, and that these function indexes are --- in the current permissions environment. -translateCFG :: PermCheckExtC ext exprExt => - TypedCFG ext blocks ghosts inits gouts ret -> - TypeTransM RNil OpenTerm -translateCFG cfg = +-- in the current permissions environment. That is, this translation is +-- happening for the body of a @LetRecS@ definition that has bound function +-- indexes 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 piExprCtx (funPermTops fun_perm) $ + lambdaPermCtx (funPermIns fun_perm) $ \pctx -> do ev <- infoEvType <$> ask blk_ds <- translateBlockMapDescs $ tpcfgBlockMap cfg ret_tp <- translateRetType (funPermRets fun_perm) (funPermOuts fun_perm) @@ -6344,11 +6361,10 @@ translateCFG cfg = tupleOpenTerm <$> translateBlockMapBodies mapTrans blkMap body <- lambdaBlockMap blk_ds blkMap $ \mapTrans -> - translateCFGInitBody mapTrans cfg + translateCFGInitBody mapTrans cfg pctx return $ letRecSOpenTerm ev blk_ds ret_tp bodies body -{- ---------------------------------------------------------------------- -- * Translating Sets of CFGs ---------------------------------------------------------------------- @@ -6372,35 +6388,99 @@ someTypedCFGPtrPerm :: HasPtrWidth w => SomeTypedCFG LLVM -> ValuePerm (LLVMPointerType w) someTypedCFGPtrPerm (SomeTypedCFG _ _ cfg) = mkPtrFunPerm $ tpcfgFunPerm cfg --- | Convert a 'SomedTypedCFG' and a closure index for its initial entrypoint --- closure into an entry in the permission environment -someTypedCFGIxEntry :: HasPtrWidth w => SomeTypedCFG LLVM -> Natural -> +-- | 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 index term +someTypedCFGIxEntry :: HasPtrWidth w => SomeTypedCFG LLVM -> OpenTerm -> PermEnvGlobalEntry -someTypedCFGIxEntry (SomeTypedCFG sym _ cfg) ix = +someTypedCFGIxEntry some_cfg@(SomeTypedCFG sym _ _) funix = + -- NOTE: we use GlobalTransTerms instead of GlobalTransFuns because a function + -- index is the "normal" translation of a function permission, while + -- GlobalTransFuns specifies a specFun withKnownNat ?ptrWidth $ - PermEnvGlobalEntry sym (mkPtrFunPerm $ tpcfgFunPerm cfg) - (GlobalTransClos $ mkBaseClosSpecTerm ix) - --- | Translate a list of CFGs for mutually recursive functions to a list of --- @LetRecType@s and spec definitions of those @LetRecType@s -translateCFGsToDefs :: HasPtrWidth w => PermEnv -> ChecksFlag -> - [SomeTypedCFG LLVM] -> [(OpenTerm,OpenTerm)] -translateCFGsToDefs env checks some_cfgs = - let (cfg_ixs, cfg_transsM) = - unzip $ evalState (mapM (\(SomeTypedCFG _ _ cfg) -> - translateCFG cfg) some_cfgs) 0 - tmp_env = permEnvAddGlobalSyms env $ - zipWith someTypedCFGIxEntry some_cfgs cfg_ixs - cfg_transs = runNilTypeTransM tmp_env checks $ sequence cfg_transsM - closs = concat $ map cfgTransCloss cfg_transs in - map (\cfg_trans -> - let lrt = cfgTransLRT cfg_trans in - (lrt, - defineSpecOpenTerm (permEnvEventTypeTerm env) closs - lrt (cfgTransBody cfg_trans))) - cfg_transs + PermEnvGlobalEntry sym (someTypedCFGPtrPerm some_cfg) + (GlobalTransTerms [funix]) + +-- | 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 xfunction indexes in this lambda-abstraction +lambdaCFGPermEnv :: HasPtrWidth w => [SomeTypedCFG LLVM] -> + TypeTransM ctx OpenTerm -> TypeTransM ctx OpenTerm +lambdaCFGPermEnv some_cfgs m = + mapM translateSomeCFGDesc some_cfgs >>= \ds -> + lambdaFunIxsM "f" ds $ \funixs -> + let entries = zipWith someTypedCFGIxEntry some_cfgs funixs 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 + piExprCtx (funPermTops fun_perm) $ + lambdaPermCtx (funPermIns fun_perm) $ \pctx -> + do ev <- infoEvType <$> ask + ectx <- infoCtx <$> ask + ds <- mapM translateSomeCFGDesc cfgs + ret_tp <- translateRetType (funPermRets fun_perm) (funPermOuts fun_perm) + body <- + lambdaFunIxsM "f" ds $ \funixs -> + return $ callSOpenTerm ev (ds!!i) (funixs!!i) (transTerms ectx ++ + transTerms pctx) + return $ letRecSOpenTerm ev ds ret_tp bodies body + +-- | Translate a list of CFGs for mutually recursive functions to: 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)]) +translateCFGs env checks 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)])) +{- +FIXME HERE NOWNOWNOW + -- | An existentially quantified tuple of a 'CFG', its function permission, and -- a 'String' name we want to translate it to data SomeCFGAndPerm ext where From 0f71b2b776d2352ab08d03fc8f44911bb68aa895 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 19 Oct 2023 18:21:54 -0700 Subject: [PATCH 128/305] finished updating tcTranslateAddCFGs to the new SpecM --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 93 ++++++++++--------- 1 file changed, 51 insertions(+), 42 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 3898422e01..f444d167cd 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -360,6 +360,13 @@ letRecSOpenTerm ev ds ret_tp bodies body = applyGlobalOpenTerm "Prelude.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 "Prelude.MultiFixBodies" + [evTypeTerm ev, listOpenTerm tpDescTypeOpenTerm ds] + ---------------------------------------------------------------------- -- * Type Translations @@ -6460,27 +6467,26 @@ translateCFGFromBodies cfgs bodies i transTerms pctx) return $ letRecSOpenTerm ev ds ret_tp bodies body --- | Translate a list of CFGs for mutually recursive functions to: 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. +-- | 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], OpenTerm, OpenTerm -> [(OpenTerm,OpenTerm)]) translateCFGs env checks some_cfgs = - (runNilTypeTransM env checks (translateCFGBodiesTerm 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)])) -{- -FIXME HERE NOWNOWNOW - -- | An existentially quantified tuple of a 'CFG', its function permission, and -- a 'String' name we want to translate it to data SomeCFGAndPerm ext where @@ -6497,7 +6503,8 @@ someCFGAndPermToName :: SomeCFGAndPerm ext -> String someCFGAndPermToName (SomeCFGAndPerm _ nm _ _) = nm -- | Map a 'SomeCFGAndPerm' to a 'PermEnvGlobalEntry' with no translation, i.e., --- with an 'error' term for the translation +-- 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) = @@ -6506,19 +6513,6 @@ someCFGAndPermGlobalEntry (SomeCFGAndPerm sym _ _ fun_perm) = panic "someCFGAndPermGlobalEntry" ["Attempt to translate CFG during its own 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 _ _ _ fun_perm) = - typeDescLRT $ runNilTypeTransM env noChecks $ translateClosed fun_perm - --- | Construct a spec definition type for the event type in the supplied --- environment with the supplied @LetRecType@ -permEnvSpecDefOpenTerm :: PermEnv -> OpenTerm -> OpenTerm -permEnvSpecDefOpenTerm env lrt = - applyGlobalOpenTerm "Prelude.SpecDef" - [permEnvEventTypeTerm env, lrt] - -- | 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, @@ -6527,8 +6521,12 @@ 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 @@ -6544,29 +6542,40 @@ 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, translate all those CFGs to spec definitions - let lrts_defs = translateCFGsToDefs env checks tc_cfgs - - -- Insert each spec definition as a SAW core definition bound to its - -- corresponding ident in the SAW core module mod_name, and generate entries - -- for the environment mapping each function name to its SAW core ident + -- 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 <- 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) (lrt, def_tm) -> - do tp <- completeNormOpenTerm sc $ permEnvSpecDefOpenTerm env lrt - tm <- completeNormOpenTerm sc def_tm + (\(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 (GlobalTransDef $ - globalOpenTerm ident)) - tc_cfgs lrts_defs + return $ PermEnvGlobalEntry sym perm (GlobalTransFuns + [globalOpenTerm ident])) + tc_cfgs (trans_f $ globalOpenTerm bodies_id) - -- Add the new entries to the environment and return the new environment and - -- the type-checked CFGs + -- 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 ---------------------------------------------------------------------- From 94e5db7c20b545e8d3f069979775fc0adf90738b Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 20 Oct 2023 12:52:15 -0700 Subject: [PATCH 129/305] finished updating the remaining top-level entrypoints in SAWTranslation.hs --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 20 +++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index f444d167cd..887f8b9f27 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -6575,24 +6575,23 @@ tcTranslateAddCFGs sc mod_name env checks endianness dlevel cfgs_and_perms = return (permEnvAddGlobalSyms env new_entries, tc_cfgs) -{- ---------------------------------------------------------------------- -- * Top-level Entrypoints for Translating Other Things ---------------------------------------------------------------------- --- | Translate a function permission to the type of a spec definition for the --- translation of a function with that permission +-- | 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 $ permEnvSpecDefOpenTerm env $ typeDescLRT $ + completeNormOpenTerm sc $ runNilTypeTransM env noChecks (translateClosed fun_perm) --- | Translate a 'TypeRepr' to the SAW core type it represents -translateCompleteType :: SharedContext -> PermEnv -> TypeRepr tp -> IO Term -translateCompleteType sc env typ_perm = - completeNormOpenTerm sc $ typeTransType1 $ - runNilTypeTransM env noChecks $ translateType True typ_perm +-- | Translate a 'TypeRepr' to the SAW core type it represents, raising an error +-- if it translates to more than one type +translateCompleteType :: SharedContext -> TypeRepr tp -> IO Term +translateCompleteType sc tp = + completeNormOpenTerm sc $ typeTransType1 $ fst $ translateType tp -- | Translate a 'TypeRepr' within the given context of type arguments to the -- SAW core type it represents @@ -6600,8 +6599,9 @@ translateCompleteTypeInCtx :: SharedContext -> PermEnv -> CruCtx args -> Mb args (TypeRepr a) -> IO Term translateCompleteTypeInCtx sc env args ret = completeNormOpenTerm sc $ runNilTypeTransM env noChecks $ - piExprCtxPure args (typeTransType1 <$> translateType True (mbLift ret)) + piExprCtx args (return $ typeTransType1 $ fst $ translateType $ mbLift ret) +{- -- | Translate an input list of 'ValuePerms' and an output 'ValuePerm' to a pure -- SAW core function type, not in the @SpecM@ monad. It is an error if any of -- the permissions are impure, such as @lowned@ permissions. From fa011758d68cfe90b9f1cd184b6e2a628cdc7417 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 20 Oct 2023 17:29:30 -0700 Subject: [PATCH 130/305] added the TranslateDescs instances for permissions and atomic permissions; define the translations for the folding and unfolding rules for recursive shapes and permissions --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 278 +++++++++++------- 1 file changed, 176 insertions(+), 102 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 887f8b9f27..6b318cf111 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -239,7 +239,9 @@ tupleTpDesc (d : ds) = pairTpDesc d (tupleTpDesc ds) sumTpDesc :: OpenTerm -> OpenTerm -> OpenTerm sumTpDesc d1 d2 = ctorOpenTerm "Prelude.Tp_Sum" [d1,d2] --- | Build a type description for the type @BVVec n len d@ +-- | 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 "Prelude.Tp_BVVec" [elem_d, w_term, len_term] @@ -299,6 +301,10 @@ piTpDesc kd tpd = ctorOpenTerm "Prelude.Tp_Pi" [kd, tpd] piTpDescMulti :: [OpenTerm] -> OpenTerm -> OpenTerm piTpDescMulti ks tp = foldr piTpDesc tp ks +-- | The type description for the @Void@ type +voidTpDesc :: OpenTerm +voidTpDesc = ctorOpenTerm "Prelude.Tp_Void" [] + -- | Build a type description for a free deBruijn index varTpDesc :: OpenTerm -> Natural -> OpenTerm varTpDesc d ix = ctorOpenTerm "Prelude.Tp_Var" [d, natOpenTerm ix] @@ -367,6 +373,22 @@ multiFixBodiesOpenTerm ev ds = applyGlobalOpenTerm "Prelude.MultiFixBodies" [evTypeTerm ev, listOpenTerm tpDescTypeOpenTerm ds] +-- | 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 "Prelude.envConsElem" [k,v,env]) + (ctorOpenTerm "Prelude.Nil" [globalOpenTerm "Prelude.TpEnvElem"]) + +-- | 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 "Prelude.tpSubst" [natOpenTerm n, + tpEnvOpenTerm ks_elems, d] + ---------------------------------------------------------------------- -- * Type Translations @@ -1332,6 +1354,10 @@ data DescTransInfo ctx where 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 + -- | Build a sequence of 'Proxy's for the context of a 'DescTransInfo' dtiProxies :: DescTransInfo ctx -> RAssign Proxy ctx dtiProxies (DescTransInfo ectx1 ctx2 _ _) = @@ -1402,6 +1428,9 @@ descTransM = 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 @@ -1627,8 +1656,7 @@ instance TransInfo info => return $ ETrans_Shape [d] [tp] [nuMP| PExpr_FalseShape |] -> return $ - ETrans_Shape [ctorOpenTerm "Prelude.Tp_Void" []] [dataTypeOpenTerm - "Prelude.Void" []] + ETrans_Shape [voidTpDesc] [dataTypeOpenTerm "Prelude.Void" []] [nuMP| PExpr_ValPerm p |] -> ETrans_Perm <$> descTransM (translateDescs p) <*> (typeTransTypes <$> @@ -1704,8 +1732,8 @@ translateBVDesc mb_e = return $ bvSumTpExprs (natValue w) (fs_exprs ++ [i_expr]) -- translateDescs on permission expressions yield a list of SAW core terms of --- type @kindExpr K@, one for each kind @K@ in the list of kind descriptions --- returned by translateType +-- 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 |] -> @@ -1770,8 +1798,7 @@ instance TranslateDescs (PermExpr a) where inExtCtxDescTransM (singletonCruCtx tp) $ \kdescs -> (\d -> [d]) <$> sigmaTpDescMulti kdescs <$> translateDesc (mbCombine RL.typeCtxProxies mb_sh) - [nuMP| PExpr_FalseShape |] -> - return [ctorOpenTerm "Prelude.Tp_Void" []] + [nuMP| PExpr_FalseShape |] -> return [voidTpDesc] [nuMP| PExpr_ValPerm mb_p |] -> translateDescs mb_p @@ -1782,6 +1809,21 @@ instance TranslateDescs (PermExprs tps) where [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 let ks = snd $ translateCruCtx tps + args_exprs <- descTransM $ translateDescs args + return $ substEnvTpDesc 1 (zip ks args_exprs) (globalOpenTerm d_id) + + ---------------------------------------------------------------------- -- * Permission Translations ---------------------------------------------------------------------- @@ -2844,6 +2886,7 @@ mapLtLOwnedTrans pctx1 vars1 dtr1 pctx2 vars2 dtr2 (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' @@ -2925,7 +2968,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 @@ -2943,25 +2988,13 @@ instance TransInfo info => do env <- infoEnv <$> ask case lookupNamedPerm env (mbLift npn) of Just (NamedPerm_Opaque op) -> - error "FIXME HERE NOWNOW: translate opaque named permissions" - {- - exprCtxPureTypeTerms <$> translate args >>= \case - Just args_exprs -> - return $ mkPermTypeTrans1 p $ TypeDescPure $ - applyGlobalOpenTerm (opaquePermTrans op) args_exprs - Nothing -> - panic "translate" - ["Heapster cannot yet handle opaque permissions over impure types"] -} + mkPermTypeTrans1 p <$> + applyGlobalOpenTerm (opaquePermTrans op) <$> + transTerms <$> translate args Just (NamedPerm_Rec rp) -> - error "FIXME HERE NOWNOW: translate recursive named permissions" - {- - exprCtxPureTypeTerms <$> translate args >>= \case - Just args_exprs -> - return $ mkPermTypeTrans1 p $ TypeDescPure $ - applyOpenTermMulti (globalOpenTerm $ recPermTransType rp) args_exprs - Nothing -> - panic "translate" - ["Heapster cannot yet handle recursive permissions over impure types"] -} + 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) @@ -2970,13 +3003,42 @@ instance TransInfo info => fmap PTrans_Conj <$> listTypeTrans <$> translate ps [nuMP| ValPerm_Var x _ |] -> do (_, tps) <- unETransPerm <$> translate x - return $ mkTypeTrans1 (tupleOfTypes tps) (PTrans_Term p) + return $ mkPermTypeTrans1 p (tupleOfTypes 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 = error "FIXME HERE NOWNOW" + 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' |] -> + 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) = 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 [substIdTpDescMulti (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 _ |] -> + translateVarDesc mb_x >>= \case + Left etrans -> return $ fst $ unETransPerm etrans + Right (ix, ds) -> return $ zipWith varTpDesc ds [ix..] + [nuMP| ValPerm_False |] -> + return [voidTpDesc] instance TransInfo info => @@ -3031,7 +3093,7 @@ instance TransInfo info => (APTrans_LOwned ls (mbLift tps_in) (mbLift tps_out) ps_in ps_out $ mkLOwnedTrans ev ectx dtr_in dtr_out vars_out t) Nothing -> - error "FIXME HERE NOWNOW: handle this error!" + panic "translate" ["lowned output permission is ill-formed"] [nuMP| Perm_LOwnedSimple tps lops |] -> return $ mkTypeTrans0 $ APTrans_LOwnedSimple (mbLift tps) lops [nuMP| Perm_LCurrent l |] -> @@ -3052,7 +3114,36 @@ instance TransInfo info => instance TranslateDescs (AtomicPerm a) where - translateDescs mb_p = error "FIXME HERE NOWNOW" + 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 [arrowTpDescMulti 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 @@ -3087,6 +3178,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, @@ -4608,29 +4711,21 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of (\(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 _ _ _ |] <- 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 - let args_tms = case exprCtxPureTypeTerms args_trans of - Just tms -> map openTermLike tms - Nothing -> panic "translateSimplImpl" - ["SImpl_IntroLLVMBlockNamed: found impure terms"] - fold_id <- - case fold_ids of - [nuP| Just (fold_id,_) |] -> return fold_id - _ -> error "Folding recursive shape before it is defined!" + let args_ctx = mbLift $ fmap namedShapeArgs nmsh' + d <- substNamedIndTpDesc (mbLift mb_sh_id) args_ctx mb_args withPermStackM id (\(pctx :>: ptrans_x) -> - pctx :>: typeTransF ttrans [applyGlobalTermLike (mbLift fold_id) - (args_tms ++ transTerms ptrans_x)]) - m -} - error "FIXME HERE NOWNOW: how to translate recursive named permissions" + pctx :>: + typeTransF ttrans [applyGlobalOpenTerm "Prelude.foldTpElem" + [d, transTupleTerm ptrans_x]]) + m -- Intro for a defined named shape (the other case) is a no-op | [nuMP| DefinedShapeBody _ |] <- mbMatch $ fmap namedShapeBody nmsh -> @@ -4644,31 +4739,23 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of panic "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 + -- Elim for a recursive named shape applies the unfold function for the shape [nuMP| SImpl_ElimLLVMBlockNamed _ bp nmsh |] - | [nuMP| RecShapeBody _ _ desc_id |] <- 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 - let args_tms = case exprCtxPureTypeTerms args_trans of - Just tms -> map openTermLike tms - Nothing -> panic "translateSimplImpl" - ["SImpl_IntroLLVMBlockNamed: found impure terms"] - unfold_id <- - case fold_ids of - [nuP| Just (_,unfold_id) |] -> return unfold_id - _ -> error "Unfolding recursive shape before it is defined!" + let args_ctx = mbLift $ fmap namedShapeArgs nmsh' + d <- substNamedIndTpDesc (mbLift mb_sh_id) args_ctx mb_args withPermStackM id (\(pctx :>: ptrans_x) -> - pctx :>: typeTransF ttrans [applyGlobalTermLike (mbLift unfold_id) - (args_tms ++ transTerms ptrans_x)]) - m -} - error "FIXME HERE NOWNOW: how to translate recursive named permissions" + pctx :>: + typeTransF ttrans [applyGlobalOpenTerm "Prelude.unfoldTpElem" + [d, transTupleTerm ptrans_x]]) + 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 @@ -4787,56 +4874,43 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of (\(pctx :>: ptrans) -> pctx :>: typeTransF ttrans [transTerm1 ptrans]) m - [nuMP| SImpl_FoldNamed _ (NamedPerm_Rec rp) args _ |] -> - error "FIXME HERE NOWNOW: how to handle recursive perms" - {- - do args_trans <- translate args - let args_tms = case exprCtxPureTypeTerms args_trans of - Just tms -> map openTermLike tms - Nothing -> panic "translateSimplImpl" - ["SImpl_FoldNamed: impure arguments"] - ttrans <- translateSimplImplOutHead mb_simpl - let fold_ident = mbLift $ fmap recPermFoldFun rp + [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 withPermStackM id (\(pctx :>: ptrans_x) -> - pctx :>: typeTransF ttrans [applyGlobalTermLike fold_ident - (args_tms ++ transTerms ptrans_x)]) - m -} + pctx :>: + typeTransF ttrans [applyGlobalOpenTerm "Prelude.foldTpElem" + [d, transTupleTerm ptrans_x]]) + m - [nuMP| SImpl_UnfoldNamed _ (NamedPerm_Rec rp) args _ |] -> - error "FIXME HERE NOWNOW: how to handle recursive perms" - {- - do args_trans <- translate args - let args_tms = case exprCtxPureTypeTerms args_trans of - Just tms -> map openTermLike tms - Nothing -> panic "translateSimplImpl" - ["SImpl_UnfoldNamed: impure arguments"] - ttrans <- tupleTypeTrans <$> translateSimplImplOutHead mb_simpl - let unfold_ident = mbLift $ fmap recPermUnfoldFun rp + [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 withPermStackM id (\(pctx :>: ptrans_x) -> pctx :>: - typeTransF ttrans [applyGlobalTermLike unfold_ident - (args_tms ++ [transTerm1 ptrans_x])]) - m -} + typeTransF ttrans [applyGlobalOpenTerm "Prelude.unfoldTpElem" + [d, transTupleTerm ptrans_x]]) + m [nuMP| SImpl_FoldNamed _ (NamedPerm_Defined _) _ _ |] -> - error "FIXME HERE NOWNOW: how to handle recursive perms" - {- do ttrans <- translateSimplImplOutHead mb_simpl withPermStackM id (\(pctx :>: ptrans) -> pctx :>: typeTransF ttrans (transTerms ptrans)) - m -} + m [nuMP| SImpl_UnfoldNamed _ (NamedPerm_Defined _) _ _ |] -> - error "FIXME HERE NOWNOW: how to handle recursive perms" - {- do ttrans <- translateSimplImplOutHead mb_simpl withPermStackM id (\(pctx :>: ptrans) -> pctx :>: typeTransF ttrans (transTerms ptrans)) - m -} + m {- [nuMP| SImpl_Mu _ _ _ _ |] -> From c9e0fb69d652321a4108760eca748e230b205565 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 20 Oct 2023 18:15:47 -0700 Subject: [PATCH 131/305] changed recursive permissions to have a body with a permission variable free, similar to how recursive shapes work --- .../src/Verifier/SAW/Heapster/Permissions.hs | 109 +++++++----------- 1 file changed, 43 insertions(+), 66 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs index 6d52f4c12d..62a2022ec5 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs @@ -718,23 +718,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, recPermTransDesc :: Ident, - recPermFoldFun :: Ident, - recPermUnfoldFun :: 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 @@ -6307,8 +6310,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 -> @@ -6999,9 +7003,10 @@ instance SubstVar s m => Substable s (OpaquePerm ns args a) m where return $ OpaquePerm (mbLift n) (mbLift i1) (mbLift i2) instance SubstVar s m => Substable s (RecPerm ns reach args a) m where - genSubst s (mbMatch -> [nuMP| RecPerm rpn dt_i d_i f_i u_i reachMeths cases |]) = - RecPerm (mbLift rpn) (mbLift dt_i) (mbLift d_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 |]) = @@ -8216,61 +8221,33 @@ permEnvAddOpaquePerm env str args tp trans_id d_id = TrueRepr) NameNonReachConstr in permEnvAddNamedPerm env $ NamedPerm_Opaque $ OpaquePerm n trans_id d_id --- | 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@. +-- | Add a recursive named permission to a 'PermEnv', given a 'String' name for +-- the permission, its argument types and permission type, identifiers for its +-- 'recPermTransType' and 'recPermTransDesc' fields, its body, and optional +-- reachability constraints and methods. The last two of these can depend on the +-- @b@ flag computed for the body, and the last can take in the name being +-- created and a temporary 'PermEnv' with this name added in order to construct +-- the 'ReachMethods', which can be constructed in an arbitrary monad. permEnvAddRecPermM :: Monad m => PermEnv -> String -> CruCtx args -> TypeRepr a -> Ident -> Ident -> + Mb (args :> ValuePermType a) (ValuePerm a) -> (forall b. NameReachConstr (RecursiveSort b reach) args a) -> - (forall b. NamedPermName (RecursiveSort b reach) args a -> - PermEnv -> m [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 d_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 d_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 d_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 -> From 20edac732f769a48b28ae3559f2fe9c59aac71dc Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 20 Oct 2023 18:16:10 -0700 Subject: [PATCH 132/305] implemented translateCompleteFunType --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 24 +++++-------------- 1 file changed, 6 insertions(+), 18 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 6b318cf111..b0bdea26ac 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -6675,27 +6675,15 @@ translateCompleteTypeInCtx sc env args ret = completeNormOpenTerm sc $ runNilTypeTransM env noChecks $ piExprCtx args (return $ typeTransType1 $ fst $ translateType $ mbLift ret) -{- -- | Translate an input list of 'ValuePerms' and an output 'ValuePerm' to a pure --- SAW core function type, not in the @SpecM@ monad. It is an error if any of --- the permissions are impure, such as @lowned@ permissions. -translateCompletePureFun :: SharedContext -> PermEnv +-- SAW core function type, not in the @SpecM@ monad +translateCompleteFunType :: 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 ps_in p_out = - completeNormOpenTerm sc $ runNilTypeTransM env noChecks $ piExprCtxPure ctx $ - do ps_in_trans <- translate ps_in - p_out_trans <- translate p_out - let justOrPanic (Just x) = x - justOrPanic Nothing = - panic "translateCompletePureFun" - ["Attempt to translate an impure permission to a pure type"] - let (tps_in, tp_out) = - justOrPanic - ((,) <$> - mapM typeDescPureType (typeTransDescs ps_in_trans) <*> - typeDescPureType (tupleOfTypeDescs $ typeTransDescs p_out_trans)) +translateCompleteFunType 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) --} From 91c25477bfd68385beef11d2e91e86a6a0fe6af5 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 20 Oct 2023 18:20:14 -0700 Subject: [PATCH 133/305] removed the no longer needed IRTTranslation.hs file --- heapster-saw/heapster-saw.cabal | 1 - .../Verifier/SAW/Heapster/IRTTranslation.hs | 836 ------------------ 2 files changed, 837 deletions(-) delete mode 100644 heapster-saw/src/Verifier/SAW/Heapster/IRTTranslation.hs 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/IRTTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/IRTTranslation.hs deleted file mode 100644 index f663bea881..0000000000 --- a/heapster-saw/src/Verifier/SAW/Heapster/IRTTranslation.hs +++ /dev/null @@ -1,836 +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 GHC.TypeLits -import Control.Monad.Reader -import Control.Monad.State -import Control.Monad.Except - -import qualified Data.Type.RList as RL -import Data.Binding.Hobbits -import Data.Parameterized.BoolRepr - -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 = exprCtxToPureTerms <$> infoCtx <$> ask - --- | Build an 'OpenTerm' of type @ListSort@ from 'OpenTerm's of type @sort 0@ -listSortOpenTerm :: [OpenTerm] -> OpenTerm -listSortOpenTerm xs = - foldr (\hd tl -> ctorOpenTerm "Prelude.LS_Cons" [hd, tl]) - (ctorOpenTerm "Prelude.LS_Nil" []) - xs - --- | Split a 'Member' proof in an appended context into a proof in one of the --- two contexts being appended --- FIXME: move to Hobbits -splitMemberApp :: Proxy ctx1 -> RAssign Proxy ctx2 -> - Member (ctx1 :++: ctx2) a -> - Either (Member ctx1 a) (Member ctx2 a) -splitMemberApp _ MNil memb = Left memb -splitMemberApp _ (_ :>: _) Member_Base = Right Member_Base -splitMemberApp ctx1 (ctx2 :>: _) (Member_Step memb) = - case splitMemberApp ctx1 ctx2 memb of - Left memb' -> Left memb' - Right memb' -> Right (Member_Step memb') - - ----------------------------------------------------------------------- --- * 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 ----------------------------------------------------------------------- - --- | The local context maintained by 'irtTyVars' and friends for extracting --- @IRT@ type variables from a permission or shape in variable binding context --- @ctx@ with top-level arguments @args@. This information includes the name of --- the top-level permission or shape being translated, type translations for for --- all the top-level arguments, the current permission environment, and an --- extension context, represented as a list of 'Proxy' phantom arguments -data IRTTyVarsTransInfo args (ext :: RList CrucibleType) = - IRTTyVarsTransInfo - { - irtTRecName :: IRTRecName args, - irtTArgsCtx :: RAssign ExprTypeTrans args, - irtTExtCtx :: RAssign Proxy ext, - irtTPermEnv :: PermEnv - } - --- | The monad for translating IRT type variables -type IRTTyVarsTransM args ext = - ReaderT (IRTTyVarsTransInfo 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 info - where args_trans = runNilTypeTransM env noChecks $ translateCtx True argsCtx - info = IRTTyVarsTransInfo 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 $ \info -> - info { irtTExtCtx = irtTExtCtx info :>: 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 = return $ mbCombine RL.typeCtxProxies x --} - -irtTArgsProxies :: IRTTyVarsTransM args ext (RAssign Proxy args) -irtTArgsProxies = RL.map (const Proxy) <$> irtTArgsCtx <$> ask - --- | Create an @args :++: ext@ binding -irtNus :: (RAssign Name args -> b) -> - IRTTyVarsTransM args ext (Mb (args :++: ext) b) -irtNus f = - do args <- irtTArgsProxies - ext <- irtTExtCtx <$> ask - return $ extMbMulti ext $ nuMulti args f - --- | Turn an object in a binding for the bigger context @ctx@ to an object in a --- binding for just the @args@ context, by substituting 'Nothing' for all the --- additional variables in @ctx@ -irtTSubstExt :: (Substable PartialSubst a Maybe, NuMatching a) => - Mb (args :++: ext) a -> IRTTyVarsTransM args ext (Mb args a) -irtTSubstExt mb_a = - do args_prxs <- irtTArgsProxies - ext <- irtTExtCtx <$> ask - let mb_maybe = - nuMulti args_prxs $ \args -> - partialSubst (psubstAppend (psubstOfSubst (substOfVars args)) - (emptyPSubst ext)) mb_a - case mbMaybe mb_maybe of - Just mb_a' -> return mb_a' - Nothing -> - throwError ("non-array permission in a recursive perm body" - ++ " depends on an existential variable!") - - ----------------------------------------------------------------------- --- * Trees for keeping track of IRT variable indices ----------------------------------------------------------------------- - --- | An 'IRTVarTree' is a tree that captures the structure of an @IRT@ type --- description but with elements of type @a@ where that type description has --- variables. In practice, @a@ can be '()', meaning the tree just tracks where --- the variables are, or 'Natural', giving the variables indexes into a list of --- all the variables in an @IRT@ type description. -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 - --- | An 'IRTVarTree' that just captures the tree shape of an @IRT@ description -type IRTVarTreeShape = IRTVarTree () - --- | An 'IRTVarTree' that assigns natual number indices to the variables in an --- @IRT@ description -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 $ - lambdaExprCtxPure 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 $ - lambdaExprCtxPure args (listSortOpenTerm <$> sequence tps) - return (tm, setIRTVarIdxs ixs) - --- | Generic function to traverse a permission or shape expression and find all --- of the subterms of that shape or permission whose translation needs to be --- lifted out as a top-level argument; return those lifted arguments along with --- a tree shape that describes where they go in the permission or shape -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 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 - let xCbn = mbCombine RL.typeCtxProxies 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 (ImpTypeTrans tr), - Substable PartialSubst a Maybe, NuMatching a, HasPureTrans 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 - if hasPureTrans p' then return () else - throwError "namedPermIRTTyVars: impure permission" - let p_transM = typeTransPureTupleType <$> translate p' - return ([p_transM], IRTVar ()) - --- | Test that an expression variable for a permission or shape is bound in the --- @args@ list (i.e., not as an existential variable), and return a 'Member' --- proof for it. Throw an error if it is not. -irtTVarMemb :: Mb (args :++: ext) (ExprVar tp) -> - IRTTyVarsTransM args ext (Member args tp) -irtTVarMemb mb_x = - (irtTExtCtx <$> ask) >>= \ctx -> - case mbNameBoundP mb_x of - Left (splitMemberApp Proxy ctx -> Left memb) -> return memb - _ -> throwError "irtTVarMemb: Existentially bound permission or shape variable" - --- | 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 :: Mb (args :++: ext) (ExprVar tp) -> - IRTTyVarsTransM args ext ([TypeTransM args OpenTerm], - IRTVarTreeShape) -irtTTranslateVar x = - do memb <- irtTVarMemb x - return ([tupleOfTerms <$> transPureTerms <$> RL.get memb <$> infoCtx <$> ask], 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 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 - if hasPureTrans mb_sh then return () else - throwError "irtTyVars: impure shape" - let sh_trans = translate1Pure 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 - infoChecksFlag _ = noChecks - 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 (lambdaExprCtxPure 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) - (exprCtxToPureTerms 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 <- lambdaPureTransM "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 <- translate1Pure (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 <- translate1Pure 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 <- lambdaPureTransM "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 (lambdaExprCtxPure 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 (lambdaExprCtxPure 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 (lambdaExprCtxPure 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] From 8473d0c8460991760ce435d698628a789822663c Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Sat, 21 Oct 2023 09:17:14 -0700 Subject: [PATCH 134/305] started updating HeapsterBuiltins.hs to work with the new SpecM monad --- src/SAWScript/HeapsterBuiltins.hs | 97 +++++++++++++++++++------------ 1 file changed, 59 insertions(+), 38 deletions(-) diff --git a/src/SAWScript/HeapsterBuiltins.hs b/src/SAWScript/HeapsterBuiltins.hs index c656627df9..a921e74537 100644 --- a/src/SAWScript/HeapsterBuiltins.hs +++ b/src/SAWScript/HeapsterBuiltins.hs @@ -13,6 +13,8 @@ {-# LANGUAGE ViewPatterns #-} module SAWScript.HeapsterBuiltins +-- FIXME HERE NOW +{- ( heapster_init_env , heapster_init_env_debug , heapster_init_env_from_file @@ -58,7 +60,7 @@ module SAWScript.HeapsterBuiltins , heapster_dump_ide_info , heapster_set_debug_level , heapster_set_translation_checks - ) where + ) -} where import Data.Maybe import Data.String @@ -70,6 +72,7 @@ import Data.Functor.Constant (getConstant) import Control.Applicative ( (<|>) ) import Control.Lens import Control.Monad +import Control.Monad.Reader import Control.Monad.IO.Class import qualified Control.Monad.Fail as Fail import System.Directory @@ -124,7 +127,6 @@ 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 @@ -135,6 +137,18 @@ import SAWScript.Prover.Exporter import Verifier.SAW.Translation.Coq import Prettyprinter +inExtCtxDescTransMNil :: CruCtx ctx -> + ([OpenTerm] -> DescTransM ctx a) -> + DescTransM RNil a +inExtCtxDescTransMNil ctx m = error "FIXME HERE NOW" + +-- FIXME: move to SAWTranslation.hs +translateCompleteTypeDescInCtx :: TranslateDescs a => SharedContext -> PermEnv -> + CruCtx args -> Mb args a -> IO Term +translateCompleteTypeDescInCtx sc env args mb_a = + completeOpenTerm sc $ runNilTypeTransM env noChecks $ descTransM $ + inExtCtxDescTransMNil args $ const $ translateDesc mb_a + -- | 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'. @@ -409,8 +423,8 @@ heapster_get_cfg _ _ henv nm = -- type, that translates to the given named SAW core definition 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 @@ -418,54 +432,60 @@ heapster_define_opaque_perm _bic _opts henv nm args_str tp_str term_string = 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_ident <- parseAndInsDef henv nm term_tp term_str + d_tp <- liftIO $ completeOpenTerm sc tpDescTypeOpenTerm + d_ident <- parseAndInsDef henv (nm ++ "__desc") d_tp d_str + 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. 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 = +heapster_define_recursive_perm _bic _opts henv nm args_str tp_str p_str = do env <- liftIO $ readIORef $ heapsterEnvPermEnvRef henv + let mnm = heapsterEnvSAWModule henv sc <- getSharedContext - -- Parse the arguments, the type, and the translation 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 - 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 + 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 <- liftIO $ completeOpenTerm sc tpDescTypeOpenTerm + let d_ident = mkSafeIdent mnm (nm ++ "__desc") + d_trm <- liftIO $ translateCompleteTypeDescInCtx sc env args_p mb_p + liftIO $ scInsertDef sc mnm 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 trans_ident = mkSafeIdent mnm nm + trans_tp <- + liftIO $ completeOpenTerm sc $ runNilTypeTransM env noChecks $ + piExprCtx args $ return $ sortOpenTerm $ mkSort 0 + trans_trm <- + liftIO $ completeOpenTerm sc $ runNilTypeTransM env noChecks $ + lambdaExprCtx args $ + do args_tms <- transTerms <$> infoCtx <$> ask + let ks = snd $ translateCruCtx args + return $ applyGlobalOpenTerm "Prelude.tpElemEnv" + [tpEnvOpenTerm (zip ks args_tms), + ctorOpenTerm "Prelude.Tp_Ind" [globalOpenTerm d_ident]] + liftIO $ scInsertDef sc mnm trans_ident trans_tp trans_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 -> - 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)) + permEnvAddRecPermM env nm args tp trans_ident d_ident mb_p + NameNonReachConstr (\_ _ -> 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 -> @@ -1235,7 +1255,7 @@ heapster_set_event_type _bic _opts henv term_string = liftIO $ completeOpenTerm sc $ dataTypeOpenTerm "Prelude.EvType" [] ev_id <- parseAndInsDef henv "HeapsterEv" ev_tp term_string liftIO $ modifyIORef' (heapsterEnvPermEnvRef henv) $ \env -> - env { permEnvSpecMEventType = ev_id } + env { permEnvEventType = EventType ev_id } heapster_print_fun_trans :: BuiltinContext -> Options -> HeapsterEnv -> String -> TopLevel () @@ -1292,3 +1312,4 @@ heapster_dump_ide_info _bic _opts henv filename = do penv <- io $ readIORef (heapsterEnvPermEnvRef henv) tcfgs <- io $ readIORef (heapsterEnvTCFGs henv) io $ HIDE.printIDEInfo penv tcfgs filename emptyPPInfo +-} From c78e2f22903644ef23534c9a4d616931f7f5f576 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Sun, 22 Oct 2023 08:10:04 -0700 Subject: [PATCH 135/305] Moved most of the details of adding and translating recursive permissions to SAWTranslation.hs --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 56 ++++++++++-- src/SAWScript/HeapsterBuiltins.hs | 91 ++++++++----------- 2 files changed, 87 insertions(+), 60 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index b0bdea26ac..ea13d583c8 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -1410,6 +1410,15 @@ inExtCtxDescTransM ctx m = kdescs = concat $ RL.toList kdesc_ctx in inExtDescTransMultiM kdesc_ctx $ m kdescs +-- | Run a 'DescTransM' computation in an expression context that binds a +-- context of deBruij 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 = @@ -6675,15 +6684,50 @@ translateCompleteTypeInCtx sc env args ret = completeNormOpenTerm sc $ runNilTypeTransM env noChecks $ piExprCtx args (return $ typeTransType1 $ fst $ translateType $ mbLift ret) +-- | Translate a type-like construct to a type description of the type it +-- represents in a context of free deBruijn indices +translateCompleteDescInCtx :: TranslateDescs a => SharedContext -> PermEnv -> + CruCtx args -> Mb args a -> IO Term +translateCompleteDescInCtx sc env args mb_a = + completeOpenTerm sc $ runNilTypeTransM env noChecks $ descTransM $ + inCtxDescTransM args $ const $ translateDesc mb_a + -- | Translate an input list of 'ValuePerms' and an output 'ValuePerm' to a pure -- SAW core function type, not in the @SpecM@ monad -translateCompleteFunType :: SharedContext -> PermEnv - -> CruCtx ctx -- ^ Type arguments - -> Mb ctx (ValuePerms args) -- ^ Input perms - -> Mb ctx (ValuePerm ret) -- ^ Return type perm - -> IO Term -translateCompleteFunType sc env ctx ps_in p_out = +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 = + liftIO $ completeOpenTerm sc $ runNilTypeTransM env noChecks $ + piExprCtx ctx $ return $ sortOpenTerm $ mkSort 0 + +-- | 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 = + liftIO $ completeOpenTerm sc $ runNilTypeTransM env noChecks $ + lambdaExprCtx ctx $ + do args_tms <- transTerms <$> infoCtx <$> ask + let ks = snd $ translateCruCtx ctx + return $ applyGlobalOpenTerm "Prelude.tpElemEnv" + [tpEnvOpenTerm (zip ks args_tms), + ctorOpenTerm "Prelude.Tp_Ind" [d]] diff --git a/src/SAWScript/HeapsterBuiltins.hs b/src/SAWScript/HeapsterBuiltins.hs index a921e74537..d9c702096f 100644 --- a/src/SAWScript/HeapsterBuiltins.hs +++ b/src/SAWScript/HeapsterBuiltins.hs @@ -137,17 +137,10 @@ import SAWScript.Prover.Exporter import Verifier.SAW.Translation.Coq import Prettyprinter -inExtCtxDescTransMNil :: CruCtx ctx -> - ([OpenTerm] -> DescTransM ctx a) -> - DescTransM RNil a -inExtCtxDescTransMNil ctx m = error "FIXME HERE NOW" - --- FIXME: move to SAWTranslation.hs -translateCompleteTypeDescInCtx :: TranslateDescs a => SharedContext -> PermEnv -> - CruCtx args -> Mb args a -> IO Term -translateCompleteTypeDescInCtx sc env args mb_a = - completeOpenTerm sc $ runNilTypeTransM env noChecks $ descTransM $ - inExtCtxDescTransMNil args $ const $ translateDesc mb_a +-- | Build the SAW core term for the type @TpDesc@ +tpDescTypeM :: MonadIO m => SharedContext -> m Term +tpDescTypeM sc = liftIO $ completeOpenTerm sc tpDescTypeOpenTerm + -- | 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 @@ -429,11 +422,9 @@ heapster_define_opaque_perm _bic _opts henv nm args_str tp_str term_str d_str = 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_tp <- liftIO $ translateExprTypeFunType sc env args term_ident <- parseAndInsDef henv nm term_tp term_str - d_tp <- liftIO $ completeOpenTerm sc tpDescTypeOpenTerm + d_tp <- tpDescTypeM sc d_ident <- parseAndInsDef henv (nm ++ "__desc") d_tp d_str let env' = permEnvAddOpaquePerm env nm args tp_perm term_ident d_ident liftIO $ writeIORef (heapsterEnvPermEnvRef henv) env' @@ -444,46 +435,38 @@ heapster_define_recursive_perm :: BuiltinContext -> Options -> HeapsterEnv -> String -> String -> String -> String -> TopLevel () heapster_define_recursive_perm _bic _opts henv nm args_str tp_str p_str = - do env <- liftIO $ readIORef $ heapsterEnvPermEnvRef henv - let mnm = heapsterEnvSAWModule henv - sc <- getSharedContext + do env <- liftIO $ readIORef $ heapsterEnvPermEnvRef henv + let mnm = heapsterEnvSAWModule henv + sc <- getSharedContext - -- Parse the arguments, the type, and the body - Some args_ctx <- parseParsedCtxString "argument types" env args_str - Some tp <- parseTypeString "permission type" env tp_str - 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 <- liftIO $ completeOpenTerm sc tpDescTypeOpenTerm - let d_ident = mkSafeIdent mnm (nm ++ "__desc") - d_trm <- liftIO $ translateCompleteTypeDescInCtx sc env args_p mb_p - liftIO $ scInsertDef sc mnm 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 trans_ident = mkSafeIdent mnm nm - trans_tp <- - liftIO $ completeOpenTerm sc $ runNilTypeTransM env noChecks $ - piExprCtx args $ return $ sortOpenTerm $ mkSort 0 - trans_trm <- - liftIO $ completeOpenTerm sc $ runNilTypeTransM env noChecks $ - lambdaExprCtx args $ - do args_tms <- transTerms <$> infoCtx <$> ask - let ks = snd $ translateCruCtx args - return $ applyGlobalOpenTerm "Prelude.tpElemEnv" - [tpEnvOpenTerm (zip ks args_tms), - ctorOpenTerm "Prelude.Tp_Ind" [globalOpenTerm d_ident]] - liftIO $ scInsertDef sc mnm trans_ident trans_tp trans_trm - - -- Add the recursive perm to the environment and update henv - env' <- - permEnvAddRecPermM env nm args tp trans_ident d_ident mb_p - NameNonReachConstr - (\_ _ -> return NoReachMethods) - liftIO $ writeIORef (heapsterEnvPermEnvRef henv) env' + -- Parse the arguments, the type, and the body + Some args_ctx <- parseParsedCtxString "argument types" env args_str + Some tp <- parseTypeString "permission type" env tp_str + 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 + liftIO $ scInsertDef sc mnm 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 trans_ident = mkSafeIdent mnm nm + trans_tp <- liftIO $ translateExprTypeFunType sc env args + trans_trm <- + liftIO $ translateIndTypeFun sc env args (globalOpenTerm d_ident) + liftIO $ scInsertDef sc mnm trans_ident trans_tp trans_trm + + -- Add the recursive perm to the environment and update henv + env' <- + permEnvAddRecPermM env nm args tp trans_ident d_ident mb_p + NameNonReachConstr + (\_ _ -> return NoReachMethods) + liftIO $ writeIORef (heapsterEnvPermEnvRef henv) env' {- -- | Define a new recursive named permission with the given name, arguments, From 97158f9d33e42f2356e42e769b095844c8c1af02 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Sun, 22 Oct 2023 08:29:45 -0700 Subject: [PATCH 136/305] finished defining the heapster_define_recursive_shape in the new SpecM monad approach; updated the interpreter docs for the commands that have so far been updated --- src/SAWScript/HeapsterBuiltins.hs | 177 +++++------------------------- src/SAWScript/Interpreter.hs | 35 ++---- 2 files changed, 39 insertions(+), 173 deletions(-) diff --git a/src/SAWScript/HeapsterBuiltins.hs b/src/SAWScript/HeapsterBuiltins.hs index d9c702096f..8aec2a8ad8 100644 --- a/src/SAWScript/HeapsterBuiltins.hs +++ b/src/SAWScript/HeapsterBuiltins.hs @@ -430,7 +430,7 @@ heapster_define_opaque_perm _bic _opts henv nm args_str tp_str term_str d_str = 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 -> TopLevel () @@ -468,164 +468,45 @@ heapster_define_recursive_perm _bic _opts henv nm args_str tp_str p_str = (\_ _ -> 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 = +-- 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 + let mnm = heapsterEnvSAWModule henv sc <- getSharedContext - -- Parse the arguments and type + -- 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 - Some tp <- parseTypeString "permission type" env tp_str - let mnm = heapsterEnvSAWModule henv - trans_ident = mkSafeIdent mnm (nm ++ "_IRT") + args_p = CruCtxCons args (LLVMShapeRepr w) + mb_sh <- parseExprInCtxString env (LLVMShapeRepr w) + (consParsedCtx nm (LLVMShapeRepr w) args_ctx) body_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 -> 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)) - (\_ _ -> return NoReachMethods) - liftIO $ writeIORef (heapsterEnvPermEnvRef henv) env' + -- Generate the type description for the body of the recursive shape + d_tp <- tpDescTypeM sc + let d_ident = mkSafeIdent mnm (nm ++ "__desc") + d_trm <- liftIO $ translateCompleteDescInCtx sc env args_p mb_sh + liftIO $ scInsertDef sc mnm d_ident d_tp d_trm --- | 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 = - do env <- liftIO $ readIORef $ heapsterEnvPermEnvRef henv - SomeKnownNatGeq1 w <- - failOnNothing "Shape width must be positive" $ someKnownNatGeq1 w_int - sc <- getSharedContext + -- Generate the function \args -> tpElemEnv args (Ind d) from the + -- arguments to the type of the translation of the permission as the term + let trans_ident = mkSafeIdent mnm nm + trans_tp <- liftIO $ translateExprTypeFunType sc env args + trans_trm <- + liftIO $ translateIndTypeFun sc env args (globalOpenTerm d_ident) + liftIO $ scInsertDef sc mnm trans_ident trans_tp trans_trm - -- Parse the arguments - Some args_ctx <- parseParsedCtxString "argument types" env args_str - 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 + -- Add the recursive shape to the environment and update henv + let nmsh = NamedShape nm args $ RecShapeBody mb_sh trans_ident d_ident + let env' = permEnvAddNamedShape env nmsh 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 -> diff --git a/src/SAWScript/Interpreter.hs b/src/SAWScript/Interpreter.hs index 898ed9eac5..98d1bee09c 100644 --- a/src/SAWScript/Interpreter.hs +++ b/src/SAWScript/Interpreter.hs @@ -4248,47 +4248,32 @@ 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 defined 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." - ] - - , prim "heapster_define_irt_recursive_perm" - "HeapsterEnv -> String -> String -> String -> [String] -> TopLevel HeapsterEnv" - (bicVal heapster_define_irt_recursive_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." + , " 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_shape" + , prim "heapster_define_recursive_shape" "HeapsterEnv -> String -> Int -> String -> String -> TopLevel HeapsterEnv" (bicVal heapster_define_irt_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." + , " 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_reachability_perm" From 6b71ded208dd259e7c9a12a9777593e1bd3539d5 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 23 Oct 2023 08:02:42 -0700 Subject: [PATCH 137/305] expanded the comments on SomePartialNamedShape --- heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs index 62a2022ec5..9c181861d4 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs @@ -7950,8 +7950,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 From cf5d6454b583d82e35aec89ebc892f726a9e0684 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 23 Oct 2023 08:03:04 -0700 Subject: [PATCH 138/305] updated more of HeapsterBuiltins.hs to work with the new SpecM --- src/SAWScript/HeapsterBuiltins.hs | 224 ++++++++++++++++-------------- 1 file changed, 118 insertions(+), 106 deletions(-) diff --git a/src/SAWScript/HeapsterBuiltins.hs b/src/SAWScript/HeapsterBuiltins.hs index 8aec2a8ad8..0a6cfa55e8 100644 --- a/src/SAWScript/HeapsterBuiltins.hs +++ b/src/SAWScript/HeapsterBuiltins.hs @@ -412,6 +412,7 @@ 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 heapster_define_opaque_perm :: BuiltinContext -> Options -> HeapsterEnv -> @@ -429,6 +430,7 @@ heapster_define_opaque_perm _bic _opts henv nm args_str tp_str term_str d_str = 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, and permission that it unfolds to heapster_define_recursive_perm :: BuiltinContext -> Options -> HeapsterEnv -> @@ -455,125 +457,78 @@ heapster_define_recursive_perm _bic _opts henv nm args_str tp_str p_str = -- Generate the function \args -> tpElemEnv args (Ind d) from the -- arguments to the type of the translation of the permission as the term - let trans_ident = mkSafeIdent mnm nm - trans_tp <- liftIO $ translateExprTypeFunType sc env args - trans_trm <- + let transf_ident = mkSafeIdent mnm nm + transf_tp <- liftIO $ translateExprTypeFunType sc env args + transf_trm <- liftIO $ translateIndTypeFun sc env args (globalOpenTerm d_ident) - liftIO $ scInsertDef sc mnm trans_ident trans_tp trans_trm + liftIO $ scInsertDef sc mnm transf_ident transf_tp transf_trm -- Add the recursive perm to the environment and update henv env' <- - permEnvAddRecPermM env nm args tp trans_ident d_ident mb_p + permEnvAddRecPermM env nm args tp transf_ident d_ident mb_p NameNonReachConstr (\_ _ -> return NoReachMethods) liftIO $ writeIORef (heapsterEnvPermEnvRef henv) env' + -- | Define a new recursive named permission with the given name, arguments, --- type, and 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 = +-- 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 let mnm = heapsterEnvSAWModule henv sc <- getSharedContext - -- 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 + -- 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 - args_p = CruCtxCons args (LLVMShapeRepr w) - mb_sh <- parseExprInCtxString env (LLVMShapeRepr w) - (consParsedCtx nm (LLVMShapeRepr w) args_ctx) body_str + 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 shape + -- 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_sh + d_trm <- liftIO $ translateCompleteDescInCtx sc env args_p mb_p liftIO $ scInsertDef sc mnm 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 trans_ident = mkSafeIdent mnm nm - trans_tp <- liftIO $ translateExprTypeFunType sc env args - trans_trm <- + let transf_ident = mkSafeIdent mnm nm + transf_tp <- liftIO $ translateExprTypeFunType sc env args + transf_trm <- liftIO $ translateIndTypeFun sc env args (globalOpenTerm d_ident) - liftIO $ scInsertDef sc mnm trans_ident trans_tp trans_trm + liftIO $ scInsertDef sc mnm transf_ident transf_tp transf_trm - -- Add the recursive shape to the environment and update henv - let nmsh = NamedShape nm args $ RecShapeBody mb_sh trans_ident d_ident - let env' = permEnvAddNamedShape env nmsh - liftIO $ writeIORef (heapsterEnvPermEnvRef henv) env' - -{- --- | 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 -> + -- 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 :>: @@ -581,9 +536,60 @@ 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 => SharedContext -> PermEnv -> + ModuleName -> String -> CruCtx args -> NatRepr w -> + Mb (args :> LLVMShapeType w) (PermExpr (LLVMShapeType w)) -> + TopLevel PermEnv +addRecNamedShape sc env mnm nm args w mb_sh = + -- Generate the type description for the body of the recursive shape + do 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 + liftIO $ scInsertDef sc mnm 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) + liftIO $ scInsertDef sc mnm 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 + let mnm = heapsterEnvSAWModule henv + sc <- getSharedContext + + -- 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 sc env mnm 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. @@ -595,11 +601,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 -> @@ -615,14 +622,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 @@ -630,17 +638,21 @@ 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 + d_tp <- tpDescTypeM sc + d_id <- parseAndInsDef henv (nm ++ "__desc") d_tp d_str tp_tp <- liftIO $ translateCompleteTypeInCtx sc env args $ nus (cruCtxProxies args) $ const $ ValuePermRepr $ LLVMShapeRepr w tp_id <- parseAndInsDef henv nm tp_tp tp_str - let env' = withKnownNat w $ permEnvAddOpaqueShape env nm args mb_len tp_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 @@ -664,13 +676,11 @@ 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 -> + RecShape nm ctx mb_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 + env' <- addRecNamedShape sc env mnm nm' ctx w mb_sh liftIO $ writeIORef (heapsterEnvPermEnvRef henv) env' @@ -898,6 +908,8 @@ 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 -> From 18cea15ad3d91df5aa3d002aac7ffeee41472aea Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 23 Oct 2023 09:59:21 -0700 Subject: [PATCH 139/305] finished updating SAW to the new SpecM monad! --- src/SAWScript/HeapsterBuiltins.hs | 68 +++++++++++++++++++------------ src/SAWScript/Interpreter.hs | 29 ++++++------- 2 files changed, 58 insertions(+), 39 deletions(-) diff --git a/src/SAWScript/HeapsterBuiltins.hs b/src/SAWScript/HeapsterBuiltins.hs index 0a6cfa55e8..b56424c964 100644 --- a/src/SAWScript/HeapsterBuiltins.hs +++ b/src/SAWScript/HeapsterBuiltins.hs @@ -13,8 +13,6 @@ {-# LANGUAGE ViewPatterns #-} module SAWScript.HeapsterBuiltins --- FIXME HERE NOW -{- ( heapster_init_env , heapster_init_env_debug , heapster_init_env_from_file @@ -31,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 @@ -60,7 +57,7 @@ module SAWScript.HeapsterBuiltins , heapster_dump_ide_info , heapster_set_debug_level , heapster_set_translation_checks - ) -} where + ) where import Data.Maybe import Data.String @@ -73,7 +70,6 @@ import Control.Applicative ( (<|>) ) import Control.Lens import Control.Monad import Control.Monad.Reader -import Control.Monad.IO.Class import qualified Control.Monad.Fail as Fail import System.Directory import qualified Data.ByteString.Lazy as BL @@ -82,7 +78,6 @@ import GHC.TypeLits import Data.Text (Text) import Data.Binding.Hobbits hiding (sym) -import qualified Data.Type.RList as RL import Data.Parameterized.BoolRepr import qualified Data.Parameterized.Context as Ctx @@ -909,7 +904,6 @@ 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 -> @@ -939,19 +933,7 @@ 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 @@ -974,7 +956,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) @@ -1042,12 +1024,21 @@ 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 () @@ -1098,11 +1089,14 @@ heapster_typecheck_mut_funs_rename _bic _opts henv fn_names_and_perms = liftIO $ modifyIORef (heapsterEnvTCFGs henv) (\old -> map Some tcfgs ++ old) +-- | 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 = @@ -1133,6 +1127,7 @@ heapster_set_event_type _bic _opts henv term_string = liftIO $ modifyIORef' (heapsterEnvPermEnvRef henv) $ \env -> env { permEnvEventType = EventType ev_id } +-- | 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 = @@ -1144,6 +1139,8 @@ heapster_print_fun_trans _bic _opts henv fn_name = liftIO $ scRequireDef sc $ mkSafeIdent saw_modname 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 = @@ -1158,18 +1155,38 @@ heapster_export_coq _bic _opts henv filename = 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 @@ -1182,10 +1199,11 @@ 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) tcfgs <- io $ readIORef (heapsterEnvTCFGs henv) io $ HIDE.printIDEInfo penv tcfgs filename emptyPPInfo --} diff --git a/src/SAWScript/Interpreter.hs b/src/SAWScript/Interpreter.hs index 98d1bee09c..996c62aed7 100644 --- a/src/SAWScript/Interpreter.hs +++ b/src/SAWScript/Interpreter.hs @@ -4266,18 +4266,8 @@ primitives = Map.fromList , " resurively use nm (with no arguments) in those permissions" ] - , prim "heapster_define_recursive_shape" - "HeapsterEnv -> String -> Int -> String -> String -> TopLevel HeapsterEnv" - (bicVal heapster_define_irt_recursive_shape) - Experimental - [ "heapster_define_irt_recursive_shape env name w arg_ctx body_sh" - , " defines a recursive named Heapser shape named nm with arguments" - , " parsed from args_ctx and width w that unfolds to the shape body_sh," - , " whichx can contain name for recursive occurrences of the shape" - ] - , prim "heapster_define_reachability_perm" - "HeapsterEnv -> String -> String -> String -> String -> String -> String -> String -> String -> TopLevel HeapsterEnv" + "HeapsterEnv -> String -> String -> String -> String -> String -> TopLevel HeapsterEnv" (bicVal heapster_define_reachability_perm) Experimental [ "heapster_define_recursive_perm env name arg_ctx value_type" @@ -4288,6 +4278,16 @@ primitives = Map.fromList , " p1 \\/ ... \\/ pn, where the pi can contain name." ] + , prim "heapster_define_recursive_shape" + "HeapsterEnv -> String -> Int -> String -> String -> TopLevel HeapsterEnv" + (bicVal heapster_define_recursive_shape) + Experimental + [ "heapster_define_irt_recursive_shape env name w arg_ctx body_sh" + , " defines a recursive named Heapser shape named nm with arguments" + , " parsed from args_ctx and width w that unfolds to the shape body_sh," + , " whichx can contain name for recursive occurrences of the shape" + ] + , prim "heapster_define_perm" "HeapsterEnv -> String -> String -> String -> String -> TopLevel HeapsterEnv" (bicVal heapster_define_perm) @@ -4310,7 +4310,7 @@ primitives = Map.fromList "HeapsterEnv -> String -> Int -> 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" @@ -4319,8 +4319,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" From d4ea60203026feca5eafff1aac89cf1dc720138a Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 23 Oct 2023 12:51:19 -0700 Subject: [PATCH 140/305] added varKindExpr for use in translating descriptions from expression variables --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 30 +++++++++++-------- saw-core/prelude/Prelude.sawcore | 8 +++++ 2 files changed, 25 insertions(+), 13 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index ea13d583c8..a99a9bb49e 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -306,13 +306,17 @@ voidTpDesc :: OpenTerm voidTpDesc = ctorOpenTerm "Prelude.Tp_Void" [] -- | Build a type description for a free deBruijn index -varTpDesc :: OpenTerm -> Natural -> OpenTerm -varTpDesc d ix = ctorOpenTerm "Prelude.Tp_Var" [d, natOpenTerm ix] +varTpDesc :: Natural -> OpenTerm +varTpDesc ix = ctorOpenTerm "Prelude.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 "Prelude.TpExpr_Var" [ek, natOpenTerm ix] +-- | Build a kind expression of a given kind of a deBruijn index +varKindExpr :: OpenTerm -> Natural -> OpenTerm +varKindExpr d ix = applyGlobalOpenTerm "Prelude.varKindExpr" [d,natOpenTerm ix] + -- | 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 @@ -1740,15 +1744,19 @@ translateBVDesc mb_e = let i_expr = translateBVConstDesc w $ mbLift mb_i 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 = + translateVarDesc mb_x >>= \case + Left etrans -> return $ 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 |] -> - translateVarDesc mb_x >>= \case - Left etrans -> return $ exprTransDescs etrans - Right (ix, ds) -> return $ zipWith varTpDesc ds [ix..] + [nuMP| PExpr_Var mb_x |] -> translateDescs mb_x [nuMP| PExpr_Unit |] -> return [] [nuMP| PExpr_Bool b |] -> return [constTpExpr boolKindDesc $ boolOpenTerm $ mbLift b] @@ -3042,12 +3050,8 @@ instance TranslateDescs (ValuePerm a) where translateDescs (mbMap2 (unfoldDefinedPerm dp) args off) Nothing -> panic "translate" ["Unknown permission name!"] [nuMP| ValPerm_Conj ps |] -> translateDescs ps - [nuMP| ValPerm_Var mb_x _ |] -> - translateVarDesc mb_x >>= \case - Left etrans -> return $ fst $ unETransPerm etrans - Right (ix, ds) -> return $ zipWith varTpDesc ds [ix..] - [nuMP| ValPerm_False |] -> - return [voidTpDesc] + [nuMP| ValPerm_Var mb_x _ |] -> translateDescs mb_x + [nuMP| ValPerm_False |] -> return [voidTpDesc] instance TransInfo info => @@ -6091,7 +6095,7 @@ translateLLVMStmt mb_stmt m = case mbMatch mb_stmt of \(_ :>: ret) fperm -> (PExpr_Var ret, sz):fperm] -- the unitTermLike argument is because ptrans_tp is a memblock permission -- with an empty shape; the empty shape expects a unit argument - :>: typeTransF ptrans_tp [unitTermLike]) + :>: typeTransF ptrans_tp []) m [nuMP| TypedLLVMCreateFrame |] -> diff --git a/saw-core/prelude/Prelude.sawcore b/saw-core/prelude/Prelude.sawcore index 0b69477138..b01168f08a 100644 --- a/saw-core/prelude/Prelude.sawcore +++ b/saw-core/prelude/Prelude.sawcore @@ -2363,6 +2363,14 @@ kindExpr K = 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; From 030a927669dbe30af081788be79654038f0895fd Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 23 Oct 2023 13:00:54 -0700 Subject: [PATCH 141/305] fixed BV proofs to use the correct, non-monadic type to pass to the errorS combinator --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 26 +++++++++++-------- 1 file changed, 15 insertions(+), 11 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index a99a9bb49e..0513ee9d17 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -3713,13 +3713,13 @@ catchPImplTerm t t_catch = -- | The failure 'PImplTerm', which immediately calls its failure continuation failPImplTerm :: PImplTerm ext blocks tops rets ps ctx failPImplTerm = - PImplTerm $ \k -> compReturnTypeM >>= \tp -> return (implFailContTerm tp k) + 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 -> - compReturnTypeM >>= \tp -> + returnTypeM >>= \tp -> return (implFailContTerm tp (case k of ImplFailContMsg ev _ -> ImplFailContMsg ev msg _ -> k)) @@ -5308,9 +5308,10 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o translatePermImpl (mbCombine RL.typeCtxProxies mb_impl') >>= \trans -> return $ PImplTerm $ \k -> do prop_tp_trans <- translate prop - ret_tp <- compReturnTypeM + ret_tp_m <- compReturnTypeM + ret_tp <- returnTypeM applyGlobalTransM "Prelude.maybe" - [ return (typeTransType1 prop_tp_trans), return ret_tp + [ return (typeTransType1 prop_tp_trans), return ret_tp_m , return (implFailAltContTerm ret_tp (mbLift prop_str) k) , lambdaTransM "eq_pf" prop_tp_trans (\prop_trans -> @@ -5337,7 +5338,7 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o , applyGlobalTransM "Prelude.bvEq" [ return (natOpenTerm w), translate1 e1, translate1 e2 ] , (\ret_tp -> - implFailAltContTerm ret_tp (mbLift prop_str) k) <$> compReturnTypeM + implFailAltContTerm ret_tp (mbLift prop_str) k) <$> returnTypeM , withPermStackM (:>: translateVar x) (:>: PTrans_Conj [APTrans_BVProp (BVPropTrans prop unitOpenTerm)]) $ popPImplTerm trans k] @@ -5364,9 +5365,10 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o translatePermImpl (mbCombine RL.typeCtxProxies mb_impl') >>= \trans -> return $ PImplTerm $ \k -> do prop_tp_trans <- translate prop - ret_tp <- compReturnTypeM + ret_tp_m <- compReturnTypeM + ret_tp <- returnTypeM applyGlobalTransM "Prelude.maybe" - [ return (typeTransType1 prop_tp_trans), return ret_tp + [ return (typeTransType1 prop_tp_trans), return ret_tp_m , return (implFailAltContTerm ret_tp (mbLift prop_str) k) , lambdaTransM "ult_pf" prop_tp_trans (\prop_trans -> @@ -5398,9 +5400,10 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o translatePermImpl (mbCombine RL.typeCtxProxies mb_impl') >>= \trans -> return $ PImplTerm $ \k -> do prop_tp_trans <- translate prop - ret_tp <- compReturnTypeM + ret_tp_m <- compReturnTypeM + ret_tp <- returnTypeM applyGlobalTransM "Prelude.maybe" - [ return (typeTransType1 prop_tp_trans), return ret_tp + [ return (typeTransType1 prop_tp_trans), return ret_tp_m , return (implFailAltContTerm ret_tp (mbLift prop_str) k) , lambdaTransM "ule_pf" prop_tp_trans (\prop_trans -> @@ -5434,9 +5437,10 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o translatePermImpl (mbCombine RL.typeCtxProxies mb_impl') >>= \trans -> return $ PImplTerm $ \k -> do prop_tp_trans <- translate prop - ret_tp <- compReturnTypeM + ret_tp_m <- compReturnTypeM + ret_tp <- returnTypeM applyGlobalTransM "Prelude.maybe" - [ return (typeTransType1 prop_tp_trans), return ret_tp + [ return (typeTransType1 prop_tp_trans), return ret_tp_m , return (implFailAltContTerm ret_tp (mbLift prop_str) k) , lambdaTransM "ule_diff_pf" prop_tp_trans (\prop_trans -> From 951d232c75a8d9242eb67996ca22c4ba32b4934f Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 23 Oct 2023 17:20:01 -0700 Subject: [PATCH 142/305] bug fix: the type description for an existential permission needs to handle the special case of an equality permission in the body of the existential --- .../src/Verifier/SAW/Heapster/SAWTranslation.hs | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 0513ee9d17..5f61413913 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -203,6 +203,11 @@ bvExprKind w = ctorOpenTerm "Prelude.Kind_bv" [natOpenTerm w] tpDescTypeOpenTerm :: OpenTerm tpDescTypeOpenTerm = dataTypeOpenTerm "Prelude.TpDesc" [] +-- | Convert a kind description to a type description with the @Tp_Kind@ +-- constructor +kindToTpDesc :: OpenTerm -> OpenTerm +kindToTpDesc d = ctorOpenTerm "Prelude.Tp_Kind" [d] + -- | The type description for the unit type unitTpDesc :: OpenTerm unitTpDesc = ctorOpenTerm "Prelude.Tp_Kind" [unitKindDesc] @@ -3031,6 +3036,11 @@ instance TranslateDescs (ValuePerm a) where [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' -> + let tp_repr = mbLift $ fmap bindingType mb_mb_p' + (_, k_ds) = translateType tp_repr in + 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' From 524bb91faeddd1e7709c825087e44713cf9ed1ce Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 23 Oct 2023 17:20:14 -0700 Subject: [PATCH 143/305] implemented proveEqNat --- saw-core/prelude/Prelude.sawcore | 18 ++++++++++++++++-- 1 file changed, 16 insertions(+), 2 deletions(-) diff --git a/saw-core/prelude/Prelude.sawcore b/saw-core/prelude/Prelude.sawcore index b01168f08a..1a209ba54f 100644 --- a/saw-core/prelude/Prelude.sawcore +++ b/saw-core/prelude/Prelude.sawcore @@ -840,7 +840,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 +879,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); From 95ed96b145fb0dcacb527e46b39ae7b821b2407c Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 23 Oct 2023 18:00:35 -0700 Subject: [PATCH 144/305] added a Tp_M constructor to the output type of function descriptions; changed pis to lambdas for generated functions; changed constants to use the more general constKindExpr function --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 36 +++++++++++++------ saw-core/prelude/Prelude.sawcore | 8 +++++ 2 files changed, 33 insertions(+), 11 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 5f61413913..d3d360b778 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -212,15 +212,21 @@ kindToTpDesc d = ctorOpenTerm "Prelude.Tp_Kind" [d] unitTpDesc :: OpenTerm unitTpDesc = ctorOpenTerm "Prelude.Tp_Kind" [unitKindDesc] +-- | The expression kind for the Boolean type +boolExprKind :: OpenTerm +boolExprKind = ctorOpenTerm "Prelude.Kind_bool" [] + -- | The kind description for the Boolean type boolKindDesc :: OpenTerm -boolKindDesc = ctorOpenTerm "Prelude.Kind_Expr" [ctorOpenTerm - "Prelude.Kind_bool" []] +boolKindDesc = ctorOpenTerm "Prelude.Kind_Expr" [boolExprKind] + +-- | The expression kind for the Nat type +natExprKind :: OpenTerm +natExprKind = ctorOpenTerm "Prelude.Kind_nat" [] -- | The kind description for the Nat type natKindDesc :: OpenTerm -natKindDesc = ctorOpenTerm "Prelude.Kind_Expr" [ctorOpenTerm - "Prelude.Kind_nat" []] +natKindDesc = ctorOpenTerm "Prelude.Kind_Expr" [natExprKind] -- | The kind description for the type @bitvector w@ bvKindDesc :: Natural -> OpenTerm @@ -297,6 +303,10 @@ arrowTpDesc d_in d_out = ctorOpenTerm "Prelude.Tp_Arr" [d_in, d_out] arrowTpDescMulti :: [OpenTerm] -> OpenTerm -> OpenTerm arrowTpDescMulti tps_in tp_out = foldr arrowTpDesc tp_out tps_in +-- | Build the type description for a computation with a given return type +tpMTpDesc :: OpenTerm -> OpenTerm +tpMTpDesc d = ctorOpenTerm "Prelude.Tp_M" [d] + -- | Build the type description for a pi-abstraction over a kind description piTpDesc :: OpenTerm -> OpenTerm -> OpenTerm piTpDesc kd tpd = ctorOpenTerm "Prelude.Tp_Pi" [kd, tpd] @@ -318,10 +328,14 @@ varTpDesc ix = ctorOpenTerm "Prelude.Tp_Var" [natOpenTerm ix] varTpExpr :: OpenTerm -> Natural -> OpenTerm varTpExpr ek ix = ctorOpenTerm "Prelude.TpExpr_Var" [ek, natOpenTerm ix] --- | Build a kind expression of a given kind of a deBruijn index +-- | Build a kind expression of a given kind from a deBruijn index varKindExpr :: OpenTerm -> Natural -> OpenTerm varKindExpr d ix = applyGlobalOpenTerm "Prelude.varKindExpr" [d,natOpenTerm ix] +-- | Build a kind expression of a given kind from an element of that kind +constKindExpr :: OpenTerm -> OpenTerm -> OpenTerm +constKindExpr d elem = applyGlobalOpenTerm "Prelude.constKindExpr" [d,elem] + -- | 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 @@ -697,7 +711,7 @@ exprTransDescs (ETrans_Shape ds _) = ds exprTransDescs (ETrans_Perm ds _) = ds exprTransDescs (ETrans_Term tp t) = case translateKindDescs tp of - [d] -> [ctorOpenTerm "Prelude.TpExpr_Const" [d, t]] + [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 @@ -1764,9 +1778,9 @@ instance TranslateDescs (PermExpr a) where [nuMP| PExpr_Var mb_x |] -> translateDescs mb_x [nuMP| PExpr_Unit |] -> return [] [nuMP| PExpr_Bool b |] -> - return [constTpExpr boolKindDesc $ boolOpenTerm $ mbLift b] + return [constTpExpr boolExprKind $ boolOpenTerm $ mbLift b] [nuMP| PExpr_Nat n |] -> - return [constTpExpr natKindDesc $ natOpenTerm $ mbLift n] + return [constTpExpr natExprKind $ natOpenTerm $ mbLift n] [nuMP| PExpr_String _ |] -> panic "translateDescs" ["Cannot (yet?) translate strings to type-level expressions"] @@ -3347,7 +3361,7 @@ translateRetTpDesc :: CruCtx rets -> DescTransM ctx OpenTerm translateRetTpDesc rets ret_perms = inExtCtxDescTransM rets $ \kdescs -> - sigmaTpDescMulti kdescs <$> translateDesc ret_perms + tpMTpDesc <$> sigmaTpDescMulti kdescs <$> translateDesc ret_perms -- | Build the return type for the function resulting from an entrypoint translateEntryRetType :: TransInfo info => @@ -6459,7 +6473,7 @@ translateCFGBody :: PermCheckExtC ext exprExt => translateCFGBody cfg = let fun_perm = tpcfgFunPerm cfg blkMap = tpcfgBlockMap cfg in - piExprCtx (funPermTops fun_perm) $ + lambdaExprCtx (funPermTops fun_perm) $ lambdaPermCtx (funPermIns fun_perm) $ \pctx -> do ev <- infoEvType <$> ask blk_ds <- translateBlockMapDescs $ tpcfgBlockMap cfg @@ -6556,7 +6570,7 @@ translateCFGFromBodies cfgs _ i translateCFGFromBodies cfgs bodies i | SomeTypedCFG _ _ cfg <- cfgs!!i = let fun_perm = tpcfgFunPerm cfg in - piExprCtx (funPermTops fun_perm) $ + lambdaExprCtx (funPermTops fun_perm) $ lambdaPermCtx (funPermIns fun_perm) $ \pctx -> do ev <- infoEvType <$> ask ectx <- infoCtx <$> ask diff --git a/saw-core/prelude/Prelude.sawcore b/saw-core/prelude/Prelude.sawcore index 1a209ba54f..4755ed8165 100644 --- a/saw-core/prelude/Prelude.sawcore +++ b/saw-core/prelude/Prelude.sawcore @@ -2486,6 +2486,14 @@ defaultEKElem EK = ExprKind#rec exprKindElem () False 0 (\ (w:Nat) -> bvNat w 0) 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; From a73206852f6185c46e763d8d91b489cdd9b2068a Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Tue, 24 Oct 2023 06:57:30 -0700 Subject: [PATCH 145/305] whoops, translateCallEntry should not pass in the top-level arguments as inputs --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 33 +++++++++++-------- .../Verifier/SAW/Heapster/TypedCrucible.hs | 12 ++++--- 2 files changed, 26 insertions(+), 19 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index d3d360b778..0e7952ed8d 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -334,7 +334,7 @@ varKindExpr d ix = applyGlobalOpenTerm "Prelude.varKindExpr" [d,natOpenTerm ix] -- | Build a kind expression of a given kind from an element of that kind constKindExpr :: OpenTerm -> OpenTerm -> OpenTerm -constKindExpr d elem = applyGlobalOpenTerm "Prelude.constKindExpr" [d,elem] +constKindExpr d e = applyGlobalOpenTerm "Prelude.constKindExpr" [d,e] -- | Build the type description @Tp_Subst T K e@ that represents an explicit -- substitution of expression @e@ of kind @K@ into type description @T@ @@ -5880,18 +5880,22 @@ 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 + ectx_ag <- translate $ mbMap2 RL.append mb_args mb_ghosts + ectx <- translate (mbMap2 RL.append + (mbMap2 RL.append mb_tops mb_args) mb_ghosts) stack <- 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 @@ -5901,15 +5905,14 @@ translateCallEntry nm entry_trans mb_tops_args mb_ghosts = case typedEntryTransIx entry_trans of Just (d, funix) -> -- If so, build the associated CallS term, which applies the function - -- index to the expressions with permissions on the stack followed by - -- the proof objects for those permissions + -- index to all the terms in the args and ghosts (but not the tops, + -- which are free) plus all the permissions on the stack do ev <- infoEvType <$> ask expr_ctx <- itiExprCtx <$> ask arg_membs <- itiPermStackVars <$> ask - let e_args = RL.map (flip RL.get expr_ctx) arg_membs i_args <- itiPermStack <$> ask return (callSOpenTerm ev d funix - (exprCtxToTerms e_args ++ permCtxToTerms i_args)) + (exprCtxToTerms ectx_ag ++ permCtxToTerms i_args)) Nothing -> -- Otherwise, continue translating with the target entrypoint, with all -- the current expressions free but with only those permissions on top @@ -5925,11 +5928,11 @@ 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) @@ -6454,8 +6457,10 @@ translateCFGInitBody mapTrans cfg pctx = all_px = RL.map (\_ -> Proxy) pctx' init_entry = lookupEntryTransCast (tpcfgEntryID cfg) CruCtxNil mapTrans in impTransM all_membs pctx' mapTrans retTypeTrans $ - translateCallEntry "CFG" init_entry (nuMulti all_px id) (nuMulti all_px $ - const MNil) + 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 diff --git a/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs b/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs index 38c95b1e24..cdf7e74edb 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs @@ -1090,7 +1090,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 |]) @@ -1098,9 +1098,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 @@ -1122,9 +1123,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 = @@ -4235,7 +4237,7 @@ proveCallSiteImpl srcID destID args ghosts vars mb_perms_in mb_perms_out = -- FIXME HERE NOW: add the input perms and call site to our error message let err = ppProofError ppInfo 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 From b0a49354bcbf1ca479becb1fa0d842e90289f8a8 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Tue, 24 Oct 2023 07:26:19 -0700 Subject: [PATCH 146/305] removed some unused arguments; made some small cosmetic changes --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 27 ++++++++++--------- 1 file changed, 14 insertions(+), 13 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 0e7952ed8d..c929d1c2e2 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -659,13 +659,12 @@ instance IsTermTrans (ExprTrans tp) where 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 :: ExprTrans tp -> TypeTrans (ExprTrans tp) @@ -1758,9 +1757,14 @@ 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_fs mb_i |] -> - do fs_exprs <- mapM translateBVFactorDesc $ mbList mb_fs - let i_expr = translateBVConstDesc w $ mbLift mb_i + [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 @@ -2153,8 +2157,7 @@ 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 @@ -2197,7 +2200,7 @@ instance IsTermTrans (LLVMArrayBorrowTrans ctx w) where -- | 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 +permCtxToTerms = transTerms -- | Extract out the permission of a permission translation result permTransPerm :: RAssign Proxy ctx -> PermTrans ctx a -> Mb ctx (ValuePerm a) @@ -5908,11 +5911,9 @@ translateCallEntry nm entry_trans mb_tops mb_args mb_ghosts = -- index to all the terms in the args and ghosts (but not the tops, -- which are free) plus all the permissions on the stack do ev <- infoEvType <$> ask - expr_ctx <- itiExprCtx <$> ask - arg_membs <- itiPermStackVars <$> ask - i_args <- itiPermStack <$> ask + pctx <- itiPermStack <$> ask return (callSOpenTerm ev d funix - (exprCtxToTerms ectx_ag ++ permCtxToTerms i_args)) + (exprCtxToTerms ectx_ag ++ permCtxToTerms pctx)) Nothing -> -- Otherwise, continue translating with the target entrypoint, with all -- the current expressions free but with only those permissions on top From 529a149bb73e1144a1ed1661f7c9b643080ed4d1 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Tue, 24 Oct 2023 12:21:28 -0700 Subject: [PATCH 147/305] updated Coq translation to work with the new SpecM monad --- .../CryptolToCoq/SAWCoreBitvectors.v | 2 + .../CryptolToCoq/SAWCorePreludeExtra.v | 25 ---------- .../CryptolToCoq/SAWCoreScaffolding.v | 22 +++++---- .../SAW/Translation/Coq/SpecialTreatment.hs | 48 ++++++++++++------- 4 files changed, 45 insertions(+), 52 deletions(-) diff --git a/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreBitvectors.v b/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreBitvectors.v index 46715ee877..02d77adbc2 100644 --- a/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreBitvectors.v +++ b/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreBitvectors.v @@ -6,6 +6,8 @@ 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. diff --git a/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCorePreludeExtra.v b/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCorePreludeExtra.v index c9921e60b5..496c202e9a 100644 --- a/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCorePreludeExtra.v +++ b/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCorePreludeExtra.v @@ -126,28 +126,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/SAWCoreScaffolding.v b/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreScaffolding.v index 301bd12bf7..a0f02a2581 100644 --- a/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreScaffolding.v +++ b/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreScaffolding.v @@ -139,7 +139,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. @@ -233,8 +233,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 @@ -354,15 +354,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 *) @@ -378,8 +382,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 *) @@ -387,8 +391,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/src/Verifier/SAW/Translation/Coq/SpecialTreatment.hs b/saw-core-coq/src/Verifier/SAW/Translation/Coq/SpecialTreatment.hs index e801bf8b7a..cf50a5fdd5 100644 --- a/saw-core-coq/src/Verifier/SAW/Translation/Coq/SpecialTreatment.hs +++ b/saw-core-coq/src/Verifier/SAW/Translation/Coq/SpecialTreatment.hs @@ -200,6 +200,12 @@ sawDefinitionsModule = mkModuleName ["SAWCoreScaffolding"] entreeSpecsModule :: ModuleName entreeSpecsModule = mkModuleName ["SpecM"] +tpDescModule :: ModuleName +tpDescModule = mkModuleName ["TpDesc"] + +fixtreeModule :: ModuleName +fixtreeModule = mkModuleName ["FixTree"] + polyListModule :: ModuleName polyListModule = mkModuleName ["PolyList"] @@ -497,27 +503,33 @@ sawCorePreludeSpecialTreatmentMap configuration = , ("test_fun6", skip) ] - -- LetRecTypes + -- Either + ++ + [ ("Either", mapsTo datatypesModule "sum") + , ("Left", mapsToExpl datatypesModule "inl") + , ("Right", mapsToExpl datatypesModule "inr") + ] + + -- Type descriptions ++ - [ ("LetRecType", mapsTo entreeSpecsModule "LetRecType") - , ("LRT_SpecM", mapsToExpl entreeSpecsModule "LRT_SpecM") - , ("LRT_FunDep", mapsToExpl entreeSpecsModule "LRT_FunDep") - , ("LRT_FunClos", mapsToExpl entreeSpecsModule "LRT_FunClos") - , ("LRT_Type", mapsToExpl entreeSpecsModule "LRT_Type") - , ("LRT_BinOp", mapsToExpl entreeSpecsModule "LRT_BinOp") - , ("LRT_Sigma", mapsToExpl entreeSpecsModule "LRT_Sigma") - , ("LetRecType__rec", mapsToExpl entreeSpecsModule "LetRecType_rect") - , ("ValidLRTFunctor2", mapsToExpl entreeSpecsModule "ColimFunctor2") - , ("pair_ValidLRTFunctor2", mapsToExpl entreeSpecsModule "Pair_ColimFunctor2") - , ("either_ValidLRTFunctor2", skip) -- FIXME: implement this! - , ("LRT_Either", skip) -- FIXME: implement this! - , ("Vec_ValidLRTFunctor2", mapsTo entreeSpecsModule "Vec_ColimFunctor2") + map (\str -> (str, mapsToExpl tpDescModule 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_Vec", "Tp_Void", "Tp_Ind", "Tp_Var", "Tp_TpSubst" + , "Tp_ExprSubst" + , "tpSubst", "elimTpEnvElem", "tpElemEnv" + , "indElem", "indToTpElem", "tpToIndElem" ] -- The specification monad ++ - [ ("EvType", mapsTo entreeSpecsModule "EvType") - , ("Build_EvType", mapsTo entreeSpecsModule "Build_EvType") + [ ("EvType", mapsTo fixtreeModule "EvType") + , ("Build_EvType", mapsTo fixtreeModule "Build_EvType") + , ("FunIx", mapsTo fixtreeModule "FunIx") , ("evTypeType", mapsTo entreeSpecsModule "evTypeType") , ("evRetType", mapsTo entreeSpecsModule "evRetType") , ("FunStack", mapsTo entreeSpecsModule "FunStack") @@ -541,8 +553,8 @@ sawCorePreludeSpecialTreatmentMap configuration = , ("bindS", mapsToExpl entreeSpecsModule "BindS") , ("triggerS", mapsToExpl entreeSpecsModule "TriggerS") , ("errorS", mapsToExpl entreeSpecsModule "ErrorS") - , ("forallS", mapsToExplInferArg "SpecM.ForallS" 3) - , ("existsS", mapsToExplInferArg "SpecM.ExistsS" 3) + , ("forallS", mapsToExplInferArg "SpecM.ForallS" 2) + , ("existsS", mapsToExplInferArg "SpecM.ExistsS" 2) , ("assumeS", mapsToExpl entreeSpecsModule "AssumeS") , ("assertS", mapsToExpl entreeSpecsModule "AssertS") , ("CallS", mapsToExpl entreeSpecsModule "CallS") From 094cccedc3a58d75ca4320610a8aab9f93e6fd3e Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Tue, 24 Oct 2023 12:22:01 -0700 Subject: [PATCH 148/305] updated CryptolM.sawcore to work with the new SpecM monad --- cryptol-saw-core/saw/CryptolM.sawcore | 942 ++++++++++++-------------- 1 file changed, 450 insertions(+), 492 deletions(-) diff --git a/cryptol-saw-core/saw/CryptolM.sawcore b/cryptol-saw-core/saw/CryptolM.sawcore index 7c458c6b86..e3975c97c3 100644 --- a/cryptol-saw-core/saw/CryptolM.sawcore +++ b/cryptol-saw-core/saw/CryptolM.sawcore @@ -49,12 +49,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 +68,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 @@ -91,10 +89,10 @@ Num_rec_fin p f = -- 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 = +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 stack a)) num; + (Stream (SpecM E a)) num; {- bvVecMapInvarBindM : (E:EvType) -> (stack:FunStack) -> @@ -154,317 +152,307 @@ 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 +primitive +vecMapInvarBindM : (E:EvType) -> (a : sort 0) -> (b : qsort 0) -> + (c : sort 0) -> (n : Nat) -> (Nat -> a -> SpecM E b) -> + Vec n a -> Bool -> (Vec n b -> SpecM E c) -> + SpecM E c; + +-- FIXME: get the defined one to work! +{- +vecMapInvarBindM : (E:EvType) -> (a : sort 0) -> (b : qsort 0) -> + (c : sort 0) -> (n : Nat) -> (Nat -> a -> SpecM E b) -> + Vec n a -> Bool -> (Vec n b -> SpecM E c) -> + SpecM E c; +vecMapInvarBindM E a b c n f xs invar cont = + bindS E (Vec n b) c + (existsS E (Vec n b)) (\ (ys0:Vec n b) -> + multiArgFixS E (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) + (\ (rec : Nat -> Vec n b -> SpecM E (pushFunStack (singletonFrame (LRT_Fun Nat (\ (_:Nat) -> LRT_Fun (Vec n b) (\ (_:Vec n b) -> LRT_Ret c))))) 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 + invariantHint (SpecM E (pushFunStack (singletonFrame (LRT_Fun Nat (\ (_:Nat) -> LRT_Fun (Vec n b) (\ (_:Vec n b) -> LRT_Ret c))))) 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))))) c) + (pushStackS E (singletonFrame (LRT_Fun Nat (\ (_:Nat) -> LRT_Fun (Vec n b) (\ (_:Vec n b) -> LRT_Ret c)))) 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 + bindS E (pushFunStack (singletonFrame (LRT_Fun Nat (\ (_:Nat) -> LRT_Fun (Vec n b) (\ (_:Vec n b) -> LRT_Ret c))))) b c + (pushStackS E (singletonFrame (LRT_Fun Nat (\ (_:Nat) -> LRT_Fun (Vec n b) (\ (_:Vec n b) -> LRT_Ret c)))) 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; +vecMapInvarM : (E:EvType) -> (a : sort 0) -> (b : qsort 0) -> + (n : Nat) -> (Nat -> a -> SpecM E b) -> + Vec n a -> Bool -> SpecM E (Vec n b); +vecMapInvarM E a b n f xs invar = + vecMapInvarBindM E a b (Vec n b) n f xs invar (retS E (Vec n b)); + +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 = vecMapInvarBindM E a b c n f xs True; + +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 = vecMapInvarM E a b n f xs True; -- 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); +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); -------------------------------------------------------------------------------- -- 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)) +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 = + maybe (is_bvult n i len) (SpecM E a) + (errorS E a "bvVecAtM: invalid sequence index") + (\ (pf:is_bvult n i len) -> retS E 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)) +atM : (E:EvType) -> (n : Nat) -> (a : sort 0) -> Vec n a -> Nat -> SpecM E a; +atM E n a xs i = + maybe (IsLtNat i n) (SpecM E a) + (errorS E a "atM: invalid sequence index") + (\ (pf:IsLtNat i n) -> retS E a (atWithProof n a xs i pf)) (proveLtNat i n); -bvVecUpdateM : (E:EvType) -> (stack:FunStack) -> - (n : Nat) -> (len : Vec n Bool) -> (a : sort 0) -> +bvVecUpdateM : (E:EvType) -> (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) + SpecM E (BVVec n len a); +bvVecUpdateM E n len a xs i x = + maybe (is_bvult n i len) (SpecM E (BVVec n len a)) + (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)) (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) +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 = + maybe (is_bvult n i len) (SpecM E (Vec m a)) + (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)) (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)) +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 = + maybe (IsLtNat i n) (SpecM E (Vec n a)) + (errorS E (Vec n a) "updateM: invalid sequence index") + (\ (pf:IsLtNat i n) -> retS E (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 +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 stack (Vec (Succ n) a)) s + (streamGet (SpecM E (Vec (Succ n) a)) s (divNat i (Succ n))) ); -------------------------------------------------------------------------------- -- 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)) + retS E (Vec (mulNat m n) (a * b)) (joinCryM 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)) (zipCryM 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 : Num) -> mseq E n a -> mseq E n b -> mseq E 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)))) + (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 +460,110 @@ 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; -- 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,310 +572,292 @@ 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)) -- 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)) -- 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) +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) -> 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 = +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 : Num) -> Vec m (mseq E n a) -> + mseq E 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) + (\ (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 + (\ (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))) -> + genCryM n (Stream (SpecM E a)) (\ (i : Nat) -> + MkStream (SpecM E a) (\ (j : Nat) -> + fmapS E (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))))) + (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 (\ (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 (\ (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 (\ (i : Nat) -> @@ -905,28 +865,26 @@ ecFromThenToM E stack first next _ a = (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"; -------------------------------------------------------------------------------- From 536f6c164a4fbc8ded075f6ad8c6b2999541c466 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 25 Oct 2023 07:42:24 -0700 Subject: [PATCH 149/305] redefined all the SpecM definitions in a new SpecM.v module in saw-core-coq, which now supplies the operations for type-level expressions --- saw-core-coq/coq/_CoqProject | 1 + .../CryptolToCoq/SAWCorePreludeExtra.v | 8 +- .../CryptolToCoq/SAWCoreScaffolding.v | 6 +- .../CryptolToCoq/SAWCoreVectorsAsCoqVectors.v | 2 + .../coq/handwritten/CryptolToCoq/SpecM.v | 132 ++++++++++++++++++ .../src/Verifier/SAW/Translation/Coq.hs | 1 + .../SAW/Translation/Coq/SpecialTreatment.hs | 83 ++++------- 7 files changed, 173 insertions(+), 60 deletions(-) create mode 100644 saw-core-coq/coq/handwritten/CryptolToCoq/SpecM.v diff --git a/saw-core-coq/coq/_CoqProject b/saw-core-coq/coq/_CoqProject index 693407ac57..d6a70468c6 100644 --- a/saw-core-coq/coq/_CoqProject +++ b/saw-core-coq/coq/_CoqProject @@ -5,6 +5,7 @@ generated/CryptolToCoq/SAWCorePrelude.v generated/CryptolToCoq/CryptolPrimitivesForSAWCore.v # generated/CryptolToCoq/CryptolMPrimitivesForSAWCore.v +handwritten/CryptolToCoq/SpecM.v # handwritten/CryptolToCoq/CompM.v # handwritten/CryptolToCoq/CompMExtra.v handwritten/CryptolToCoq/CoqVectorsExtra.v diff --git a/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCorePreludeExtra.v b/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCorePreludeExtra.v index 496c202e9a..22e6165044 100644 --- a/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCorePreludeExtra.v +++ b/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCorePreludeExtra.v @@ -35,9 +35,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 +46,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 := diff --git a/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreScaffolding.v b/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreScaffolding.v index a0f02a2581..44144b7e96 100644 --- a/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreScaffolding.v +++ b/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreScaffolding.v @@ -6,7 +6,8 @@ From Coq Require Numbers.NatInt.NZLog. From Coq Require Import Strings.String. From Coq Require Export Logic.Eqdep. -From EnTree Require Export EnTreeSpecs. +From EnTree Require Import EnTreeSpecs. + (*** *** sawLet @@ -269,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) := diff --git a/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreVectorsAsCoqVectors.v b/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreVectorsAsCoqVectors.v index 1412eddb93..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. 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..6786f3562b --- /dev/null +++ b/saw-core-coq/coq/handwritten/CryptolToCoq/SpecM.v @@ -0,0 +1,132 @@ + +From CryptolToCoq Require Import SAWCoreScaffolding. +From CryptolToCoq Require Import SAWCoreVectorsAsCoqVectors. + +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) +. + +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) +. + +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 + 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 + 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_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_Vec := Tp_Vec. +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 tpSubst := tpSubst. +Definition elimTpEnvElem := elimTpEnvElem. +Definition tpElemEnv := tpElemEnv. +Definition indElem := indElem. +Definition indElem_rect := indElem_rect. +Definition indToTpElem := indToTpElem. +Definition tpToIndElem := tpToIndElem. + +(* SpecM and its operations *) +Definition FunIx := @FixTree.FunIx TpDesc. +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 CallS := @SpecM.CallS SAWTpExprOps. +Definition LambdaS := @SpecM.LambdaS SAWTpExprOps. +Definition FixS := @SpecM.FixS SAWTpExprOps. +Definition MultiFixS := @SpecM.MultiFixS SAWTpExprOps. +Definition LetRecS := @SpecM.LetRecS SAWTpExprOps. diff --git a/saw-core-coq/src/Verifier/SAW/Translation/Coq.hs b/saw-core-coq/src/Verifier/SAW/Translation/Coq.hs index fd781cd27c..78ea6593fe 100644 --- a/saw-core-coq/src/Verifier/SAW/Translation/Coq.hs +++ b/saw-core-coq/src/Verifier/SAW/Translation/Coq.hs @@ -105,6 +105,7 @@ 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 SpecM. From CryptolToCoq Require Import #{vectorModule}. Import VectorNotations. 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 cf50a5fdd5..894eeb84e6 100644 --- a/saw-core-coq/src/Verifier/SAW/Translation/Coq/SpecialTreatment.hs +++ b/saw-core-coq/src/Verifier/SAW/Translation/Coq/SpecialTreatment.hs @@ -197,15 +197,10 @@ stringModule = sawDefinitionsModule :: ModuleName sawDefinitionsModule = mkModuleName ["SAWCoreScaffolding"] -entreeSpecsModule :: ModuleName -entreeSpecsModule = mkModuleName ["SpecM"] - -tpDescModule :: ModuleName -tpDescModule = mkModuleName ["TpDesc"] - -fixtreeModule :: ModuleName -fixtreeModule = mkModuleName ["FixTree"] +specMModule :: ModuleName +specMModule = mkModuleName ["SpecM"] +-- FIXME: I don't think we are even importing PolyList any more... polyListModule :: ModuleName polyListModule = mkModuleName ["PolyList"] @@ -371,6 +366,8 @@ sawCorePreludeSpecialTreatmentMap configuration = , ("widthNat", mapsTo sawDefinitionsModule "widthNat") , ("Zero", mapsTo sawDefinitionsModule "Zero") , ("Succ", mapsTo sawDefinitionsModule "Succ") + , ("addNat", mapsTo sawDefinitionsModule "addNat") + , ("mulNat", mapsTo sawDefinitionsModule "mulNat") ] -- Vectors @@ -512,7 +509,7 @@ sawCorePreludeSpecialTreatmentMap configuration = -- Type descriptions ++ - map (\str -> (str, mapsToExpl tpDescModule str)) + map (\str -> (str, mapsToExpl 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" @@ -527,55 +524,31 @@ sawCorePreludeSpecialTreatmentMap configuration = -- The specification monad ++ - [ ("EvType", mapsTo fixtreeModule "EvType") - , ("Build_EvType", mapsTo fixtreeModule "Build_EvType") - , ("FunIx", mapsTo fixtreeModule "FunIx") - , ("evTypeType", mapsTo entreeSpecsModule "evTypeType") - , ("evRetType", mapsTo entreeSpecsModule "evRetType") - , ("FunStack", mapsTo entreeSpecsModule "FunStack") - , ("nthLRT", mapsToExpl entreeSpecsModule "nthLRT") - , ("LRTClos", mapsTo entreeSpecsModule "LRTClos") - , ("LRTArg" , mapsTo entreeSpecsModule "LRTArg") - , ("applyLRTClosDep" , mapsTo entreeSpecsModule "applyLRTClosDep") - , ("applyLRTClosClos" , mapsTo entreeSpecsModule "applyLRTClosClos") - , ("applyLRTClosNRet" , mapsTo entreeSpecsModule "applyLRTClosNRet") - , ("applyLRTClosN" , mapsTo entreeSpecsModule "applyLRTClosN") - , ("LRTInput", mapsToExpl entreeSpecsModule "LRTInput") - , ("LRTOutput", mapsToExpl entreeSpecsModule "LRTOutput") - , ("lrtPi", mapsToExpl entreeSpecsModule "lrtPi") - , ("StackCall", mapsToExpl entreeSpecsModule "StackCall") - , ("StackCallOfArgs", mapsToExpl entreeSpecsModule "StackCallOfArgs") - , ("StackCallRet", mapsToExpl entreeSpecsModule "StackCallRet") - , ("FunStackE", mapsToExpl entreeSpecsModule "FunStackE") - , ("FunStackERet", mapsToExpl entreeSpecsModule "FunStackERet") - , ("SpecM", mapsTo entreeSpecsModule "SpecM") - , ("retS", mapsToExpl entreeSpecsModule "RetS") - , ("bindS", mapsToExpl entreeSpecsModule "BindS") - , ("triggerS", mapsToExpl entreeSpecsModule "TriggerS") - , ("errorS", mapsToExpl entreeSpecsModule "ErrorS") - , ("forallS", mapsToExplInferArg "SpecM.ForallS" 2) - , ("existsS", mapsToExplInferArg "SpecM.ExistsS" 2) - , ("assumeS", mapsToExpl entreeSpecsModule "AssumeS") - , ("assertS", mapsToExpl entreeSpecsModule "AssertS") - , ("CallS", mapsToExpl entreeSpecsModule "CallS") - , ("SpecFun", mapsTo entreeSpecsModule "SpecFun") - , ("applyCallClos", skip) -- FIXME: translation bug! - , ("stackIncl", mapsTo entreeSpecsModule "stackIncl") - , ("StackTuple", mapsTo entreeSpecsModule "StackTuple") - , ("SpecDef", mapsTo entreeSpecsModule "SpecDef") - , ("SpecImp", mapsTo entreeSpecsModule "SpecImp") - , ("Build_SpecImp", mapsTo entreeSpecsModule "Build_SpecImp") - , ("SpecImpType", mapsTo entreeSpecsModule "SpecImpType") - , ("defineSpecStack", mapsTo entreeSpecsModule "defineSpecStack") - , ("defineSpec", mapsTo entreeSpecsModule "defineSpec") - , ("mkLocalLRTClos", mapsTo entreeSpecsModule "mkLocalLRTClos") - , ("nthImport", mapsTo entreeSpecsModule "nthImport") - , ("callNthImportS", mapsTo entreeSpecsModule "callNthImportS") - + [ ("EvType", mapsTo specMModule "EvType") + , ("Build_EvType", mapsTo specMModule "Build_EvType") + , ("FunIx", mapsTo specMModule "FunIx") + , ("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") + , ("CallS", mapsToExpl specMModule "CallS") + , ("LambdaS", mapsToExpl specMModule "LambdaS") + , ("FixS", mapsToExpl specMModule "FixS") + , ("MultiFixS", mapsToExpl specMModule "MultiFixS") + , ("LetRecS", mapsToExpl specMModule "LetRecS") + , ("specFun", mapsTo specMModule "specFun") + {- , ("SpecPreRel", mapsToExpl entreeSpecsModule "SpecPreRel") , ("SpecPostRel", mapsToExpl entreeSpecsModule "SpecPostRel") , ("eqPreRel", mapsToExpl entreeSpecsModule "eqPreRel") - , ("eqPostRel", mapsToExpl entreeSpecsModule "eqPostRel") + , ("eqPostRel", mapsToExpl entreeSpecsModule "eqPostRel") -} , ("refinesS", skip) , ("refinesS_eq", skip) ] From 893ff1cf5989e4fae5646fb17351e89200e9cd11 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 25 Oct 2023 08:23:39 -0700 Subject: [PATCH 150/305] whoops, fixed the translation of function permissions to apply SpecM to the return type --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 21 +++++++++++++------ 1 file changed, 15 insertions(+), 6 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index c929d1c2e2..ccc86d8ce5 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -359,6 +359,11 @@ tpElemTypeOpenTerm :: OpenTerm -> OpenTerm tpElemTypeOpenTerm d = applyGlobalOpenTerm "Prelude.tpElem" [d] +-- | Build the computation type @SpecM E A@ +specMTypeOpenTerm :: EventType -> OpenTerm -> OpenTerm +specMTypeOpenTerm ev tp = + applyGlobalOpenTerm "Prelude.SpecM" [evTypeTerm ev, tp] + -- | Build a @SpecM@ computation that returns a value retSOpenTerm :: EventType -> OpenTerm -> OpenTerm -> OpenTerm retSOpenTerm ev tp x = @@ -1129,6 +1134,8 @@ sigmaElimPermTransM x tp_l mb_p tp_ret_m f sigma = case mbMatch mb_p of _ -> 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] -> @@ -1143,11 +1150,10 @@ applyNamedEventOpM :: TransInfo info => Ident -> [OpenTerm] -> TransM info ctx OpenTerm 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] +-- | Generate the type @SpecM E evRetType A@ using the current event type +-- and the supplied type @A@ +specMTypeTransM :: TransInfo info => OpenTerm -> TransM info ctx OpenTerm +specMTypeTransM tp = applyNamedEventOpM "Prelude.SpecM" [tp] -- | The class for translating to SAW @@ -3305,11 +3311,13 @@ instance TransInfo info => rets = CruCtxCons (mbLift gouts) (mbLift ret) rets_prxs = cruCtxProxies rets in (RL.map (const Proxy) <$> infoCtx <$> ask) >>= \ctx -> + (infoEvType <$> ask) >>= \ev -> case RL.appendAssoc ctx tops_prxs rets_prxs of Refl -> piExprCtxApp tops $ do tptrans_in <- translate (mbCombine tops_prxs perms_in) piTransM "p" tptrans_in $ \_ -> + specMTypeOpenTerm ev <$> translateRetType rets (mbCombine (RL.append tops_prxs rets_prxs) perms_out) @@ -3366,7 +3374,8 @@ translateRetTpDesc rets ret_perms = inExtCtxDescTransM rets $ \kdescs -> tpMTpDesc <$> sigmaTpDescMulti kdescs <$> translateDesc ret_perms --- | Build the return type for the function resulting from an entrypoint +-- | 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 From 4bc68fca407c54f6040c4b409781b464e81d5b2b Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 25 Oct 2023 10:19:20 -0700 Subject: [PATCH 151/305] whoops, re-added invariantHint --- saw-core/prelude/Prelude.sawcore | 3 +++ 1 file changed, 3 insertions(+) diff --git a/saw-core/prelude/Prelude.sawcore b/saw-core/prelude/Prelude.sawcore index 4755ed8165..bea5b2515d 100644 --- a/saw-core/prelude/Prelude.sawcore +++ b/saw-core/prelude/Prelude.sawcore @@ -2952,6 +2952,9 @@ primitive LambdaS : (E:EvType) -> (T:TpDesc) -> specFun E nilTpEnv T -> FunIx T; primitive FixS : (E:EvType) -> (T:TpDesc) -> (FunIx T -> specFun E nilTpEnv T) -> SpecM E (FunIx 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 multi-arity function type from FunIxs to a given output type arrowIxs : List TpDesc -> sort 0 -> sort 0; From a582e5c1c442a976ca1541176ac43003ef102060 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 25 Oct 2023 10:21:24 -0700 Subject: [PATCH 152/305] updated arrays.sawcore to the new SpecM --- heapster-saw/examples/arrays.sawcore | 58 +++++++++++++++------------- 1 file changed, 32 insertions(+), 26 deletions(-) diff --git a/heapster-saw/examples/arrays.sawcore b/heapster-saw/examples/arrays.sawcore index ff7ef8cdbb..69ffde7f38 100644 --- a/heapster-saw/examples/arrays.sawcore +++ b/heapster-saw/examples/arrays.sawcore @@ -3,39 +3,45 @@ module arrays where import Prelude; +noErrorsHDesc : TpDesc; +noErrorsHDesc = + Tp_Pi + (Kind_Expr (Kind_bv 64)) + (Tp_Arr + (Tp_Kind (Kind_Expr (Kind_bv 64))) + (Tp_Arr + (Tp_BVVec (Tp_Kind (Kind_Expr (Kind_bv 64))) 64 + (TpExpr_Var (Kind_bv 64) 0)) + (Tp_M (Tp_Pair + (Tp_BVVec (Tp_Kind (Kind_Expr (Kind_bv 64))) 64 + (TpExpr_Var (Kind_bv 64) 0)) + (Tp_Kind (Kind_Expr (Kind_bv 64))))))); + -- The helper function for noErrorsContains0 -- -- noErrorsContains0H len i v = --- orM (exists x. returnM 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) -> - CompM (BVVec 64 len (Vec 64 Bool) * Vec 64 Bool); + SpecM VoidEv (BVVec 64 len (Vec 64 Bool) * Vec 64 Bool); noErrorsContains0H len_top i_top v_top = - letRecM - (LRT_Cons - (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))))) - LRT_Nil) - (BVVec 64 len_top (Vec 64 Bool) * Vec 64 Bool) - (\ (f : (len i:Vec 64 Bool) -> BVVec 64 len (Vec 64 Bool) -> - CompM (BVVec 64 len (Vec 64 Bool) * Vec 64 Bool)) -> - ((\ (len:Vec 64 Bool) (i:Vec 64 Bool) (v:BVVec 64 len (Vec 64 Bool)) -> - invariantHint - (CompM (BVVec 64 len (Vec 64 Bool) * Vec 64 Bool)) - (and (bvsle 64 0x0000000000000000 i) - (bvsle 64 i 0x0fffffffffffffff)) - (orM (BVVec 64 len (Vec 64 Bool) * Vec 64 Bool) - (existsM (BVVec 64 len (Vec 64 Bool) * Vec 64 Bool) - (BVVec 64 len (Vec 64 Bool) * Vec 64 Bool) - (returnM (BVVec 64 len (Vec 64 Bool) * Vec 64 Bool))) - (f len (bvAdd 64 i 0x0000000000000001) v))), ())) - (\ (f : (len i:Vec 64 Bool) -> BVVec 64 len (Vec 64 Bool) -> - CompM (BVVec 64 len (Vec 64 Bool) * Vec 64 Bool)) -> - f len_top i_top v_top); + bindS VoidEv + (FunIx noErrorsHDesc) (BVVec 64 len_top (Vec 64 Bool) * Vec 64 Bool) + (FixS VoidEv noErrorsHDesc + (\ (rec : FunIx noErrorsHDesc) (len:Vec 64 Bool) (i:Vec 64 Bool) + (v:BVVec 64 len (Vec 64 Bool)) -> + invariantHint + (SpecM VoidEv (BVVec 64 len (Vec 64 Bool) * Vec 64 Bool)) + (and (bvsle 64 0x0000000000000000 i) + (bvsle 64 i 0x0fffffffffffffff)) + (orS VoidEv (BVVec 64 len (Vec 64 Bool) * Vec 64 Bool) + (existsS VoidEv (BVVec 64 len (Vec 64 Bool) * Vec 64 Bool)) + (CallS VoidEv noErrorsHDesc rec + len (bvAdd 64 i 0x0000000000000001) v)))) + (\ (f : FunIx noErrorsHDesc) -> + CallS VoidEv noErrorsHDesc f len_top i_top v_top); -- The specification that contains0 has no errors noErrorsContains0 : (len:Vec 64 Bool) -> BVVec 64 len (Vec 64 Bool) -> - CompM (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; From 8d88703eb3b23c60d0b8b91c2dfcf4906bcfacb4 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 25 Oct 2023 10:22:14 -0700 Subject: [PATCH 153/305] started working on a new arrays example for iteratively initializing arrays --- heapster-saw/examples/arrays.bc | Bin 12640 -> 13168 bytes heapster-saw/examples/arrays.c | 19 +++++++++++++++++++ heapster-saw/examples/arrays.saw | 14 ++++++++++++++ 3 files changed, 33 insertions(+) diff --git a/heapster-saw/examples/arrays.bc b/heapster-saw/examples/arrays.bc index 3d64791297c376b70cc49658c77a6dfd2d509242..c24694e4181765fccd62885ac5b8f17156240c88 100644 GIT binary patch literal 13168 zcmbt)3sf7|x$Yi~q!B_0VX!T1fk%E-wh0JuFn*;HV28xG6@Jx8+>693&|(me*x=+Q zBP1;BLvpa|`j95=5ss7VG;R;6-IV6`t}6j{NJ?@^>f>@<*9#KYrD>W=(=^RJC+GHl z|LBS1oYl2Di$ODcw)Wn$_xFGQ_y1crf{T+Gjtrdp3mFp_<4Q_{H||COu35Fty7Kht z7oPviFQ54OFMjgXfB(rJe*ei=lPjePjxn>2vDfhJWQCb2PFps{2jP%@OJeIT>*cQRp@N+9?}R$Y(mg9;>o%- zXp%gp5qtKB=B(?3DYrb?S6!w_SJpLW_N+boMkwp8!IUXHa%Hh@(>t#05xZ$>&~#18 z9x-Q44W?W+o2JkRXZ5?C{w|9kS%of*|B%IBB>4}Q3x@;#wthjRI;=bE4OjN9!IWux z_8Ts0>W#sa2`>AZ*)$&idV{~i?Jsir+lr~dq9K2qQ8>~mbTxP%Ef?AXLI;~>;`N!V zYhu>*kO{3(3xTW=PxfTI5x4(v1OLc5{~^g=6!5zZ0>;zDCNNZV%E@03W{rgK?qB$I zZ&$g$-7U}IBwoRPc;Jpx$40Vl45nbBM!4*0%+ieMbAyqDu1=v96EYwi(fC{U3)71q zpILmF%ev~yo^@qC9-Dkl#N>~-OjqS8y5XT&nw`nIIhZmwm^~3Pyj5W%BYtS@{w;RL~XTMJqo-N&N6dvp4H#@y_ z5#)>Z^X)-@SHDoS-+QP*cnswOez#3%moKoCDDN7;yQ8LjF%Z27@Edv~*FfDy)DH?< zhIt97Lkm`bjc>=yH~8JOUa@I^UtaNBGg%X!>}x^O)C{c}Yu5;e&YgoYWtg z(;w{DAF>HYoI=N>`j#YMIIW`4IjR0o5{>{A0ij)tJiTBL+9Y9#S$B+8DxD|ubT3NV z8Ei9pG)U&Xe5Q?Qq6I9)diH&jl1Z_G0C#lHH~TG&DPu*bbH;n`ZSDN4#i0egMJw5O z-HXk37fWb*iL-p6{vUZ}i`HS2taNQ>Kgf_KL_Q?7an~_l8pjOL61G0ruU&Ood)tr- zXKo*oHu*ko{;U1#0mtIohV+&9UcYTfbxW_P<_&4VQsr@V9%Hp0mV`kRWDjIyrd9O! zC9S^qva54#>wE>Erk;)JUeW8B=`*x3#yl*f-i&B3nuO zK&$Q+OZ|gE|FNVm)RknzMgin{t4glsT{^*U9WUM5$8VkJ?CWp~k7@*%soO0aar1{d z{ch2pIgzISpkF^@O>MTOzBi|zbLa~VV_7#~`sS<=S9ZPi*yf*kH&2#syvT3)nRkni z-#jswamXn=+8}Ib0CI&55*e1;33v&IK2@RF!;-%WhHLb<4fwkTJUJiE=|7y-|2e4t zz{*#T51MWcnqX)6f8Awz!)zM!fala#`%5>Dmu?)8{|}EApDHbe?VTFUL#Lm0Z@$8B z9vaoX*64Td_qVyd9SuUK)8AqAcLe;IZ|zR~kfna)(BJIWzh_IG5%nM7Ekp|lk1YEg zv+24g`}(x$=1kW6Tz0*&vUsR;)3e^q6ONUU7jgOzcM6>Yl@%ZNr_u~$e?#UHa~A0Q zaW0z%Y|ffav z4RtPedq-W{T`0?|>vSD-H`TS<-S{uoG`X4|77vB{7xVLTt+`klx%965d}|@y7vvTd ztjVirtZs9)b>)>&zb)>%w!G4og9lyBwH1xcb$eP`n%eX5D(!hYT{U0by+60T_M3T+ zw72CoHrF&gQd^hT-qoI0)zRgy!$)ItN74GKj@*XGMNyD?6rkhzSL%npy z_=PqV3vLl?>cti&SS$Jci?Zev4wA`??yi^~lVk@<4bf=b^aLXa@{CDBfNmzNL3{S~ zP=$}pa@JBN6s9SHLU6rzjw@6?Zr!z#T$r1cF!mV@*xkU~rq^0czg zGIZgmm0GKY&o}Y~<2_Hl`NKDRDn6K~JKub2dWU?w>dEsHPvQ=Wp0O9;jG@}3$={1DRm6PcJ52-?anm5c7C~0RcJl)z&5M4UMjwD zJdiQL{&)RC`B{mu^37^Ii|`FkdOC(1Tt~TPr@rVm%(zEou9-giz&4wk76wZ^c)u6Z@7WSY40i+M+ik;V69vXFUa0*pbt)AU^n3l4E+lhRu4W}-%YbTKiG zS7xX`5v^e2f3>7n!6LLY6Czr2P^Hn&@DH@4TKuGJ_8vP+R|j+KXx2TBkVZwzSKNo? zQ`7R9?gi~!7nQa2d+My~6CWynLG<;u>%S3wy#{L9;Xu6`2;yu>L}aUx zB%YSoYMt~zH`<<7?_!dRAMt2#^QpR$p}1y*i2`w+F-|b>%8dBs72Pu(2n^-JB{Fsr zS6_sc96SqSWlRa_5XVZDs~);FhL?OtPd>y-S&*@}7^`3Cu?%pTx(mmh855E&3>lkx zN`{QZTe~l9pgZ%F=f~AH)z>4L(b8>r>_5X$+;>&U75QXJDraWQH3i66&udKj`rE})vaNwQVKB__dnzci7xJv@iPw)DTAm#6eT2W zfdebpK+v$O^?;7sYv{-N+ts=_jxu%6A<|XWUJh8iV*s6&Kvy>jHVM0~GrG?~sg6Aj zA61|$10+w`cgY^un!?fdr0uW<~7VrVKDxHFnWuSa%QZjs#8TTX+D4Xi3& ztz&JhpvDof<7I|IKF(m^zX(sSC*X z>S{^$G`O1T54*Zz_`18_dv_wfLcrHj(}m*_@Rb5L21=S%zjc1ORaNNbn`C?iJq0gm z93kCJ@#($F7oF<1p*Pod@3HcmoWw`g`XP0bfk74-;ojizlnl^2Cu-{r0(5LJ?9#wY z!T*Gl0x?cM6cgj;RYuLDhY`npHhMr7AMD!AvX4Fp+m`Vc@z%-*iNnnzdOwZC{__PiJ zQzs9165vZFp*1pCEjXlElWoNc-*9eHv2oU$>3uh40Pg5_>ffhD^Q#phu1EIvrDnY(M3fQ&I2%h`k~) zDAFvQ(LaT{VeYlkx_E>TNI;#gw%I7qP~dz>X`83-{wvDTmD}#gzCKdd z)>0+s72mfB`1( zNyG%6n??&km}T5md$~$>YMHKA;p}Dy(|yu2qLSji!n6>@2w|;9F#@=A)E?!|j+e;{ zridCvoWz|k3(thzv@zfv>73)jE!SQ=65OiT@E!?*z3Wk3R zSmbr>?qO8Ni8}R3M>D-6sYiEVVhFf%c4NPS9T*D2PdC|CavT75K?(SU1bz*Z-ZEx9 zVSqbPjvl_X(7L(b})UvoJ^cRR0Ut@wKn2Z)-W&QePj#0AE?Is!YTH zxG`h_2EdKZ3}C>at+#5gAD_v1Fto79z?KF%Q`2%KLk8iPRoj=@t5~X}KydqDK3^$C zM}qSe+nq4L$NXn!90S$}2FzL~CZ9sYnE$+k z7VEJLlj#g`X)&lA{mZ|h34WfUI};SJ?(($fYe%D6ZM&V6I|mEDWU-O5N-43a>82Pr z7j%j=z~MP7R!^2|-5FX)v$eFQ{Uy~gGTLQS&9Ln543o@%E;!|$5S+4}obq!H z#07UiK)$v#jDQym(1e75C!y&%lRR6&71EXVRq0=?W zgeE3Dqv6U`PUHp@HR|sNV+!83aN5QI6;XRK^Sr`@)DNH%%IEhy z{l6rPjLO)i0E z5lpGpHQ?rguA4A*-iqa(ltX}pq|szdT`Z}IV(R$5a$w35%{nxIi7qM)f3`^6g2C#H9|EgbJa9*&KWJX`=`)b7*ph$@nEp)ro8 zXx55S67M`sk?MYz2ZN$|A6X+*m%w!oi;$l3;SwR`ah0yT?~XW!(huW& z!5Dv3R5Aj0L2XlhQ^7Z4`tL!h=fOmLBf%BA3-}IZOiV8VzTMh-cXA!@4Z-Ig9FPUy zuw!DaVy~4yQ0!gEue+|uJ#T!_ytuKnANw-IT2WN zz)XmDXwNv+KV|}gMwBDZc1~4nq)6mccdhyr`ndpN+}&;rU>f<()?@wJvrhFemB%6! z?P9HibG+(+ihs4ovx{BH)t!PDooh|^1>i+*D9xY3R*V&fZsY+A(%wN8_p-FO0N2q;3?Tc!T5+Uq7`ja(L1l=PYj4q!l4x^%3;xU1<2N> zASe7#5cnM@#nhU79X&?EqSoYVxXJNKfbgZebcm%RqM+aNJM@q$2WK~NMHztUkyEny z8j{22i^=dL-@lfzG%^OaeK!nBN!ZWr{C?bgbKSVPp!1RW4m-|5pYkU%y~`IryO**1 z$tB$Ez6kT>NuM4+;D-LQXpl6tCDX7EoWuPlku>Lt1Sz8DiVTmuNMJ>jzdDVR{EFP`C9-Pa(0mSPh~4 z9U91W1*MG+^dt0w^V}2H8?DKsF!=}QEj!8aO;JXmXE1|_qB^`q{E$+D-}#34gOSrS zDJ%B@_2HZ}j2AXpmS~e#Y)Rpq^bS0eea`~rR;s@v$CN^LiA|#_cSqabyKR!V2UJYE zF|-AQi`Z@nZKy?aQEqpS`*zzeE?akWcYn_V#yt$L5&Rx6^1EzIx&I2gY6*-8SV-1`k9e$43q%iHueA@-s6Lipdfb`2_WMNUi zm8P!)*Ur~LKZu!NG$*yKcr3vLzxO^GNR<_F)NA$fyKnbe`Fh9?mPCNKJP1Gx2Z_6< zBoX;%koi*ON*%!4Y9vvc=`*8jJOIer^?lI4|Ln5?!JxrKtYgh78T3z%V4`tmsb5xouZE5hrnim8*g^o^Viw8g4X$vu`IsM8m!rje!_w{$0yP{lNPZF>2kUSsnVrkH5%uJ$1YHXn*@nyj?tCc71y+vzeGUcKg7S(kEtpw z=`RsYJCdkr!zs;q+i}ySpVPFS)R?B7i)-3@5;g5TVNEN?NuS0v?eb*~wPwX%T z@`6)-yX*zSd_#HfY7yg*50}W0h$SrAW&fwdHRUO7X{YSwQziMQ@Fm)trMN51J4!Vr zZd^@GEj4oZB`0F4I_laxB7Ta0VwQg*j!DX}IP2$913;J3uDgf0!!=a-d?Zx4{7c#X z|4-tw{*{*XW4GocW{(}i;KACOQzZ6n3cSEfa?AWbO}1>nNs2tQz!~9xRh0ijGXJ}2{Y#^JPdkPq>tl#2a`groAacIr zkElv^pYt;9fNp|2@L8~c@TGT}ukddT?wnIxj(3=cXZo2ER2}B8sinm|56@4}@=wR- zP~OuC?F@75^y)Cjy3?;74`uAKFASsInjVn3)BrARP|OofJBdr%s%0+CA78EUsH65E z|GXfwEjM_H=FUNHK1%+(agx6C?&=K0yE8|b*-JM@+&rN6ke_?T z2+t^|2tDZ(U1t)>xZj1onVpd=5dWU^ZHQA~TRJkxX&-IC?69KsjrkBf2Kt4-yQ`N| zG`%PsO|OdUq~>Zw)3Y-}>)-6N52k+yZ_?}G@Z$>0gL7zL(;$Y|ghpp+$k=j8@T;f5 z!T3!&d@W=xOa6dqVB&rJeW!XFpB0XuJ@)48FP(5Jbuh>IjBFZ5r4WZZuZ zC$$$XKN4xjg)&;FX!&uJr{ms@lYC6H{JSVe0s-DGJZI7Jvna>ZV!tQcPqcgp<<#!C za3;Rj|BSRhi1Nht-$6Nz{{qg$@&6X(G+(dbOdRK5BK5D{Rv)+Q>ln~cd}6J0$bZK7 z@vwo{)O6@zZf*6$xwW`Hb}Tc znDBW)c_(*%n@dT!jWJ~S*O;BfMQHRc7yVrGu7j?cmiEqkYi|DCx$EWc;K!fw_oO|| zs@vz}w#Ny#@p+K9*%O|`=cOuPIub5vd!Xv`QzL7Zf^gh5*iL&x zz@SU}M3=gBr_XM%P9NK`yL5EA%xw4B1kh3kUE1l>WvuIlYCE*+beX9;<8+*v{hgan ztlek+*|`rl_ndRjJ)gh#eShzJxEh?7N^oW2E-xU2Cxj_23tnA?0;EZ`+Pvt+YfVMsBvL=hObv=JtnIiQ@)uclx^t|-en4_ zyY%;)?)MiwGq~rdaDEK!9u^3hk7wb6o)n?BTb{Y_WEXy}bq)BlGPd{jrgn{P*L8&q zj7euxqHe|(!pT(Dtj*RfMj{a95>`h}_IZ?~T4j|Ji$>9n(m?$SWZ*S5QP>`qiT|)h zW*+l2z996=gq~C7WSXti6Y^v9Isf*3xBiHWagh`gYhi~)y|2yBcbI(50sg?4uh{Qv zJH@vNKDXd27JRLPzE-5`y&XM#N5EHX=G*JN2bBCl3m-HLdvZPD!W6qU< zv`;;`A36*Zj-1Q(+-Ym>)lkl*fwW1ya^#Rs!~2fhVXI+sz;Id29X94n4y2to8Ya;Q zWA?f1z77*Fn)wc;?|{iyEc)6i__l!0?dJtrhjiv#aO8eEkQTP)UU1N+E)1lNGr5BR+(&xdP;SlEjjh}lvDts+2X$>bZ1z%hL zU6+mw=Ug2~!$J)+xnZo*l;LZG5&4dGz8MSB&mUC!ns@WzdCyMGJI~~N=*XRR!{SYexb!fp1u(2&z`Ffv= z?pJ)-KbLm=)2WuxF51-!*dzFnl7O8Wr%`{~3=T;7sX?CL>p+N(Cr-U-dY8O>gzb-Q?sqD9~j zntAsGHzV+EIw>s`Mk)YS2Q2(SJKs9NeTH8tyVtI1C;UMj?-u#JVNH90Z?;E2MCHBa z)MkNi52O$KmAcJj@o$Iys(N{3z!)nbBB$T6%FoC}nvt#vQug{KDL>7d!XIt5`5X?>6#mU&6HW&WY%7r(ahL1MY_?Pt55^RoMA_<(|mZ{+un5( zWoyo|>)-aS?_$@D&tx62^H10FtLuScezi!2%w-4E_ye~TXtquCRY8dLK6k&bqu;aa ziy6%qVa@*pH8;#`_1J*n`hWp4hu

!v&*Z)B~NzedsS+Ggh{yU-}&yDd{UKfgJXY ztU#x?JJ)@{t{WUtztiAz?e@7{-qw1)-R^7E`&t9O>`ObfUl8rDY?|wS%{7a5O3>WE zECdsjAC>a=jfN|p+$&+j^{JfCnOvv7vShGq?aSVE&Gk3Hbd6!d^6R8zU+_AYi`)JzX(GnwV#-^p9tDt+cZr&%{8+I*)PM~XJO5Co933e zZ0fR+nyDE^8aah;2LM!#ggduFDC<#Yr??9%goU2oqetH>59my_>kA4?U+^1W>31yR zw=Ge!NxLQ}#*Ew7*t#$6@C|gn2?%3;UtZT8l@GI0bI+~so4n)Qw6cpy0^UZ=u zDqUVsXhtr-s4%~9$qHJ%p~lgQ;kK;UU9+#YF5lsDtti{q)LPfn+OndY4r`yQ&b`9c z=xBBBbMI|g@t~vT+dFsXyP^e2bujt(>z3NTj8;VI|F@qN`&-;A8k%Yv_t(~~Xz6HK zQPtYvs>7q9skL}zRcn5IG|{*Zt0MiN0E^vN*VOQ599nEx`{Uz^r4j?%-_+9ZWK&(O zfI2Pv_x>42m%MNkm2}-A&p+cJ8j4DaquZBXUsYA>aJMxyNkUT9DlJm-`Zzlvw7ATj z{xu7gmy0_6)`iMPS9bchE>!+(W#1gLQ^Z^Ole7+D1ai1=B%t_6&ED5qq`n-!Xnv-A z^+<5eWsAaYAZFHFCaNDIFg9NrNcPGA$qJUI*$W!N%v1DplDR6#5;DjIXlDC7Jv+xD zC&Bf+h08P%-dxGC|nFN{~P1Ca;hM+{R1+0 z3;#CxKr))h9bd)g*{Lf+&`>`uHP8%3FoQ>!G0|L++U4il%$Y`Vki4uXhIg6`{M>4R zqkmz}{|WbMK=Zl%N1i38*qkBH{2|Yhpm*&l@7f7ZuY9p-VR7+47yr#$tADWet-^Ul zZw;RLQKibPWDE3c;aKe;zsbKd-^2Qr{_6i3*z6h0KwKD4J5r_0Q$;86KA`;J;wtR(h5 z3vPyLxO4X?i8(+0D^lpKPUA?wVEIUH3@=t%>70tvEyYKNx0m}LJZa8kYBQINmy@5B zt46p{zb@DlVnji&|Bqi#O8R5`Y#O8N)LdiBa!l~V+-OlMnO?ntC_6px{p=5T<^LUi zytnbAE#fv$abU0`T)8XW)Du!uLwKKP>S;7(VJuFy>e>uT0*p|^b%$;-M7>%W${yEe zZTT2o{Y0k>^;#VUslm~sx?r!hIqNw>&dASoF_ta#>rqBQ0y2E9Sm2S7R*SAP+be6f zFvLX0x)}2n-AX$~F3d5J;Ia{m9Q8h?z0B8bFC!T2jxHG)&&bN;$a3bT0@LvavxqoX zME|M!9vPXC`Ln&%OV~<6)Pk4cn6?+<}|&2yS{J zxG}GhaAUtL;l}zs;D%@>i6)L4?>lOtB!U}H4X2wQ!wsv{P~6Brk~1IA#*JLUP5PgV z8%y<{fE$IJ{}XUyc{YZdBh$c*KzDxgXcRYk>|135H|aS^xG~O&<7P8(bL8C^Zq6-= zO44g(LF@`}6ao5gq+)i*5lN8-3aI;LwL)D+)=8P|xUYr=;f-8{oPgD-_n zFCdDd>0^&>)~TEmk1jn_S)zDI|2N9-g!@D1IfnFZ>)O~pZuhbbIe%|wp2ZmqK^d;q zF7g}85A}9^%zZ^{S1oyDvC>~`Rlb!{8l<}NoAr(uR~CB`dS?_GgX*2eC-O*ekTDwM z=4uxalpOZ})i`Be;79vQ{A|L)e{|1H3@f6RLKmr85~WH}wWOH$TS@FaR+7mDms!!Q zt0#{T1>L@q8(Mg+bo&gyf!etu$ZP5Q%jkBQ*G`qjYHYqg9opc;wo-6n4G@x} z>$0B@Odqomq9TP3s4saMg<%e~x%nq%9n{x*_Xemwl>d~fulF1$sQP*bs%e`I^{(PG zOA1wF`RYFqlJBw)6MeC8TqKLt;-j5tJA7yp5gqKXM~Td>LmLT-YlexyQ=O+zC>R#& zOZCfJ>hCU6Ax$rbK*%vXzX>bL@GgRtQ8`siajaB1oZ#$nycC$a3*hpW2MM`Eh;xoL zub;_QpE(lLj*IFDWGvjI1R0aJc2{~=XLg_Ght>M-hiu(xqm*U@LyJpE1rtS(e$YzD zwTuC6ZjqiX(MdLospV=2&ywl&e#;?Uc45X5H3gB=Ji&`8va=8BWKEsA*8dAb3EPz; zVdzH`88O?{8`1+G(EGAdvXJ9Rr`_IqhE@nus0g_KIMQn^;F=?nSv>+$Fqsd3Ap5zm*$L;3!-DEFrb>+VcUEcM)`kih{0g z0@@^Ex=yIS2BkXE4I5RcE=O;DRvB>BXfdZT^g9s|l<^FM1n7bqTYo5yro#Taqe<{i zX{ot#3DjI&vQM+5|K5_tYT_n^HMW2ilNk(kF*+UlO?Y}Y2~V_+#C7Tx5_uLQ@tvh8 zlQ5+kP~ z_sRtC)bTD*)`&@4ZB?%SKXg(cu9N;Qfv0hb6zs%l=AMW>D2?N({fBrJ!IPQR0-oOF z4urvTWK_V5ORyz}=6A}~G_xBSXSR$oh{-T48H8TlO<~mI=L#QD@cFS zsa(e}86*A_79ePsILp-lIE@4XG2P1&tJ(a1_%|3nPc>^ERiDq{`;UX!AX*$Xw+8zw zgv={1s;a(ZhWkE@nYBF{ZH~@gun6*qrCK#&{lU`F%k>F*uPORdX zXEW84Ha+CT$iE8@;$cd|J{8q}!H^zGp$hm08>&>>sop;_pYp*1{##3^Jvge6qlxiQ zCEjmyfn{|mAXlf@LNi91N=KR#@GKz~UQSo}^RRk5Ln>IbS&4Wi)b2fW>DCUhJBgUt zNoxc&sIf(@Ci0NwHFg0l3KoFx6$?Q@5TW}u8q|%bUo(|+5AT6!bD5mQqNcq6ad}`C zzk?Zv?%jM>JAGeFPPi_X>g$7b?tN8KY$ai*H|V=JB+CWWyLnN)tBsm!-Z@yU?A~eV zPGf_dYw)m+RKg^eQW4-IA}|dR_;pkSo+U3adDIpsOtsguk@V%MZ!-2yQkU6f`K}c?Qmaxu0j>UkP*2m2B`C_UyS;2 zv-ZBq>E5?@pVJw~09z?2Dw8n)-54?f1JI53EMS1BoMzRPBi1aNaZa(0%nve##szYF zme_na%)gM`BbzU$j^OQZ0b40X=^C8N9+^Q+0$*BW*`>8(6{jloGpyysVR1HNyBh}B zxW02GFrdReQVbYXb}T-15##prE?lhJG(_cQkV%h2g}aYJWkk}mF-CVH$YbB7WiL>9 zV_a>El`?ngFP<}50$^5Yr5286N{~6DmZbv@ub8oW5?$-eI)XjDpYEx@G$XEwc9_88 z4yE?03ki-TG-3mh-}5rDqnWze7*NVhM6j+l z-C*f;372v%AQE0&bXJz+1*o8aNCCBOd!}G;1qBe?y>uDefrt;`>MoN43CabOne7Qt zbA7J>CH9C3#(g>k=7vdCqm5P6W3e+b1(_BFsveh_1Cn|iCIKZHRV-VC{5&PpCzf}o zCF1XZ9*z!EdYA#lsM@9U!mCKlN1)SsY z`byHn6G%~F`a$PCA_(JrU3pwlKl2)1Z5pQyT4*gO>dMqMtWZ?2&ilSXsaF!xn@CYR z{Z=s23e-K^i>P4z=Vy4UmBcjG-IY>`aVaJkvysiI6@Y09g=rI$38=GFSub}1>M>=# zydD`S>kRbtPi7F@sN-(r5<_*NFFI6DYNkZ@tji*dKn;lJn@-{sj530t;tgnQ9o5)F z;TI`Wjxd6uATr~Hx-D3eaH$o*SC>PW_P9XtObmqSXzDR=L#@OO-67DtfFRH?ARV@Q z0RL7Kk*>}8C9g)MOQ6!VIe!`QG3nZokgn-c2RhMF>Dr_7?np@2l8AKKAziKklSH*K zkSFw87*bCeZgZ+#P!X3EG!iDU5~McDd(JIaW0h(d%6k+FC( zG;IR)Ac^9FdXzy3cA`V@sEviSi#{k(-(~{ij<6Q1{B1}&4XxAGi_#yOE#nZwB);^I zRJJCl7{=^dx~7hb;Vi!NBU-^s1-~p7QZE_B;Yv&h_ej=FV$Lz^*2BVuKr2bstv~~s z5)s1l17J);L8{{?MFBn^l>U7ABDkSPn)Q_YW_KA;HWmOFt(xuN$$#Hvc?lux{^2gh z&*&f(Mk*C!#uT(;iL_&r+UXga6o^=ppPRAv zpiL3pO!52DEY8%1b-WY1bZzNbiV;rI9}`9>1a zxkO>Z9jp)P^$Gd(G>@KkfP zRoq4pQWptA9-~1>@|X!l zpT1+CnT-)%O!6YUSkyMaKUVB4>82$2h3v_)T*)8$3jWa3Ly|vKnrCymv@R$Rgp1fQ z^~@|`&)NvrIB?Se&mLjasIbS+L%xao;;bsVjgfP-f1%qLi$zYB&5y9wgl=eki&mJS zkPvWFyXVk$B)IREM<`H6Bv<-ZNKq60n<)1kPUgOm(C4gUyKvdpxUWYW=e{!u?z=IW z`)-VIU&)`k73aPS^7Jw8d!2>9>k4IH!#9=(D2+XY2=y4x!5+&*kbzMe<{a~-BA-R= z^KS<|u`uU?ynHkxMa=i4kHQ#hanM3GP%ZN-Bh^+>EkjS$%!r1;J1@D3G3zHh9CYm#zZO9Ib%1B<|xDppdThQq%H z1$(Vb#`}=`KOS;yg}nQR{(zWdT90K3{9xIlAvgtpNR$6HHcLq7W_{$Gp*;=Mqo)P4 zdQwJvnnF*TXZ4gG?dckNIx?%L1<{_Aedx(JtEcpgNKeMYClJ3}bQU8@M=aWEwhh_; zw!rkQ(%(k5wd61Y+1OS>xAJj$5LO-b0Xm1Cv8R4alwBTEFT1s`yWwU2$jQU6pHBVB z%BKH%TdN+nsLzY)3qkcIlJ>qO4TtELgK1ao5+a&~$oGXB-GVOi8E0}mC$ils734Kh zaWb`j=90*Nk=8Twg_!c1?$m_Illpe%m~ERUZE_Cnosc^GAHrTdGuXa*iZ|NmJGeRA z+i^3vDNg7`pY&Y!6fMMc5%)c~e~z0%gU*9qvG+7h>(lGMamUiM9@QB19}RwwG}Nf{ ztu9)w#37Fceb5D>IHupl>gS-G`bjiq4|*6czYpc~dze(|yIB3zD5p~`!<~gYRt`>0 z|0jh!f}6G%D}N-~jss=1|5*8xD9=RRg`37cV&w->&LiK6o32@`+=Fr~E$P8c`-zo5 zk8;}XU*k@m*UQoN2T-2e{y(Cej{gkq?ZfYs=Z*}b@ z#rR@5{%fwWZuwqE&AyiQ0&{-Bs{G>EfAb|KK@VuE?ws%)uamNgNlIsiNpBL9u1cC~ mQj*3xtG+&ONwF42!eCLaL@J7<@!xV^pL^BaCQtV@cKt7*YwO"; +// 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"; From a0473d80ff6938c4866d9ad47c8b7c01172e1e98 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 25 Oct 2023 10:58:02 -0700 Subject: [PATCH 154/305] whoops, forgot to add the type description argument to heapster_define_opaque_llvmshape in Interpreter.hs --- src/SAWScript/Interpreter.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/SAWScript/Interpreter.hs b/src/SAWScript/Interpreter.hs index 996c62aed7..c857c98cae 100644 --- a/src/SAWScript/Interpreter.hs +++ b/src/SAWScript/Interpreter.hs @@ -4307,7 +4307,7 @@ 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 d defines a Heapster" From b40bed4bce7da08e9a05109950a8c6246f9241cd Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 25 Oct 2023 11:06:53 -0700 Subject: [PATCH 155/305] whoops, was computing the type of the type function incorrectly in heapster_define_opaque_llvmshape --- src/SAWScript/HeapsterBuiltins.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/SAWScript/HeapsterBuiltins.hs b/src/SAWScript/HeapsterBuiltins.hs index b56424c964..72620986ca 100644 --- a/src/SAWScript/HeapsterBuiltins.hs +++ b/src/SAWScript/HeapsterBuiltins.hs @@ -635,9 +635,7 @@ heapster_define_opaque_llvmshape _bic _opts henv nm w_int args_str len_str tp_st sc <- getSharedContext d_tp <- tpDescTypeM sc d_id <- parseAndInsDef henv (nm ++ "__desc") d_tp d_str - tp_tp <- liftIO $ - translateCompleteTypeInCtx sc env args $ - nus (cruCtxProxies args) $ const $ ValuePermRepr $ LLVMShapeRepr w + 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 d_id From 401594d6c433bc757b17b11947bcd554e1977c62 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Wed, 25 Oct 2023 14:17:56 -0400 Subject: [PATCH 156/305] make atM, updateM cases of MRSolver more flexible --- cryptol-saw-core/saw/CryptolM.sawcore | 14 +++---- saw-core/src/Verifier/SAW/Recognizer.hs | 55 +++++++++++++++++++++---- src/SAWScript/Prover/MRSolver/Monad.hs | 41 ++++++++++++++---- src/SAWScript/Prover/MRSolver/Solver.hs | 30 +++++++------- src/SAWScript/Prover/MRSolver/Term.hs | 12 +++--- 5 files changed, 107 insertions(+), 45 deletions(-) diff --git a/cryptol-saw-core/saw/CryptolM.sawcore b/cryptol-saw-core/saw/CryptolM.sawcore index a9fc71b85b..40f48a30d0 100644 --- a/cryptol-saw-core/saw/CryptolM.sawcore +++ b/cryptol-saw-core/saw/CryptolM.sawcore @@ -255,10 +255,9 @@ bvVecAtM E stack n len a xs i = 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); + ite (SpecM E stack a) (ltNat i n) + (retS E stack a (at n a xs i)) + (errorS E stack a "atM: invalid sequence index"); bvVecUpdateM : (E:EvType) -> (stack:FunStack) -> (n : Nat) -> (len : Vec n Bool) -> (a : sort 0) -> @@ -287,10 +286,9 @@ 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); + ite (SpecM E stack (Vec n a)) (ltNat i n) + (retS E stack (Vec n a) (upd n a xs i x)) + (errorS E stack (Vec n a) "updateM: invalid sequence index"); eListSelM : (E:EvType) -> (stack:FunStack) -> (a : sort 0) -> (n : Num) -> mseq E stack n a -> Nat -> 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/src/SAWScript/Prover/MRSolver/Monad.hs b/src/SAWScript/Prover/MRSolver/Monad.hs index 1ee53ddbf6..d0346b350c 100644 --- a/src/SAWScript/Prover/MRSolver/Monad.hs +++ b/src/SAWScript/Prover/MRSolver/Monad.hs @@ -24,7 +24,7 @@ monadic combinators for operating on terms. module SAWScript.Prover.MRSolver.Monad where -import Data.List (find, findIndex, foldl') +import Data.List (find, findIndex) import qualified Data.Text as T import System.IO (hPutStrLn, stderr) import Control.Monad.Reader @@ -623,13 +623,38 @@ mrCtorApp = liftSC2 scCtorApp mrGlobalTerm :: Ident -> MRM t Term mrGlobalTerm = liftSC1 scGlobalDef --- | Like 'scBvConst', but if given a bitvector literal it is converted to a --- natural number literal -mrBvToNat :: Term -> Term -> MRM t Term -mrBvToNat _ (asArrayValue -> Just (asBoolType -> Just _, - mapM asBool -> Just bits)) = - liftSC1 scNat $ foldl' (\n bit -> if bit then 2*n+1 else 2*n) 0 bits -mrBvToNat n len = liftSC2 scGlobalApply "Prelude.bvToNat" [n, len] +-- | Given a bit-width 'Term' and a natural number 'Term', return a bitvector +-- 'Term' of the given bit-width only if we can can do so without truncation +-- (i.e. only if we can ensure the given natural is in range) +mrBvNatInRange :: Term -> Term -> MRM t (Maybe Term) +mrBvNatInRange (asNat -> Just w) (asUnsignedConcreteBvToNat -> Just v) + | v < 2 ^ w = Just <$> liftSC2 scBvLit w (toInteger v) +mrBvNatInRange w (asBvToNat -> Just (w', bv)) = + mrBvCastInRange w w' bv +mrBvNatInRange w (asApplyAll -> (asGlobalDef -> Just "Prelude.intToNat", + [i])) = case i of + (asApplyAll -> (asGlobalDef -> Just "Prelude.natToInt", [v])) -> + mrBvNatInRange w v + (asApplyAll -> (asGlobalDef -> Just "Prelude.bvToInt", [w', bv])) -> + mrBvCastInRange w w' bv + _ -> return Nothing +mrBvNatInRange _ _ = return Nothing + +-- | Given two bit-width 'Term's and a bitvector 'Term' of the second bit-width, +-- return a bitvector 'Term' of the first bit-width only if we can can do so +-- without truncation (i.e. only if we can ensure the given bitvector is in +-- range) +mrBvCastInRange :: Term -> Term -> Term -> MRM t (Maybe Term) +mrBvCastInRange w1_t w2_t bv = + do w1_w2_cvt <- mrConvertible w1_t w2_t + if w1_w2_cvt then return $ Just bv + else case (asNat w1_t, asNat w1_t, asUnsignedConcreteBv bv) of + (Just w1, _, Just v) | v < 2 ^ w1 -> + Just <$> liftSC2 scBvLit w1 (toInteger v) + (Just w1, Just w2, _) | w1 > w2 -> + do w1_sub_w2_t <- liftSC1 scNat (w1 - w2) + Just <$> liftSC3 scBvUExt w2_t w1_sub_w2_t bv + _ -> return Nothing -- | Get the current context of uvars as a list of variable names and their -- types as SAW core 'Term's, with the least recently bound uvar first, i.e., in diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index ad55e148e0..01214baeec 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -390,19 +390,20 @@ 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))]) -> + (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, stack, 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, + n_tm@(asNat -> Just n), + a@(asBoolType -> Nothing), xs, (asBvToNat -> Just (w_tm@(asNat -> Just w), i))]) -> @@ -416,19 +417,20 @@ normComp (CompTerm 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]) -> + (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, stack, 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, + n_tm@(asNat -> Just n), + a@(asBoolType -> Nothing), xs, (asBvToNat -> Just (w_tm@(asNat -> Just w), i)), x]) -> diff --git a/src/SAWScript/Prover/MRSolver/Term.hs b/src/SAWScript/Prover/MRSolver/Term.hs index 3b6d2399b3..807aea9a76 100644 --- a/src/SAWScript/Prover/MRSolver/Term.hs +++ b/src/SAWScript/Prover/MRSolver/Term.hs @@ -261,12 +261,6 @@ 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 a @Left@ or @Right@ asEither :: Recognizer Term (Either Term Term) asEither (asCtor -> Just (c, [_, _, x])) @@ -288,6 +282,12 @@ asIsFinite (asApp -> Just (isGlobalDef "CryptolM.isFinite" -> Just (), n)) = Just n asIsFinite _ = Nothing +-- | Recognize a term as being of the form @IsLtNat m n@ +asIsLtNat :: Recognizer Term (Term, Term) +asIsLtNat (asApplyAll -> (isGlobalDef "Prelude.IsLtNat" -> Just (), [m, n])) = + Just (m, n) +asIsLtNat _ = Nothing + -- | Test if a 'Term' is a 'BVVec' type, excluding bitvectors asBVVecType :: Recognizer Term (Term, Term, Term) asBVVecType (asApplyAll -> From 1bc1a09f7f85a4da985674893ae18c9bf1ea3007 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 25 Oct 2023 11:22:33 -0700 Subject: [PATCH 157/305] updating the rust_data example to work with the new SpecM monad, and also to contain a few lifetime examples --- heapster-saw/examples/rust_data.bc | Bin 281088 -> 282016 bytes heapster-saw/examples/rust_data.rs | 44 +++++++++++++++-------- heapster-saw/examples/rust_data.saw | 46 +++++++++++++----------- heapster-saw/examples/rust_data.sawcore | 19 +++------- 4 files changed, 60 insertions(+), 49 deletions(-) diff --git a/heapster-saw/examples/rust_data.bc b/heapster-saw/examples/rust_data.bc index da8841005e2a6b0ccf5b108c78e507488e9baaca..0469401e80a7ad67b56fab548f6cd275200fb566 100644 GIT binary patch delta 90829 zcmcG12V7Iv+yA{u$bc+%fB-j$$TkcS#F2nnK-5UxS`BEGT2P!-tL7$QX|;`Btypah zRxMh!sNkxt37|!46*rD*uvBptXQ`|I=iCq=wD14-zW;GQ2}#a<&U2peea1P7ExFd& zxY1d7!{q6N!Q}?el|xqxhcR+?te!Ljzq#*%C>CO0x`!yMAGWfby`z5QDGNJYt=pNEAFkHz$zu1eWw@?& z?-q!=R=9V|#$7M0+whVa9!1FN2|)wKuhRN9H2R)Uik_*ZH{gA#^n}*$T%+&xOh3wy z?nA6Gu)5ce0iNZ7+Nvye1n`OVNIqm1eq~~IX-ED#trqqbSHL;mpe}$Rj!Z zxts;+qK_n;e)alAM$V!X&PVa+{W#nEIE*Hm!BFa;XzIF)lv25KH5O)U8Coa~(=RS(_DNw5NJ*MdB|jeud`>a@6zlsQ zt?qZox(c&zv)0d;gvKk9;!Re=+ZdPQl2gon2A~ANn2F`d2`icXwpJ$|s-|br++cb| za=Zy>wBh;sL_>9=rlL9=q^wU)XjQsgvV6Ybx*BdupD9Eq8hsnIzIB<>W|{8|v+r&2 z0p?qk=~oYLjJ{R4AJC{|(%ZQ2c$w6q72Punn@NGm==XpWz9t-I$qs?VW~U~(q(ly` zWnjgTF;QC#!bb|HCo19ZCeCv;XP$+VIxB zRinyEZ)6__Xr>yEOR`*F0DW21_B?$*t|33Le#%M?AIp+=|F6h`g|{>;{-$g-H2h+PKZQ-x>_##y2gEl_Zl0iR%P|0(R= zBs{%@RnD>sF(-PJSB1DJP(0(5vEXc=c4Q1S((#c>^pN1>nK-+sh0Z4u zT<8!=mYQ(?F5v|JSVKs?KXqP{Bn^eXVosk=o%e}3X`c!oOx@le0Mspc92c-#GzT#B zKfts;wnaZOTZ^$8PR^NDMF~W{!%`d;2Xhwv&)EdZd+;tuV-A@UW*hHF%z`Xq^Qn{P^ zC5naDztVcx57YRI?niaiCM5#%yg)g%oOW~Ok2Z> zs3*&u1KBZ$N)_xa%nfSMTEZ36c}!(QsPxm;jFtJ`*7`MJ!dB9Ke~?Fp%iy45ck5uQ zHK-Jj1>I06$^^x!Nf~AOnAH7%CTlF2*lLpffrYc!$l0Y5-d2cG73nU``j`T$Tt)bx z3=N3__lEQXN#JNzpFlh+)hIqaRY(mRp`ZpbWR!=@C&k7Z%E^aJQ=Pc--?9!h+s{V~i>=l5txa|j?`MZLrXQmc z83Z-JA&g=<#QQ9xm)PGTe5ewJlrg_F+?bc&3*sc+HJIuV7ht+pT8$R^z|jx<}u-`){`%(6=7{+pS0Rt-t>5RttR#pZyQDq#jS`TfEuZyBfpS z0~4+xC0oVL)9Ap z!oN*3S*N-E+cc{oQvYolCZbhx|K~K3&}xZstA89gxgKdi@ zWYQ+O1Ws!kakGxJQl;@jouMmPkST?(j#eQ{vS02~Z3zO20bXuL}M)dcuv{ zGT&#VsF1$sM12AizAW{8Z4$xwK%kUKFUfetjS^h|86G{gH#s0A@1K|I~p z6vdOw{%Qy6QD0ALR;+`kK_5%7LuzEbPS@;B>H|$g4K8iL!>Fp5AYss_?&mW7nq_Ul z77-)$Y$gPNq1m;oVrE-w;cTddCP&J5fQ0HFD-*>1{k4n*s=l`2NAN2dDK2lEu$Es23rX5z#v}@$& zNz$$tZy9m=g4OlyD@nbQq&00Sg-pNKxjF$LeW>331%mk=L>vk|93K*SB!BLis7BqIQg=GJc)2eFe39fYgzWqmn?fa1K?fAb4U}BHcxi{5@5t zAe>ON1o4celTMGM9wzzmkl!g*eSJ?#sw8+QI8qte!6nq&0fZBBZ6F>Sdul@{m8bM| zbU=}?2J;TRO{stt(mWLt_|9!#7jTZ&U4zzjLXJc0{=DfVbxPsq2oYtSK7&#w1@Mq} z(84iPPLhnL02`sHTd2>I0=UQzXkp3(gvK_BXHfT(0vy{GeQ$0MwQGQ{aG6Z_piSnD zG2_-K{GE_R(X!Xtm+fm^_8wYRhzy99?R`=iv#J`k0-FDWeMkGYqhs5G_cOwNDmfl) zVerJG)$!0LaQXYxNxs%!kBm7uRW3xSlHL?oXXd4Rxkd{J4ch z3s7>OCK!2|(s!46(;KV-^~`=H1s`P>%}HTotx?qy~oS<1c zhKU}Cg}Lgf^pu|J3-qMlE>OHHz-O{^pT-x4hTka78}qWbU`p@ zF_$xki~jbjXO4v}si9yF3B9@gy)sVUW`_YOT9@K4M;bQFgW3cIgx-wRm1=yUpj?$n zpD3kJeeRik&%r~BwrH?9LxZIr*JZx&Xx5^Q9h4`yWr21R?X3MC!3M6;^Ezy+8+{*? zLh(b}I}6Y^N|!06Pqcn@nTXX4voGw&&oxS~mr84uZfIkk=?h!Es?v`%!fxUnipQIl z3;*A8cUhf}n(5dxUG!~J7y3YSLLl?^Tc(vZHTqhRIozwD?U6}g^ZG>Vh6c4F>L+{% z4u*_1{YHE6!|~W9Og$rhBNUUMfeE zD1(sRyOTasP7NQ}$Jv@=>7Ax-Nd186byUl60+&+_$zfF1m_)WYB-j|ErCL>TRx)Fn z3%biLD}qyvrBtk{zhj_6Z5*ibZcZTdc_R+A7^QSiV42fxvz)l-zm723)VbSbhheZa6PYy~P^n16!wV{2^ z52gGv&PgsX{aWd*RIv`_tX;{Dp=q99hV(=IXH45U2}0x}Gjjd^O=}qe^Z)y;B}Mj1 zV7)&tXo5{c>h#FItPj49DW!}BQ4Tgi9{OUeija%H#ZJ2>j^p3)I+SH7rqy+sfXp1lc z@e61o+)iXlA^F@cb!$@kLB4wpdtf7apONS2eK) zCt8vdP)*VXA7%D$>2&JXo*kO>@oTGlUeG6Qg$J`AN*PJrXNm=Pof%P5gYwi2al&uz$|gG>FNgG=ps4;L*q|Ig!V+q%=SB6LLKBNkdi z8*Fl`McAqmHqmbUgA^^HCcP7%)RB2;1ODgaU_qx3$mRxJe#VgL0YxZ?sdt6pVsubN z6hZMFXDrGy7R{kvrzXA=sIa&_JGWuW?1h{~!KmEL&E_md5$>>%TePqY3N?0o?bI2C z;k6fn2EMy9q~EGdgEPJ^Tg~G#s=2C2IFueC!LUdBe;@NHL*wX;VIeHsr3^n{PSs;6 zqyypb^|wWYz@o0+!e$yUCxxTZTkW%{7nfv>#WLha=JL*A!noiZF}79AN-?nW%9S7J zF`|G_=wdOwpwLH*ghZ_<&5)7=>a?m@b({B%B8U!xbW!uVij)p#YABI6p68}+vwG4LVD z`hd*In`D!znf8FiWMj7>!@$liH!rtIFl8HZ+Na?x1tS~_k^CA8({oh?<64oy@jOya zoKpH#mHO6|3M`GNZEA)Fh}c$<~xIwC8T>mptw4wzWMqFzqS(rlX0 zM$l(H_Z)W3VzCLdZ6JbH=1B(}VX}Y_nAG|$PHmcCY@bc<*(OrJ**z}!s11;1<;uGb z2rpb+EEyO7qZqTgMdQ8|ugLt%sv$5m3LN7#EM$B)bc4sStz;B@8sDb3?{Hf06E<_I zGWE$qoK|n}oh+p{X)fF*WzjCs#VYiI6$vy$2&W2jLQ$JHyX{A|bnJs1trTxnmYY*; zw={F%UJHbpkkMu{iX)XtYdiYr=#T~b3WlQv-u$qo#03-1ZK=;#uI2Is zxJ576Nw^>h24K|6tSKXj!3=DTfS+oWvIg`q`C~5i9G~JfTr8u(P{M*F2uKmnu}qA5GkZ#RmKxtF;19907_Q*>toVEYu8SQjadbBlIn;d@IN_6lb9Dj_5}@=SStT#20ZnNPY{*SmyZoynIiw5WCB zfv))^jEkc(xyAADW{x6VqDvrxxXL&sw^^-ISD5o<I*68~Ki(CuGwNQ~4BsTk3X#LX(hAJD4OXimk73+`?Nx(>_ zk_2(J!N74uy`GmWcU&x2a#J!H&K1g#k}6g}d;#tr#Mj286ENkqx=I{>oMqQwoHZ~k zUBcM1Q7+j7Dz5BP3%!(Lo@=p!7@t|Cjz6An&MW8X9s_r#2aJeolAlLqmXzGBxxlY23!`@UGfW^2F>bHIk&VW6}zTcvD@Dp*Okhe~ugh+`qVaoR{onqYbjsBTD(1P6@| zE&@Y3{tkn+Fi0lFWpWi}pf@KNtMg?Bhny-g_X;Zj)1Pz$CVk4P^EI-uMRUNx4^*I& z#VsACZAH^sOh91{E&*wZ(X^>~pba;^M8SG!f!(5#YXNK30Mms{Fh%?uAS?eHH!vjN zL$_!lc&cSB%q2JRk`j$};^d9RwAtxP%~UVoOVy z)1#MDB}Bftccy~(om-H2zG3Jxd8Rmemd>JfWqng3=MId5Svgh2)P{Ug7^LCuRi#Tz z>gWOXQqN-yo9bFPAe%X$M7|OS zn*0PvohqLerC+)PQq4ik97*`@* zsR1ZKfc_{JzL3jm3wU}68#|l@gS+Uk~jetT2-B|%sawk^vkbiDY4}|y<(wjK3^EbWl5p#V6M?i zOw7bqheV@3j>}m{Qe`uCYmTHbFbp0fhA&9rX7Qh|6Jr=EQ#j*+!N~9$nS-Xn#b7na zMioajj7h>UAi-GN^5lDl_tkp?F^quET(P=nB)d4~=vbEyf*H&jFLgK%?zVBbh`R`4 zKkryVV|a;`vZX^h39*e-C4br-2MI7tL1KwpM=Q#dKdnI`!b%F#HzR^LkvEx#V+t4$ z6DHvfPs4}Jc5(=dqb!{ToxvICV+xmbl7m?#$OJhw?Yh3i;RgdlKu()6x@#9!mvjeH z*yQ+Jaa4QCh0!6$P$E-aGOm-l_jomuCt;nIS?7?&f7#ihR~b=-Z_+we(WK1RN|>6? z%lxR=W42TG1L8!zow~im(UN*QtFq^?^UVTjXqhrCQ_;Z%m_!#x z8SI#N1q#@`JL9RBo}2t$XC_}Mhh+w)ROWXwOI)o#|7$xZv7-uIs3$W6G@~Orh0#fI z7C)%7aprML3ra6`3X(Mv*@?WYPJT*VWf&kyv18(##SiYxS-m?G2 z{90UNopd}V+Hnsoz_w0886i3J$l%-9Xbh7u(MS3M_FwisC)&@zm|ie|WK>{;$*|)3 z>fUAU7*+=Z1U%uw3rEI$R%_l341p;I(!d4Ugf5-x+W;%YppSr3ctMIwgJv4SFl-ah zDPRaL27kwrs1Nk-!3YR|vK&o$F)e6LJy06$C|^de*5~1*On@fBlfcC4l;>Y9mp*gE zuo*CbOhIe4Q$Dnb=mBPgk3gxxtOodHMgZqG24;feFj_5OVKVHTN~wZ9F{}Xw33!@% zAX(Sl4ccaaW3&o82}Z}?)z1gB+a!P`)hPvaC;e*Sx1cj&a)$(~hg~HnVQQoj1L;o- z>u`Cw)B>cLok>F<4|~*3YNK5D8_&C*gYm(v3K#=%!Bk28l+2|#X@<{;FNp*lb)?5a zQ%_7j6$U_7kO1uO_$pBF+5uyOO$iv&fDyn|J2y9*mtiI~jC44awXU}q+nRu|4&2BwFVY1MIn)XqyIACSHnCI=$qCX}Vr zDZRF=@GS>6Y5)_;n;(r}bu?T&n2a&aoOsXw~yi$*>h4hCD z@bY_Wk}#8rk$&hSJ%}Rkre}Wx*zW}l5cDAO*P>%(IuOZZGc0W_Z{>EkTCi4sAZwS^ zJv4foIu660*~vP7jh6#NFF=;YKjI7Ka@cq(xD3K~Df)=UXxDnZf7_IcVJ$Y-(z0#{ z-S7AW2>jvME^FvCuME-$!`{Lm0Z+I<*2o@M$J5!Y?GJPtRRo+ z_ze?NgaU1cZP#whNC9k)1V0jR11_*_(69Mb_c5&8rWpt)-`eM4p<5Q13lP@Hw3W96 z;THh&yJ57$v@#WXV}`eq;;y#xjXJmCV(rr$R(S|LR2P&0mV z5BC}lMverU4utzAZdU;2?GgU$N|eJ>E5bWub-4OzhygI)8Q_}aP}h%!;V_h9FYJ+I zr+Zz64Sn$C7&XXh?}e5>D)g@~%m5~A_t#EO|4}4R!WS2vwfgIj?ln+$@|Q-wb?2F% z+?uq4EyPTJ@O0UsYNFShn%qOyl4ouQbUC$J7vJonrT%+YAn* zR1%c#@NV}52A>*$b{Pz|$5?1XL5(a2!w%Wl(jj&-s!13F`bVPt*X}dNU9ykLK;FDI zdC`)EBO`@ch7iXLHVNn$n=?PfZ5|lxJ)l8Iw5BhIr-oqo)&V=xCV@45rM-}iXaTnK z?9AXU7`z1=4C^=Bn|H#>iOQAGaoOaxnqjKfVTKoumD_}{R??;z7l&vDMnZ>1o57mF z&VCT+m<3Apgi)lMHG}QDTmjz%A&yzIvw#3xjp-6x;dLXSJEDz*6>#$uz+i zlfHsX55{SCM4iXB3D8YTmf0LZw`jQ`za;s<2rAt00v8~cF@h((0ZRiC2zm^;%o2K1 zDaA3d9p##Fslr=ajLbt5X;Rco+|{I&%iqDUV$eWgWdLerkJT0Q0kxzs0$RWY#c9y# z4BzX{7}kV7(u1g$Z~FWm@fn5%L!u(-K~$U$ABc7On1zuEFw(A7=&5bvn!8~bY-Kvh zs(BXqgV`TSi=D9EAKw)u@h}pKLx-^I9t`1I6R)-a?VJlrQ z>>dmvS*=K1(Y?n=MRyFl)JXzO;mC>vtu7RDCD64CyJB#Uj65K1Xd`W_3wwr@iHAVv zZzq9ifv#X2Y#nS8SYc@XW3A%>7G{Dn(!nwjKrJ<#v zNv(*De)xg=Jg~t+7)1`V#+dtWR9FjWHVZ~NyfArlt7$!k#ls--msNs?ueUl{zzg})G^ml z^pc4cehh=i1|%I|%iax^0j0&x3rSyn!CcJ12!9~!!0ewFqz$gt;@V-Yr{6rmA+Izb zt*q-K&}yfw6TJj|1^|P0wL*J`8R|i;Ry(y0kJqvw1(n;WRrhP1pBh$1W@!(wi(zA4 zl!Ln(>|{;*{vLA~AO5oe)%-b4KQfit$}6`-?GV-+5uoy zAZZu0?qOISYTBZak?0G>p|MgF?0_ZPR8r9GWcS^DR6xn6DQW$I^sj9WqHqUHZ%0}; zboau%5KQvcraisTQ;DZTxduabsMKfrCxWSt zw3I+euMea#xqG!hik#H0)4lH^;tU`u@FZazE)aD0!BOm32TYNIKGK8GB0HXlh%E=o zfo;pTh3i)nvdMQbY$ebsfV8cG=N+t9e1l;N9S~cz{$`M_aAfeTQhYd$scgbpYmDVa z67wsl1t>iM^S01x{IP)DAB2FGyd%9hvc8K(iQj5iphe=YYaGSSa==KiU^@UqM;)yr zcfoxyn1)1zH0ck&t>aAVN?LLBr3pyoK!TPBF0f7bYJI2?y3oMROn3JFVWbkeTRX~i z->na=ft+nmdG?2q+LhoZSiTefD_geFbu$$fX*cY>&wGwigHG_z$vXKpbLks=LKgr! z9_=|I4=9^qIss3(z^GZvmNTHYR@jV6gF4{PA#P331EPIxC;VTTyhSmlV`~jJp%m5s z?c#8NVJ#2s2G~|u65Id=K;@ysstalqS};H{ng~zYRL4J;1UJFrU;_m`hIlr(G993` zCxEIW|G00=GLo?TKp+FV!Uf@%H73Usogg7e+XMCD-K+x!|1OmGGQ&NdK#3R|25An20i+W_ zyZ_Gy|9lUO-vh*?wa3wxIzI9kDLmWATFTKoOy|}%>k>n`BZ@tz)s(ok--s| zWEgNH5dMKRxN81}$I1_I6A9UhHUNEEwBpPu&tXnj;aZwwo2(bVomOfX4}H8%R@zhQ zxI~92@RUtf+WzyuzY;eXxS1&&jJrA=5MfRn}D``;ZK(G`GC zzkFl%?Fy?kPalYEuxfYKsH4+0^&qS5zy@i{-(l(hig^fR6{7e@hNXpl{`QJL64oA8 zy)V4ARKiBWW>`8_E5Clh+3SFrpdA5Ep$o|xQ8}OlWF3hNOAjKu-rw;?nG5ZO&8{@C zGTz-Sn(2g*+X@n>n zVjY5*fVHh9?9>SkM~?+cJJo*)7{fL~rv%3|oxHxJsgB$Z)9Ly}&j%|#4;;g; z1Vj&kfp(^8u?aERU742ln9hdZ$C>OX>jwP`<=K$wh$o`#v`tJKlMu5In5yk`B7WYW zT+&7Rx}1cVlCI0|jhs%`?{qssmnFn-eK2g29nbhvzf_?phuRCrw6vyxrt#BfdfWpv z&4Gb-kFJ|MH(SxIOY;;xODM<&W3+h`=)p~qr&r^vx)?w0^x+sI#Ei}On`z3!r@w5c zL}}96mNOO!{aV2H8#*uV{(5e?2@?G&SWN*p;DP{A?A1HGggzBMwF~N=zM$MV8N<-l zs$C_<8KFlr9DUjens?Ql1k2_DAq%A`48g>4YU0>t5xof{(Gc8&EI*Uu^agML#s>vY za;W@~T6wHvOF$<$hcmxMpd%%CDCo&Z%3qljPYXpiAf5hbOhgxXB21r6r(~gl_I|&lEmZ2>YiF!>+6Q_^>()lQ-LdLYMgy zH@|mqWs=GsK#F7~kgVH^{3DIv0N6iaV$dHhV=Nmp4F@_T0VrWIq&*zauRIElSI|c^M!UA@?>E|2P!Mg_ zf+gi!y_4k)Om8?s18{fv>-SI8dBS)$#6LXS9k%lvi@EF{o1KDC$pihT9gwkx>#YfL zBhLWM9>i8h5Qgi`>CIqUFJvnEf=t3hs+NH$P2KdI%WPnwbALmgQn{jNe|2l z=|adCbL=Ak5wDGlOn}R)AEyA2GeZ$Uc?)r~N@C7=4C4ebhkZrbyv;R;`$FN;cQx)_e zve~`y{2M5T%2E9Rdbj`)gKh)g#a;Ps@YH{Fs2h9(ZpSwup8W?2e9@_{f@XmD-kQxH zn0y8_hB880M?tq=?n;W;o4dxv&YMwU!2qTPGerPpyAbm)Pa(XG5O2_Hbyzs`=1+>) zfr74Q5Poa4*{xvVnRXU_8^}CM^nxsGC$VM-drRgFz^a|ZNt!SC7UCkb{B|NA@8xAO z@5C`VpbZ1&Z~=xLXGIt5$1_PSoO00;6Uc1cf1BFEJ_tDqRX&6X1;Rw=g_DHaJONgC z1kHsfiOSEqT1px6%p1cN*d&HyayV=}--Fq|6+~`7kD#5`Z7lnicqS%qg%DQ&3*Zh$ zuG`B$k$D|cw?djB(I}lLOQ(62Bp=2x3raKX63;mw9bYt;iCO$%wB5#|_P?JeyvK%| zYwLe#kymJbwn#64$RlZ{Z6aTcU$2ywLksgajJ9X0&@UpH33P5ylUsaytDjP z^9>9`zeON{Gh8T2w|g1&KS0K`bKk9ZV@fzn;HzLDYL8OQ#cN+^!^)Xmes%EjGJg_$ zYoV^U@uiKtcb`{-wriB8ZT*E5Jri_ka+c+?w_)#sV4#`;7K96YH~2bVt-T4SW;V7E ze<(tZco~ysbv;kIx+tcFse$TgJEEcCw(iw5LimD>F((5{7CdR+%@Cb23gJA>zSC-1 z$ewS4*>*iy=+7}_%mrXbn9H^HUkI5qzf#h_RRB~e;0|0M@1$q^(U2(AkSJ*Q&=PF> zcDjl~aIj>^!!#gp1mX4lATK6hlIYH;T=&SU9`BkiLp5heBr686CN%U?C{^VyVb4Rt zwzp<<$lZxCB4JHH*6y=WLpLk^ilrETsSP(sg3!zTnTZVme@Minl`EKbb*op4_9VoG z9TXVPV+=*-8KkT`S|4zR(VBJtb9y}oPW-FwYYv}m_dP*1A1T%y5%fqFE!1<9#pHZVy%7Dn17UUwk7h4YOA#>|G%b~HFHJ&U=)=?1$VM%yKJ z_x>6W-UR0>rJW>(uSw?(W{xm|$OG*}p0SF(m6+RAWkcs>_#;xwvzS*@;~j2iSdG3^KDEm zvGc{rx!$cweK3=XCc~`3=6K+|!X5Ts_Tu*WihbDhE+)SK)>QzxmF?|*f(8GGpxkhp!m3%MD561P2Z<8AgOh>jjj@f1Y7!aS&tMtsG$-Mdtj` z%(#V#1UAg37+v1tcC*J_*WfsbaBjUog2f;9GU?x93{=5soYNA_zcC|^ljXo7p@Mg4 zR`=6IwPzlWOF}v&tQ;NL9_7@iK%V=r43e~Ip!Vv5r?Jt z&^jIdg2n3ITqGZR64*pLd0&3V7M{fL7F$@-21_#cDtYa|B`?Fw_5^iNxJMb%1O_Vy zGthXX&5$>d*}nnIpzg#LzNYJYm_6hsj*FoXwp}RPe+DxgV=@$RFxKvf=NmsXalYoT zOgS*x?%)~kTsDf*;Gcwoe+VlJFvFoE?2inK61sOEPvm z@@`Sy2O)sC0}auQz2pU#nGBPi5Xb92%;W3@A##DXLx`=H6`z1|d7xa|1w!=ufqmft zjvMTBTXDZve8E-F4T^lH{_=dWJ6X7JBvH#A{0ENbb!J<~x&r?#0-UQM?MS!QvabTE1<4DX;R0Vg z85EaY1rnU22hblVm>2u(GhbSuz}6y*SuY67^fiJn9z#$d@LDejie6MsIp=pU7_=`P z2CM6J#p3xy!{XY$Vg8XELb!;*LVj;Y+0NK$ z%xJ{`0yA}TL|`1(?Gk*sRLcORMgfCpzmi}t=XAqLYW5bTMjXc8=YkieRVnyEXY<17 z$G4>}nb^SU-PT88S_>hnRm5ITqaSsj^Y7vZrYb~|(7%`}HM3*VngUs;Nt?bA3l6%_ z5AV>~e#y4^Gs>E(B(_OmRMgiV8jGL$lj4vGJy};4H}+G*eR=!+Ya^y!DctjwX@Seg z17B|JQT~HN$-_I%yd2+}A@Y$=I7TCTOXFzkBf0xFwPPOPJ+nLgc>i0+$O#Wdc<|S8 ztEI(-6PD8t!MfLY@C9x5p>_1*qAE4KHi6;S>3)4uM02P6C;dr=f2Z5m8Ii5+x2eCs z9>HMY`!lv?;X@BB_(Zq+#uoMcgTbwik&cyxpCs+RwMBLRQ1FGcNXL_(e^Ryk_LjW+ zhl8)Lh;%%=^Ap{k`&*1*-v_5$i*&s7<0n;>EnCRkqrp?ddOBV`P2t-^y$g2Wi^|EZ z$H`}8lbNw5h8+K9;cg9nKZyc$gw~vu4rtsso^H*X9_F(vJME2_=5#@(&-HY-z&kW1ib9iyO zpDAnX%;gc6ri8Ej{l(a+{iuv@rmBezgAGI8^`7K)#qG<9ze;>pV@&EK%j?uxo?NjZ zgUsJ|E%JVp%c+^ycKwtR|NX=Le%+#We}7?ddRU4qBB&tND+^~wPHBlgOsp#HeK5ht zdoj+AewV*5FKx>HQkj=pL3xx7#kJJbvN3{qN~j_)O}T}$@2(M1-|a}IoOV3pwyad1 zk+iNfQ=FXvxR?svsphC-eer@B-Ko_($KWZ{-JJ_?HKqP`6uy1`fp2k^{PE~++%5Q+ zZd}vYRRlJ*7yMhG>F7^3`tw0A9k%u&Hz~9X{i(RfWvKVx`Hqd_`>03dgw)xO;Ii*1 zrsRuHxv+flnea6=gdIDVcwIS^+Os#38oSraj#U0%k-mfPr&jEX_Acgdb;^XM5@+sy zmYLnCXy-Qq_(`cr`@-x9FZ|bpE>!vfU+4XU9b=p$WZv}a5yE>vwfI0Rev6vEe;j)O zl5-p-JlLONRkV@r01`Cidqf&t5s24PV=6k422s~5x?8z+CFRyGBncP(4<>3-MMekn zAnItP42*E2GT2jz>~*)rFIhfBoFf)ONkCO0j`BT_{$EP^-GNTaPr%Em83%*#AZqnN z!hHl{_r&myIb3OMRM5QGxzyW(9@O=NE@Bs_X*`C2133&WLf?oH?;Y&8pQUt}Jl3&7 zF_`c8lu{mY#qUs~4)tUJ#iOG=sNIL;fnBLErM!5%|e;@BU{-LkbSC2n^p{BWl^ zu2jxpnRD_Ahy5&VA>hEa=2wS<5aT{S__%A4v|*V8{wXd02+w^rx+|aEk6!}_*-Qv_;S?};2F_xK(XbCIn9=vbt@lPdg_i&xskYvl4{@~4OvuZsG zwC+zY{$tM=;G4QI>zf2jJW$uz<7HU$A<2sU1b81bBzn9>8up1~Gb2_w>y!GyN^=-B zlNa&HPm{>B|Um+W+i1n(V{7mmfaXtp!kAAt3s53Vz zU{i@r1GgM}&xbo;=2dph=2w;P`-nA<&U?yP%G`Rk`TeuhE|bic4u)lCCn?*5fd-A0 zin?d|=Thb{h@&)f9}tI_SUHGVK@S`-2iXR0nZtPd;vjsV_3++Dc~oVI;*catAMTjk zv+Sz({i$QeB-G|A9*3PPpV&Y5EcIPg0y~JNp&nJmSY!WdNEdOA)$Dw=SixpBNV(-(enBjA(@r3J|YCg58&XM)92c(I@>S!mcL_Xa0x#y^!HL}h(yHV~nqAmn+ z)|Jro|F9BOUelJn{xfk8N`9P&S5SS9_ZM{%h+Q@R8dY>W8txqVmphyjZPL8?&(f@^ zcA+9q@O|&MrOE$1m98YZcnOUkAfVhelBwYUO~Fy4q;& z=`_{1`0nBgighx+8>IV*6-pmg@%w1fHJCKvAWV7z!>zd6Io3dG5HvzT>AxxOWY;ZAv-l6I5%gYExX-6yFd zHm$iu)%V?|^B%eIvVOLN;YxjYDgfV0eR_&cHm6TbfDfU+&?!ITmt?$>`uvwP+)Oq8 zqJ+ZL?Q}rYRd&^PNZ6@P#S!-k1;{O1@=tU>s}Af zd(5O3obJsSyo>tobO+%ltdGzASLM= zrD$eCZhK@(<{G+rMm#9Toi8}x+3{ke#5ANma@vFnbKYMSsnoa#w0GqwAy51R(WdsNWb7%R7$KK~E6 zojwaWu}!0W6yscXCPW1ldM-{{_zxKPfKD4AC@vnLmYho!mZNEjGH-Z2FL_R#Kerqo zO}%%1jCalWV7`yoJb{HdU|g@M_+UQ&74!%#&KIcD=lz@k`mbA&h1;vdoAU$x|HW;M z%YPxUjZAz&4OU92FSvOH<*H+`o?dI)9>Ao_xsY;TiZ%d)VIIC9Pas5{>2a_hDXvvciN68F@N1 zBkTk3-zfeiKRl2MyClQcP(v?;GpEnrK`pry0L|m(ON8g2xUM+5c+@JsIkpJ8ge`&` zhveh2?@*U6?d|JRfd^nBf^c2nHc))w2M0g5V?$q62ox#-hdkcILiOiFeI7w? z1%h(LDReqYLkJ4IX#MtLLhx(B7c8p0b)M=9Z5 zNv*lMNJOW(oI!oe;pXTpRW0RxZGc4l5_P+Yuf+^`>one{pa>R##GqzhbBj64&L0?F zu*yg5vc`EquKe}$+4nNtR#8p zvZap6;%B3&N7v|t8F{^TO5rZZ8#TL@!)ucFR}Iek0Mvu!o$jkUn~zE0KNB-fXWTqh z)xhwI3VsGzO>yU3H_1>gd6p$B=`Mbm%H~8~&#E!jQ@gL{x~+Kw!k6`W_wc^6+`&^m zCnZtxRx0vWj}HoSRj(@_o*xV{&(FOAz__+7_d2}X=?}#OG`Ix!=Rdmakt=rFj`W%d z|L+F`9t(Qu4_zD5dyxr<|Ta(0_))_}L$5Z!y4V9qW@WQ!s?Lp<>kdg|&p-O>5S-+YUoxa9VnKxQD zUXVSgrPzEH)uQ=DKJPsC@WO~f0XKk4j?-n;Seiv*mj1~3RW-$*@G&u@YG;-yTp5*> z_l&B!5hz^%EB%R9noyxsO|(_Iw$)fSQ=wE1yXnCmj9jH$KWq~2L6J9oVf3q;-cF;@ z=m_M%`t<`mpei=pY{!wrA_J;E7Jo+f@2CluLHGiy)Z&3F*OOJiLyT1G=?nae2%6#ao z7u*eXjQ=P{4;rPAl6kjctyDYdw(K8NV{aj<`M1JQBy71A2GXCtMYkC!EMDJ|{!beP z>iXSaYUOX;qiES4K;PI_VC-IF>Be zo2nASuam8_{iCw=>I5?B3o?6OF0=8V;F_X!*7tGZx33)wiL#z*F5?xekT?`^gE%D2 zNen%5MK65ecK$tEzm&IV@jJuS(@WR5MmC__hFs4>*TIMFSX%-GH)Vu zbcYu~8J&5PQr;c@f8gOk0YB`X$ZQsv++!vgj@?#K!>>`N?+tf`u4D`*y zH=i7LZuQM+B;6SB>Bay>`JqISjQpx^1$0bp8|`7R(auLF4X6)4kV~Y00^%IYy$Ju) z5ftLj!MN(p@CIc7azX{Q@BRRUlmz>w84m)(&OuUDkGURN(jE51e3U>fA%6zzGMPy{ zuKIH$(VaI{pGUw~LfBwx!~+lCaXzf|0Ia{4IV6jlwu2##Ko9@3)zO(${sZN|Ao9|K zP$}}ceb?;+ev;CiHzj?jgoCX~4;Q`@Dw7TQ`!kOL?* zW;U?R^X$UI8X9c#9IPM~KMOeuhu?0YZOH+CoeOp9K3|go1Fo!;aCDUJ0ME7g zy3%ksDV3*@6Qdc52OHr8CdS#87J7F&eM5j6R1AQ6wqksD$WvmFO=)1T)-%={8VfO8 zf0zAz$tP;qCNUa!u`2_{p3gg;LGsot_gK(Ca-Zq2?FsNpxPdFW^%$9+qQy2kbs!{J zBr|Lor<3s*IdQB8XQmZV!}{fuUp$$8Ged!$yV85$BIO8zAALUQ~XCE&JghS?xY4k ziopY@#gD@J-9X6%Dss5Br$F)kr(LY0eUmSW^Y?vNCG%0NUuRdHnT!yXOWk@jL~{V8 zG%~xv+5l&MSSoj&?YbosHYToT+g_bL>CZU|w?)oaHJi2C6Ng=k+Yk&I{2CYRytEqw zPQ|WQ^Ai9{aMQrR<9rzpit!{=mS>OgOEQInBlp4`2RzQd9E58)U}q?C7hBT%)2jEAdDE}Y3G^Bw zR=+DVeJUZI!AYL@qedC);;V4Ed#!7G(pq?eRc0y>Yw~h&GNf&Rt*OxR~Bh4pe)x;5ea#3;Opl*Vn_z zIV9QTXg6E3hg%)4HL&nFPKQkI!20t2tmt(E)Yb7Oo(Fb}tK2_f_@zFE-z{2DCqy*Ia_JSf(i>Lf_OuS0zBjymk zpnv-5{nozsJycuTPhDV}I$#zc;TV(Z_hOa{jgCP+;duApnrAWOR!If*U}5m`3Hs&oK?O@W)Sv0hnxFfK&6fwR zjdiZ>iJkEhD^)iy!@XQ^9D#i{4z`%N6TUaA@K1KY+b^$u5BtwIR?|b#&@6*C>cRqW z+V}IRmezs)oA$A@$z%WWg8DY>FX?Ej9q!oK;jq;XQe+23^nuk}*pQ)bG%&hep~dLq z1Q4(#{VcM+4+3Lv*mW$W3)R#Mlh1-@Zrd?Sh<(-c|F33ZuG4wgxdVd2fspn z|0)`t{o9()Zfq6?-!uq&MCT~@I23ir5C1(z)a!(y_2^JUOdmeE?saW@6{6Sr%W~Gt zMh{5iCb432HF0zhEWqO9(COZXgow@Q6%A`u3-C##Ib1J?RSPJuH^Ge7Ayo34K!&9! z^}(AlveP?9gcW_z4fBeUpF+FQ|Ha;yhgDg1?Xw?_hl7G1MuCHH7)3=r2qNahLBt6a zO-V%qoHY+PB&8*jNSG5&Yz@t!GAm6q1~nB?R4O&61VhDHOG`{eOU>WC_HzzkuhrZ8 zec$!{{`k5s+s}D;#=Y0G_FDJ4*VNpV4X)i}!y@Lrc)dOBFLy0@&u?;V>Z zLBGK3%n?nwuh2H9B1BW}yKLd_?o7XI%kS+AP-zI}6rGW}gdCsz^XZ>81pOZHZ-0ff5Wkt{0n}@Ut zTXyGJ3$}TMGi#%`w%M^@MPH_42Uon!bmm_yJ-uQpYmQ&#te2$zje9WGl-2N#jJ5BR zTdcoZwR=FNXkynkz-O5Fi*mlM$2WKE=Y~fX8c6Y6#%o=9BUF*rZ!Nylq}dMP>Wac1 z8YkOr_FVyUXTk@M&E-273mm1vXIYtlP-9iRP_rAGI{_9IAJyz)cj2!8K(2Vf3XPRR zUIqSGRd7vX^=x(wbZK^yk!N4V;d&Qy~Z% z2id#MH<)7*RvJQkl@6-2rv$iQIKl6jGe>7(WzU4?bf+BlR9eD!%0mQ0ITvv^1?#SX z5#^;+;-gs?+h&yg2bN6to))UKB&)=RzpY??ExzzP{prQM^E}cT?O2y;_F>|vp;z~> z2OM9zPe-Q5lYMJ|rRXB87Vx7A=F}J1M_`X+M2s5bX(Oh~8m5Z&btV5|tB@%N_-u$D zR6oR|l}0n+Rj4DlmCB5aF&XhDbS#PM8nE8{lSs+h$7By*gp=-wubraN!rfb^-WSw! zKE;j;X7B+PtfS=#Pi>Zccf+sNe2E3~aso`1r9EJn+h2E-HoeVb9`x5Olsvh*5$isF z4Yc%@+?~+UkF90P^qfRW{<3)d(G_U?7fq4hf*`6J)SJTjBuR)oL6%hvK8lCvT1HOI zxk8LZuZVMGSuQaJ6r%aAM$DIYZpeJZ>$v~T>+s$dtQ$MQ=UK2;rWaWF|G^8aRxyuO z0uRTuDO$XUXfZC^jpKsfP?Omhmv{J06$@pTcnizA_juZ`b|CJ`12NeW1F?z*BIaKQ z;*vZN<@E>R1`Pz+3t}KNwF5!gscs-P)(yl$(?CT0(}7snPz=P;hA(`9|0PN4ZYiK5 z`UbetifNgSH@9NGYy7KJ*jL?@NY<__5aa#t0YYyc6n>Y=gk6{s$UhMxk+ z!N$xs{w!Z@&HVXkE7q*uJ${q#p|NJZF&hNdFyU<=tD`GYLnTQY-iTa$m>c%^_g}qt zKlTOxyfHL?JeL}?mu%~6wzCAAj^q6sv)H<$4*mI2U3pX!)~s!9UlDtwWQzG+$2i?L zTD)N`^PpnLPtbT4K4J%7-2~In176yM`FGtYy7DY_x zHDW=hN7qNu$Y>JIbyCqf8#a@rAfhB-2GOQYI8AQu#kmtsyR?Awnm&^5;NeYofYMZi zAKiSKEUGtb%-{$vtLF$_@lebM{7+!s&BIOC=UA}dMs@xdJlx~DQ`)vtdRFLee$4(W zf4$zqEKE5pm9Mm8eFQCJT~q%yV!Fg0vwdXv&)Z2=tW9YVHQ^vsCM38e!X;(%Z|7@rU4ID$4~g-IYBlYFjgD%tZmXXeKZBy>(qPbXV&Q(022Zy{KV7cBEXr6B1|yO zdXPsgZKLI=quB+c&!~s@oz!nz!L>6^g_EWn{i*;Y?veA~?Du2ASLK^xixz0u+l*%= zvmPlqZ)*Junz^aw8|GTE$^ZucI|wsQO!?ys@%W5a&KB*bxxwz|7kz9KJHXc zL_$ZBDPCxpZ&5Ppq4L0>Q?dq(PSp9&FxkFWungCkz>woHyZEJMEUJx=cFcC7-6Etu(B_Y=P>u_n)a`k!8*Jxz zKGTi)wx3FawDnZ~c|mZR`H{JUSMeml1ib$D7K%zZzma4@5sI8xuvcbFj zv>WqrxW3t?VA`8G`?S3qjj2doCrM6-A@auVtbK&6@5jUMUsH)GwY*?Gte1r{$g!$` zr9~=6697a2T-9|*#17z#DFBQW?QF;ckIJPfA&1X%XQS0n=@eks6TYbLutCqCxU=w- zX$nP&S>pW`^VT(A>Ei^tSu>{BMFkG+4I1GvdPzd!Yo|DND0x2FB3 z^NPLY{jhMwbs&E)XbBLo37s{n!gc!&zT2Ovtt@u97z50QHgT;No5n`-zO7kv)i=We zCS9uzI?QLaW^m^0UrIetfRd?^>LZOUcc{g)?XWl;d#CG9UghzC;2vi=^VR{Z zyGnCOf496~aRuMkoJ~*Z)It0E`JTr%sM62%Y>fY3=y|*P;-g!YTW6QP-{f6)G}D?a zD!%aa`<{(URq4BGY+7~oOU`|`#4aFx-LcuF8=5S7_VeuTd;Uy+d}#Al2lemgHd*IL zLmjBdUJ9%c38Ct5H!)etxPXXwb@ zd}|p1X;q>+=Qni`XF23uiwdt2SG@fc1oj{hWSH$e7Cp&-ga!iPN^2X0z5k<#a zLX=tP|2N;YhHc^%{{Qze|KG>_e;@OI@-bU6zPvqiPO0aNPaHF~#Ul{2bQ8$ddHeMr zbeYy!o?6h8;!4-S=~2vi&-s&4IiY3y=Td}TV%h5(EY-J3D&420KXx4C%|}@ zOaucZ?3e9 zrnxraiPGoPJrVQ46X|$yFmurTJCE?kC-CF`9hl$vb7ThQt(|a=LJ(#frjj|xvJP#T zyFW6c4O-&IYF&y5V*~b9L>QZ*L=HE` z{c8{WzV(V;q2CkpCA;i@pl#%dX}0*o(}DQIy%4nVRX}GspmYsy;PkorDp3LH=B}PJ=WNuR$>ssKgL;8Rd(vum;2^yQNYAUp&}cZbxAv4aNJ=jYTxUJBL=O@} zmOhlE%DFni?5dMG&aQEttJLgWRhlNhBuMohzt@RH_7!nxwQjMyx!ft zHTKlgOJLsg69_RyWKs;89WaB65X4DYm|KLX4Cq`|&lYNm_}$LTQGXQs*Hl9Es_x6- z*Lfy(Nl%J70I9zSV}q2zJNTV&9YOfY{4@xzK72fBhbrEy3mfYpv;*a{8AFWqw1pgm z;K#bK=Gvvc0LkXuS^hF>a3qf{Q7E$KIp(B$XU8uZtjhYLhcmH)XA62fKTxtD%xtbY)(uZ9+)- zSZ>~p_4zlRGojl*c+SV&{`;TvgHZO;AQ3EpD}{EL(EmTgI4#QeYp1?4NaxaSRNQee zJJP%tp(oA9DeHaVmtM$xTCiT;E@V$E0)PZixzQ6h0Z3Fm^ zdgj_`8{K{O>k+--zQ}2ZsBs`qHvi83qMH7T$Pk`pk;^xQvF6Q=O^Rxjek%21V~sj3 z46m#77_NmDuvPEN(g*O{Va&UG4aB9uC?xfP=5d(s1pb(tpB5T=2)~{HTbNRXcdr4A zl1+HZBdDx(F$MhP?yPIG7d}YOT%aG1tUK|~!~jB_1VB{i^ffZC&jNU z@`MQH&Ia;D5kT($fF?WevIyp5FOb~^3(;*Wt-Cstgr<3L){|+pBGs^>&l`x1csK{# zhU8Kf)+4XJCH^d6RO$}ixhM0ERUucxsdNqSChrH=t-c!>4mBI4P8Ert6hgU9>cK#f zhH^)W*JJ3xAFn0DLd1!hQ45+@;+5_Rg9bXHSX0Q0d$K-uphTQ&xdc*qHz;$C;nV*vp;-Zv)FKH*Y z>oe2jp22nJb1axi1^TZt^RA*-VGbx8U6VbV@lZ>PZnL zMCqP{7*_MCkxZAe-r`_NW%6v1IWiL-@xsRsU>Zc-J2MLhC2Y1hu=qwHHg_04waC!* zn19X9K4tdff(CB>`|Vp7zie+C;JmXWPqm2r?~%DzKn^GzP$`<&N}8Bzv|fxJcIP zGdX*tw!&0aH$7lajD9UGj*L`9&PG+ImMA@{s$cW!trO<1hynlf82fLP%Uo3P#0b25NKqvw@8T_LVx} zBAKZfbNI{Sn70pcWztAS^yB0jee+ zEgO$@b2|14LW-NFUf{yXM(VU_&ctlqD2lbh6+1*BUVV+f8O8b&^i~$d+=z>EGm5pL z)@dOAe25Pl$lCi>nv##kWn1(O?^PDc<`1Ym414vwhN9T{3n3V@b9w$i=D~9LnSpG3 zid_etXV`|Eul8GKR&BIC7x(C=?>AVlwp2M@jx{^7-gj;AMDy`d`rJoN&8BbqYOA3N z2b^ozB(v(wVo6{@7R6TKLsje6zkhD8b!Nk%3+~1}y7RrRN#?V?M=P;;ZkKiDvoo!$ zQa7c3R5*RkM`k$ghYLQY@J>vDn1`M7`K-aLL)R~&;mf4>xQN!6 znD%4^63!?w&Dj1iG3~>2N>l@oe~sT6%v@jcqae}a^&iO~`2xs-PPOH%UJ6Sd0-&5& z=ndga=8@}ma#pjkIqQJoo8gqG0N!H=>jd8?Z3we>Jw#Nq>TgEIBTU$?ulBfEDgv{o z$tKuypKlw&0#mLb@)XzYrwrw`fWFnZ{|p2Y)WdIeSF$A~Tfg>aL6bvQ>Z8m+`&xrb zEqDBFB`y^t$3-`sjDi1TgTfC-Y<-E+hZA13^Uy~YquQ<@^lajxMt(aZ}1 z?D7ih6C=3L7@GQ$C<%{oCXD=C~Y6zxol#fHwd2@s<;Q9kR;D5BPwuU#gAyf&MruqR|^JqjUBd z2efO)Epa&)or1MFp=RSOk@kO?ju|&LKPTRN1EnHpzlvzo7agzb*;4WKu-20fR>NC% zZh&#FumqWS;@!sW`)c{{p$w_R@AIWY*%S*BfV8zcxaBYwU@@8)!H+)T`eDqykut$F zYBl^d>_Ga`d^F*?`Ai?$6{*?^_Gd>kEdO~JYcuE&2FD}=|e`e@Z+C;Mys{TSwyvVa1`d26Ts0@De^vQ6~C9&fm|)w)}+jLivk4%X(cGXuk{ z3%>7=))&4C`kKD)92;|4UJkF`pSsc~4&u?jRy@L9dwUoB(N#X$Oii{5~msI3F;AX`6fvwx(IinIEjiS$>YY z^5hZB7Yg&E5n}8QqG_VpofaS7_`&HMj2uY9{N4!Gl6}wJMq;IG1V5`Q3%?TM2q~!C zbpo5`E5Fp!8AFkyT2*kCNQRZfH{4Z#H2X{Vd6Xz}m4~1{i{Q(2O8_NvZA>BOBbl!p ze78c6W?`@7Z@hy#4nNnD!YQ!+m)G#(6|v0DzTSn#gwB&6 zh(C*E4$gmbc2pcplkGeqjt$ae(!&m+F%!Q1VPf-Cg1vMLkGnRWIq>Q@=BDgHKE!cu zAI}0{@kYe6Hm!V3^Jj&aKjT4<7mP_10YLy6oXV3{r87t`%NJ_nCPLyS4m)s)dcQGi z^IP$(le6HD{=BR&JXkH<>LcCFN-3?<=@#!ciaEcmguoU+XAuZ7j1*Na*{{2XVDl(k z=Ts*-8%@R`%9Y>Pb!2zFfSY6*jvJ@0XIFZGc@&iKz-uE29lHip^3O)Gu`a@r=%KM% z?6r#CoumVaZm=@di9nXj{Pw*`vHF)W5 z-6cD|c{H=^FV3!+(`ODuCyFNQDP)zfC;5Z)#2BYc02H4C9VNT7&A_KH+G+fD^cG18 zwSroAVKFRDV_5T1vQ07dBgHBoHB^e3C1xC1&)isHADR-`iJF=W9?IR5t@}s?%I)Xllx|J`##Kg-VHpmNd8^6s{Ve+QP~7V=&Lo9b4@ga zGmS<+pWr9PF(!;JjxFf(5!(>R}w5D(@e-_B0LhT=@Eomx4`ep z2t%rBpSh|m zsKPcf*e=;_*hWs<31bVxO#J?1Yx=wK_{pK#4{c!J_TX`o*h_AAX|kX7{rW4KbWHy5 zT^RtcuHoBXub(3YWKUegcT8f-*%{vNHRhs{%`Ffg5?^D^Eq+%hmTcVj@k=h|4NF5e z>M^t0e4OXLq@fbDgiK9(XO)<$H+KA;Z+nf|*-#{7Rl~bWJ~8`s&M;}xdsp~(ud&{P zB>=8N8-yq`TPgMj9bTKNo#yc9!#;0@ra6@ffIHn`_w?uz-O;;nCC4=AT5!@WN~>(w zZxDd<33DGUAEGOhPuuSBNYOW0oc1oCHks*~(HRT$X#qBqF6ZTwnXejuEOWMhbh__n#y?scScnU~U$9^G#MPtH&=qc(9utj+Q8bSP(~k%yciR5#C9LJjLxlV9O8oIo(FvG|pI2hj{LYtacvJ#&gC(1oz}&m!-qfE^pIPiwzyiXL zjXps+T^2T|_oC4vrz`ww`8Z+a+@)EcVlEF1cSr@kL*RvGC;uja1=w5y0FoGM0qQ`q zJCKQ8E4XzcYZH=caWM8&S3?>#$%Z0}165VyfP@4aKC9E(tGqv{O( zAz=YFZxr(BiL7I|Z$c=*u^1rX<@XJHaPq?>9MdJ)19#Yc4R;nGwvbuW-20J%X!gMxc5Ez*{SHd<^0i9HX$Vf-}sjl+89as zV(n*JQ>f!9es3YKtzdQ|{C;E!g>!>kx!Exnp_z8C$KTIWG^`*YonBX&82V)AfSBFv z?u}$%Jf-T6i$_BB^s5B6P?Zm3F=ck;WwIL|U~`QI9zpr8pRljKT}n5<-@SlqnV;w4|jc?g|w2bsci#9 zwu%$#IOvn__lr7W>so7}J%xo0>fXW}s9RLD!3MHP_+Ed+9D8(2UaN2AnGu?axYBSl6($X`HIrp)# zm>Tx1;%#TJKD@_LX3OW#U_O#fOTK*u8?2rhojJVOYPEY#dY5eLjryOtV-kDGIVnM{ zljr_%WCQ||P7$>0Xg)EC`7{}8N^bcWw@awtYm!)`eC@~hv&yC=0(;#XE#y09u>Qt7 zL}_!R(Et1n)^D=G{OmGjWsj;pr8E!ROqW{#wxvAnO$hK^{>>~l(Hu@0Z!(iL4gQ6t zm$kdN;x{U~vnf@()GAro>Ovk{FNc6PHrOr~f)bIjl);FD^`OUG!g}yNOoy5-9gso9wR8ac&sSGwO<}A0Mv4~ zVKNiJx^sp2s-7a6k?oE_`3-UA)XGA+EKJwgR-i2%;%#TK;eY+2j=XplYxE~?JEY#* z2EX`ir?s#Dwi$2zFTZVTzC4Awcxm7iA748N1sc;EDc>LKlo8s~>Rs}4vn^(}1PW#| zX9GWx0*f)cirLx=qk%$056Ku>3p0DCk)E9KHf!Idj!eAqpOT3`J5yBiHe1T9k`loG zO~iyS=td5=Z^k;NL}O1dXu|sk#avFyt4IQ`xX8gx)hJ<(#r~x+pc>z-0k8PW2O3qQ z#K+40C#ysvBB1$-2Lz2*5-2`9=88UV=-!gN)5d`Ad4zSSz*FAo!i6xn448}tT>*6F z|G@AQHgAm&Fok&pYAFL!N)@F-KPx%sG=i zyzk_GI|~|=gF-#+=!t^y<=R*0&+7L}!4KtrQ$9Px*QT<*>=D0}3Wxu9?wAH<=3E|{ z20L{wH^|Lo8;y@xsm4Jkl%URIY6f$@fd0@@pq`1%fFES zc2WMDRR;a7C?tdJFi$BIb_2yQuGGxZp_tDX*t{3W5O>M`#;S6 zElqbf_-*`5EQJL^GqLL%gkYvjy-|~>bA3og!PGmxGj)+24DVVTc)im1O>7d*`1&p1 zL~JI0V{u?>)gfHsrG!)1ycaQB_heS$O{G5W9aTwurNx2bszcb-Dd7q>??oi*p1hTK z4U<@|XP9o-E|fP2P6X0$0@@-)iD~uzda~=^;6G=vCQT%i_SdRW&JE*Mjrzs>6mm7WmHg{ zXKRXizj@5fvoJ;Xr-}kR)hYe1P?@pdMA#^a4-2vR(6Acj z$`xRRtbeT1M)BtCrs3*~g-c-BoOj3XM}~5X0|U#G-qyL!Nca|;RW)zvTpuLBq#F1z z7!uGS@v_B%!KXIP)kV)$3a#OgZX)1R(2drVTbf zj?iTQ?dv?aC-RagDTWd^95JDZfHQ~^)wgKkG?upN&G*h{?(${ETosooaSJw&G+pMU zG5_Xe+!nCl_Q*h@z!KRX1TGJJ?W5yN>wOq-twIs1U}XX?K24zQgq_FoWVGiKK5qdV z5JKMgjARpIVqs_xn-h`6HXTpHfJF@N8-ig-^*y3!1hCowGrK92DH6=p3t8*NB8@!6 z!-Zm}t`B(Mg={Q~=Gzv+(9`p87P2t;h&V6P5t>CWK0;f2jaz?m#AB`L8ecB1e~nJr zEP^s}1-C>*UgmxRkSJ@QD+QX7P`NsrO-A8fwPGB%UIM_WlDAsIf?se-_7c-6Z!h`d zDUFu0m-w%@n3WYw0Z|C>HVXamyUSRM1{LP3u7~jXOIc^Oj+ZTEW4ln{k#+9JCg=Ku z?oTr_bATkE5R}41s*-yf=H%i^WE0#FD9`smdC0>p8peNL&OGsy9xGULp1%x){paqR zib8~R-_|UIyDt~_9I@PZ&rt6p|K)r3)d6J@;iR(RXn}Qz-*|0mZ53-ecHi!(Y|zOA zX&*>|Hfx!}SFd0lK=wVo0-ARQXF2HP4ctA4xk?dOeI|zuasLFdpX|U14r9Jh9L-|^ zBCg{q3NExj-$d|jIWS~pG-%~sgj10-^JEW&07m9gWUvsnJ|cr;r3wpZi?Ch4BqGyM zGLcO6B47g*8_<&}1Oxw}TpY4ufdq~P*P)mM`ZpLxd9m1d0?yiT_XBE$v||a6;_QKg z5NZ%z(8}+anmlbPAHI@#gP@Ryp^m0`;&`&y-Hl< z&Z@t;2-m*H#!e8(Bp&3swyQ{#3$$6^oc3GJ9QC+&=7cuyB`?))XtdKQAY^a@6ur5V z)P35|qbgE+Nm5z5S#Co{6)#0pH>Qclx{W}ckces}^(yu0G%9;D|LHyOOvenN5K)uP z_AP>>2?Dco%>XI!t3^)UpJDiPvo4oJeqe)WTq#r?u{1tv?sn8)zfJbNJur^2Vt{Mk zR31#M>T0;I6xIHIR31zzN9ALsKK_#O>t}s|w%m^;@>%)rsTv}m38*ywva+r5kBOQc zX}>&!C)VxhsWVVcg+}E>bz~kE;tn;!IjG_JxvUG7z7iik+F>Imz>4G2YBtV~fJ;%` zj-;Uu53C|E9h}8f<6Y13?A5GCpwJ$v6HpBhbv}i>1FK6Pp$K)W!|HBD6ING|>a@tr zDL@;+Rcj#SOS$hF&{(2*!W!1P|6B@*-aoK-$QO!U0*`P+pF|VdIh$C0ue>0|beP6I zZMw}I$ZfaUGEVf!-y&!czm_?$VE$|k>;K#nLIL1Q{QDkNL@U zOxO4~sx;#A+d#mAgcqyVv(7z&Aw=z;qX^;aEk?PIKa_F$uGZ)=c$|*i< zX1L9pf53)#9r_G{n{VUX06{LYT!_WuYqDHoP|eaw0O(y&FZ#j9hdPW$Sj6xh4Lo=wYv1h)3`SIJ3*@_^JdJV-x+#0* zE~|P5Ufp{VgI;3_+L$i#=|T!gja?*H^JFTC3E zkD0!)NK3Cqtywb03b^|w1j#b^z)kEGk4y|lZGyb0{}_{>Hr?#xT?_l|R^ce$&A-~j z!o4B3YZ`Y?bKIYmCTD?q^{0y5S1+wTin_@PF^lkkPmuZ+O$wF*E}|G3x{Jz(@(G`? z)(*l3%cQ>Aanf2&<4!%tKmCOHHW^p{F_5QU^$80T)=g`ZRVBAjZgWIBeSkO1?i0c# zizO4SMlij%({R6)*UR|uPht05<@{5S=8pXs#rJ;7v{oo_<@t@-Af0{WoSXc|Pm$tw z7gG>sqF<;cnMJ}TxwV<~QH`Iw zX~_OlP7isPEo@NARO1y%8?3IYy-e`Y$Xo&ZQLu8Mdx=b*7OLWuh`H95Uf6~#W3u|` zjUW2JTB^c3J_*1(#uOR}{S%FZetd|;exvU(CUgF#LMz_*bEZW#mbRZW2a(_{oFMV8 z{lt@@!ZvEb@+qG)OXnq2++jz!hC~fD)2YIvFp1?F&V1A7%*VfepBPP10_Eh1&|H=k zEz7oCo&?t8ub)FMrbf@@+O4b$i{-CwWy38f=-%FNlNWDgj?Y#9p&A*eIfqE+On!SS zn<)gc8R~aa&v{YB!Y6j&Rlx8dT1w}06i{M(Z1N?X%>&mY1CfiuQluR+JltYFp z;pOW4Rf(cFKR`B297Y1LjUi80IKK~OH-SVNwKSmCXS7DZ;#~CqjaNty8Re^lzOajL zU{5lvh?~Ix^?swWcd;;8pF-mDww(pDDLi{SbM-t!p8>+!6rm9Fh_O5pI;fI9-J-Gl z*mmXzipIn3Y><}#{68}S|3)?%1ckHVp81 z7GM4a3yG7nb3b}V9eFay0)Xitt1%6_EfS1gGh0Z2JY1;77ue&0F)veonpM<6LQzu( zDGfy11V;TW3D+Y4bW@1ki`ayJKI<2Oq#ugfid2*5GlWX}$tfn`1B{tM#*`D&ep5>+ zD7-kIHMbo~`X{XS!t_s0#c!&p&N^O5T5ZC?fA7 zxrA7AK$;LR0*;heeuI?OMQl~oV8DYxl0oz&I)P$gD=)!t*yVr#71Bvd6QMeyxrBvAb@lg1o<2|phC8q|K|1{4@Gg&tA@|AHmZm&hy7&!8a- zPT<|Xgjf5lhz;ssGL%Ty88iC9fTa{J(_#b|041eznSO`2#BZLpgSE2r#>8%!*{$UV zp*Itqy?0I7*l`3uv;#wOgPZR}5u)EX7T)cSAk#ZLG1)fS#XsN4z7GM;hMss(+Y`ul zO005}Umv`p${jyY;3<{@O9l`C6Yt620@9{;u?{_b#b*vfEJc`IZ-^+~jR*?pC7ZvK zrw;Ajr3QUKHm0c$?ukA~qdquk?1MAB>z63W6Tsj9lJ)G12^&Q~cR{BwSlYOOSYSe* zMKi9vQi1T>9$R~aSc%n@M2$lF9F2=gJU@@?cC#+s(W}GMSX0Pq2JE2Fk6dlxyJ#1C z8L+yHaTN&MtMq)LicN#U6|CiGT=0(*di##`s+!JIk9t}A97AnCt#;8!nvALtrt-Ha zs2tim!b)w+-S#j?H=$K)qezvoB&nVyN|;jZA74Ib4{IwmzR$5Du#ZCo9>AEJp^tKw zh3^F4gF_q+!^n49Zr9KTGlbT-szxwpdr`(<6?fdr+VUk~%&tkG%^h!Y+UJFg$8t*c zeEeSKqu4*pdJ@mx3qa}+|8y@)j&KwMNRs=Uk|VxNWhN;(OzyHX)`8$UR7Cz3EL>6d zmO!v6YcU<}O5+K|YyvEv@?z%E$k#L&atR#=?zE4E+k=>7wd9`t!U2`}tX=rAmxEB@ zjZfLf+FPSnosl0VmjvS5_pv~KdHs;DyQ^0Ape1L>K25?^LB7#;zuLLSl~cjStHpu~ zV^hL9krCd%guO&<8-?V$>_U~2M@29tPby)J`MwgS5FC~wW2oX{3G;q#hju^uWE+2J zKWo+ks!bQ-@p4OuiM-+s*~r1v8AKmTKp)5+Dh zXG>Q6>H%g8g#Y0I_6pJ)29#pjIj)>zZwZ!_s_}P`uu$J9W$k1*62WSS2`cpPqEgJ` zFc?Z%ckMU>#g8ko;?0d@Vbu~`D;RUs6MOW0#6i~aW%{&4P46FGb81|m^+T!ofROKj zxrCNq{m_ZNvlW}^JL_DR{I}*!Rmld3Ep=)%E+ukFuqc8IOceCsHxIIQEq*49<*g3~ zs?%gM2n$@|_&T4#_#znY?uVF1>nkInbU!#N6GbS8>Xrqmcw;%$cGUt6ezad5qPcioQL>K4m?{tlq|0L;FYPtV38QqM@Q9 zyx#ke-Z0jy|Ly$T_ZN!g2H0=sd%QnZpL#T14rcEwV-78i#g6W((=%6z$CTfSw3iIe z97jcP@`xh%voaRu4KuI9rnxY4!$Qrxz0=@!2~Ut5Ql(t43j;a!D;CK1@qS;kZp$Kz z)XT~qSg}(6;46&0*c*qD$D&_KmLz~y1s`w%{K4a2vu2(`pBW2O!&IrLU%3l4;jC@j z@+RLPxy_hx^rlLm9yzB}rSi;J^6E=`?GYBl6Te{t-F-<|rx^9U?0$k8Wt9;`*2%3L zUiA%YPG4r~QKsd7M_7xV_3wNx<6rOW*_Kve+j8^B210g5DrhCJ!S(vw_$Ykk5!Tg` z@MUfD;S1j5Q@#Oym8F->fwa-*{Yz{bD<~!EA3UL6CB_^U9RKPl+v*OP`{T=D3dG9^ zy&>~At0_}mk$*v}C>t|b?# zm>Zh%=Y6>2%F@tY!nZ-D*W{C|S)<%S26kCNBqfF}KM5D%I6rxkd8+W1Pxt^R*e53e zuOH_vPqDUg+T(5KtW55EnkBe68d7zo3afpJq2xA*NlV6A^!)SF%rWOQ$^Z&y<=;J} zEx{-_Qz-H?%#%BP2i$Hu5B`pYSwiUL1+aM9cPx}366YyX1nBiV2EyB%A=WDXTpjBzkm%)MPaS;mteV2vFr6?j^ZrO$#at(7xTUsNuz z$yrd5;(431%;}{c@oA-Qc^%m?YPn8=pu`44GKvOhFgIY41Ry<$v9M!AU2aW&8qDNN zfa7@TS?2MwxP3y8PGPkb$kiX_z0)kfPh5DxoB!#BU0!ryvn;wWZ~HxS@cwrn(TS&i z&s;E7=6=t5w2l@pmMgy)GJl`P%28=dZLVV`1;?!`nUm{_9t7Evf``uamCVko{-ZoU zlhz6Vf1{GQy@cwrwadOyXz_GIjLBXA|ZUehbyb?}o<(Y*j#ZS9dS9nXUPn%kyUG3HGYC zj73F7K~|@3Aq_0p+qHrQ+Dcg!VYkM-o&TT()ou;%e37}?>)S#?{kUg%y!!5E$a522 zns5z6@Lx#{X;a67{m3Uy~4>KfA8(COnJfgtH{%@eXeP5HFkry83wwG83p~wFl6?OJU!qWfwQtc%3Z%q}OCcJ1S`TR0#XVklHIaipK zN%zuvR{VB3WKj2lz0WIiqwW?6U>=V47HjO3tvC;2BQ3%#EPY=Z*dC^j4VwPq6;wW- z%WbX#etzK}<;(1I`1{MqN9ITW?UCL&*O;ZJ(0J2^kebP60KwO7q8!S?%el1y1-`Y4 zIkm1=Jk}1PX=WC$H4|W#9WAFJt}?k+S@9{?n0*tP^lE{5xpJ*TE3)6}PTA7q?`{lP zynPMUt+>M*WB$?MQ`-LS$LSr;W48;Vi<+v}{Uai2GzaD&;? zkK`N3JV1-e0B*btJMExSOa>%8ll1QGm+ASP8>|H^9HU9VJ#MlfV6Cu3u<-F*i}lxn5r74Y)p15I z4Jta0mUDZ>XyTmVQ*W`(j(<2xo>znUfm?|4&ddk71Q{iQ%R?=_}fZU*xabILw2g3yWU}e5}U*a-eF1X6JB-)^^mXguxi%Y zrdmk^d!Qc}DFOTxnYG$9}n>dBCa#WzE9Zq?iwfH_f694eg53s-&ehuBpexVHe z_8=a157*^jp`!wnn^|VKLXcviL9MMJurU!ZWy&47pK21ck-r8|F6c&s8o9c_!D$jC zs>dBu$G!orOSL?2j|YKKpKy*l-35$Lhl*#X_svn7WyG70Qb|Z~h4KYhmBc6CMPNF@ zpo=^*ot)8H#~(&7Fo|;h{$18VF78b{cYXmE1rTfZ3+s*2!#E4rCsvZUPtLY5Qx+11 zw_Ir`n)wThGEb55%h}YQAZSfpn>GRcZ*ri|9?Ttkap@W#)u2r$kJ+jK4E zF@tL!F=vfKgPwhn!1Ip^PZ@VJEg5#r3%H#kJJ?>e?7Ri zPWkj4RcHqXX)>@N6WV*MbH>G~5rf3S?q*Ma-*8M`;~ksn$Cj3qZhXFM31U6HPCUQP z4t+X*CSL7UR7f5z;pU54FQG2aOKPGjZ6HL2Vug@5e5A+uVsk0jMP6#_OAkeEI-)s-#?}$QjRvuS|4FQUBOCbdZn_wO}z$0R++vJ!k)#?+fpe139 zPzm)~9%CU5Xr=}w-`nYA+TlzPuZE_Zt!rQwzfz%kcU!x!zs}}|Eu@b8NdswuM+7FH z83qx0MK?ZqAWEg(??}YvLk8{O0t26?l3bO9xB>$DOeKxv3Jb~OfA-nd|MSOM)wKe; zFm2DmuLgo+BB(f!UpXb0@CT!tenL4nuvz$+@0F#C9~Z=nr9O>DQM#oR=q#M-$zurs zAu>;GI9)7!+yS;Ct&GfF8%jM?$Hfvq17i3kTMTS!LrFj?OB+h>*(jmKiMDs(s&Pe( zW%{C~-2ZLK8iwGgMv~`q4&UNNQae~<`x{AJ$)fY?6$p@rTUtp$G8l$wb32c)l4fepk5HBk-_fSXJwcpw95Sa+xRr&D-w@n5{w%*+W}WDlpYHvE~D+Q_64 zZdN_Jds%PZ*;;CWXB=lOwe*K&SZ|RB>LtOy{=`D2D9kCemxBk(;8HEZwG(U;5-)n>k2$RmedU z@*qjqVdW;C=p;GwJhkNEZ^B9cunLB?Ev->u9(k=S9xo<=KoO+c%b%*H&hAt~>fH~D zlCMtP*b!@$+FZ>Gczqr;`vc_1_%*WULv5ti-j~f4ORlE22-^1PL|Ze3&9&-}_vjbJ zxp*V5d069>eU^Rmo)XIt*+@YtwDL^(VXA0&6I(aRi5pQ_0RHD=;zLxLuv#i;X%qnD zzb_q-3q#{qNVkz;1OspIE67Qi4dd=&Pgr@gEwV(gwO}qhZkUPtizzVo6wI4E;^K5f zX9!LTA7LvsL)zUeTS=ojA?D0Z`S2BO=VKgDLm^@>lyqvvp73u>6CG8)BjG5VEk0CbLTLTv8weaIs$Fo4SKCRw zyI{m%1lFIE_jo8GmZ(|;n@f`&>t^4^oint0M1F7sc^V{t8OwY~I^maEkmJl}U>DZ?JGfcTn_TNtn zGu24k7O;+peg=!{6XI&TKJgvpuU*d4uXd0u9bbGw-UMmk%^*aKLX9xW8>^GX?>K{j%N|ves0#ko~(2A$o zO7?#cUA2>B;#pk{`xBm(&@1vqKKcv2(w`Oay-reuWLv|P&e9l{6G~+}nfpf;v1Pt zEGUq97RM0wh|$(l{IvpFwnUU4#fPs40XW4)>cKwd2XUTr{mu~(U@chftdabiyeqVp z-3dzdqpZFPjpXg-i$|ndBPoJ&9V{XngmFe-|1Lex(MW+WJkg6zq`0LBiOZ3Vej2N9 z?bqNlrlpp#CKPvfmAW)^G)zHlkGA2XjkE3Bu96GBO71Fkv?qW;T%?ZieVku)l>(Xo zQo-W9k6kh^`)7f+%DtOO9#X@nyk|4X4Fw#=HIw>;6vDu1Pc=cll{xHFWtabZrJgM5 zL=8oyfIi4n3Q{kHq(c+V@|(@1Ve-OGMyi%v7))e%h=dkodZ5K@kb&r9o8hQZ5yq#u zNrO>5?x33#iMkTD?$TBuaQoe*VMyD=APe0RfMken7Sdix zo_+_DEPRYfAOVHv3bj&{N?xyW`4;}UJw!_G^kx2M)!e_K)DX;%(H>Gu>-uIw5B{Eq ze1^MwVo-ojE%KE7_#{uMiNha!4qDL% z(IEW2!$1BL8Q?h+5R3@(l02Ws#+o*y;wg4m*b`|7i@YR_+BBQxiwIPCFyHAV1^w${ z;QV(lsg1lEI1H4i*jib|YT&e*^A5r4aNr}orM5N#DydJfg9TE)ueBl4LiwUCCplJM6&H&A2`VmTbeiXptZg)|!!`-GNK0uavg zEu}#F=zlpLO31sF)YW6|BFy8PR&Ao#NdqYnfn0hT(qX1Jjd+@stt73J7%*hJ3r(OF zoL5@THGm&)C3Tj^P3$sWJalq`rC{NHuCX@C) zJq|Z~3}{SV5|vV@u}INLe`%1D7~Rqd#&r-yTFVinF?#UMt)-UoO((UM+}R%fZfmJc z3pl&N&8xee7^ic8TvR@qUurFlkk@}34^-39R3`U&uen;1T{53AroZKW>i2=ZVRB6%^;2E_t+T3g9Y z4CaQmQX4NCOo~nwldi9T6qSfB!92!Lavv`;cOt*nR*D!W%yg`$Q?H#VXhzP)hu)$* zHfBksLq~;S>KOfVfG4%mkfUUT3tjK<4L>^i2UtJoFK`NpS&EZ~5si857au_Ftav!^M@qhWvx4 z3!*AU&p%z0cK`J0j<=I~*a$!o^w3N~5vb+9fs(IK69WRJv8b?xL7<513kKng7=#(T zJW%RmyikARh0yYLL6S}u#Bo8=q!wrBO0zXqD`1U*=Ofe~42N@=lmuV_=Jv<15QouC{0K6OGnccrv3fNO?mZ8 zlEGGtY4{p|#WV$^O@eYr>?DnJ%EX%&O*ENs^?ZXJoh2Q&?<_U@k4}wO3!c^&zAh%d z7H`o-+LZDb%!H`dHjf&+DQ(Lk%FBv-1V5qV=ewC7O$A_0%ZSxLI~5Q)I#H~4IRkuW zrP_HZoQ5!>CA(3Pw$mg)z*x%Wz*85Mf|`V>GOm^@696WVIZ2wI5>&I}#{(bEgKDSV#(GBRocYC8`{?HT7Glvd#<;mNSFciNP_HgoST%0H1~2(5s*|kK1uMIXN9d(M3qixSDC4PmsVQ5(Ebg?u4b5G~shh1=I{{hQqX!^Uz<<|E@vt-F z!X%$o)nIN`zczc?Q5lILCZ-ZZG&`LQX&zxrf=n-;o);$Fb|}Q|LfrY80fiYB=TcDy z7?h~f=Z<8O6DZf`986;JXG~6w*N94+IfBi3Y~i1=Ib};DDqQk&zDfDqu=f9@+GP5!^9Cnu21#??g!PDdSLE;mvvpRFvRi$h}@tedUoJ z0%J^SIVX}@s8-XL1~;p27pfQ}C=nGi7FTtEL>(nc{fuOa5$@Uondv9;kP0cw8>>;I zoluvCTAhI;79?PJV((lh_aFf@{n&@jD6N6=U5hPB!|az0gdFWPVs_VfYEQ{ON`v}M zm0*?EBfb_;4ue?CqH;%jN@p+%1!`o41yR+ABEu4til{=R4amoNB^z}W5K`q%$W z3LlaDQSYH|w)}|+iWTOZk)X4Lrcm;eYw+bDJ0F!MsR|UI5Gm>9wQ&&({M(2AcVF(G z9oMk##zpP=NrlQ3C5oVg7*0d_Ds!;;$WVpN8;+=lvLoRd)pps4%{LRPQHG`57Zpl& z8fvh4g^HETOh{85SbJw&7B&;JR0p=6I)u$#h9%gnN}7jyD+#NydFMJdUrOAdI#7Hn z>0Q)WF>JwRRSh;fC3t^$HgH{{Zg>}ZY6HB_pt{L6m4X0S9qs`47-K7T62 zdt~lSY!;!=N%2C>kJ#K*fXzKrr>^qpOtpT>DWgWpL@Am#3@BZbQh6Pl9TE;;^F|KJ z$vjLr#n=g5q{h0XYLF@T z=h0Fi)lm<$@dYD~TGTy2i(p_JmPyYlqvh-U#&+8uVBL%Yqdi$G3A~#-sBaj&7WT~XPBhNdfH)V2Hb4} z*vrac7PnrHX{VsS5^|&@xrL}3VZ8T9gHYa4C-hwCx=Pxe3f6} zD(jqfDv*&)flLB<;i=G^;tQ1_@?_xVwH%IP51}udvPLHU{jt70HCa-21cES%!Ur{l zUZq+S5j zjF93$vN7fiT^J!XwY)@$xx4biI`ZE~NC{pMVr&Rytv5D!_foUSeX=&}!55E|nl-_f z^rSv1_REoyFU#bYM@sD))4W|+M^g2C6(MQbCv1p1s&E{!pbL8QX|GBx|A6xF-LE2E zv7LYasuX5{AlzUC;kZ|<6e0Vwqda97v3|?bW2LvGh_6s{S#oIoFI}5cD=+|6@4yG8 z8bqcM)yDzg+smLE?hhI`9C+~3o4n)PQQ&J2HH0~W$GPr z8#nRAV^O0wzY4Vmj`JO3rH+<>O#^Kxr-%PGR_fpMi*~1fyf~usu00=g*EVg^pttr5 z#n)N-B|LVVG;#38geY3wq);^FMHGyR6^XhcnwmdSqfYtxR3;vLXKW?P!~(9rLriP+WD@b692J$u&q`x-gu(a_CLMfI}`t-`#I)Jk_xQxjwTM%^fbPI zlGLVA5_JJ`&lC{;$CISrtS{9av&Dl;lclPmXO!jxPesFDoq;4h^MRGY*nEJh#^wV- zV8-5rXJmaDM=n9D&Y!JOg`=LQ6dzNR7JBZGL95;YTqiu?d!@7<0f*4rng6e~_m8i+ zjQ{_y>w2Bpj@pkjI{Q5u&Ne@08_wp}A;d6?ViY!PBs3CZIM+FB(-KSaT0$pDOK3@1 zh>_5WmQ*7#KPt_SmQ+i{_i?>`9Iu`C=l%Zc>vpTx>$*Rl*Ymor=k?=tya&Vcrg zlT&7}siBXw$H0p_64meS2dwIY-5~khJ>u&`Gnkn^CZC>x$2|zN3WH_>J|c(CWc|>w z^7xtPV7y7Zd?vHDQF~RtV-?d-S@^~GNld>>p9JAYs=uAdI^m-OF$&Q9zH-3RENOu9 z8Z~+vN5i-(5*LWF@aOy_^U`=c-@^cJg9`8e?g8z02E-Ku1?~r`-p!y55`WMZ`&u_gqhyByD)yyn>68Xm7;Fm5kTJO)ucVp86vs%9K(+rKynv7P5GlrY>ZmL6}j= zVk4uyi(4a4UdXKN@$eb1V78a=U}y2XF4)+9M(9iP4#_oUnS)O+n zvySbzM~j-GhI_xV{9nJ}1LH3EFzozdc7LE46UsJH)Ls33pSH5q!S3y)>|iS&FB7i_ z{O^0uySpo~EQ)`xM-vh$&vLLVM*+LZ<5GPB`kTr54OP9|%hR3GBg|geK0mPhjgeV| z_XUXo>oDxn(y4Mg!c-7lw#H_e*r?}T@r&%fPbwaei zy&=6dO0`(YCfcbf%P*)#zQEbq`x636 zW6ENzec+9h_Yrj%B(HR`sQYT#TMv?GK@XBFN}@~U{Z7`wQQ5vc+**? zqO3pl4WmajVOyOuU6UTq{_tHwq@-@O4}#2ZERouIpL_9^$U{4 zn(>T5cG5v!;$q_*1+Ggx&YvU@!V~>Tvjh^I*|Pj=J~9E-v`L}nWGT|zyeqkkt{W=F zbyd8lbtR}(kX0&`rgbHikXB12T}c^OrgYl8r7Oupy{fy`1t${Xs&_8%C(-cl@+TSS zlcECGcl@0af6@t}qn5AoC$oW96u5He6z98d#&2EgPudW|PVtTYWQ3ip@Nwok`?{W_ z-;zbHE&c?*uI8HJ+~IF4M2p-rCGmY`cb=42&X-)$EuUa>oH@wXZr)<63wGlh z{JU9;H3Y_cmcz~(5F2edn{TVkCf~(UTuNPVr)bjLcQU(3 zK6Ng3jR+v=2-flf*H?5h``Y;_y~M}rjMadhP}oGBxxiei-87vsk@uux=a?Np;?Up& z&RS=IbAg(ua-MQ7bh-jWFDw;GiFzvdssNJgv0ob?UfD5S<`o+Qh)wO=%lx8qO8^;) z)UpD0nOt;M>kUlc3yCvR!@h~ADtHhND#9A!|Rok zrRVuz=Zye@FUpt>ppLin(*h?86m?npEBTo>S58g8@}GH&K(ZY}FEo&360&>_y~S^l ze(W*lFT714=|+g7=y&{9;*-ueCDlw#BnFa&QpTI4vVgtw{7vqAp3HI1avfxK{3qwb zbO;;h9PaAJtas>i=K%UWzsaAX{}H=$rt?|nAZMy4v#a8sn`GH}{(oh5kfyo&1&XQC z><+oY$2ilJMA037g^YEM2qYU3)6xRhe|!Kv!}~dJ@CH)P#|DzE;Hx~G-XIOUo>xo^ zB;$hypc7nvw|N7frYD*CHVkG5l6L4vM+3jYA9pTLQq3C374n4B6)2X2rGJvEyhJ%Q z{mHNLRe>ZIkz5-no=NbH%E9$F-x5eL$x9G+a)1tWraN~8lAg*)V29~q=k7pam5^Lr z;JUyMx+c4NAEckK19UO1;|I}A4k;*ytSw+A&Hv$N`2g22*FWSD*AUkL=Ri8kSsf_8 zMddo^I-%B9w7kFbbRb!QuUGYR4sagEcUq3~AISIQ2>p^@2qb%h%p~{+qH0I!SNv;! z)On2m!0Q9a8e|$sA7XvkKj^n3wAy*Z>3G_CLmfDF`ZK?!p7wSA%vrD~x>;X(fSz(T zR}vU;1p3hcO3xdgR^yi8K_Pm|_%ZIq8 z(R7z9SiB@_de}MGSrSYVrJ#o z(1~Dj(+3e4zL{=DdMZRB34e`@(t4bAHUp zTI&3BXLJ4B^@X!VOMQhJL618_wG?(NBj}gTHZ4gOMrla_J4YXNo}`=O?gHmX`i*mQ zVoS0Bi}!JIjG%P-3r}rHB2m@j&VK62m(H}7B(;jP@L%D-az)@F*CF<)YeY*iJJ?9) z*p^BFv2NR08ofr+>E?+7Ih3{B?n-lB!)N=Or?n&2ipVA*SO~>C-`e{bM=#aU0UG7)r}qR;a=#& zv2ko#-qW}Hm;)W{Ii}shu6IrX>E~OfErS7FZJQRDn3mc-J z8)qNuE>bvmyy#x0_^*1+UE;$n%FZl0vntcQ+=qldD(vm!>N4$_?iD^Hz>lyo_JvjN zRTa2PeTaV$N~)WjSyfQ?9v|;s<-@z9fFCzxjjkF+db`KjM`iVjzS{hq)jlK{elKp| zquryTdz10eqwKxhYm{OgWURXkaX?!}yVoj>sv7NH=Ogxo(PP{j6v;lu?N-9}`V)MN zd!rA>$nE=BRjPZFPkL)|AL6~Xl~@&AQ=J=?6TYPt3CDQe(F&dk->n`Fs)uUzaH5r% z><%{Ad0IJRgPa#yiS>ckw-T32exsGGQ1T=6$Ik8ZleZ+1i+TPYW zi*kZ}&n)LiTsZtjnM|S8E8l$@BTwzNe0P4`mNP!2g(BMLk@@bkddfYI=ez6lRNXv#zWaji zCTm_@zWb675u3H2)Wc=6?d4&3#3`9GJi-INbMY=k^Ki0PQqu zf;-3;mEe8z+;hnUcMD&xnY)7(C#`4M^W3eJ)AP^3pT!sBfJF~_`>=DQUF?E=E6vrj z>Vn0U;#=no*Me}HxX*FF>W=nJKfp-V(RS{34eiR0Ivpc%jqr>1O`Ba8EY|*~U27Fv z(sy=rlH2N=o{b)?X;cAT%0E~79zQdqq|}4;n3}>5(7?oc zoZ4|HR}a=N)zp_X8qiupIp%+KU3fXpa8es?{Yp7$2rpMpE{9uB&?-Xgb>g1ngz#){ z#HsabgzJFGZ^vP?UOc7Yy!!&dE#z{l*}W@+nQ{dN2VfKt%~((s(HQ;NgNLH`IRi# zfnFk8^2OeaRI7*jd@=~B=JOR8rykPO!?gLz2R9|^Vat4RjrQBO5bYOqx^dH(7ZrN#i@t1 z0_CeS(+b26#IM}9q(Hf?;q{SX^UiNXD*KQII^TIKl3+<$+TfgzTUgQ!*FaoQ=Q*24 zk>1L=E8p273YTf*3XKwL9B+dpmbx3xxF|9THrS9(aQ)-Va{WuUeM|pyCaU`H&Q#@u z-Ej6(Pkwi%McI6?z|lqaMedWBGNP;haE=u1x!_x}2zP9DvaHnujm~V>v?#H5k=Bdt zJKSe{(;eqA@RmiDbtwN!^f*q-+gcl)BeO8s{`6gHj$5oWaOr$QFZ@qeQ z%eQ$c$w2NKzSDf;O6!8L9Pt)0qT_g|dT65_;$oC5K%#PR-EyWnV#H>H_lqH^IHbjp zbR0&+h&vcQHbyvg{mUoDh&?5n>zt;V%~riEh!GbW?uro&;3Y~4Y>;bJjA)5#|JoSR z8^#DOwTP<5?TQL&Z zRcD*FirYB#kl5B%7;JIygU-W;S6A(Dr<>CcG$&bp?Jl<>?W~Ww#Cq#D!W{Rq=t;jv z&1o+yvwPah%2m)c$~CdA%||>_df7eJ%zL7q^XpdEy&PTUe%$?pnd2`soPU|DagR5r zXQOy)rfXy+uI?mmjna3AebUy5ap4F$WIpUOZ4I&XT}?1}4*EY-jeG=HTo7@frOTxspp$0)0j9i!Q=eR&Sc!a8ehhX+cz%4u{v zyQ5vXdTtYVih>hxT0X@kE?_~c&5b_I*OCk;Ntk`q+`^n-PBoXB!)@oe|N2qKgMnm~b*dadEFoFZuRM#!I5>I}r%;`=D<#{gk(a^fOV01MP zZEq_?4BSV}>8*Vs&vuPmCh|iL#yS+~oXr-wQrp{n5LJh}#+=?)IGN)T`z(^SUKw9} zEOb#ut*D48s}WBD%jYU4ezoRm7@*TIiO+?P8vc4+9}*O7EA&u4Xn z*{4QDx3$h!PW?Js+m_E~9L?wLtqa6Sa5QgOuAD{ZMOh0JtyG@5hK&kK3rz5PG`jiH zEj3aH)^ZthxBrX0WcS$^J+)pww}y3(syA?>}CayuUE5MYxz=Ay~(WM#JUFUmcamH%Nt(bVGXvTs9*rX9|%Y!y*7y)L`< z!>FQ}YbG|fiZ9ChVxnbUr=r=#lWg-+i{>1hl=)q+qPhP~%KvU~QU2$X%i3oaEpX>l zKKw+{!f$eFM~^RBT%6muYg!Sfdvh(8su@KtddZP%vy?tvw3L22CDT%|sHlkkJ0;(e z@m$d|dT45yrEW!02`ziF(o(vvXgMvKR%_u~idN7g(;6)m$BIhnmFbp{gxaE2v}}eg zgr6>2O)F<)hGf(it)cJD%nu=d7nRWupDqijx?QxE^1RBBEOYTXx;d{lB+tKi1N|+} z(HK%?DR$GhW?4d`!;3f4W3z0b4H3ng=#tr)p**#CGyUP2{7`rA;&QrgPFZNp@Zv4> z^=B(X8^#rHrEBKahPtO0Z>J4&8$+`e6j#uid6qDHN%0PPF5ebbv%YvIUA`bQEbrao z59!*1{IH7M#g+8Sg0irNkBfKHUkWN6VO2+q_tJM4)`n#qE8a(sENTp^I9psrS1q=L zXIv>hNWWif3lI9c_z*qf$PBLvwD7}pkBjDq=XJF3qx6Q0mW9`(T6i`6eF?1$uNr3I zU(inrX>EATGz&jY*A&yn@PtJcUPDWlQA-3qe&HwRjb+ppQT3{YJ5JIspQD)(e2ayD zOFw&_=11_4@$E|b^YgSUB5S_|KV(+8oK{BIk6ZW|`pFBlHlpSS3qMQ$e1SGbWc*^` zb#&(nYKe4TweSnHZUwbr%M-#c(HCE&nUPfyA^a!$)+(AGnK3_vU#3ge(Xz;_&qH`U z{be1kbVN4Phw!WP&TF(bGA|&MU#DNbP8%aLtfBaYlRfw&4p9}IL-`H5=M8F$YDf#^ zH|hROG&70}3*~>(vNvgdRK~ba-bgo>)3PZ0yP^CReeoSy8I`a%l>bYwZ>6zJ_Re?VaQR*MYT@LnF1+`i2Az^$e+wmUFw7Mh0coBPk2hF#Vj$wQm zyRn0oSxaqUyo7CfpH^C{dWP}k?6>!6t+lRC7+=9kchW{{-QX}@%C3JvEwLF-hVfPG z(~qbvw&vY1zMB2Mhi1k$d=bXiuy;PD`LP*S!gv|mzn_-HIudS&@wM!&1GF->;^}a{ zj=gk**2Y#W2sEH$Xq9Beth2G2wur{o}^{*LBk^W zZg%k`t&GnY9>Mpr;%{heeCe17zK@;yhBn6Y2@$-Cz4|S+bf}vj!4IE!Mc z$uF?=m#D3ieMls~#Ex8|nVs^6Me?86l}j|g6CWSRFSFY}(y~tWCnI@1d*>%w*(qpx zB)`h=J59Bn_<~4&ofTcCjh(Vyh~y3I&0nacv;DP5euEvWr?$>{+amc*cCnsjcCOj( zh~$5=4OeJ>=Z3wJypdhHLd!byqmld;TYr^Sc8>l$lK;z&T&1<0D~?6-+idAI+Ss}D zR3zupo7bqt7W922cS#>#qc&UKnMl4=`uZBpwB?ongMR3FKgN&BwTGF!&= zNM0g2f2EbSyuTy)a_OC49kkX~`cEWZA${{JZL|g5iR7iy^9|IJV!tYvlqkMY+W9-RrIz-La_~*k+23hqs=ZGX-z+V=N%K?d z21oI7Y3EH^mg*iF#kWZ3Z_>(CK0JzVm6rTLYg6koqxg2|wLfTMYSq{%ULhU$gIapj zjEmwsq`&^4wjM!GM)94}JAcy59(;Nf|4_Q{C(Z9s_jDAmlve#k%X-)yQGB;l|2K71 z_HdU+@x9W)TeP-E(6K1KPrCUpZS0Y7DvDQ0AO1%zJv07|;s>RZPG;*_6=~&%B<^CF zJ$bB^AC|VdSbk5^!OD+HKe$*~&xFoaUM&?bVU;~AQmp(7>CGjqwr4}Cl^>V(FJX;6 z8+uxKjdXSiv-D~hX623(Qe7dl^(vieS&oNu? zgtb8;d3i*kd7^9mOc%~t^9`c;tR~yC;GIN-;^p|V3~c$87u!&dVU4V z@58TJd872p3Rc#~-Du^vq<2=b%04y!Soy!wnU$=zPe$`tep@>AB5UkJqGCCBn3k<# zmO<{gSne|IT*YjI@;b!wrKZ!XSmvObPO-embY~UI9~7Mu%a@rxdWn?{%Ig!$OH7AW zv&umvGnOwmop_nm4k{fV%U75-tznIWqMwT8rKaO+m}PL#)3JP&X{pR?gBupb^3|p{ z%2?*$gq5*;jcL;>EPt?rl*jTi)0wrbY;fI2v3#xR$5&b9VE$PwUuUXY$7%EO(p!SkEkJ3BSbhjixOdm@UnHEtYRGUEjbm(-LmQ^3A5&*I0g<`<^&n zZu}`hxQgbbi?>23CmsJj_ z`X`R>HJy5w)egzJ9mn^X3M*LS5Mqw!Ri>>K%rcbR8_y5o55qCr(4fG0e#o@@J(fAt z?TCoyhfTNMWBEhfvGM$&Ut)7ke~ z-^z`1-orKl_m!-1lDz#K&9G>a072 zh^M?{*baHY8!R;C4diwA0l>f99Yp!ck^@I^uOuEIiGR8-&V{}BC(Fm)U=M`efa&8% zZUP>Q;~o4HPnCw@x4+(CtwPJ+SM^MkY1E~ia;HtKRY>ohg!DkZtI+Z6!jpf#JZ=+v zAY`W|XW=f_DE}(IAmq3Y)Z8b%)9G*CN+@F#C zH>2{gRfIeO{0Za?U557saxciCpF@5Wcv27{BXt>-i#j0B+zjt?4-j$lP42}zDbAs0dxrRZ|^!*Y5#vd@7o zD*q>RW92u?i$wNwkVUo$cv@ksT<{TjyU3n#M9qF2x-q*;{sGxT_COY;cYmO1>A%VT zZ^L`rqiWk;gKTWuxTA9Kx8Z%crkgN*jrt*ZhRELRGj+Z!gzTA4sAb>JUOtBGA#v5Jybj-MG|Efl|AhCiA*UnPL!p@ehTN?`mpg5N_s2e0+x7`` zV`QI~$8CZ4eUL?^;=(X*4A~py7lfSf1tDUcS_>IZBt3O|TK-tbZ$Rz`d=H-4^fkyo z%GV%=CLU8qVj1Ml26^H!Ir1IUZ3}eK9RU$dN9_0Vuy>F>=(t+=Y{X{cY%?^#7oX zk*)Xo8TpvV9(Y2nbav~eBf9?y`L@V@7`g~ut2RwT_m|vp8+*X<;Mauohdc|iQc1WM zGh+(4m>@gBMd^B}uYxZ|`e*P(I!9wePO9!FKiISf2ZM|JFM%6tzYu&n9?g+YAv~o! zLW!3lh#`;=L&TG0Pr(m-qo&7$cQo(;;G%%%!HosvYy4v)M@8S!_^%3g+%4d&CbVwb z)X{z4ss)Vn;{CzTSq2Vz30##wy_yaRZW75y)UzV0ag zlsb>cBZCN)&ZmKkmaYRAV_E0xz(q@sfp^n6BKoz)CDhW$o1a$gQ#{US_WbcaWnq6vkn;NhFV#aK81ZmiG+jo+mF$Bju+ny{uJ!q1D|HFzweUD z!%$0&JCuvfLI|S3LI}ndS84pH7dQQ=?IzGoeGLT+)c8;@z6?AIb}xWWFxX%I5%Cwo zRWD)CPilyUVA6_;=`DUi<14-R32?E(eGM*_Y~7yztX7a>6|x(6KX5T7`Z^$pzR)u) zgU}D@B5-5Ns=S08w==nMP0CxQ`Hda1w5zm1zx;H<5gb#fvaL=ME^I#^7OEw1rs2MkPQQW z)WCOwi%7f}P`yL3$h(3DFR}q922c{BMD$i}|k$_g+^k@&^Pl zICMS|T+E6dSarnM(D@p0VYdj}IEK!Er-L5^A7-$R`&I4QKrE+^Xxt$#M++f{3|SD2 z8LGjjgKq3sbQ!XyYa z$S~26VeIeN8z7yC_zQ=+qt7(%_Tsji>hujjzu67;^T9<|rsIFeLhd-=Np!(pO(@j` zjo;Du2`}F757kjH=91z_vo8c64#%UwMVA6A{!eOrlNWb9_^0aVhL@vUjVGgjj0L<6 zj-Zjb;EN3fSpQP5^EbgU(>w)F(s(C~R3qO2K1R5j3L(>w;V%dakgfusZ{V{U)yr`T z=IUev|5oGcy?Bqm)dh%RporU5FUlF4Z=u6hF-VSy`LC) zSq8oVJPGM6@I(XuO5>}%xal8t+8qMV(Cx+k|1nJn#wy_vz&C?;gW+WGu6hRWGa7%z zi?{e!ZNPDGV*_$E-Wqey$ajM)ug1-RAf|&JqIw7j2zkSchyJJD51at+Zm=JraWf{l zk(Ypr^~4S?=D+U$J8%SnEFX&a8|QKKZFSn5gtgs}Asbw*6T$F?aq4lj8C*EZ1ULHm z6t}!pZoAXqo1ANy}&1c_cYl5=71m^yb1x`=5f>$FUAP|qZcm*7oqHoW*H0q8hi}+ z0&wGO>cFTHi4)+)NGt*uW5Lk|aTDtXVU8DnP@=>IyTjm4gZ-P}1xP;(Ct}*_ zexglOxraOeZqs=J<~;awNdFDKOw4~h!vzTF3F1VxlJpD!t?&kq;5)r|8n`I%XYlz3 z`$HPfdbBC;-Ha*~KLyS`_6|b!Yr+_;5_bjkyDug4V0a3At|tTT1vNf=R8!u`k197R zpMs0N)*Cim<7{+Oz6Jatlu!CV@GP+i(KQI2z@6Y74UWRhRJjS=4xVM;3&9s69e|D( zU7-{VKaJpG{df-CxPEkMPRT6rec+BfLx$HN%tpEsMv^el9o=^iCC?)L8u%OoF9NqB zeg9ZO+Up#BwH;hEAQjx$fHUACJq5gjYVS~{pZQ)@cRldxNchq==7ayhZS}*PZ7ZoK>G_B~H z8gJ|H5xN%+CsqxO^RPN9n-O+^k znxONvK-JMFUi@W^`;Tv0K%K@%d+~UD24hFXUk5j=qz>{F1Z-|d9R$xT5Q9kLZ6-A3 zziE837f;5AJ;KjsFFsG>m%aFIg*)&>E30V%|3MJ9Uem$tIO>t;-9qJCy|_c;SG{J6*5eKgWte0EIf{W1Mi3Q@SLW1 z$4L)R#c?S(wt=3=6=?iBFaC+fBXbddV}^Sys-v9TrhKHvw|enc!R;vUcW_UH&^6y{ zJaI}>9u}h7&(gUAF%o_GxF%HSg2rFf_^)34dyRLR>Qz9fTEGl1{vWH2#(se;*vZMg9iQ@$COa%Ocf5H-5Td(1GWJi|Mx)9Gf4{;Hn14 z1(EpAXu9QkFp4UBzZ~#k2K!kW-(lop|G!@o?idAd|7fagr-#mL`V_lAcn>&sfs1Q` zGRqZT~Uix1Fvz88N=(o zA)ftzr6yeV2rqLShW|fo;`2 zU?R8(tv(pLYkZ6sp8$@!6Aq4G-`)S$KzIZ~1B48Nqt@+IZlBYX&(?UU7ym@#bzVHU zz3L|cJK4MbvHs_10&gM^@}b6SytuDbbre0<=m={7ICj(|4_sWv^+;5JuSNO@_$xY3 zz^*BllCCJ9WX&^tD3pwt2mySx7vHJzqh9706%TwRGysQls^tG{7(lL z>yM|VrJCS|VC0{Iqr&7QcxQwCAK;H6EzNKGq%;l6xAJpUnaIr<(2X5Ex!T$tLLi#p%qJhVDq{?eh z2?b4Gb6VOF`~R^pEP*h_kl`#cWFmbLe6)dg>!hyvsSBH~`76N-VYdo=slh(DvwF+c z3Rki$1Ai8LB+_#o5Jnh;qY!eCJ_?S_j~WTItYZRI9>I24?D^84o_iV1FE3T+TlQN09U`c90=S>fLK!r{V4uj*fu848y(PtM6tYPb5<% zo#Dbu1qR*#E+Tgk+!HzYd9172_YW^=+V>UUlf?D^bqEs;j_&U!1dM8Qq><0nc#ao8 zrST(Pyk~dyh9njPqo2XQ16*u&p91fJ^7T-VJrG0}Y=&U$fvbNym(x1)t)VHYQGlz6I5^( z_(4%o2dXN%U|b(nNP0mNG#+hN`5#{VqQ-ZvXllQ?uWCPkWmEoSKb7|=ZOR=T9#Vz> zyo6shzW>Fh8Fuui$}1SoRq8WhJ=7O9{+<^P9zd0)_&j(Qy=$nMa=Ljg~MPer;DRwLtz_Lat8HgXh@GDx-m*NeXno(Mma))*oouD@SHNP@5$ zf-ulS+H5dYuIGoryBm0KjsNGx=YnU$E?G8QY~cSpaIv7R2A^o~lbVM8zYzZP64pZy zYjtK>(|I2{geq^loCFsU(JQ(Hd=An*Ur|3)*7;xH!@=JLPuJ}cp@BoGvIYC^74*L_ z(7Rv_1kuu=Yn$Hj90M19>;gCTar0s7nAity91|JfVlOGZ+H{NdI{0Alk>G=H^z8rZ zA&3R#RS2Gy3pI^RS3`FS+!H$R<>1|5-(y|VTdji{&-3Dq8h_J^cXA9@9i8?PCWDJD zQs8>SbAA+Dq1lfG@2a!_>j(Hx;39G>!9~UNh(=_nd%aJ=F%&#qHbUc$zrBQFP3X9x zX@##1>BCK zUhqnAQDE%rO~=Y{@Q1*sfcG=l-}k6m(YL{k6@3I;eEv)>L$Dh%tP%p!){Ra1*WjXn zso=%}T0KUU(Z2<}zroMr;9|wR4(^#9i0JF!J;0OR!1^otPH)*6&Cv`9Mn|njQDt-a z9=LF*+fUW_UtauO@W)}-Yg5xLSM$;8{$Buh2X+IU~^OZdhiM0v%$w3><5p*{(lHS4TLmZ~btK=4c(OpiXAQ02wv zgAanEzri2Y3xNFrjoaUD%FR!x_QhWO5pWT)+F@hfU%4S0yoJ7E2{K@bsm7lKU} zQ1C2pk^UK6tZaIP-Ub(45c$sCE)W&<8LzH%^TCny*r#fIn-_l?JV5OK&qMInGoZ?g zAc*vJ@OyO*k0s!u#kascEe3xDJQ&<>YtzVW10M(;20p;x=XY?i&SZi26!TwiS;7RW z6u1t;Jv#3IBXAL+x4?}NdKO$bIwu_I_NdSf@ZLy=ZM(ami3l}-i~O13dPE&Uux6=u zBr73^g+Z^-WN=YHHMp^W*TKagY_|RGdLaB<1{Vbk1=kA@JUW{yV`mAt7z2ubG^|H9 z_Wvyb)g5ZlZsX*%t{2lNnao#;%zUo&|m!d;*Sog-&Vq9p7te-*U2Q zKNZ|)pY|+-NpNrkf(W7Rs202}(y=@4KJOD1{SUl3xcKLX|Af8xHkxmaeEST(c6DD4 zRU#Jz%}3X9d>}{e^aJ$P&_(_T{AbJ`pCgYKdRI;F=%x3`kyi+Pu%?S~Y0N(|N8Ts& zahg8NOP`V>Ul;l;O&{l_7v#v1XQ3Br`V239WsaOK^j9=}k(d5Pj=Wgt+cf~J^97?}0 zSB?G;UV2!ryg}$~HT{~G-Z@u3F7y;l|IbT*C|ABM^kJIrPn-76=v=u|9rSEXkMPo; z%9Y0p{aH=#=%qVy+Vz<^vpXediSBaCi}?F$$q7jcNKQ!Bj$KuQ zZi(7a)swm<%Q+WWXGe;PZK`>at(%s%smBz}e~MOUismLobCZ%hcTV=i={cRWVp42c zTJ@8hpxP%Vbklfu#cy&K)o-$+i|RPJim~N}c4qg_4h4cZpe3le8lA zDkN#HlQh>!S`(7AHYVvFQ{?k6OM`bk|0CNN6_lLZJ*8`QLQ+mr_b%Bv30>u0K2lig zgv9O>vnORwOw3Kn>6SaO+kgpU(^FA}HKGFylHYfYZ=@Vu=JEu$csW}PRUArZxOtd9;>(aGLZdcjqD?Jc4XZEu* zCuPscfkF3)$;r0tZpmFH+7c!w=H@B}yZ-f+BB@+!k^JQ`W+_?@HA{WuBD1tWJ~9yO zwcV0cp4?o@k+XM89p#RDqPfdPnjUU z*nq!ge5|Epme=K=oDnfnu>ARhQs{l%yG=~$mXne^DR*K*mt0%!06FFxY0|F4G1B{` zExbcIV1nG+M+$B8KZE-JjA{$-s3QM6K2q|oP9I9`{_o)StduPOS8#X1pa+%ZgKAtO zm+##zjZy^!w^YP6VOQrp_;U&WBapuxlHzwEkT3qv7-m6|5x$UJPk$zb z{Xb*a;v1=@62lOoUvI>;2^u;~^l37#`gu_>PXDW3c(C`VseJUQS+UtKhY^~H16 z&7*eLSr@G|`K>`F|6VZA79YKsOVv~OxWV%1eQ(B^4`(%$f zmKwc)M339VZgR+AQ#=18z1_)4T_!YLSlY;+4K`Uj>v@wr)lAZ>l$@l;FF8rvlZb!+ EA75aX5C8xG delta 90577 zcmb@u30xCb*FQd!glvQ)>|viMBAXfz5JYqWR8c|WzH2~>OF_}PSIva5Y1KwY1+BK= zgI28z3Mg8wNkFC61$SHvu4vVwRUfL@{?46*CHTDmclrG110-|j+;hKYz31FS3%|9e zHrR{r8C-2KxSZhk;lOp`AuQvrb(3e|rw;y-FB-FH)P6)|#Q79*E-c8p;5Oj|oTo1ytR_k>y+4Bu4IbH7s@6RTCHpsp18ND9UXG1*X zgkYeGwH!ENgB|>XQ)>{HsUcY&&+7z$8fy+PLp-WyoGvvkolmCr3jEmau!P*@|7f=t5msqt3Uii>T*5 zU{l$rPzQ{o@93hp>G&&#OWV_j$f3bV4^{!S* z-l#qAX}xNTJWp%AFV}nBN%jV{)W|&_<6iLQmfW)rXfS6}vUg39vkCWZD)fF%iEA;@ zGo!e{AQ|51k_m!K^L>4_4?`V03!m1B%LvIMm3Wy-vXJDh&}aGjYa3Fsg0E&jhrifh zsxgIw`D)*Uj)=8=tr9;n@ZPF<^Xqs66Jovddi1Z3ol@N+HG|z{JxPVI@%4I+!)o~* zk^=txsjHG|I|~L@v)uZ#*DGjmx|^R5{Yzk^rWg+yNQ%0gcABk9bbu-2SIZ-kzkw<4 zQ-!^1b=bfJR?KPs>>Ac*r$ytzo-;!GSD$j-723bB%C#XhwZ`PSp4G3eLch4&(;Zud=4Z+K3!j|i7N$4+qns>B3M9{ zt zd?1tC&Mkb{U>K763>=}eP@kQVk^7}T_yT=V7A#HxpUZaPlhn50>3)4^iNsToJF+l$ zp58*>h6q?+t|!lj=sdPM@|Lc(ze8|WT}XUHhYu#`2i&1_Z+U=bU_xfbjNYd+*bCN! z+|#ssre=jpsr_GO`C}4k+@*9#?eq=3t(Q-!o5B{Sr$huL z>cFi1uKIjgVeFTZ5DV6}dH;>u9a0dYqE-W|ifMiWYgl%9?#dK}&OQvUh`0Tt`VtgI$I@e6}-}8PQ72E)8zqp9zG^RDrK=cJD|!%oYr3 z_UAN=J44T1QOH|r5I$0i-{?72zS_Q#BV=@mtB+?(AQwUuYrPwcL3`sIq%=oZpZHio zH;f?ZFGVhN-;sV@Rv5TymE=#o_`OPum??yR)B!W`OO@mi!?J%Q?T=W>ara_~TxDbl zJNkHKB!oF66?ng)GO{MF_if{cKno&!MuXgr%&q4 zb3S?E_X&FmVV2qX>EJinn_sKxN;C z>sP~$k!3H+;4MwyE!vekFM*Zfpq#jMWfJVj4~x*&d=K}2Y~G%XUJXib*rZk%J!|W| zUZO!K*sRTiiLjN|dpDsa2het^fH2sa%-dHLOse<3gUG#sYh97&g(7d0(!A-pm`8?~ zN9dX1!^CRW)2J-)ex~$3i#yR@geQ(CVe9h-ICXMQ_`3ogBzs?0`kX~PecGs#MRkQf zOO29dpeLPx(vLlZsyV{VO=d%-Sz9|eO| z3POy`BS2i|T1VJ{>(8xT-7|f!Ui>F1nTs}+IsIgGVNZ!|#OQ?FC55?>6uU3|F-GQ| z$Bt~WiArFn=wm&HKS=aw+jr1)P=HxOtn^pdp6?qi7>zau~dx~ zsn-4nsccHg@FiT4MPugVK=hP(Lf%k;dbOS?#8jQ9TQq1+C(Y4*wiX33yY8HR-cEXM z6=4(W^vh?YINYF}0&9f+~b#ZrCWrbN; zWM20ui?W#N0F>qFqT4j*+N&SW*&@-#d46UGY?X-C z^p)DqHM>-c##|H@F?MfVX|{Ze82+}Nj4QS3%MP?xv!B8w2eb`Zkb#lZNMbo;mq|4AHMZ?l1}&D;4k-Hr4VwKzn9Z%sG) z0!i4Sa2d#&;h*1g6#X*RhYt(+;$daK(u9(*MS-y%bAR?I(V1>kdI=bN55(*~(t#u) zK;|v*rE)UqElNUwESl&*##PeGfGu))KS5zp%7u~i=2&k5G9AsSsR>~gMb<)#Ze|ws z79bm;RnO7sv2p=rnVU-I$9Cc)gTRt8v@y1m;Gt#W7W#Rt+!kpcEqP_@FZ2r1TbRf0 zZ3euDCgVEUB3+|3!>1pjYe;VqqhJL1P!vsXReB4hJfv5&Fr5a>ktz}9*=Sumq&Zl3 zIqeyCB@(KOwf3z=N-5W&Ye+H_lS8`r&|L=wIidtzkiBRIlbWxSkG4Mbpoezx_F$Tk zMs`e%ZrtMBh5os|z<>Ub(3-@$5c;Qqz3CEePhM(`_$?_>)3Y2^c0ValJ@KbX0=0f2 zj3jBG;DGlHOwDl;N}fjBMgvqN;zv+tlt>;J#D6FxZ=r=ya5HKoC+eVuU=7gsp6;NV zyO_7cpBGcZUR=mq0`LG^VQvPIn*o2}ma4jtd(sZ9G{UpAASmHJzuWTIZdNpM_uXOu2YUG zgCnS?WJMgb%+V!rePMAJY{WaZ!PRk*cYuR7IIA+I zCN?q;YUQ}V3SBgG-;M3cXvCz_EqXPO8Usoyqw`=follceXd*vs4REEKY=U(2*+3L zHw+#VHcJa~=hx6bC&_5rQO@*Xm4lGQ;SS>L&|Yv7(mo@7xaL-X_8uM)4nfc;{GI6m z#J#VCi~oQ~fH5hm;{Q;fioVEPp{ssK{(7e>Ug8j`#od~x^ z=V#yx(BR;bX0U6kFSI)ei3NgsuhT_N55ZrQ-lzg8MDK^|Rm1(e%-_5wpI1w$GqVPcH}`D;yp5;FNT^30R6HN1v<1hAO_s-hub>g zTaW}=Yl?^3A&NV*jt7r+5R%vW%uO}%(`RKv=Qn`vJj%(3Z?jOHyGWKhT+dqqS)dW+ zAM`#!8M}LX&%5*m6-{$T^m9|j)M!tOFlb5W@-o=I6=U>`nI(OTU*#{1As&zi-l%}#zv99k1 zoe%2rOwkqWm|_$JQNED13)fy4=|KPEPtqTVe)N>Vp+3-wzEwz`7D^s5YTFKeA{B$< z@Y6Q*?LA_MWt9;g&tqfils%fXh-+SEpAB)5d*g(GgXG(GBezMQ=Lx#o8=-EM3{rYO zl-vAJxb8xgW9v$5Sl+Hu;RDFd3dx@>E{Dve=F$^bK@Q-Wgb>nseTg_g7O-)?9}0*7 z`oka}+K}X8@pmVir^P+%E9s&DpHwF9n6T4E9%uL6z((g|d8X((w$Fb^0&#uw;-Z>k zV=Cf$!%q#$3_)4U;ML4%&`vQN6XI=E2|7SS_V=M1hj*0#W2D|Vp~IknZND%vkzIUjs{@d1>2VJvXC7IZlTW z*#wyxM(ON?9vm!ygF6)CvNXjl3QNGHI=i(VE!@s>W>V?IJrcX1u4M68dd!v-D%}l6 zZWl2|Ib~vk%a}OAf1U=zilv+cJ-3ECUCbhI7s_e1*gG=}g9W@W%L0d$yLGr_;fRt< zujYT?!t{6@mP{7t`edO)2oFOg@|l{rsA@KoPcdBbx>0;zB~FL44ypJ-iP+GiIkOMM zVNGQZ18h3F$PJZ!G&OONt1EkBoR}XpG!P z60<_CVz=t3Sc}5Thv>O8N{oVREP=8iZ2o1NOF(MZbr#}`Cj0k_R=O7&xt}|+fGNSh zOw{W2CQQ%D;3}nQszF*TLC)6`b|rRe16nNd4_Jifv3i688;(_}<1&Sq9xK*JIn~^* z&KAwToQ_0{+#|&VC0Ma~{$599U1D@HSW#yZvcQBC<0TtLW8fkz-vstF-GdfP10;-r zpR{nhupu*y)Y*xHEeO1VY``ZnQskI}8c#4bjFu;`MQOUgY7?@jgksaT#-{jh8b`D_ zU`>lYwv9mg&^phmN3=W&>qLJuVXCIK<@wQgJ-3$o#Kj^=_b!Z&+IHtN&JCEk9vddM zU{=)DHMC6JJW|iyRieC^ZSia}+fLX6Ii6BljF%aowiw{UkAz*J-Pb+LvH-($)e5-= zsksn6u#Ie8DLuo~BH`jr3G6goC$U9wl+a`ATs|Y6qPMHgGHbwaa6A*Y zi#PJ-AQZ;V5&o~4C|2sZM(%WPiwV{~1QSHShal!?mC^~x$x}%Px9ZBM4eXdQZ4~TQ zHE}Vpm7immaQ{?D9znR}?C|C?SpZFreAkGq&937ad@u(RUx2+aavyvD4PzRt8Eayb zEdN4DLC(^LsNT zeNa73xVKJ%7VL*jqx&aM^HTnmYw-#!+m4gK$9&RM+4?3#g6rvVlTt>qXOx?%)}=Vun8OD`U`QuR2n^`~CSeB`R-yS4%ncJu zaXLI@szx!q6XrsRBV>Vc%vP1I9&KKsMINkoZDC0jlSGv6lqqLN7qiwGug@85R!0I> zu3fwmarVJNYe|E75wff(ZzaLcv&&B8E2%X9)L1?%B~Iz6loB3!TP(r_MR-Qoqts>O zKJ+u|yBf>GX2xlOj^nXvt2C2#dWnw z%}-M#^S_HIAULxXO8$3(xW?l~jy%tgkB21li4>DmngIm&sR9LO9+@c3Ov{v>Gjfb- zogfZ7Xv{JevLgx-rXu91Zh8(V+g8;2;njV8kg@z#1yxxLwb4%psj#t23pmO`J|@_Hh4fLA+X68IUMr zO^4}einqordB!S1rajk@!*=!)^$%1#<`ANv1-c^Pk06W*<}P#0!QT6ca4!wKBSd+E zI0d(sW0Ho>F{!JyJ(KzT(XeWKuVlq|Ev!0UpG2^<4SrHBSz^jE0(V`#+L2QU+)oF= zh@8q!F{zuC5y^^&#J39BK`KeM8srh^f}3%VM1N7JIyL z!HF7aW_W@0s)-}71vPXNIp);4WF(uUWw8;-{CUZCFxY**V~*N&ry#b()-ekc0csDC zV;-5> z@WwSlsW_dSDb1?PlFN7#K~-g>7}jvAhQZY^*rZD{Nt=~XfZ)r>TwrTknW6JW4V{7|7u=3g%YnX~~LK#gQJOuM5*6vM!-aTuCbeNPSUHb)lqh^k~(GG7t^lJx@|uN%RW>g8x|6sXPHkjzp_PGI7<3T0s~sHcVezF|T$PohzsyL=d!8cBRPF$~PBYYC2t9um?h4B&E z>f8+~!HNRK-uOX{mEdIFn;_Oq50d;F>*bp4;fj?4cHc5iggj%VKqqgm%u@UMiC7_t z(!AtMBGQqwy+B%G%p$fB$K%7~V|4;$gnaQz0XQkO@&}0@KSb{6m{m})QeX^~&+y}1 z#U3+A%Ykx zbLSTj$mCMw?feLkyH*V_jaPY&S&@VvpA(cQeF)1)?{c(u&j5|Vn5DH#C~^WNT}qO1 zGM)YSX*E1YPDCBB4%}k2A!MSquDO#Q&j@qjVaSoQd2`-jFTO_DJMcsWXY% zsw}mq#*hDig1DNDP#FXB30W~a*CV}32<2=UzMCm32$Z*B0tV=S#`j=rkAo% zHzyPO+>w)4Kr~l|73ta20|j&ek!9?a%y@tl62@{xGNhBtI>-}0fU4s|U{;!mm{yym z7W?r_REaW!Ixt%!FoLK2UFZozRFd>>$R1U!OhzreIh1`%W&^78I1$piiC?P!dgB1a$a`D)dOcY}*KkwoG zHgti)5I-2CS+dxV)2L7yz`uxw*j`GAz)by0@TrVr0#hHVlA~iBR4~qyQqLBz9`Zh9R$q{{7@LaFoB;U`g5Zc!#J=_ z;jHKSLYA8<4c?=R#i^B#$_uF(6N_O$f^qmIanJOhs}A~N7yeScf)( zS?nseiNOMRYTfEc`FnRIBoa55Na%7X@%liC5yFk7TZoj_U`rq ztxyh1RI0A<4dxf3VDzY*XHzdcN zo;;_MW_Y)DVf2eMMdaHqjP&#QMcK*M+6Bpanf$aWrJbDyuF?0C#al74PZ9aGXYz)B zG`q-(iNE}GhM5Wd&zxyNB|kt!%AG$vHAZ0u6n)5--Z^1>MR8~)DY<}ST!huV*K`iC4aG47gc`C!Egd(n zFa8ysIWGoRmm21!uyHlrd0}7td1=bRYP`RB(y5-Eg!^GVu6Ytl5OI5s_J52)pDkmf zTjm1xn|ocBl(I0k8w?=GBt{tYv*?V)&cUJIR2%mJ17L!|>TrQDot97Yss+wH(JeCw zVqf#14=#2JS{gD_Hwh?Vf!0SG2l>sb3Bs^K7$+Hej3wILL^m#W(meWZrRQq+Zr>~z zN3t<60~JZJMbKK0wZOEfsD8_a*kc%GumTf$yI6AF2BRWiYU_&En*6>Zpye*JT5(zA zI`&sMMu>nE;KL==s1s~{9q3VKi-}rDISAbQsH5yTQ&o-@hx?R$~S=Ol?*D zs>hBowGvDQloX5u0x;6i6^FRKY)l6*89m|1oXtalp3_HkP2&#koRwZp58n{qn5Q8_sD6mD(6vf+SMm zL8icCqicy&3@fm)HnfN5`ZiwKdUj2hqlE5Z@O{NWb(!i9q7Vzy)<*rbK>xd0hUW3$uN z=M5MdjAM>%M}%P2n0yAoOBf~K7cKxB^%H}DvO;j^?heT;KoAWytq87(dMwX?@T`O7 zNi-V_B-*WBBF`NU{x3nd%pmgr&u-X8W!Yia5*TTVK+h>nq&J4uv=|K3BO89{{dVDN z@FIB7rmeG2@`n>17}f-X1pLAUSRb6+ka-hGt+2+%r8?Ds4*CL(8LI|mj^3gFDunQD zv;uo){bu$N94l-GR-NGd-MPSOfb+Eg=38Mk2E_^Iu`$XANLwwtYPQ?x z62SU53=;5LqUp*+Hoxay3LL)KfSl8S=Ay4BBT7rwj_xU3#>PnG1_*)K4MV^3b7}@141*Cq6j+$q5f=QN=ud$g z{|knZWVMVR2<^U|(qMzZL3n%JcD>mg3(1WX0v$Yn3;ZkeVvZB|CI$O_n;&f45>Z?S zf)xNN5)m?R@08EgUBAwPTLHl?AZpX?z4Sry1poj*P-r^i2ibES zg$F>lf#{YQL{YQVV|X5%uaCB1En!rVAUxQRu_7eK}j40H6BG%!*@-jbyv8_yCy7YrnV@DH=I?#6?)vu!ouD)Ao^AVDa zl~m;?hXyr+R3*qF@N4nzjo)h)@Z}hmVx`zGKUSFdzyW>ZA0AjzeQa}bt|JRmyTE9x zX|KJ!7-;xJTgNpC@@&9m?OVT|$K!UMP28%E7P-E1T^I=LjQV>Fz+=8e@Sc2sGsoDqEpgioaqurAEU{pY zu{{fO=OLGuYcL>-_WVG3+N8X|r))|IQjkXGnf9O298%usihdc&e3vc5F51 zo*9J{Ht24G!~hH@!$7Nguki;|WOT)_`RyrhJ@WUd0R*sZ5zK7Fw9IQAdoOHRRtDbP z*r!u&IM~-(uvg1Q+Ad*Xlm?vIYzbtDrf+5!jmFfCErwtUucGZ?w&@(q&;u4~HN>p0 zT{0GfSbe}h%>ZC~eDQ-XZ!VBTwx`^a)FmnpC=C{q!85>mGSF!9#G(F#yws+Er4s}$ z&p>iiJGCj`pFs;U24EQ4bx3#s7x-7h*gd*FAONayki8iH+IZn|@N+Q1BXr9QqHXNw zO{qoSm`f*$8AMz8iHbK|4F}U0qF|_1tg{z)^x}5`9a@2X(fzK{AIH%4)P}XwS5L)% zg9*Nb!8WWf2k%u3f=_NNSS_B|bE^v92>BC~O#wMv2*Cr6a1TJB0DddjJx8`C7=d)G zh19Yy{25gg8w~zph2Yi|flI0YqZR@`guv{E<%dQD);eI=OBiWo8+dEmL_8lt3?K?z5+`usXPF zL-6?%I*@|$?-h(91eRp?u%<0!jq8%@6L+oh5F7-g_Agw)w%2 zBfbRNV-KyQivR8`Zy87hdrpf~P=A*HGqP_3i1h(RTg3`ox|fXo9&~3V)}`q-4o%=O zu$Q*OIyvYo3IIT1YR1Y0*s}>YE5Q*}R#;h2_DGt56i^XB4VMODF=os) zgN_6ZQ}a5sV6PTm-Tg)O&@bkEhY`^FuRh+3p)64BG$pGlr$)*WErk@5?e9~9p$lpup_ z__h7lxC$GLM9HB|q^xcc`Tzzc1>h1*t{0w*1=C3l+5*(%fLmq)wR zK*dN{Nnd`r#(*e6sT8oVgllPf5k3TVaEL7o$SphgyW6qsZ7j^tQW>BvMgxZ%N3*$o zY%t6Vh!I%x9y5M{t=(d%L9E-Q@IPGKn*f9x#vrz&mu*MRVvzW)6l?Q-v|Apm#5Gd_ zUkIzSzXh@nLAbU#pa$YFXvo9>lY|Fw0n?Fx z4!0@qNV#V69_fINl*`@@w+V$3#urUwrlbBV`*40B+BZA5S8U*4Cq`=bLGNKvEKq~B zUcGwDOM|nH_LO^;{~T`w%9eiFO!@Y07h#4?TMG@iFqgkg_?hJatVkpCC0 zSjmDTo0irZMqw{@|7);Qtq`No_Ry+;QBS9ASC7H4a{z#Z2XKJ`hDg~qhglc_BDGRp z3rH!{gPP-k1c>1Rp1lW(oEm{AP!Y@+hC}}OVWpNe8MZ{4%4wRBC)Qk3&cF>Si?2cy z0Mhky&q-o!v7GflhGe3cE^+TvjdVPwC;*rw3<6w`ezNxi-6a-f^o0T746MPW%HNOm z+28`7h=NdU3Bc)`s;CT3Yg%jyQ4RiYOgYWlVS`l;WH=($=m4Ng&nc1JFqx`7*pbgR zXUEP0OSNESv^xIEbEhiUh}XgVR{d{0p8A8~6IXp55uFXHZs&l=|7}b+1N0poaLzsviVK3CHNsQ<+dk{pG0Th z?U+=~fAOdeHdS;U0pi02o_bbu-gPNdylq<==>AB>DbpNqe;@$>aDhh&yY-sL@4*N| zF=Hs9XdA8zA3zUIS*dgM-SP5%9rEdp(g{HupoX?Wd0|m0`$z|rqa<^d){X9f^4Oz& zV(X0;dB}-t%)YAuIIS=P%Z~IZ48Slr5<@U88_N3=FM!mbwoo!5vgg8)&`1!-LWv&9 zhCh8jnoD$)NAufR;sl1Nt=wbX$I;wEC~9#y18B4Q)!)vlfm8w9TCM)*?+I=c$ZaKh zsy>Ll1#H=}nVG#accR->*tEJ?sdMtfbA=swhOgi1Rt)Ow4wTG?JV@NQJ!Sua^zD|d z3{ynf2K4>Ib9KOUv6W0O{HJqYb(CK9=$!iJ4k9hszm?g{6^JL&zj^shkIoTk@EL>^ z)AQYW*`k=Y>T1qr9UZp|lwS=D2xdO&YL1>O!qR#Zh5}5HMC|+7Uj08wTAA zBNDSdlK%SR3snC$q~;d%Qm;jAq%FnttTR!IQA3sjMrvC==%SGYS)YJn5(Ca~L4e#^ zE_P{vvns0q`J&dCxdJL#Ab}nTQ9^{w@`)acjvJxLpwJNGQ2SDOws4$bV349Q1k~$= zx~QMI&ujIP^8H@HZ=ec;9}>}l1BrIOJFK($*w!DwBRCBbE;@orV3b1{lo|xn;Ys(d zZ)`h!j_~2`B`v^I17)i|pPi5HT>zp_gt-JffD1JL;NB(WGU)1Iu#NI@be|dsrBsWO zEQbZZFIrqT0_p`IC1J99D4YR+Opb3F>W+i$p%SBD7%m8>7exbj5Kbhxew*tpdUKCD z2_1)(m;6;cz_uCYCZUP&Yp&wf5AEUH1lef|jI{1e*S=f2*DwW|OrRs-fd+n28FBqf z-rvxu`=ML-Wg=?SN$;p8SNKvRpk)x?2?p84v+2KH^oL8L2+P?DWUZV2s25*VP$}?P zfCVgKA=-Vbv9rL1O(l0_I3m`tH#z6~MCQpb(GnPJ!z%kY&3F=1msnw4^ZNjC1qWjf z1yT-@p8@-9e!m5cJuq3C71+7W+gPh{tj6NimSVc`uQ-7l__S62vAI7bpa!;wzAf6q zkhX^Z^Tu%6++k9%6kK50k01Wci{LUHrujpD5W=88`^U+c!jO)=)L;K>W3OdWWt(#e zJ&lwP30pbDHNh}Niajpiekh!ZVbfp)Fj%n8b{5TG6?f>7%70cX9D4%-E~9_M0>B1p zxa@iU;4unx%Ul3r<{7f*T8J72?9~hi zCcOx+DQa}lkjjE#6zm2UfG9tZT*!OhF%uuNW5=k2I;6rAb2Kt4b2E;qtoSZ{ps3cp zfxXp=Z}x@c67eT|Z;II~$etKh2a6N%3m4epfH$`p9hg{^3*$d38rk8XvvzEu2icgJ z(#V5PkqqNtZky7aPf-$dZVW#J;>zd51{YR!sor=*Z3b_CEtZN;d;oV?fUk{xG5 zN>;;YE89VnPr<(_16!2ADA!Mp!1Njd8i~@SN zkoT6$j_Xh*i*C^v*&= z76cb0UlO>$1qrHYv*>=|bxd8*f|yB><>79}jr%&rk>-ASDBorho6>eili`;@K78%L zG?nlKK%N96t&j)Z`Gu0Kurph&4e>=<8=2+N;TR)O8myZu>xIdhK@I}A0CTigjpaU8 z&Bm}d;4UN#BKrg6;iaMr^>^S?5(sh%hTsBA8)v$0)g8kPt)E9QsruN>&`90_HifsO zKL+umlb=g@&*8JserPVk0Yd-TnqNurosNh{Mdlm5vY?S_K$st?W1Zis&)^TU#vz5aFO=Pimd;dB+o=t>L;cGvt`;bqilc$xpuEF8rhnf0o>{ zj=dbB-wLj#`?tyf1DvYNg<)pn0{zDYejmXei#|JqBxE)o<8Ck0xw~q>iK{?166oOq z+daP{YBv0asq?_36dGgP?b1(fdAbw0p#%~v2K2xjDxE{id+uT{G-oSDXG{-xP57PC zs|2Ql^+_Ow3;2?+M9(O%4wcrZZ>Fnwpaw&G^#+#r(T##UVg03vYfs#+;?=Oz11WL{ z66J|ONf!-bQr!AY4D=Z&xMkf^?)*>k<@TFB3lUfYOl~!>^Rw@81}p3`Bs_o%h1|bI z4G1gjT)+@rU^1IC)AhVgJd8aB?pqNAZUY4GKv?)882@K<+iy8{nR*^*+{zUeeh@vZ zhhqcMs)8tg@Ad{iiyP{!bUXa7o=xlxY|01;lL0{>5F6i5Z{+#&Fr5_$q0OZ_$w*Lx z<|Gg!;V7m&4cM;qDe=Ta=%Y!-8&Js=xIUh(%80^bP@w^2xEP%kujH=4zQh!$@*~kG zb0iY)WEZb|jHyxON1;*18`cH7HydZ-hDIyI?&HEVSoRebRc{43{MZak_=63`p209h z+`)3QvM!NMGXQc8!_1TZqKBVx;`~g9luT!wwwEd;Y;XXk^dvS zzzDjvr0__a@8P>UAX;m@Z7kSh3_zg;r9H_|qIkPJ%FdvKG*HpvWuQ;l@E!Zz6KC-_ zh8Be(1cCQP>Gr*#FakCK%LSBo54cAz!#U(kB)|CrL+r`AM%mpH^RX*1)QVt~=Z{L4 zMI^QrBHnTVf|29w8Vmb@rGPJG9tOTE%iQm1$KtpiHt;sV&VCVIYcr9>s$;cd>%8Vi z-0PgiON#BW!aH&dyZ5eW0vp|8U|^IpvUxxE{9PP3Aim}c6gFr{xH_K8r>?_D8{G3h zYU4sltimcmot|vxw+?3+po9RAK^NqP&;LD3qY^FwjeP+F$RRN%(*C(dN#2S1)D5_A z<$KL*zwt7t!C<9^__=nCb$?J;o|PJ&K5%a|HsCn=YEYXR4*eS5pu5aw)q%V%Y&G(0 z%k~?+ioK;+sg)YSC+T9w#t_&HD>Xbi#$8skl*F=tmIU5#fh|l6?Go$XQrIpl5ZnH6 zzoUGP<7z7quj|8W?t^T%&9jmHQLuR*z{9^H&EMKHKLNgDm)H#{dPiZ^R(#LDao-U8 z0&Hx>*YqNspL?6lB6}fB3=5QfpL{{^j)H=r#E_c&_{l$Lp*l8#ExIDZ3B&PW!NQo^{CRy}?I{{oLMad+a~g zO{sPytUnrG8RU@{_Z@~KySF;os`)o5QH{inPyN;c3@p0Rj+OmjFpeD}G5Y;>m8LO} zTjGG{3^I`-zf0;M=I6&Ehh!{Xx6k~OGpLb}RFh$~gP5PQn?z6W!_yQJS>Ru6m73i) zX??c5-K4EQNbL?gFhA~rbG_qQ=Fi&o&?IY_6r{O5FyZF<VsbYu3Iy z+sQAE_%}Z5CM;d?wP|nNcEuMJ{^tU_3(u_mI(FZ~?W!-1`d^*ZU3hW(*R1_dw^KhJ z^Cy4mF1&j9>)7&_+tn|A@}FqiLs)y7-n=u=J!?0Z8*q7O{Vgs2B z|Bv0>opPUf%g2t%U9_OUPp?xIOcuu`&x?|sIAL$2(93iyLkelHAGRs5siM%GqSct5 z+aJqg&v>(C-+{xo&W5<3OtpQ!@5sDFZ$qcC>DgYJrUvI-J3Mx36#eXnX=>@_{`$cq z+$X!;blNuYuFPv4#$Nvm$L-uDfkLr)IK?@1)9=?1hqI|a1)oV!e4AeC+1b9^PnYK< z1|`V5`DKT>rQqD)sWqWTi8V#NjzoF5FU7fv5u!sGgQk`i$=%chy?<8{j?>M%#@I&C zVpYbbsrPa2lhVn%qi}x1YU2f2<7y@S{hm%ZpEm7L^T;qSJbR{`4)}2l9!YC|T!<5N z(~qO@9i>C|;vB`L(Vh9*>){VMb`620glFo7pQAsi=+E@40+>J-KXxnQS*aM&v&+WM#g19{opIE7_283%CD3cCoybtoz{s zAo0S({&)!e{b6U^g)Tpw_+P>paHMtOv0-Axx!y+Z<{J$+3_IFqkP5;y3l(oynGMz7nX9A4pYVo z%gFwsRj)CnB5(5sVX7c6?B^1v8QRq{r^ob*iXJSO<9&3@f2QBqfqwH*3w>{zb4+eu zxzeVTqs;-^w_jaxT#A@ZKIY*(7vT;{?q`jA?J*x`EqbDu+u_ON3K!ZkUHnrg#O0G0 z4stPCdd7ub|5In@+A)g3QsjJ0$7XgvC4KfMQu+a)f1(%*@7Uu#fm3gUW{6C`|(6)?q^FV zLROVH2z0=4Mg!UO=o8(|`s_;YJJGpC3q?rQv|*#IwSZ)m{p{5pIL50p6TifWJWkw@ z#xeR+uA5lh^!B>#eMqS&W#^8}ahaXI=@D#WUSjIcqY&R?KQDD)Rly^|lMlVBS@I;1 zTux6v>4hkAPWI>tyaz5$`5_9E#%I=deHYYFAzM{S^k*a`y1qw}_U_JQcUxtz>l6d4 z%`=^(8%|n;?M^EydGs8E9rtmXbmF@-I@91MewRj0ESTa$%9F^j&875V!=#WiOF<9E zw=E{l8tX|BVCfHjdt{Uczu)XyZq@f6$|re9H7~EYDmcpY3tZ#p7wLGT+%E(vWyQhC zN-$uWRE)eA{kBjoz_P>eOC0)ZgO{WAn)ux0zIORT)huVa#%K=#ci-4s3QjSxJjR2c zzuYoUTIWQQCOddM#N-D8pvUx5Q;?t}0>b=FSN9TnzbVDm1woDS;EzeaNPARv;XO`M zOzaEq2UJE0Q2452|Wr6oy|GNd?KdE6Rh`h=z z>FvLpQ*=s!AEGax>MLmnifdXhf%Z8a3QvZg{`ATBrz6Y~fBYW-a`5`yl0^SI`l3@^ z>B2MdPVbOalwh>jhODO;BAo54!-n>$J>o1X=A?Hsl1AFF8LX&R7q}zvK z(sdYa!ksR2;^`Rr-@n8rl|~3Vb60%@PQ8`4*d}+Fv@%$!NKqe$ZAtsp8<&ZkQjQ6> zCFu7UPk(PCQmVc;NI8eiegu3y5EyW+i4_CsoU`2>4CDQMi?VkRf@uYvoihvfa?0r5 z&pL4^A;jbR7NWaQ8 zX{NwhZv`Ty`Zst34(en$6qy<0LD*7JS07&C(w^tS{)-i5XvKGSfEV$22Rt%-j8aZT zR6Z39;k5FZqfi1;IdV*ST6_A!ITz96G*zDw53jsKFZs9!%aLZE?}Q(q{m%DAC{xc* zfE&|!KXmi#d>md%cfT+Q9DT_JCBB#b=|ZQFTCV8;0(v;zL)!0;8#_Uo<3qnKRc72Q zRZ?zcO1+o%6=v7z>f>}(bNGuZ@6u`U#a^t_Khgs(1_)8&;i(cFrAhhSy;v@^{-QIt zv_F_9m;UjhHxB>r`9*grN;mJ25pI_nGyW=5(r+$KF^Yfa%F}Wlh@p6!6h;>XYV>wB4-x90tgSL0g@@!M5d_stS1M_2K| zP97;@Y7wSC0lfOGMCb=I%X zv&{DtjF0y}7msbXr?+1F95>Od>w)ZHqxp1?>pe8Nu<;xc5oi2vhUF}$i0z_}MLvD( z=J^nLinxjb7gygOT4QeKUeB_n1)*4$=n&@SE6<4GpABS9In;q>?1Q&axzo8F9GR-}K;tDN(P%MwNN!r6Lw`}@C@ z9PRntwQ5y+~&E8#WP{kvLw9gCLSb;n=Rf$+DQ{_JkL#^EEN+!a3J=%Gve z{!=$mvJk~PHpi%bd28xVse)CE;>=%EO@*Xc{^E)sz*~@h1I&MWMfxpxdD0hl3IKZ; zo-cTL<6WB6DF=x#`!}4uHeXx%tE^Io6~C5CtQ?e`Ou>MNq?s(Y#g*!61GaY7T<3ze$T ztnqfKpEc$gjmRnsayP$vEyARbr|mh0U}Z>3 zMk77(H($@uu+qQLO1Ddus);STmu0oBzYX*{;3piw?*sW+i|I=o4=N+2kjpU44_PNF z|DGCm$tS&VF6|BfLj^-S_p`!EZk3de*+ttk{VU^R5r}>uvgU>Si!#_0GwND>tfWrf z3G`5DcM9W{inP+=!fdYyf>l9K<5($Gg&25j{GkAWR? zZM}((x9Z;+ z6=)szG}M($n!`6H&#w~2O{}u98Avel!J!!zK^NT*^I#_LVXC!`lj+9$p0Fv*z3502 z4`e91dOrwq1BF#`;}v|&rbSmR4d03fq5s=rgKmD16v9Aw4uz#5{3oB1V7d_m`ikn6cd}NA#ew%8V>k~3vr;egxw@@<{$>CS`-U+QlYpXpy1%MFVM+P!rU$)KQ2k>4?SH8_*z@*Lhpal!xcC)6$iYI zd>#+2Hpb7ych%8vo&>Vbt|Do9gBu=8M>kATK8COiPrnPn3aMBz(vZT$<5ghR#z`euX59qIvOA8`2s!p&NwxToFtpJ~7+3}+|Ni=RdY z^hfN{Jvdja>c9!8QaG&4moYGqki0WD2d!JRateL= znM$Sq2eR7Y&EE+fVhg$u^Eava=+pu}`o@rehf%+{0#ylJLF16bDtmqg=?9;EpKCe^ zo2J};@LUd<;axg>#pSVz9y)rgS3lYgqbZ`W3F}8BAhLIR=f$uVyQcqdi|J z|ARBmei7)23~pVpe+y-*CsVZ3WiOOaYQKB2)Dcy%M~2=$jKBJAMfzos1aRwKcB6MS zdf9_-bnx=)jXmKUQ1~h+<__{Z*d2n+TN!eVe_Oc)D%8D@OHA_M6r>}!xWzSHoPyT> zoSye;aDM$U+)*>vak~ThraZ>6E6X6F5lPD?_c}J)o_jT zm_veTx49eR%&AcgWwI~$C9dIt3qnr( z{LjR`WhlmDOm0Z`oN@Hg>lrjvQ%i#nN}_8nj0aFXe8 z;?=Gk=vVc8kiWOFrUuSuJ9GQ5givfM*w3#F*6KNU1g{O#08px;lvA0fOr~$X@$2j# z#NH?N^A$|frB#$Hw~eD*hjaIj6)Kc)ZiK44+KngZPH%f^rlJ$0d;9yAi65Xs3Vo8C z50%55C&;OG&Q>+QeR1V5^K#<{RUcBv-K8K>qya4m;!>bLw!R$N$v}rQ@FVWlPB@nN9_<;-=7BQ*ktq67bC_AxWBz+pm;J9)ovub(pd)?$g)6Q9 z=qzZhHt78yT_oA)IF_3DwFr)>@{~pNkADxdMTz~eIjhh;{`SDf(S!dEMJLZKRZ3?r z2ZOV2ao5l^QiS77%J`o#>ikbsQZ?$~rOW||<3UHus~El3+)!|4*SkQPH%Q4TmBjJS zU;&N@hmzoCx@Zs$+ky1b5u=XHo-CX9NO6*VWsW}h&rbC-N z<;mgMistg!&*1GJo8WEuoJ-vP{o}1;fKrT;7cARBkZujl{5#={4BoK(L0 z?fB3M%*&MTZ6NCAG;+UIeD>=fPTBE^o6=DgS_k4iSVVHPN#8?QE?n*$FReWs;~{f6 z=+qYuS#zLQoZ^w6z`=W_e0$8;c)RR`hv?**Zy_LWABCffljpxZiob%k@(H)<;)n7z z9wO(Gv2d92TlrlN(Lc*?9|u*P7<#)LMt-^k=N@-Ilz-;oiIS7=xS#N0_+U84i2r}= zy?I=fRrfZ|zJbF*LC=vvCgCuOipnH{BL@&CR5WKYz!0%Kpr)pk%o65=T5OF>G&3uG z#AFbM07a#8*1$poht$#>a?Bxr*V^}CD(iWAzTfxr{{DFVd~o0AKIfkHUiaE-UF%wF z8+(y2{Vee;KWD@SNZIdjm;jwrvZvYva`H*W%;#^vZO`kCnJxQ*KQd+x4)QDbKA{04M>)uW4ZQRh+heZK9pfnqW-VjQGhu??teHyF z(J942f<@L8^M5H=s69+9SA_yEP=0i`$(A3PGVk{_(47_86^xsiFwah3xE%ki{>w$q zX{~qWry6Wbnmqo}zV(2YD$6~|GI>(I)_JwNcet4upJc*phQdqt8;}eH!ni;a{+ev8 zoTGjH$V}ZPq{|A%e=R1@2bj~+XrjCXEd}pHk(n8nIiUfq8OzH}*kE7bT{Q$R8@#T1 zIDppB02CS({zJa1-2c!!shW0XMRRzaDGM^)?xM-I4AuQ+&YfE^R~tYo*_!>jg~Pp% z(59PV)V<-}OMi93{KrD4z6bTZ)xH$!`LVgfz7PZRduJum?)Bm^Uam&twQPp`G=!gA zAv;)jGb9rcC&&P+#cT2aUChW(KAWox9yBQYEZLun8u0A^KBNuv;D^nayVpN?EdHG- z>(91x+g7Yg!-FjS|G|TJwPwy;1fGlW5iQ0?v>2ZP{rKQBRA>&y$Ar&o&4O74FKylQ z98ZTe4#;hJK%TV5fUKYasonXf0jZM*35H4VtZh5_;T zZwI7A7d4w#X*gQ*SL#nx~y74zb8ZCQtA*LbI`xW?ygnMYJQux7Ih z32z~)`|_F8U`f)1wT{am+uDHGl>gIf4}-W5;gf2yRVSV?nY^s~(_;b$IICB|IL7=VcXoACXY()HF}v1eo!z7%*fWz~ zY{$BFTR{$F4~tQNWxOXx8sNhlw_mF8N`s9@QF25apFC*5PXG({w_pMMTs~{nmckz| z8kH9?wI%aDvVt$OU~|0?_8MJ&;gmv0P0hd=%GS*P^vlf=8nUSbYB9FN+mg*^DTq$_ zsqqGjHZ|ceMK9_XCLFfwge#;^qANJN(G{RSjlzy>IZX!F>uLkIj;orvju)Mc76Y}W z2e^8ueM+tg3uxWsvB5z;?tMzrRZ7ne-ouYte&warnizyACZuvtYc@pi7V_J7K6s>^ z4QyLa@!&kmn!ViN6~haM7F2#?ihalo8&}1_#eAeKv*V? zv^(G^t@Y$HX3ByfRm?y$IYhDh2UYrhihB^S=&`C|S9`w1o;mrnAs$bv(@2-hnA~9c zo*Xl4pg)KZ?|>)mL7UOSKoH)`4qk36S@K)<%sP}z4a4G;cu*+JNH{toFLE@me(1wHH$5tH98Lc_oPAMLUFqOYM z$LbEO_uxUFo2L`E-2l$3i`|z1a;6FBIo^Dfb0deK^Gioki(IQ!6NbhQTVM2XwN240 z(~p!EnbhRJxOn!k?~4}IY<{W4!I8bi%mNa05g8KVO8n4oO_R7VHj}`mAi25?E;MQF1dOA#{jX5sU(9wTYMww)Tj z$bV=mV1ocS)duljrn~Jh8r<3FOoSW{Cn=xwhO)x)NIOq(q!#fwXXb9TX^UOqta-WR zn!&B(&ZOo`l8uk&ulz%2)+1cj_)`G^tc`*lQd6`BcFa;47_lv4X%R**6LOSC$k9QF z$4=mqDT&nzBVRSS?2-2P;^tg#>%v}E;jSrq?ELC_ZwqbD4bFUt3kyq0G%~6%NV?l; zQGUnO?lyq69GKQS(r^4=u;V5uK7v!3t~T69v+*OttnpJtpwJfL@j7sTWO!}2#$xWe zCx_UY&!TH^<%_u_vE=*J!gRVBk57C1+IyCJYb-AKm(K$Dbd@Q1q$?Z$H#b+Fc>n+I z%?0x5-IzQ7&W%~JKz_rGbxbLynGJMG(Sl9!+_sbc`=_q*_lX{I+pxdkxH30+KW0jC z9?0KwT7nJK!Ea1HYv}h6l4Y`fN+*LSF98tfZ>9xKl@F z)mG+ltXQPl9MU=BwH*G~8=kf!*L7q`O2Ei2-xsv2=O6g60W6Yt_GI>^FHKmGV65nK zCS1(9GSM#%y+@QPhMNCaBiy#JE}R=p|(}#iA)2VVXE|L?V#n2%zbaK={hUBJof#M z1_rAJXGE-fw5Y?T!BxCfC)R-_^Lk&_K|ONTP4A(%6g!M&0QfXHlm57e*rRQ-N-qj|10 z-r6nLI&R;VJLM0r{V?#2yndd)e{g@rtAS4rI(J)Nd?@3>wmDAQ>oYF$kS@$}^5UMJ zzdyP^ZIx)Qh5DqIZ(2}UW&X~(2kNKOvo)K4a>cHLxSFtSUiM5czpw7yQXklJYP^3!v_wfCM}zjz|uGLU>@`%PY#e!gd$nWh1WWVyO}EQowk`itv*0I#p#aP=sO=?YP1 z-v7UOukG1tp3wdOz0CjbW&VFJ^MCU)n=$Sd$ZS)Zx#QE~W_Efg0WgmvTj#CWKY3@F zXS;x@k{(l;ue1Q@_`dC@lXHWs_ATrUL|$S!>y1}xyUndESJ9V2qg-8K8eugO#OR3= z3fl0KA`$BV0x8EOMLZiy?F`)Hh~NU1!b}&bITHLLaL5YXNnRDmwBdh!N3&Yo5xg;@ zj6Aitqx6iXJ7Vs*BMl!B#H_sklUw-X9eDCRLCkaNX)*%~)+L;#K!w4Ekz@|C?C`A% z_eErOLrY9gja?C;Z9w6Q2yHW}kb~B5Q3N}zf*g0PH_KUJGuKW`_lh5aKGE0(XtGib zX0_Yj4n!yO5I(dQ8*Ad@3Y66FOTM`m8^o&k?OssN8zX{Mv5L~tP60XQ{(}Nk`-f-b zz_2({-rL2hprU}CH#YJfnxDgQ78mZ_8z%N(KBPB`N;#_t4>oP(b8er?=t&2JC~9}G znFc3kV!^2EpTI(%RQn|X@jn55pA-AlU++ ze;a_$*T!j$w0moJu?t@NyGNXu)ec`g9f>dQSW}2YcL9J*N=-ZtDiQ>hy34dX@fLPp zDTV>u6I_7(DOY;Ru*ho?q6K#+z9L>{MzZKOWMY_*iJc@KYk}R^^=F;>+3#)`aAKhD z(b`*5PcMRbGfZH`6s<|o<(0q;DnWoJWvM+j>%bT?d$u&Mn4CdJ(3++HDSNcF?Gi@P< zCHPChtfOX@2e7h?oA18Bj1L#E6-Gumi>!0g-Ev}=jaFuV(fK(4I2iU!7{3mb=tjjB5w{P~-ea92D%vJfR z5K=yguhOz1|G|C!uKfr1xj5v1|33XfS+7wdYyejZ?F6C!e~PkMR_N)gx;V<)&UbQ5 z6(}KT-(Pwm2ckKMM6)7W>*E0*zGvvDD)2&-Ca<4KRT@e8VXfT^hg{E2OXFps%*tJ8 zUa%0J32qUgOGQ(N3xu?dW3@Z9Y5s;YzboP=!k8cT3S+i1J)Q1@4-aGQt?07s`>QQ3 ztLATnF^AqO=;{k*hYyDPB4+`$X_##Olj}vc|C7iNwD$J19}sGdDM0q{pHsU|_O=}0g7Q9d)B+46!x zECO6o{`(+A-?iLvFtGbSfXY^U{9xv8DFEJu1dXmX?`KOAnx^I}1~Yq&NQXN!XEkjs#TS9w?A|vy4!+GdX7CXG2j1CwdqRq^ZTh)fNSHYNL*@}OW5n`v1Kdte%UxzX`!zp9(xorgN)-?!JxSp3Ly*clv!Wn+!&&P+Q z4r`X0a{Fynb{bc+fKCDz=d&Z&B-VzXj9`7+qycxxKi_ZS60@wB_g#61VJz0{z4tQ5 zTAb>jN{x7}lD{(ygLR32HjIU{clqsM3@90IGn~b-%lx(BY`#_en{aM_IdvI6ZV6@X zcs~i$z0cVQ=AE+6-f@M3OH9IQ`l*`Efo@7ty55*&*L=zoF@yt@@NTJR1_yVMc z3)Dn6Xm^-8G42CsqRg|scN(4d-r)E?njvd@ZC>ox9j>{a2<=M zd4RM4igCxBPz)raZLo)~0LfVz_JzhG9&=zB**kY2gv>`ySB=W@)9{=~HgcQ*zfu#< zkevzmhUf38~7a=&UrEQyddUT$Nj%B{MM+%k|!c;HCZsbeRr-MJ8otVdItg>pwiZ%RH;q_=wvv4{v_&)i&$dmrHT7n`ev7 zvz}G|@DTeMYZgKgk2e#?X z20wgrDBm`QO=PoptFg?5@>J#Yd22psEb{@&iHIe{alEyxn^mQVi@ha9dAxrSpmQ0F8Fwu9Y=D0yB zBDaUhWcczH*N$g?DVGqWis}DLreeF#&|A3vYlt(bCSD6wuoV^CzV>4N(}P!QBMrbE zTZ^80*ZR?FoXTI0o^JRe3htE}WeX0s8??j7VxhKO6;T?gz)_Yir_TxtRasbYF-*k( z9il8rHP&!miuDEoVk>1!ojQ_Dt%KW>RQCXGm5#_!bL8Ba13k!(dK-K9=9O@}2}~1l zSrM8VAbTDP^wHZ{pnxb7KuRm?{x({3^WlP;|Waz|KZPCUi|Wa0||~ ztue;=xG6}=({8uvF;v5Up2z~EthL-Fip?+~0Z3a{z}G}EACpjG8V6_b6H&~m_2tG< ztLBff18hF~7nxI-eIe5Z_d_bN5&Nx(s4tU*J5#b2n@jVEmh>BWr>EfcrcJ67p*5nv zKWLB73*_k11fKjN>o#f=Mx;Rm;OUgDwFir>cGnSX9wDcvcJF)kmf@EomzUa`G2aPr zyXy+cJ<`=)z-DO&N3&;J!B~}PZeW4%H2(XGEQ(L5XB|4pd8mHsZXR;P?T?@3{g7q8 zZW8MeP>R>b(B|=bamvjTq}a;xa{BCO-`;JFyUi@;^7xR{4nDz`L5kGeI1{Su{0a@7 zCt?IIAxiP?w`pUQ%WW(#@oq0Mn-nvO9T%*d`710aFwa)gi+Q}&x-R+G#!bl$whhn} z<{Kc7p%32Uz^*@h<^MIk$GI4BAs2@}z%t10F%W~{jbae;>RY?umacKvWZCC6tKD-De&cm7F_g~1Qy8RF|6~?# z`Y&9Sw~1yRY%K2)Eyj2Znznhn(_+Kg+&euNBLvzo&xmH7*%|(?Xx23XG0iahY|@bO438LedBm%ydzp9uEmy4oV%F@|}_ z@#sqyL;ra^`qG^t`h)&iJlaXV=4FeaGA;XEZWhZt1H)lj%>ngqe{^l5a&!Yx(q8<{I)Y?tw)e7>;zaxSYjn-Bsvu%I*#BQinXuEIFN! z;^cJ766E8{j277MX@cM_hy4TkH9HTc9!My1Zfy#zZZxvQ|Lr+kdBS97VcG0Nalwn^ z8{*3+Gb`J_y#rTXKN%KC0snn68)Z+XcF8arGU2=(B34fn=s?$SyWQiM6;FMcIVuj2 zCsEHgzRY}J_g25mx^+=BOq1ga2}+9vv0gALQKkZ6WNL*d72;9MULHK=q$i4~il`LQ@=`@&`6YMc;W=19^<_GG5) z8ivgyaG+CHH%BABReWO+#BRF+J&D&H*UwPTE)D_>$v^X+D>!&hc8!SQy{E7#cEVuj zYj3vP)s~)}qyxEAur!PLt|_dKpYW0Hel(;KReF?^V2@E~j}E^~jK8nbSu-@+nMr8o!-d zk}WsV`C$#*urN_ zWp1wVx|k;=%O7S7gn{zD8r?lTm;o!P`zF?&ADzlP^ywRN2B|86dA9bzLl#rN!Mmjt zQ9eF_Ikfm$P6F%UxRXGwRPx$HetQe=Z(}CE8OhuxLR6{}jDlafPkF$^H>hqs3EDZP zQjM&G zLIPEdVGL-ECL~MH^lOViTu&yWs~+Nt=Xo-aMCn^TZaNz<`jS3+aEZJ!gAFUl@;cuR zEv3BaTUcD;^B>!W@Abc*9<14@CQFsyn$CJTo~POTjqlfAv`@$E{{BZJ;GVU5>+AIy zl26XGHhhqdy~|GXb2?_HlZzZKp>@Mk_Xzf6~j&uvKO7CM~8;^(O^RD_SW) zKghCA@1qoR@ur|hT${)&)D*E;)9Ut$PYr&{m>|9K{zrUDA{#vV0wNXTjRO@~U5xhm z4_ue3nPv5G>u`xTvZjMON6hlKzjPgwZy-7(%( z@?l?CJv17cEDmeMr6lIvfsR8#5`2^ zvdY%-;pw5D>%Ux^!~*T;`2sv|P5WSS8oI(U%Q<01w5Z4M5x<$lx~lYv{G-+Ba|XRV ztxbRKHG}!4P|6>RI1?3kxLr9VfEyUB!ry)P?+wE@E@)G2 zu2O$rdcJ$?Al<#GtMuif4 z4f4IhF4cq!Gv+4E>zA>4PxlKcxwi?V$lJ-IW-=f3cK|w)qD?>%NOl4Ov1=(`JCk(_ z{9SP%`cyyNGis7`MJD^}>cW9|1n53885lag|F8Y4MPY~~sQ*w`OkX6vgUu_s+;A2P z3R5Ho69@*xyXLNLHx7O<7QgA6?2IeyIfpBj)m|i{HV98PDep$btp|?~FiJgTjhlRs zxYA^Q${lN-I*U1}_By(a2pe67Jdy+W!OeKSZ5G=gmpp@E+lcG)$*-~Qcr#bN2727j zyzOjeZ}@d9E$=!Tk**v*a5nsO6FzM=x-N%j&t?fJ9(c!hQwU=crHJ)dU``>8d-%MS z+^?bqt?~JxDHP5X^2rv|l3Bh7M6t4S6!j`fOr^)YjOQ#JQM;SnzLE?qr&1NPd<<02 zuqb!~b%n47Qx-&#$zJpeHrM9CkgwVGBR2Qid($?VSKuC(owGNpk}WD!_({>hL`=ye z9$HvjO@r;QkguD=mU)N@6k%UyiOK8P}LF}O(*`sT;^^XIzgQ< z=2kX~c3+c`Aa zU{7I#Rb?||VzhmoIsPrAB{N>vHz94dMTE4$e?h;%ZmubTSCg_diqh;#w_{VdGBuCo z4glXdg)&ncEvEh{V20KUTM>y(S6_$POtzpT=lDc9Q9C*sQ^VdByzF&0L?trLQWH>a z=5W~6^n^X!b{^{}-R{Uk=CRSLkz*ATJA9yW%1!T^W4=jyoo|}QdfARmRC&uYeK;oG z62QFBPORo#=d*}EUuV&LaKvsyDXBtRFXe;gvEllwMQU=T z;Q#(=Yu{j_HO-$2m239UG(k^CEpXdCT>U2G`xcK{z@{0(DdX$jWbFfPv-B$8`u858 zN{q?oRLx4WWJQ-B3fOu%61>Uy3%PpCKC>AE`tL7b=l6yiM7);CufNIqD2oNJ=TtTK zev7%kveaHxcH>kygnd_Z9>y(V1zaD9HqEs=$=uwl$3~Y=62+qS$zuteTJA~Abs}bW zHWx45Qv@|~oG@mO5N=M5Dwd0x^jlyC_R=O^_7yS2 z^xzV6M`i28G?RTRYs=CKu2zE!y!#h>W$UEh6#Guri3CHy>1XZ{oLx&m_JZ0A+JZBC zD+*5QgRtKs6hq~M3QiX%=Wn zn4PN~eE;L?Mxk_KdTYgpQ*1JWQ5BKg`5cq^odN2pGt&9U6xQCu1FxcN1EctwY(Ep_ zm7-z~$Ua;L-=b7c(=JR0skcmIFlp2V#`(_r3KcE8Fy=^hQD}9}grNz;J}o*x?CQiL z6-6CuG?Nz39d@DU(;Cm{&rkC18EhyLNZ!nV-~W_v$^cJu06(4qYjyyCDmR@o#iwy{ zlPNdb<>m*uX}wVVBv5Xq$jwS>p7OGV0Hg2nYt)?J?X%Df;GtRKyBYN9F8_d<6D3ty zY^Pxgg)tuLD57z(`VDV~xw`GxyyNkv_mg=^ADirtt*f4oy@~H(^Cl)`hq*~RP4>r~ zQoQLMQHZH?Wzw8k=_%*_w#rA29(Z+y9>CeSQnM`_--t>41O zqP6Fca6_iGb0+a9E^<@3O&XX6jwvlNfNrz)5-kSHQ;?|vq{(>IpvY z`O3+xe_gbx+UQ>5PbT}1)m5ix9E!emQXbO%VzO^V)Ng4su2(P6IP9g_cR}8l{M=&Z z=#rb_{p6|c5$uzTSAvbww#p#gIn4h7NomUcb$2{?hb7F<*&4=6kEC=H0`o$Q($=oS zb><{@g2KwhH}`e#@R>`%!C$1Tj6PM;$wiei>>`!N3P^$_lk^}Ln-6sF!>G9kXpjw$ zR;Z2UEodL6sxMvy`{$e!K0nlbYqEc2&DgiR9p)q+!De0co8Auh5@C3ad|(X;=$TY+ zvVZictOec?MY`kIyqNVCHWSOSc}K*1{CTIP?2^{GGlG_r?^4~E9Ht2{JdQx7n)dY> zjq0vxlqo|g9TXfD;b+h$Ze644RbQ-0%ZD#xPV#BuE{W4rI0hI-G@Pba+<$nQe=TDH zJ&=|}iQ8nQ5SHxo>c_{K#_bT$StFxhBUUBg;lqT{CX^m65U9_A&D?f58xcre`JChi z{>0MY0qPSGW$K{QFmn;n`-b2c(gqL7Jp(lBV_-3Za!9Os{&Lo}jhHe6o$V-+>Ts9W zE@xAaiG?n)h3y=b!$Ra=#JD#6;`5y6|3cGvjyG34{}+!n4d)oTviUE*S;@jFb5}4; zM4-j^Q-DR;BONI03`fgr6`O8+dAiCdoUdI4;3A} zx#F7FbM@B@cB}dyUvsE8&=wJ)D4&QH(IfF0k4s z!k-7%u7SBLqe3=cBDgviI%+Q={*&wp@h^r)fIuMGvceGBDlFXHL~A-imQq6@37A4< zK$!NW5E?8pzeNB>;7Q1q1tK^F%!e`(=tr=R3Zk*`1Pr$0PWx3x(#}P^ehs^4C4?HZ z7qs#-rY6rC$$x&Ixv>qrZ6337AZeP5sk12&4LDK?nb2qBOM>&5G5d>?O#DEcB;|vD za}r+g0h^K_5K7!gi?*N0p7T?$?@0Si=TCk-I4hys`^hV{8(Npz_yk58qjt{CxuLUe zOg@u3NRq134f0yCxs?WT5I3r=bN(hkQ%FoTlLl3~_nw@ykuO*a)~VYV09WB{`&f4J zml6ba=a31C;#bRT+&;zddB1U?BH|-8f^U`CT4&;HeB9CTh?iEBXfrTy#yE}@e(+_* zfuy>Ax=ZkBQNQl0;y_9bO7SYRv2}{CpA7{jb2r)^094JMY4$`#6Od_ay`sDR%cQ)L zv|pdWU+e$$R56rOv0gb*IhqH#xWawmHdOPl4_RL-wXbKnmPk=+XU9rEgwVd;`Vxm+T(nAJ{#WR4xs@4qdQcs7kAigy|}}<>l^Mc+vtD) z4!iPsLzo#4-oR{?4ZX=@H!zFV%}NIHlnur|+ZWA@rkMyAAI#DkJcF8(4%hu421$^4sRwshU*F7q?r+q{rnq@Ek;GUOxFF z=H2Eus!n3}Xe7Wx!j1DkVtob>{Lupv*+dw^+gpYLA%CbG2Ck&$S$Fl&+kjP5pOk@K z6io`_HxeLw?!1x3Xj;6PpNKb7h@;q#WIMioBkQ32qTTUV>eU$;{NP3?%Fp@l8<~yg zSlH;}``%ui{wgBs0h%po1}A6XU31uicdg)!OCycXc%}JFj;!bXK4vcCav?@V1fD0= zR3}D03Alk;zADRNZ1%W$YA(LKpLiWF2%;tgbYVOJqvRo*|T7fr6ST4ZQBUcL`y&uXOCvIX?-k4`?VxcWR zcIIZEFbnoCuK9#ns$>QPUHX_J)Y!{|hkXL%dK*uD?w1=sK^z&cFi2ih{BELL=+MBx z5I2I0{f=W@@wIKHJm3cH3WJH#E`P1^lwk#wt;(rkHhlJGrV6n}@9zBQT`EwjHZ&Xy z%{F~mUlbt?K7&H*I4c=v;vNwv6Cm&s2PDq7CO`EJO z=%<|3yUdzdcufyVg!()(^O~Qe*QczDbh|U}{~5C~LowsgB6aXI9_sj~%w0O)nQ!~_ zAAa-Pv&DSIv~5JP`YjYrC2MR4-}V`zWpVucXKb8vJchF|W1b4z%|M>HG&rQVsHq#5BSyK4%uH0Mf7&c@ag` z&|Os0l0W>Mb+r;km|`pXYUfFFIk`LaH1D;Ad9t_^0D+(Q3m zh$MR-Hz{-9@U2W^hT>N)-x!SY zwv5QA=WlF9#@kKIL70keQIovDjNBa&?C1y&M^`J)JU^3s(i=1fxu>WL)Y3?!>BAlg zpt6xhAvsb3&E^kdth8g>4Zn`ei@L8)P$v-Yp2_-L|m^ z7$t9RV?&fv7UqxHcgp5IKeCODN|~lVBdLQAnu-P!j5Nt!;DZ#kTQz{ z&3i;|i4rs?&x3}tq-a=<>AQ15fn2m5QZaI@F)!H8`m&e!jqPlr3B}%f=q~dSUoh(y zMS`eg1}fJf;5n1O^#z+R#IXY^Ra1CqeQUH-F5GMmB_34f7?t}UT*4i9FfGgAF*{g4 z_7PvVgAGfG7n91jkf2&Px!PfMqGrw&NJaypkx*`Z`Xs(&4Ol3_$#wFb2Jh>GV$!(x33d80)R(e?b*LKfs8EEt0gjBXv2 z)GZ4`Uf&m!Z;WZ=VJlu<$n4sBe$KWkcXST40+BTBb{GCrAq!y9TvNmxT#D%>0P%*x z7|p9FL8sNqvoe3Fh-hV(Z7f#A=jToN@nUg5E1?iOR!;ihh0r?&*^> z<ax0*g%yY@J~@{ZF4I8 z7wzN@JDG-vkNtL{&_3FzoiYLPO?>vy2fVD*QsBIdjUeayAKIC!N%x!?HWd7}?TQO( zgHxWD_@13?oQbd}uMXgLrGTB|c%M?{pj<(QchK#rJf@VnzbMzk)btn&KF;jQe6T{z zlG9I*N90|km=HM*2ou6dz>kt@u8^+!0b6y|80i3TWDr{kNTf)a&3PCMyUY0w}*Wn2tW;w zey8!#k>-?CcVBQOZ1&=Lcb=y>R5ZnzbRhO6-I1jp+0uJi&w&c@Lc`)p5%$&VBB*!8 z1LwS#Z1{G8Dmb)nH6EIb$%co%EgpJ4J@j$?Ll^U-dr^x=&AWZc1`frE3JkKhvd%_caNZERZthHCcmI*!ARQ|s?2e1Elo!;2(@9H zsBV0lY)Aq3BA;3z(v%ImQNN9 zCd~T%tT&n7KkR3{sQpqQIjs8f`!-xz3D+yKk{Jo|N{Jq>N8M7l7CQHy|YENgNAN0E>zok#y?N4fD2e!_iK z9$@WVx_i)ynB$6t^^r&7j`80QFn`U@Ft=5&@6uXQrKi96l{Gg@ zmCX3;gRC7O{kIRYaR^1%9mGU)RFPqc<$fZSZN80wMQU=0`O5esV%QK6R4w5H4`JpG z<%>)Gy-rckxGKP{xT9#)R)hzV!oZO6R7g$#*wNt z+3t}Cp~*+kKL|$pR26gX`q3n4_kCT5rE6EaD?zCuBT|eQqT5U29)gWP4LNv`ND*}Y zia9y$qeBiJi6G=6V}?c)#&4FcQxg3Z`-}|~^LRJ?0z^OCW`|=%gH}do!kRq~=?{JN z^GD~5KU^voLVtAbz}hL=)FbI~j63ohX4P3=_UN`MJ!_4)P5G(Fe30=NtQ<9)80{W> z`8O=Y6NX*S%?n}Hh6Ee9xuwC)66JpA#lI|9?Yb|TRkshf=c>ctLha<|4zvEW&YA<; z!xtXL@QYnB7=A2DrC@UfylTYjPJulbbA)wp5y~wUjBBEBr6(M3Uc^hoyv={@#@8L8 z1UEV9Xr5A=9+9y}sdUL)@lr3|{TTD-&yKK>P6{0)c7|U0%T6a~Q)Zd|WRzT+%ae{G z3Xbto0e$B?kFrh!n_u~C=AW-Db*I(Bwq8BFfe@!jMzj*u=w=yH*2=a(?91o8D%5R^C@bn8+@Mw|#vOJWpKzRQbAsIc@!2pP;@N~EAIUqO z5TNvs6Kr79k!w!;=SRMC5(P;buleoCe{`e^zj}(fEAcK87q5z2on~d8kc>eq>Zz<7 znwpk=+fhYj@F3yOAld85Y1W~&eK7;^tSEwVL*2fGQaj2gf6H8yc*-XnRk!$(Z-J>F z<-5LR-Q~>3>$cenUR=!*?e0%c^{zBBD>pg=TNuT;FoDV7N)Yc?1B@=G8pQyGkMf@$ z)1AN*94Zv~8Ro(_*8r_6;0J41h$$prUag6%&#+(uMr>!y5Kvc3@(n$VgEwkx$6)#rm*4apaQOT7O1Rd5I(?iLKJS^CSV*CJilA>YKh-%(> zJJMhxp9ciTRcD#=3*z#L1A2!v7B5$AEO@(vkEb~Cl6n8_iS3?uVuNftF)usItla+7 zTeRV-bIcC2WtVeoK-U2AVD^~z@LDC6zV;lmad_U1AYW2&(D{jT z%)+(#t+bp>8wG%y{JYO|#%RJke5;0s~!dyMPOaIJRQ4o+!2l8?OpJD|KI>S?fVlcD&)H5$% zoI&J${cZcEi(P?7t9PG#M!8mec|CKmt!fQs<=1Nm#X5|B@)^1ufNMKTWKnB*Wj)h$ z%GG%*55J7{6cB$v01cBH>;RiakDDHR6K(~jk@uqsg1Hwonc2JhK!_ zF*aDmN#|L&_V|^b8ux<5XTrp}Wm5icCaQ(b#va4!5db zT15EEKk!#BG8b!EmE84cP$lxBw|v7z)>A0z|2<8t*(}WY&&)M5jU+dK~;d(syGBa}%E45U;cMhyZS^!ws^9slh z%695;V<__(mqqpS^_KxEKle-dH04(R{xtG03&;N3U%K&}E6jAN&}y^BkSfVx@WAu) zMQP0oc};NwdJkLPm5_jDwPP*t3j>2#jl2eq1+Bj!&O5zPMde;)mTmty|Da^8RT$Z9 zO-F1U@Za1Cf9opi&|6&c^|=4x31;;8uTJ3g6D+4~eBw`t_+v!p{lxkz$SN_K%%gu| z?e+WI_`{!=C4Fe~Gtw8(qKtqeAOAD6w2;kcVQRvUNe}I@Du}22%sRmo(pwLF`_Igu z`S8m>GbcJ$B%wH5gF{fxdt76#=CB3>Pie!1(xkPWEcm=@xUB-d=^E>T^=^e%C?h;J zypFyq=jPX$*K@w=VuY2e3i#aXe?D;Abr$PDZdWr~qUC()^$VNOhD_&jBYiT&4!-Ia zHe7RAtiG#?(ff7K=`plI**LvLbegjptdI2{ekD)C*8GJV;MGja1^)!;smeEhGd zqkM^<{FQZ8-%t=!A4u851yr4A_W`cD!z@!2Ni!&cM+x@Yp_Iqj%kRQ}@d|tSj^ZGF zI4R~qexoC^6c0QIl8id9-3q&ENd$~MN5Guy#?8A~qqG8olio*udvt6)Nt zh{q7O87wb@*@}N)ESYu0`noX0u|k2XB6}Bs{%aF0D<+EfRKI{`-ZYT{0vfO(Lh1D3 z*X?rnm1_J6jnJ9ENoa;4b{ye`iqjl6AOfWM7Y&*vHn@inb9sX)AxwLQ&o!UsgSXt}+lXiT1 z8_A7KJ30(i96~9W$54V*%vGx3ZTdDIOR*axN6RaTFd|X|q zJ@1t7g2D$hG~sUPz+V+Kl*2H>broR1?IRrj~5kBA%y~X8On&c*6n~dZe@Y0u}=4bV7*gK4`6}5Z%7*q+qzj$?c?9 z<#EilkW3v%lH2>_$8H%&rZtiyG4i?)-h;3*6n|zX+45iu$yuzW;etDFT1&%RqLnTT zBYv!k#eNBt3;*oBe5r-h$B8OXz4K8?@}-%Zg0PmR`ci?<>_y>b@6aNHo~dlC$w2TWYstCE3`bwQu0rsC2VRAf$9gd z5G5*Wh)oei1>_$SgQB(p=cRg>`jJQC{K^sbg%z6LAmojnrE2szq{l3PsaHRc0y`$z zB4}H*0KPno#(iZJ(t8S~P62Uuf=FtJ!@{pyN*#a^~6vdagu>zY?)xLxfgC!nH0k_4}6MnRK z?PBc`52Nygbom*S^bBWems)1xv%LNUgY63c~OMxbM<&`W;|w#hG5!-`!f zSY9{+)F~?)Nfn+(xUP$Jx90aS;}RKzzbwsCAst-QE@)glqg0@^`t#ohKT>|n=Z{C5*x_go9F0|E zW#AflT}@^1qfdsj zB0k(+3YS*iU~hKJaxLClv3@v)V4I`Vx7GdWGf)Mjd)UkJ zENkW@+2Jkh=p+SM61*VJA&BmJ8J_JV`LqS7f;E62+htww$|hkcbdsE}M z_I)R5NMJ7PnjTa<6GYj!q(mY8|i#nSw#;gcg*1mRQ5*X`~6X&eCWUksISIMX(iogR`^^(S=bi(gfuFY;lq7 zQsQ+neOkLeJu(C}I>kh$)ew(pPKq^> zB=1s^q<)1iyw89$Ff17M{)xaZn#4MaR_N&2FzlZ|*(b7#Jls`^RLYBAzPpw8YY*w6 zzV_gI%%oNccbo!ulijKT;vsYjQwc#DdoA*XV{uQAm_KZ?!D&YtGm z+%OIRr5xQQPyWbFYHRfeAA^?vL9__p_x#6S2~#`g6-mKQx=SuC5wZ5IsIrO$RtQDu zIY$r4Uez#T6^am5jWr+aA^HD#RcgM>L+S=S0|pDMk4Uns1@8_rYP;ym|pp0RWu4L9o~^=T_^M+K526-`8hc3dZ^ ziyQ%IKPjT)hFfCb5m5aZpdt1aQ(yGTR2Arg$-Sm5mCU6nDF^~bGH z9VBnax^yfWBAJ^=WO7;4vl19oE0*H2;(NNlRuCa%Ve?+-BDouWJtUa7@{%SZ8}*Ol zM7ACl%rSaz7*F+*7JzpDyO)#*NK@BU^0R!-xbEPEU8R1`##m0pX7ifO6h|?Zk`U*m zyCJRB5VOI;U{>6-n*5tf#PRr8o`QXhHT^1DfcOfC?N)c-iY*-Z-S z6@WK+4st1)I&LO)96&md%oDvMl1WFO4#x!_TCd?=`Foz zD+mNr0b^P>6wXov;Aue=5 z2*d*Zp^xOw#`8)asjuqb=RmKFL_#Ay0qO?$N{(VMeSM{Ft~8jGb6rO2{S2h2LUhSM zN^Utt{kAZcXZT9t@#1E&;!d-6ev8%XwB%Vq0 zm1(EkP9ON?MThj#1Ya=xLgflW-TkEZK!Aq?h{P5O{KY4FtK>CGql#oIA8Cmh;Ee}A z1byk2pEOv$yYu?wG`aoL-ECZ6`&-~YxI2HUf7J5s*7^U_yNl@|4NwaN5exAu^o&vv zIeJJQLQT~5kfwAXoki&T^9JEG9~KDoVqSn0q(9Ga{dv&xeF2iUEQj|4q*po>(~0KT zo4p5vOV0gh%vBN`?t084;6I!x;fs1o!R>@>fa!YhbD8ma@N-_%sh=9kBB+Hp@C|{|rf&4^(+y>gs4b!4`U^=D=}!wM@VP-!Z>+BSeIF@=-wl$y zI}{7+(H=!*zz(QU7@j|s3tcE%u}JOhCHcc7o7+oz9nFni(m45GQ0jV1-T(c;uKZzd z$qI+I=_9>{CcRI?8D{?a+QCqB3GX zqBA3TgjNc~^srDXO-1vIR+^8p2vb9(i78`2X%3_c1Iw?>#pcdLiq_n$h7lH+LMaN5 z5m1S&L3vH>R;tM}2i)c?e|BQDT$a-rRSt$zA)cC2(8p5}MZWIt_4ZU5tiIybl~Pkt z27xwr+hX%*6sYD`^b5bMu_NWBbud0e`7U}ibc9)(9&54n8w!`8zQ0x-xe!nfHPP$f zs6VCIf;{#om_G_A5xBNwkv$5$QX#V1(ll&tr4m53dr+PXg(Hi#$XSocD~4}xfr`%i zL;UaK(RwCg>AjR|#X41c4eBZ&jC2>DAKXVTmkI*+IbIzq`I!jD_ST!hpT(;LF0KSaz7-3X|Ns+yK|})~gF<9g$%d;%kwzmHlk3@e3dU&*y&H zyS`Yf&Jg_1qf7sa|4D0iTJidD$k8 zr1n^xY||iV1_%@F2TQRj;V8c_uUU!}CBf+IFIU{U_)rV^(I>u~6^SoY^lA4LN3;Gv z)G-KD5{hapuj>f`J3?gqImr|w-1RX;Xqd=UDyBqmEMJj!LRA@TR*carO2lYI-y~mR zP9g~Y(GP4ciOQmbH-F90-(Dn)ww>A|Co6 z89zNlLg`hm9x4UEB^xwU3XYfyh9ZXAIuSJpAZv4J*~g?)^s*IG?T_f29@y-WL{8Cz z7HA0knv2y90)h^>byLAl4+WTQs$}L42&>@+#8NkZYD)qlq);h^3TFi9mZ3gI4GqwJ zT`o2+Zo+19;yP^J9E)z7n?ehX6b9K_o-~Tcq?$vM?9p8{#mJ991u2x|lHcvU^y=0; zX+T?rRj23dETWl|=t0$qB5@zZD5;DTe>hyi8k4x$l)t;#zj}!Oz5Q!S4vdg?C{iw? zZc3o;B;>7jE{dc))SbiTmHXJ-nRpSKcd}3~WnR(^)MlwsplnI0?k-i9qY5VT6Q5!8 zW_UI>ld_cix1HLA&0V_X*sL472t`;D-^b?7gV^kql&{=hc53W9D88cm9Gi93*zBF? zwjJBo;um{Ad7QWhn-8+kT_vAF^+W0I+g7^=Bb>|a$4P;HdEWbO-6`(iYSup`uRAsi zdth^29t}njRn6Dg(_rj$$L3n9@>a8Z0M8mHO^uBD5t3dw4FWyM{wg+0Q2nHAY2HuR z+_e>(d#S`-?bG=x?Tk};9TboHG_UJW&nBhzAU1m@R$%kWT=dn0M0iQ#CC@&v#(^;s zbx4_N+3E{d#lYQ!51xKv!=m(9GAXqH7!Nx~kT)qRlA;VNn|zdlL4h)`odfRf`SFsy zVz8#VvWnKc_ngvypO1MvzIuYx1I+NFsFO&pd9R6*Lo0iDx05in>>9>nCQ4dz z)cn*9=aLs(dEU8vQEyDK7xlg-Ad>Odr_70xv`Be8iDtx!ZUEQ3zU{wEhDftSZ`I}n zF7T1#*9HXh!oeWDa1c+7O0clFt~G&$uDKkbJ$l24sJ}jDB)OfEEb9P$eZ-W z>PMM*?&bQ$<=9F>#zuICpfNxp%9x=@y|pOCi|O-3kmed9%CbVEk+ z!g<6?0C%GJjF({JRPs+>lDfFzT!UJ>s04F2g#=R1+--*29ODmPl45`}>Jy9-qowwy z6_l;Jt1zS|UluJTx_XGQAuP4o*x=bK4I+@0bkZmcsF72Q)S)e2r6 zVkF--G*uTj(OAETK@ghu39})ukxVScx=72VSgG?LU>+V3i=adSe< zfl6)~KE=WGFW`<-q;PdW<4FKDI@`t`<8!89+R=xHk57^OTSWZY#!GWd6zI_s)IEL{ zFZJbB@sfA*J-X%}`tpLQEx+!-9e!X+3+;M}3us<CmiDuuSi~!oE^=9`f0#VQ$bUxj7VZi2JJ$0IQg)Y;l>ge zkxUw>nt%AJ)cwD`Ui<0))%B22Fc zn)dqg12ktqMnRs!sSv0r<2mt?Wl7gr(jdbWaZZR)v$k;r*2mlKj2rwAYe*=w%#|+S ztY=7woCKHc8o#4)Gt$q6DD6tu#;^PD9@Ox4|J}iUzJl@Y=9xM{(u%}G%FPJJy-?zs ziA;?f!ynI)MgbfcK35Wi(&=;2UwWldFc)0!J^ZV=K23b-d zLmLqWGSmTF08t0rM$=MMBv;(W^<$PrW=d$zxs!mA8JRk0YGaEZ#8Na&GKI_dH+k^FI4>?`&6Rvo03-jU%5wu6#|c_Ca*K zWZ~&Khu!IV6Wpx6&*EWP zF`tEpVj3lj^Naef+ryq4^O>zRo;u^rmMu+qqBDO^B4+ld4PO(VPEpA0o`)J+@bxbT zJWse-OtU;O$IkZ~XY1F1;P-J_1mb<7PW(jc01tPu*p?^pg*juyeJwWB2alzFCF?A< z+8;cJT`ZIBJK(W#78`_5F21aO%4+;REFxK)1>^AG;^H-VPYGw%$CXSEWQ+6M|Mnd{ zJtWq)^+tR_zHGend&~dp3w>amNT2k)D6vOE#0W5a*-uMPnZz1)lMk+Cql?7r|Nr}u z^TDA?tcBulZ8RaxJk-sct{nCkk4yCn?j1F2Sc3rfauY{ zpvz&7(3WIDj{7g3mg;9FJlf-3$|>R1gT2cMBfNZl5ebxCI8(eU)ywD>tD z#?}MgNO2EQ2D>L}0gHOLytQo)i57GZaZ(b^J%bjoHm>5}rGRbOKybo_YffQx? zmN1*KgM_1KwnN0p8t{z1 zj@s6qM{?O%SC0Ev9@mH@5WAQx^I)>ANY_26w_{M8klSf4-D!^E}`oNnBqFh z-qSh~lq%F_T4b8uk(5CyG!=9tMPQkxhl`)MyAhd* zURj*uo=m4on?8#F*j3Pov>=34@gdjp#W?hgzPEI}#@agn@9Y_hxDeI04=@|bu2gEXOSY}KS3LoNdy`A=f!$X@AHcduZQj@DX~scB3@LMA{!@yNSUh4!@vPF8w6sNYj;w%OzDwbETQVq8Ap( zl5#1yJD4Q<5)=fB_uiN<^3o;2#Ex?1<+v~MbJEISG61oKIqV`iCzZY*jKN6QMP4Fb zz+{U?c4%Zzu;^FwaOte%s!*;6(DTyKU=oU?xA_VAVnH?UE1e4__~4AW9A&K0E_0;o za#KO$&3} zcX@AmlJ}JU;=)Kc8Z9YIo-U_IZz(m5;PkdYRHv6LqQ+@qVqCLwmozv` zZsbw2J)fw=riYOo=+DJD?2Y^M4o`DGLkGHNhKW_s{G`-Z$_XP$rqH&eILG}jd4^6$ zZ}epMP}BSTS?Mn6g{+>CPSD=c40?vll#1P9|jxaIp8$2o1@;~^VFmeO$OmwkfQbiaEP9P4_Cy?MP4`LrrE|DMkrw2zgHny}`jB+pcU>Xf)~?+LCDue+p`NDSNkLkSJxvcwjhhfB z25CVKJ57g3t{>>S@CQU1Opi(HS~MX!SiBFD?+9|Imv~$gVnuI#CnYHtho#geB(3-aVZ)<&}dX@J%KVl}N=PQm^z0dpMB)}cZy;-<$ z;q;<>0RhY z!iNfbGS-_(GQ9}O;Qo)aM84oFo015O z?)RID7Um^Nutf=WD8Zhl@@(%bRVWuvNk^NC<$<4YH5J<>Ki3qeg8)K58sXicbm2~P z0Qzp8cdmDrpE$-uC$zL>QBH8~$&!X(uLu|%m^P+53@bDn<_>>UK3?$A-u-?Y$Xg-W zoOll@!C@t+RDz>QbIkT0^K+3fxgQ*JqO-lnG4kYYtDfV`t}dzaBaLN|%qh?Ip3q{> zIgV`aDJ|xmL$bZ6{Zu#6bG+H!YCl4e^*JRtuLKwTIBxd5mz1DJ8K77ETpZQ+UR9#C zN^o5Xusn#deA7>SmU!*Uj`7|)h1^y=-c^EoN|Wp|X>+StQHbSiW5Q5}btjV;r#PzU#k{ zhB$EI9qPX|u;9h&FtJnoC_U$%9$^>vG|qRu5&r4B8F7}iDr{BVs`y)J2)2lT2>+m& z)nQ`of8JdXVRyln(3#O4yfOai6EM2UTNSk`YqhXd@d4^3B)T}lRv|7(afRIXwu4Gc z32cXy*dZDX6We#xfuL9kY=@QDVHypHFO}hNR~b>PTk(I+1TxQ`>PR zeq1g`R;2AGDtgL=??Mrwtx67xmB5B?9-+k1H?ru_V)-)K`>5>%wgwVi7Fm2knt6*`*G76HE1TM_#V0W{7zxvJ1$tHcFRVc9^uF#sm#Wl*cxD3h>aD~CLXQ{UkcQaN{sE``(_Y05oP#WE`shEB z(>*FmEM?^Et7MC}%3s_oIkKY`wkf_T`X84?Ep7iuL!6j;*Zp~54bq~53+_^<+l`cB zYn$&qhslI7657;uOBw<>;IRMn`6Qs{QW{+oIB{HUV8MJ+2@khj{&oH(^9j5KSWFf3 zMaPD=FpcuBd2kuzQkv8ydM5OW|Lnjt7paB!%D{@i6M-lErn^WPy3$sIcvWB}SbZ|@!{cBv+VOX3vi$OPH{|yo$T2~3eW8@}pAqVbTQe2EUdhnze z@$<(#HHM@k=oKUGXLwqSaO%Fp2gisLCVN>LrI<}roJ@}q+YX-@BPzgiYV?YCsdrhm$2r=Y8OWPpQ(0E- zTIL-Um_7m7+eWyDlwq?cHOu7A+v69sT#Sp*^1wZQam$IN=Td^fv&(N<;9kEpU3@y? z)0fLnKlb>I3oKYJ7J`5i{w2!ArN9apgFGKtvz&NwyIymbhoO_$3+~ib$O`@MEkt?@=ekzKlbI9CuBBB% zE87(LG8C7^%B4-vsWOcgbgEnIXQ73GH~cDAkPL|=%-kCo9M~qXQ{bY&nicXg<_!#5 zSsjKQo)@&T`(aXhKMYJq??-31Dt^X2q+Ha0O<)0R(D1wjHW;tokI^A0kGECvvu=6v zmIMa9E4yLOx+_GfVYC&FP}WPWs+tzhkj+Q|jF8^_A9oEri3dPC1JflmT=5HTM-;)4{B}CMH_hc2By0n^N0STd&olA6+jQeI%JhzWb@o{t?hmyr$hKrRpI0%w>Wi? zpw;sD;%SgY9>+vM%+5MI|0{l3HVHTuSO6pR`GPBWmM|TLqUxvM$3(nUZ7#K`Zd2E$ zwoUOIR^5>>M`l!LOItRp#${a_OUvSH#!>yO*0xuaizda&g)_>QBNOgvyn+pHo*I%6 zFf=-7LCGOg8`fkY^R~W8-f{T7A3d$a^V$m5IqE{-$EGH3_Ln1fEstAM-aX?nTSDm2 zfS@+!CV4F370=Hr@J8lYp8G5C?uq`Mjw@L&SNSrGuot5VIe{fADLAyn0>`FIi}}sm zUVmoVC$Gru{l&=4t?%VN`RSThi@F4{qo7&%%fwA{7&bNx;(b*v&*?-_KvIi z@k;Kv6XWV!eQxDCH;=chyOTTd>UjI|`?-^IotfK$@}_?7%pTq_Z`xUB(d>}C>D~!t z+rsmn+cBYPcx2x5wG-;L+48d1O|(4PCU551iS|eBd9zkc%AC_BZ}v}3%l>F` z(YFKha&Av9yErm$-li#4|BTL?e|AdUh-rD8E}v?#IG@eKuh+Y#+ARq)@)pqd{*!6R zn46bJkN+pzQae9yAzd@A$if%p70~O`$}9;h^A^$SXR0jG#d(YA+Ua$cjDvZF^qc1_ z%__gkTSBitXKxl=mA8~GnUUG7_DtS#`o{Cw&AeChifG{rMa`Ud^H$OmFO)SS_w!a! zo>kQ>^r8GU^k9~&u9-79-%F(zE#c+O^53WbebF9X*gXG3`pb)%;nDW|b#(hn+2M|^ z`NgzoR#AA?!2A+=XI5Ew;pqI2Y3<8Z;g0F~8)?Ptx^R-6UrN82V`*OaM*bFhDcjyW zVRimidh?ac=HB)B+vtXz?B=B#^2_KqIYrI+#{3<0(cCgu^V%KxJL!*etD0vW%HKt= z&Z}!4`g49c-Tta2qVjb99{Rz2dj$VCe=qe&G&3ThxrOh;O*PGqD70DletN`Biz0Xz z3$LJS7tpeZ!b}T4M6c)4s)*X@7Jiss$)j}FVHh9X|^@`^Je@K z{pMX-WG$^~#%t)wHPlsRO}N{PU!fbkw8|P99L}#&&sth%&58`?wbX+jwTLRUhx6<7 z-4CcesysEE-=H@>pqWvj{loc9>i#dyjv}kWc^&;@JuQl=T_4VG(~1qWEGpqdIKN9T zZlqOFmDj@gJ^IcjS{IdZC!BNk!zTPl1i2s1U2e9xl-h01hnn*R>|!a+w3UZ9=Xvb# zW}0owur}ul8Q(&SY&@5k@nDMJru#)kgfoG)kZ?xNYTwf{EfMeMb5TI7n&8XLh^vTNVa zve>L?5quTfvyWEAI$wz3Ygoy*v@W*#)d=ooOZHPsoOe+Kf1kMzP+V_TH5k^k^Csb(6hHK4YcxOY;QHqY@5)?%8#>i)ik?p zbcmH#G51+o)HWg9%1^MpXK7j6(nu>m#cI#esm7iv=)#qqkTW4Dsl9#SDl5OiZeOOE?Mq!H zR(_L}*U;?tj*V7c$8OcoqW0BgR(_j(@H;JQpY?^6-(}Um)2j9vUs?G*CS9R*?JM_N zIXA7iLM`@$3M+S;@YP9nd%__rUtp@fLNo1^N31;0wDJ#{Z4W(VX4h3(Wv{$q<%>-huhKd@xozczrtR0LB_-ouD_>&z^BT3MWIPnb zmzws~(#(|7Mp1mZ=~^w#PH|YGc#&zvpR_2YIy{Q6G?o2H%TgQ>QGAuD@=scoQXUz_ z*O)H+N$XNdqoTOiRCpa<2$>NV#ossWxK8b?oo1$b+eh(rroz8ycB(Tq ziWi%{{EHT)I=V&i64RN#Xj!VadldiJbmuQxmCE}@@r|a{H)vgIVgD#zYWm>@wREXW zkK$WQ`F~S;7sse5zSXqrZ<^V~J2r}MGhO|gW_KYoqIj8UUmY##;#?fXcbL}Pa?!Fb zl{=#NPE+L_TGgd?R}|l6T5^}xbqTGB;^n4N&MaMdLmS^?I>nj2t0Tn5_nH<;EVFBQ zGaKJ$`dnh!U27w3e81^ei4}Ftin8$vljLS)T}y2?e#rE$n^ko!jkEE?rX6lp*R`~Z zjaQm>E?|~!8R<3`KWh4G0kd}t&9w1jrj@xYvs=O_8$WK^kjt{WC5*Q5D$^Iatf*W0 z7#lxf`Zbr8b&H;61#<+Vn>rtLs*pW8>APYx&I5z1C&p=S<5NGJAJt zfsLOxEq|S5cF$UA;}=Y2ue0p#g{y4*k_ii%tEhYBdK<4XZ7pDB-77z_@hhgA1+1!j zZJCW-P)lsAm!_e|#tSzQmOC6>Fmx$tdf z>6;K9%iZQ}Z!>$}!iZSDzO0iTb&up7n@6#vAVvMV`6!sxq2D1^ecTfmM<~iU(W3PYUjoBrDm+V znf=P&jOEMCWh+>=tDpD1SYBk_y^^?d(C;PnI+A6GM2w@u2{|NX|-o!`G@AMYglHQ^HwZhXFlR(*=e=GalF{P zVJ$04E49Y)67#*atSqhC7RNs}-~E79rICSge51?!?mAYNR=6>amzo!BV3z)+JL32j z^FJGyy??@?IKI_f_c6=tUtJZ)x0yfugk|?HJQ>H!%(p*bMg95ZIKIRD*+y2@Kl(}> z-)TO(kyZ6CzZ%DPnHO$ib^Xh4#qo0U`c2F-pz>}U-(y~0%IpK255@Dn=HsO-bAZbk z63_RUmv3g-1FD%JS#9I_Ve=nbSlxiy zuJOFmeDzai8R+d1&ySiHZDsa>2?OH!G4t)MEOTJSn0S8NT)mBD53GJZo>!UgZDU0P zOS9wo3A1NAD;t*M)3v-AbC zrVxt8g89HsmYweSE}ma9|F)AAr8|$r^BVK|FIic7<*9gn#eC*V zR+S!oDV|?7dv>w9^uj;ld9C@{E@l~&Q5Vmzn^%6t?1O4ux8wN@^WLv;_$K6yplz-> zpFRC!WYop-Cjb69&@boIoO_R+x)pY7Jeh*~{WBqWk;}BS_8x3;gF!BB#``c3;+~w~ z#zowL$$uhT3y)bnlsJAKShfpCh?^AoVUkdweXx8_qqx**jSln>7@e5rp{`4s~X+p5^N!kw?)evs#}|H55? zDz7xi->CeUfs@a0Q-^GWaZ~fUmVGjqM}j+-Wg8)H0mtADb+JzVFZfEtw}7wE@t)fW z`55v3xM$p;<9~o(MEoZB1&yPPj+Nn=FnZz?p6{3t%58`2t3D^>VT#5+gB!?Dop5;v zdIs@pLFgHc!x8iJEJkB@`H~RPhduD+Kizftyg_I$Rl9B4f1eZvWGp1 zko!Hen~;gXlODzwW@<809|WI*_+IeII-alxo)Nb-R&;HgE%&@Fa=Q;X9`fIi#URxR zALrREEw`O&vh{{!H^9X#s0R0qYB*@`*(}^m{6@h8@JK2}=WZ2v zC&Y8XJL>pR@NS6j0Pm{fA)bdfpe=gtQ{1#}s#HQNU5=+G*;*RO0Xcqj0$!Sy}W>Y!qWyYYJCZlve2PvGty z$aW-~)VzKh9RwHid?mPVo+IC&LrV5l;QDdb-6IKi9I}|;1MqB1Kf%8P7o)ofTr|Db zv;TsNM)?+8w4uiPc+LuUv%ga+(>+qjRg*V>i_*;m*O#tFwJ$Z;M|pZ~gu7vfv2Y?; zGb=U|U2a}*(RP!-^=)??d^C6w_$ZxyqGzpeH~EOtb1_lMGNhGmC%Bj#bHT+hmpN*G z3tTLY+rfP!0lb%oZi2hqN@e`?j3%UyF4;lwc*OI-<1~)0xCx$)cqzDOb1j?Ro(aO; zobQz$YX4aMjxPZhm7D-B29j3lGvIE-mw`(fN9iVbcEg=($x$L6v6ClTD5cSo?E-%S z{6%mvYcx)OP~3kCt{*5J!RN#70{E+%J+k=}908g1c>NLbD>%}-$Px(pg|q1~%y=Z& z3;wL;2o-XJiy_uNrvB{S4BifWEO=X;{TXm%K=4vTJ^zh=RQOJryB@S}A62+&NRSOK zS|GY*{dHppxL6k^fcyFt1trIo!MhGz3>U5Cx`T^h^DB54jk}N_2ZAW6wN?F+egZCP zmI3ao8QStBxR~3og8SA#@JD`9cBrl3HZ242t|~ue;8Va|qHoNt>-Wtv2r1wlz(q!K z4PbZ}T#VFb!DDs24qVh|DR`=mcc@av)?sil(ltNh!FwQnt2O$+yG~dGL5zjYD1M@j zSAus&d>VKsjicrKe^&S!1MjZ#V|tDXybLa8Y7k1_SN7vlj-0z7OavGVVS<(c5=5WC zOS_1F3jU0a7l2PeJOa%zS;wz|cSM|ni=m*^IOe3%ge z(PcaiT%3AH9_dRpNt41B1{j~n1qxVw@ zF1joO+}CBvnExHmD8kly0=7tS;lP4bM_+@V!25#_1y9ozv_-YD9;^ZHqvO+5{;Pp+ z1n-Ufi46lyEVWvVuL}Y3XAQj5S!Gad1Q+XtW<0@_)c&q>}>EkUS}Wio5J%AeBN(pf6+u2Ac&G_HQtQ` zg2!Pp>v@9<%1Ze>xLBGs`;OqEfUCeAIzAixNyJZq3xAsZPViocKjy-6rmxvO2*Pk8 zxIW`2E-H6S>%cQ~j+TNCNBk!EFdeS}pM`jTESoRs__#}i3_*Ms_+W%Ctwft42*;uJ z`o~jxSsCTy!TaeP^#>n;crmyrfad3Ya8ZGK;Q9(&RC%wIdfY|Y)F>I`LC|L~8(gep zN5DlBY8iZ~@+R16^xXWrVn5oz`-6*>aV@y;r}=pYd>GaratXpvop1?)Xo;>^&IakY z{R$z^BmM^X3>{ww-XHNg@H8F&6I`V4g~cOX#~ptt1t|o7Qp|s?MEMZJv^Wky3=WM~ zfQy=1uo~$HQRr30@mTPII{R_pqHjyUpVskG)&7po-X*5rJqXXiuy1!|-f9_7zoyjS zQ}A@1qtC%-AWnNI=`{ORwaWT116;I-#%F?yf|r5o$Hewpw7(GU8icz@AjX2jq4b^R zsL!7YUufWq!P~>W61*Kk&HhX9=MldLE()yi`0F^3BK~Yom$L6`!eR(7K==-GQY6&) zzbfy7e$n&i{!*szdT@u%{u6M~m6yTspU+RN%Htu*+=U!O7j(FxB$%NIDxa+DP-U0DD;7K~} zcU$3YF;ey14lbtMc<>CJ{p%{aT0<#DQ1aQVe4JAzYw|`gmegY@EPEpbqVrR{-J^I0v8L=N$>$W`-lEj zrfX|Ju>@-w4+R&S-U|cJ{tlh63UEkERz|jcg z4RAE7&(AJ!F>8*2E3?C;Out6=mHFEOw1+OiKyXo`3E-%l&(R8S;pk&<#gXFY5_mW8 z+kjnl_ALpO(|1B5Q829~vRtab4Z;`TBI62hea8NHXVOUUCaA6$-I^mOxEORZ!1XP$ z8C;B!F98SZ?9EK!t`MZs3nL)7VK@O?(k1vAd@kbWz;kqbD4ss2AU+08#F&u_lz@c> z{B^{af-lrK276OHwMIZ9P%6x-2j~AZRT!iQzM9Pk7a6+2U(q?LQ~4bOpNV%?iGt6< z6yZAizf^vs9(Td80VQ)p0<0dhbqRh~d5wWj^r!NTiW94j=xePDyeeO9;HSaG(t85j zxAdZg9t)tP9r7m;Sf1MI91VgX7NUOOP8}}=pNIH*aM2Z7Q@07E^7;{j0ijFd18;};kKp}=Czy3+dbgQ`G2}9jCvr*yP^lY6*9;JZ>h`pOYm64H-L+RX;WZ<8Ii-Nujt}p1%Dla$i`zrsD2i}itn>lc_Qd|ZBtE`WwK0=8H@xX~heE87EzX$Ju_5 zXX^7eRNlkD52$>ef%`XC{C{rXeZc37{r@I}S5ZTG5Fz8Q6@k1oy*}?5p`2K1!Nn}m z?3b#%*R%EcMR4>ASqhHs_t_7Or1F@%1wKy9f6dXy5QO6q&()uP_rS5ikz#P{m_GXv zRw|$U#GNJ1lRo~D$_Ea|Gm6T`?28aO=^SN)cR@Vz`TDn7pMnd!5#YZ0 z4L_GvzR19%qLn>mH+YK9|449`n2)z1h>YZxzp%vmCU#P#EeWCJE27XrME(7;} zO!4!ffwxupffvyJEwzkMgCVML)sWy7l|PbIzd-M)+-~6CfVYO+`5O#_d4oXYop zpMvAy>#JF|${XNdr{{;jV_`QE+@`btTjegvAXsCl+$HP5V{{3g02dCv0~bxJHR-b| zzhU6-fTN70`AfRPC%V|&Qn^ui13W{2{vW0aCl$e$!8(=4&#HfC^N-5s8hGDUN(KiF ze1*!JmDqiX6M0If=>irp=FSOrzbWl zPt!Z#F!NRHQ^AoxX+NjFa7j%t$-pCHm0K+jxLxOHxXOv&eeln&?|-k#yMT-J z$5*0T5Kv(90)+ND9vesHM=NWV9Qqugpyna7yJLn9NiHOJgyCuAIYo$Ptw_s1s6xHgW#idybN5# zTh3J;M#+O0ej2xRDSbH~!U$c0>1~xY|3~mljiaf)2G2#j?L2$}N8@nRx1Dm!wi(>1 zA0X)a%$%a|LHYH$1l|Mo2f@3mj)b3ba0lXn z7>PpH#tKPQ&i{SEMT=;>TPn`~q6P~fICR2%BoOhv21mQVv%pQSE05_lNA0>Oe5Qe~ zQTbT|5ALeiXW-Mc@`|K6ny(6971ZZfRo?E6`g~kB#nEa5KMejg3fgcHA$t&N{@?Dd z@WUE+K@m+iw1*-TzF9xPqYi}+URQSyi-_20kvXm5oNFz~+MVkw>nF4D<0#>$ujj(~gu?%PuUO2B)G<>?dzF$S~* zS0IR$D-x5wkH*nLNqv+-G!a}sh+Y7n1iLlh6E%Bea1?wp;$jgIy5_&rlT==?CV@{C z^IsN_!Djy>rbM+@bEXCPh#K1jzaz(qwbu0Z>D z(gc*04p90ya%KHK?hY=-#7J=cm{i(9R`R|J0=Tolj=j)wHLM4rl*8u%9~ckMR_wW@H}z*}Z0n@YkO z-KK(!$AgQ$d_=PXMldlbe|4=0Z)BE)^NCOw6zYlnC zoujwF#q4+;+&4Q=pdZ1-LE|uZs?I)inBphk1GK;1(J%;4!EgWs;ZQ5-DwQuW@L$14 z!>$T^l+M2UaOM1;^r7zjj{>~`E>_U_;8PWQoc|$QhcE@;JcP+QMXdKO&VuxNhvXX5-XO8yyykvgHpNafjW@PBpB zZc)(r;NxKT4ER``{V8w}-v>TM$5Tcrv!+F{Zq{IazNGTeE`#t11hHZ*1%FC&gam)9 z{G@?*8?D&4SYO{h7kmQJKLhU6`MCfdhWG*SM-aM1Qv@J`+YllEPC;m{CJ1PQ*Xzbm z5`y?Y;K4fH61*+qekBiH;}L!agNK7Bf;ZFIKL?(IcpA9a?9_Z+zR~ zqAUoaiF!fMH4#~_I?4gpJGuZa7N%|B+KMJJh#9Z6=wIOa799gF(#L)B;D*E{5)?rY z4yHiRXYeDq7=&xVMGdtYM>v%XE`sYb7z!@Nj&&n8D$TwPPR!s<5VwPi7St-dz=`v} z80`ZfXro;e=nxW!4Br9QH)-Pu%6d=*E=IRjpjqG@5Kr0k;AkcM{1;pt!JY-j?Dg4K zf%_x=?k2Q<1D$XNLJ!2(B7wH%3rE(8O3luI`)Y=!N&yds{VniDnjh5oDewry8As0sXN{UIT#ype&wq4FjMzD(tj2L7JP zTgqHFgx0GCSzf^fQ1OHa#eGL42mE-2*!B`hV=%gy(y!Jo<|4rrC!RqmA zDo0R{-%|Mu12;`o2FS|>-U!^&`#grwqpC%&!QwH`i{~*$;#GN>LGGyX)dt=}3bYt;$;%`1dN0Gw_ot zPm(znUTvBAO%+lN39e1`l>El5v3qb##V50Gt$qkw;B(KtFsVbw&T5$W(yW>764Xcs z&!4~H7Xv$_q{tvSK@pM@5>*4c8Y+5+P6?i#7w{|19TjX>{n(Q{FJ3?gsd?DdRCYC0 zO2X_}6DB@4rJb5AC0UJkQrx5{_Q?rJDp&j@Cn$Pyf*MaulI@cd)Y2v@rA$ujAoHZO zL`6tS(hQQ71c^$<$%$%4iJC*zE=jF+lIk!i$ur?1vj!!p1xV`b`QByf;%Pt79PT-N zku?ZUQax!obx=KYNECXsr~ERD@Lavb+HU{PCH8*Q!yTtg?U0m^kdk7b+F@eHDan02 zhssRh(VZtHCv-^cl+rPIQinVb9_( zO|3jv8=8iAPBk*M^Eeur-rXJ)Y`Py1+9|P9$HYlfk|#|_Na{2tG0Ah*W_omc!lS08 z=FrX)6Q)e*JZW*{G+WqN7*kt$Qr%!rPi2aH!na>vB+^7Qh>J9z$1Gq>-E z38o@UG2d09&&=+-((J@k8`{`MO_9P!m_FZ-IUHM95_qnzE+@`>bHXF4R zDe$7rNFP(vx-deKoi;I58B^1DrDd0#s1*wnR8teRI%1NlEGbb_F;9JVT1Ao*wF+al zLiNlaU~UlmAP--PB&|7;lYDt#-tHb?Zq+c!S31nxr!SeT9rlephNvn>Q$fd23Q0GVB!mjD0& 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..30d315d77d 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) -> List (tpElem T)" + "ListDesc (Tp_Var 1)"; // 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) -> List (tpElem T * tpElem U)" + "ListDesc (Tp_Pair (Tp_Var 2) (Tp_Var 1))"; // 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,20 +233,20 @@ 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 @@ -254,8 +256,8 @@ heapster_assume_fun env "llvm.memcpy.p0i8.p0i8.i64" \ arg0:[l1]memblock(W,0,len,sh), 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 (#() * #()) ((),())"; + "\\ (X:TpDesc) (len:Vec 64 Bool) (x:tpElem X) -> \ + \ retS VoidEv #() ()"; // Box>::clone box_list20_u64_clone_sym <- heapster_find_symbol_with_type env @@ -491,10 +493,12 @@ heapster_typecheck_fun_rename env mk_proj0_five_values_sym "mk_proj0_five_values "<> fn (x1:u32,x2:u32,x3:u32,x4:u32,x5:u32) -> u32"; // ref_sum +/* ref_sum_sym <- heapster_find_symbol env "7ref_sum"; // 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"; @@ -574,7 +578,7 @@ TrueEnum__fmt_sym <- heapster_find_trait_method_symbol env 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"; +// "<'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<>"; @@ -582,18 +586,18 @@ list_is_empty_sym <- heapster_find_symbol env "13list_is_empty"; 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>"; +// "<'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"; +// "<'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))"; @@ -651,11 +655,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 +669,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..b0b5ad063d 100644 --- a/heapster-saw/examples/rust_data.sawcore +++ b/heapster-saw/examples/rust_data.sawcore @@ -3,17 +3,8 @@ module rust_data where import Prelude; -unfoldListPermH : (a:sort 0) -> List a -> Either #() (#() * a * List a); -unfoldListPermH a l = - List__rec a (\ (_:List a) -> Either #() (#() * a * List a)) - (Left #() (#() * a * List a) ()) - (\ (x:a) (l:List a) (_:Either #() (#() * a * List a)) -> - Right #() (#() * a * List a) ((), x, l)) - l; - -foldListPermH : (a:sort 0) -> Either #() (#() * a * List a) -> List a; -foldListPermH a = - either #() (#() * a * List a) (List a) - (\ (_ : #()) -> Nil a) - (\ (tup : (#() * a * List a)) -> - Cons a tup.(2).(1) tup.(2).(2)); +-- A type description for the list type over a type description T, which should +-- only use free deBruijn indices starting at 1 because it is being substituted +-- inside a Tp_Ind constructor +ListDesc : TpDesc -> TpDesc; +ListDesc T = Tp_Ind (Tp_Ind (Tp_Sum Tp_Unit (Tp_Pair T (Tp_Var 0)))); From 3e8525c2d5fc866e8d78a7082477a73cba0448f1 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 25 Oct 2023 11:25:44 -0700 Subject: [PATCH 158/305] whoops, forgot to update the translation of the SImpl_ElimLLVMBlockNamed rule for defined shapes to accommodate the fact that shapes now translate to have 0 or more element instead of always just 1 --- heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index ccc86d8ce5..a1e98524bc 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -4809,7 +4809,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of do ttrans <- translateSimplImplOutHead mb_simpl withPermStackM id (\(pctx :>: ptrans) -> - pctx :>: typeTransF ttrans [transTerm1 ptrans]) + pctx :>: typeTransF ttrans (transTerms ptrans)) m | otherwise -> From 5b9fbb722795545537a60f1ce5d10eacfb307d80 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 25 Oct 2023 11:33:23 -0700 Subject: [PATCH 159/305] added helper definitions for writing type descriptions --- saw-core/prelude/Prelude.sawcore | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/saw-core/prelude/Prelude.sawcore b/saw-core/prelude/Prelude.sawcore index bea5b2515d..e139bc74ae 100644 --- a/saw-core/prelude/Prelude.sawcore +++ b/saw-core/prelude/Prelude.sawcore @@ -2364,6 +2364,14 @@ data TpDesc : sort 0 where { } +-- The type description for the unit type +Tp_Unit : TpDesc; +Tp_Unit = Tp_Kind (Kind_Expr Kind_unit); + +-- 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 the type BVVec n len d Tp_BVVec : TpDesc -> (n:Nat) -> TpExpr (Kind_bv n) -> TpDesc; Tp_BVVec d n len = From e3f1f80fb0b09e365f00287a320898743df67d41 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 25 Oct 2023 14:52:44 -0700 Subject: [PATCH 160/305] more SAW translation bug fixes: made sure to add the Tp_M constructor for the return types of functional type descriptions; fixed some of the array types to reflect the fact that cell shapes can have 0 or more types instead of just 1 --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 34 ++++++++++--------- 1 file changed, 18 insertions(+), 16 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index a1e98524bc..def1a9ff32 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -295,17 +295,20 @@ sigmaTpDescMulti :: [OpenTerm] -> OpenTerm -> OpenTerm sigmaTpDescMulti [] d = d sigmaTpDescMulti (k:ks) d = sigmaTpDesc k $ sigmaTpDescMulti ks d --- | Build the type description for a function index of arrow type +-- | Build an arrow type description for left- and right-hand type descriptions arrowTpDesc :: OpenTerm -> OpenTerm -> OpenTerm arrowTpDesc d_in d_out = ctorOpenTerm "Prelude.Tp_Arr" [d_in, d_out] --- | Build the type description for a function index of multi-arity arrow type +-- | Build a multi-arity nested arrow type description arrowTpDescMulti :: [OpenTerm] -> OpenTerm -> OpenTerm -arrowTpDescMulti tps_in tp_out = foldr arrowTpDesc tp_out tps_in +arrowTpDescMulti ds_in d_out = foldr arrowTpDesc d_out ds_in --- | Build the type description for a computation with a given return type -tpMTpDesc :: OpenTerm -> OpenTerm -tpMTpDesc d = ctorOpenTerm "Prelude.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 (ctorOpenTerm "Prelude.Tp_M" [d_ret]) -- | Build the type description for a pi-abstraction over a kind description piTpDesc :: OpenTerm -> OpenTerm -> OpenTerm @@ -1509,8 +1512,8 @@ descTypeTransF dtp_trans = typeTransF (descTypeTrans dtp_trans) -- order in the first type translation to the tuple of the types in the second arrowDescTrans :: DescTypeTrans tr1 -> DescTypeTrans tr2 -> OpenTerm arrowDescTrans tp1 tp2 = - arrowTpDescMulti (descTypeTransDescs tp1) (tupleTpDesc $ - descTypeTransDescs 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) => @@ -2443,7 +2446,7 @@ data LLVMArrayPermTrans ctx w = LLVMArrayPermTrans { -- | Get the SAW type of the cells of the translation of an array permission llvmArrayTransCellType :: LLVMArrayPermTrans ctx w -> OpenTerm -llvmArrayTransCellType = typeTransType1 . llvmArrayTransHeadCell +llvmArrayTransCellType = typeTransTupleType . llvmArrayTransHeadCell -- | The translation of an 'LLVMArrayBorrow' is an element / proof of the @@ -2508,7 +2511,7 @@ 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) + typeTransF (tupleTypeTrans (llvmArrayTransHeadCell arr_trans)) [applyGlobalOpenTerm "Prelude.atBVVec" [natOpenTerm w, llvmArrayTransLen arr_trans, llvmArrayTransCellType arr_trans, llvmArrayTransTerm arr_trans, @@ -2529,7 +2532,7 @@ setLLVMArrayTransCell arr_trans cell_tm cell_value = applyGlobalOpenTerm "Prelude.updBVVec" [natOpenTerm w, llvmArrayTransLen arr_trans, llvmArrayTransCellType arr_trans, llvmArrayTransTerm arr_trans, - cell_tm, transTerm1 cell_value] } + cell_tm, transTupleTerm cell_value] } -- | Read a slice (= a sub-array) of the translation of an LLVM array permission @@ -3174,7 +3177,7 @@ instance TranslateDescs (AtomicPerm a) where [nuMP| Perm_LOwned _ _ _ ps_in ps_out |] -> do ds_in <- translateDescs ps_in d_out <- translateDesc ps_out - return [arrowTpDescMulti ds_in d_out] + return [funTpDesc ds_in d_out] [nuMP| Perm_LOwnedSimple _ _ |] -> return [] [nuMP| Perm_LCurrent _ |] -> return [] [nuMP| Perm_LFinished |] -> return [] @@ -3337,7 +3340,7 @@ instance TranslateDescs (FunPerm ghosts args gouts ret) where inExtCtxDescTransM tops $ \kdescs -> (\d -> [d]) <$> piTpDescMulti kdescs <$> do ds_in <- translateDescs (mbCombine tops_prxs perms_in) - arrowTpDescMulti ds_in <$> + funTpDesc ds_in <$> translateRetTpDesc rets (mbCombine (RL.append tops_prxs rets_prxs) perms_out) @@ -3372,7 +3375,7 @@ translateRetTpDesc :: CruCtx rets -> DescTransM ctx OpenTerm translateRetTpDesc rets ret_perms = inExtCtxDescTransM rets $ \kdescs -> - tpMTpDesc <$> sigmaTpDescMulti kdescs <$> translateDesc ret_perms + sigmaTpDescMulti kdescs <$> translateDesc ret_perms -- | Build the pure return type (not including the application of @SpecM@) for -- the function resulting from an entrypoint @@ -6314,8 +6317,7 @@ translateEntryDesc (TypedEntry {..}) = inExtCtxDescTransM typedEntryGhosts $ \ghosts_kdescs -> do ds_in <- translateDescs typedEntryPermsIn return $ - piTpDescMulti (args_kdescs ++ ghosts_kdescs) $ - arrowTpDescMulti ds_in d_out + piTpDescMulti (args_kdescs ++ ghosts_kdescs) $ funTpDesc ds_in d_out -- | Build a list of type descriptions that describe the types of all of the -- entrypoints in a 'TypedBlockMap' that will be translated to functions From b3ef9a7dab10c3fe9181966ad39bb877fcf3e8e4 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 26 Oct 2023 07:22:49 -0700 Subject: [PATCH 161/305] re-enabled the ref_sum example in rust_data --- heapster-saw/examples/rust_data.saw | 3 --- 1 file changed, 3 deletions(-) diff --git a/heapster-saw/examples/rust_data.saw b/heapster-saw/examples/rust_data.saw index 30d315d77d..a234d515c7 100644 --- a/heapster-saw/examples/rust_data.saw +++ b/heapster-saw/examples/rust_data.saw @@ -493,12 +493,9 @@ heapster_typecheck_fun_rename env mk_proj0_five_values_sym "mk_proj0_five_values "<> fn (x1:u32,x2:u32,x3:u32,x4:u32,x5:u32) -> u32"; // ref_sum -/* ref_sum_sym <- heapster_find_symbol env "7ref_sum"; -// 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"; -*/ // double_dup_ref double_dup_ref_sym <- heapster_find_symbol env "14double_dup_ref"; From f1a0fd7529f6d1bdbd7640320ace6eaee81d1047 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 26 Oct 2023 07:23:36 -0700 Subject: [PATCH 162/305] added projTupleOpenTerm' to OpenTerm.hs --- saw-core/src/Verifier/SAW/OpenTerm.hs | 17 +++++++++++++++-- 1 file changed, 15 insertions(+), 2 deletions(-) diff --git a/saw-core/src/Verifier/SAW/OpenTerm.hs b/saw-core/src/Verifier/SAW/OpenTerm.hs index 80e482beaf..f13b12a42d 100644 --- a/saw-core/src/Verifier/SAW/OpenTerm.hs +++ b/saw-core/src/Verifier/SAW/OpenTerm.hs @@ -63,7 +63,7 @@ module Verifier.SAW.OpenTerm ( arrayValueOpenTerm, vectorTypeOpenTerm, bvLitOpenTerm, bvTypeOpenTerm, pairOpenTerm, pairTypeOpenTerm, pairLeftOpenTerm, pairRightOpenTerm, tupleOpenTerm, tupleTypeOpenTerm, projTupleOpenTerm, - tupleOpenTerm', tupleTypeOpenTerm', + tupleOpenTerm', tupleTypeOpenTerm', projTupleOpenTerm', recordOpenTerm, recordTypeOpenTerm, projRecordOpenTerm, ctorOpenTerm, dataTypeOpenTerm, globalOpenTerm, identOpenTerm, extCnsOpenTerm, applyOpenTerm, applyOpenTermMulti, applyGlobalOpenTerm, @@ -276,11 +276,24 @@ tupleOpenTerm' :: [OpenTerm] -> OpenTerm tupleOpenTerm' [] = unitOpenTerm tupleOpenTerm' ts = foldr1 pairTypeOpenTerm 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 +-- | 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. Note that this +-- requires knowing the length of @tps@. +projTupleOpenTerm' :: [OpenTerm] -> Integer -> OpenTerm -> OpenTerm +projTupleOpenTerm' [] _ _ = + panic "projTupleOpenTerm'" ["projection of empty tuple!"] +projTupleOpenTerm' [_] 0 tup = tup +projTupleOpenTerm' (_:_) 0 tup = pairLeftOpenTerm tup +projTupleOpenTerm' (_:tps) i tup = + projTupleOpenTerm' tps (i-1) $ pairRightOpenTerm tup + + -- | Build a record value as an 'OpenTerm' recordOpenTerm :: [(FieldName, OpenTerm)] -> OpenTerm recordOpenTerm flds_ts = From 9f7ad322390996564c2657ed56d1b6f1c2b60851 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 26 Oct 2023 07:25:24 -0700 Subject: [PATCH 163/305] fixed the LLVM global translations in LLVMGlobalConst.hs to match the new translation of shapes as 0 or more types instead of a fixed 1 type --- .../Verifier/SAW/Heapster/LLVMGlobalConst.hs | 84 +++++++++++-------- .../Verifier/SAW/Heapster/SAWTranslation.hs | 47 +++-------- 2 files changed, 59 insertions(+), 72 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/LLVMGlobalConst.hs b/heapster-saw/src/Verifier/SAW/Heapster/LLVMGlobalConst.hs index b388713ab4..1563399661 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/LLVMGlobalConst.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/LLVMGlobalConst.hs @@ -36,6 +36,8 @@ 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 @@ -92,29 +94,29 @@ ppLLVMConstExpr :: L.ConstExpr -> String ppLLVMConstExpr ce = L.withConfig (L.Config True True True) (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, GlobalTransTerms [t]) -> return (p,t) - Just (p, GlobalTransTerms ts) -> return (p,tupleOpenTerm ts) + (p, ts) <- case lookupGlobalSymbol env (GlobalSymbol sym) w of + Just (p, GlobalTransTerms ts) -> return (p,ts) Just (_, _) -> traceAndZeroM ("Could not translate recursive function symbol: " ++ show sym) 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 (L.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 (L.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, @@ -281,15 +290,20 @@ 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, 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 + let projs = + map (\i -> projTupleOpenTerm' tps i t_ident) + [0 .. toInteger (length ts - 1)] return $ permEnvAddGlobalSyms env [PermEnvGlobalEntry (GlobalSymbol $ L.globalSym global) p - (GlobalTransTerms [t_ident])] + (GlobalTransTerms projs)] diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index def1a9ff32..1300dd0181 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -482,49 +482,21 @@ typeTransType1 (TypeTrans [tp] _) = tp typeTransType1 _ = panic "typeTransType1" ["found multiple types where at most 1 was expected"] --- | 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 [] _ _ = - panic "projTupleOfTypes" ["projection of empty tuple!"] -projTupleOfTypes [_] 0 tup = tup -projTupleOfTypes (_:_) 0 tup = pairLeftOpenTerm tup -projTupleOfTypes (_:tps) i tup = - projTupleOfTypes tps (i-1) $ pairRightOpenTerm tup - -- | 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 = tupleOpenTerm' . 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) $ + typeTransF ttrans $ map (\i -> projTupleOpenTerm' tps i t) $ take (length $ typeTransTypes ttrans) [0..] _ -> panic "tupleTypeTrans" ["incorrect number of terms"]) @@ -626,7 +598,7 @@ class IsTermTrans tr where -- function returns an element of the type @'tupleTypeTrans' ttrans@. transTupleTerm :: IsTermTrans tr => tr -> OpenTerm transTupleTerm (transTerms -> [t]) = t -transTupleTerm tr = tupleOfTerms $ transTerms tr +transTupleTerm tr = tupleOpenTerm' $ transTerms tr {- -- | Build a tuple of the terms contained in a translation. This is "strict" in @@ -1665,7 +1637,7 @@ instance TransInfo info => (elem_ds, elem_tps) <- unETransShape <$> translate mb_sh return $ ETrans_Shape [bvVecTpDesc w_term len_d (tupleTpDesc elem_ds)] - [bvVecTypeOpenTerm w_term len_term (tupleOfTypes elem_tps)] + [bvVecTypeOpenTerm w_term len_term (tupleTypeOpenTerm' elem_tps)] [nuMP| PExpr_SeqShape sh1 sh2 |] -> do (ds1, tps1) <- unETransShape <$> translate sh1 (ds2, tps2) <- unETransShape <$> translate sh2 @@ -1675,7 +1647,8 @@ instance TransInfo info => (ds2, tps2) <- unETransShape <$> translate sh2 return $ ETrans_Shape [sumTpDesc (tupleTpDesc ds1) (tupleTpDesc ds2)] - [eitherTypeOpenTerm (tupleOfTypes tps1) (tupleOfTypes tps2)] + [eitherTypeOpenTerm + (tupleTypeOpenTerm' tps1) (tupleTypeOpenTerm' tps2)] [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 @@ -3051,7 +3024,7 @@ instance TransInfo info => fmap PTrans_Conj <$> listTypeTrans <$> translate ps [nuMP| ValPerm_Var x _ |] -> do (_, tps) <- unETransPerm <$> translate x - return $ mkPermTypeTrans1 p (tupleOfTypes tps) + return $ mkPermTypeTrans1 p (tupleTypeOpenTerm' tps) [nuMP| ValPerm_False |] -> return $ mkPermTypeTrans1 p $ globalOpenTerm "Prelude.FalseProp" From 96eb8a99f7d620c19bdf65af5cd5be7a2d0def2a Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 26 Oct 2023 17:40:05 -0700 Subject: [PATCH 164/305] changed transTerms to have a monadic version for permissions --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 889 ++++++++++-------- 1 file changed, 514 insertions(+), 375 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 1300dd0181..50ed8e78b1 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -49,6 +49,7 @@ import qualified Control.Monad as Monad import Control.Monad.Reader hiding (ap) import Control.Monad.Writer hiding (ap) import Control.Monad.State hiding (ap) +import Control.Monad.Cont hiding (ap) import Control.Monad.Trans.Maybe import qualified Control.Monad.Fail as Fail @@ -389,6 +390,11 @@ callSOpenTerm :: EventType -> OpenTerm -> OpenTerm -> [OpenTerm] -> OpenTerm callSOpenTerm ev d ix args = applyGlobalOpenTerm "Prelude.CallS" ([evTypeTerm ev, d, ix] ++ args) +-- | Build a @SpecM@ computation that creates a function index using @LambdaS@ +lambdaSOpenTerm :: EventType -> OpenTerm -> OpenTerm -> OpenTerm +lambdaSOpenTerm ev d f = + applyGlobalOpenTerm "Prelude.LambdaS" [evTypeTerm ev, d, f] + -- | Build a @SpecM@ computation that uses @LetRecS@ to bind multiple -- corecursive functions in a body computation letRecSOpenTerm :: EventType -> [OpenTerm] -> OpenTerm -> OpenTerm -> @@ -486,7 +492,7 @@ typeTransType1 _ = -- 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 = tupleOpenTerm' . typeTransTypes +typeTransTupleType = tupleTypeOpenTerm' . typeTransTypes -- | Convert a 'TypeTrans' over 0 or more types to one over a tuple of those -- types @@ -500,20 +506,6 @@ tupleTypeTrans ttrans = take (length $ typeTransTypes ttrans) [0..] _ -> panic "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") --} - -- | Build a type translation for a list of translations listTypeTrans :: [TypeTrans tr] -> TypeTrans [tr] listTypeTrans [] = pure [] @@ -592,34 +584,73 @@ unETransPerm (ETrans_Term _ _) = class IsTermTrans tr where transTerms :: HasCallStack => tr -> [OpenTerm] +-- | A translation monad enriched with a continuation returning a SAW core term. +-- This is used to generate monadic binds in the @SpecM@ monad by shifting the +-- current continuation and using it as the function argument of the bind +type ContTransM info ctx = ContT OpenTerm (TransM info ctx) + +-- | Describes a Haskell type that represents the translation of a term-like +-- construct that corresponds to 0 or more SAW core terms, but where the SAW +-- core terms can only be recovered by performing a bind in the @SpecM@ monad. +-- This is represented as a continuation-passing computation, which takes in the +-- continuation that will consume the SAW core terms inside any binds that need +-- to be inserted into the overall computation. +class IsTermTransM info ctx tr where + transTermsCont :: HasCallStack => tr -> + ContTransM info ctx [OpenTerm] + +-- | Pass the 0 or more SAW core terms corresponding to a monadic term +-- translation to a continuation that uses them to build a @SpecM@ computation +transTermsM :: IsTermTransM info ctx tr => HasCallStack => + tr -> ([OpenTerm] -> TransM info ctx OpenTerm) -> + TransM info ctx OpenTerm +transTermsM tr k = runContT (transTermsCont tr) k + -- | Build a tuple of the terms contained in a translation, with 0 terms mapping -- to the unit term and one term mapping to itself. If @ttrans@ is a 'TypeTrans' -- describing the SAW types associated with a @tr@ translation, then this -- function returns an element of the type @'tupleTypeTrans' ttrans@. transTupleTerm :: IsTermTrans tr => tr -> OpenTerm -transTupleTerm (transTerms -> [t]) = t -transTupleTerm tr = tupleOpenTerm' $ 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 --} +-- | Use 'transTermsM' to monadically translate a @tr@ to list of SAW core terms +-- and then tuple those terms to get a single term +transTupleTermM :: IsTermTransM info ctx tr => tr -> + (OpenTerm -> TransM info ctx OpenTerm) -> + TransM info ctx OpenTerm +transTupleTermM tr f = transTermsM tr (f . tupleOpenTerm') + +-- | 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 tr = panic "transTerm1" ["Expected at most one term, but found " - ++ show (length $ transTerms tr)] +transTerm1 = termsExpect1 . transTerms + +-- | Like 'transTupleTermM' but raise an error if there are more than 1 terms +transTerm1M :: IsTermTransM info ctx tr => tr -> + (OpenTerm -> TransM info ctx OpenTerm) -> + TransM info ctx OpenTerm +transTerm1M tr f = transTermsM tr (f . termsExpect1) + instance IsTermTrans tr => IsTermTrans [tr] where transTerms = concatMap transTerms +instance IsTermTransM info ctx tr => IsTermTransM info ctx [tr] where + transTermsCont = fmap concat . mapM transTermsCont + +instance (IsTermTransM info ctx tr1, IsTermTransM info ctx tr2) => + IsTermTransM info ctx (tr1,tr2) where + transTermsCont (tr1,tr2) = + (++) <$> transTermsCont tr1 <*> transTermsCont tr2 + instance IsTermTrans (TypeTrans tr) where transTerms = typeTransTypes @@ -783,6 +814,11 @@ class TransInfo info where infoChecksFlag :: info ctx -> ChecksFlag extTransInfo :: ExprTrans tp -> info ctx -> info (ctx :> tp) +-- | A 'TransInfo' that additionally contains a monadic return type for the +-- current computation being built, allowing the use of monadic bind +class TransInfo info => TransInfoM info where + infoRetType :: info ctx -> OpenTerm + -- | Get the event type stored in a 'TransInfo' infoEvType :: TransInfo info => info ctx -> EventType infoEvType = permEnvEventType . infoEnv @@ -971,19 +1007,17 @@ eitherTypeTrans tp_l 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 -> @@ -1045,33 +1079,37 @@ sigmaTypePermTransM x ttrans mb_p = case mbMatch mb_p of -- 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) => +sigmaTransM :: (IsTermTrans trL, IsTermTransM info ctx trR2) => LocalName -> TypeTrans trL -> (trL -> TransM info ctx (TypeTrans trR1)) -> trL -> TransM info ctx trR2 -> + (OpenTerm -> TransM info ctx OpenTerm) -> TransM info ctx OpenTerm -sigmaTransM _ (typeTransTypes -> []) _ _ rhs_m = transTupleTerm <$> rhs_m -sigmaTransM x tp_l tp_r lhs rhs_m = - ask >>= \info -> - return (sigmaOpenTermMulti x (typeTransTypes tp_l) - (typeTransTupleType . flip runTransM info . tp_r . typeTransF tp_l) - (transTerms lhs) - (transTupleTerm $ runTransM rhs_m info)) +sigmaTransM _ (typeTransTypes -> []) _ _ rhs_m k = + rhs_m >>= \rhs -> transTupleTermM rhs k +sigmaTransM x tp_l tp_r lhs rhs_m k = + do info <- ask + rhs <- rhs_m + transTupleTermM rhs $ \rhs_tm -> + return (sigmaOpenTermMulti x (typeTransTypes tp_l) + (typeTransTupleType . flip runTransM info . tp_r . typeTransF tp_l) + (transTerms lhs) + rhs_tm) -- | Like `sigmaTransM`, but translates `exists x.eq(y)` into just `x` -sigmaPermTransM :: (TransInfo info, IsTermTrans trR2) => +sigmaPermTransM :: (TransInfo info, IsTermTransM info ctx trR2) => LocalName -> TypeTrans (ExprTrans trL) -> Mb (ctx :> trL) (ValuePerm trR1) -> ExprTrans trL -> TransM info ctx trR2 -> + (OpenTerm -> TransM info ctx OpenTerm) -> TransM info ctx OpenTerm -sigmaPermTransM x ttrans mb_p etrans rhs_m = case mbMatch mb_p of - [nuMP| ValPerm_Eq _ |] -> return $ transTupleTerm etrans - _ -> sigmaTransM x ttrans (flip inExtTransM $ translate mb_p) etrans rhs_m +sigmaPermTransM x ttrans mb_p etrans rhs_m k = case mbMatch mb_p of + [nuMP| ValPerm_Eq _ |] -> k (transTupleTerm etrans) + _ -> sigmaTransM x ttrans (flip inExtTransM $ translate mb_p) etrans rhs_m k -- | Eliminate a dependent pair of the type returned by 'sigmaTypeTransM' -sigmaElimTransM :: (IsTermTrans trL, IsTermTrans trR) => - LocalName -> TypeTrans trL -> +sigmaElimTransM :: LocalName -> TypeTrans trL -> (trL -> TransM info ctx (TypeTrans trR)) -> TransM info ctx (TypeTrans trRet) -> (trL -> trR -> TransM info ctx OpenTerm) -> @@ -1125,11 +1163,52 @@ applyNamedEventOpM :: TransInfo info => Ident -> [OpenTerm] -> TransM info ctx OpenTerm applyNamedEventOpM f args = applyEventOpM (globalOpenTerm f) args --- | Generate the type @SpecM E evRetType A@ using the current event type --- and the supplied type @A@ -specMTypeTransM :: TransInfo info => OpenTerm -> TransM info ctx OpenTerm -specMTypeTransM tp = applyNamedEventOpM "Prelude.SpecM" [tp] +-- | The current non-monadic return type +returnTypeM :: TransInfoM info => TransM info ctx OpenTerm +returnTypeM = infoRetType <$> ask + +-- | Build the monadic return type @SpecM E ret@, where @ret@ is the current +-- return type in 'itiReturnType' +compReturnTypeM :: TransInfoM info => TransM info ctx OpenTerm +compReturnTypeM = + do ev <- infoEvType <$> ask + ret_tp <- returnTypeM + return $ applyGlobalOpenTerm "Prelude.SpecM" [evTypeTerm ev, ret_tp] +-- | Like 'compReturnTypeM' but build a 'TypeTrans' +compReturnTypeTransM :: TransInfoM info => TransM info ctx (TypeTrans OpenTerm) +compReturnTypeTransM = openTermTypeTrans <$> compReturnTypeM + +-- | Build a term @bindS m k@ with the given @m@ of type @m_tp@ and where @k@ +-- is build as a lambda with the given variable name and body +bindTransM :: TransInfoM info => OpenTerm -> TypeTrans tr -> String -> + (tr -> TransM info ctx OpenTerm) -> + TransM info ctx OpenTerm +bindTransM m m_tptrans str f = + do ev <- infoEvType <$> ask + ret_tp <- returnTypeM + k_tm <- lambdaTransM str m_tptrans f + let m_tp = typeTransTupleType m_tptrans + return $ bindSOpenTerm ev m_tp ret_tp m k_tm + +-- | This type turns any type satisfying 'TransInfo' into one satisfying +-- 'TransInfoM' by adding a monadic return type +data SpecMTransInfo info ctx = SpecMTransInfo (info ctx) OpenTerm + +instance TransInfo info => TransInfo (SpecMTransInfo info) where + infoCtx (SpecMTransInfo info _) = infoCtx info + infoEnv (SpecMTransInfo info _) = infoEnv info + infoChecksFlag (SpecMTransInfo info _) = infoChecksFlag info + extTransInfo etrans (SpecMTransInfo info ret_tp) = + SpecMTransInfo (extTransInfo etrans info) ret_tp + +instance TransInfo info => TransInfoM (SpecMTransInfo info) where + infoRetType (SpecMTransInfo _ ret_tp) = ret_tp + +-- | Build a monadic @SpecM@ computation using a particular return type +specMTransM :: OpenTerm -> TransM (SpecMTransInfo info) ctx OpenTerm -> + TransM info ctx OpenTerm +specMTransM ret_tp m = withInfoM (flip SpecMTransInfo ret_tp) m -- | The class for translating to SAW class Translate info ctx a tr | ctx a -> tr where @@ -2031,11 +2110,15 @@ data FunTransTerm -- type description of the type of the function | FunTransFun EventType OpenTerm OpenTerm --- | Convert a 'FunTransTerm' to an index, i.e., term of type @FunIx T@ -funTransTermToIx :: FunTransTerm -> OpenTerm -funTransTermToIx (FunTransIx _ _ funix) = funix -funTransTermToIx (FunTransFun ev d f) = - applyGlobalOpenTerm "Prelude.LambdaS" [evTypeTerm ev, d, f] +-- | Convert a 'FunTransTerm' to an index, i.e., term of type @FunIx T@, passing +-- the index to the supplied continuation function +funTransTermToIx :: TransInfoM info => FunTransTerm -> + (OpenTerm -> TransM info ctx OpenTerm) -> + TransM info ctx OpenTerm +funTransTermToIx (FunTransIx _ _ funix) k = k funix +funTransTermToIx (FunTransFun ev d f) k = + bindTransM (lambdaSOpenTerm ev d f) (openTermTypeTrans $ + funIxTypeOpenTerm d) "funix" k -- | Apply a 'FunTransTerm' to a list of arguments applyFunTransTerm :: FunTransTerm -> [OpenTerm] -> OpenTerm @@ -2132,35 +2215,37 @@ eqPermTransCtx ns = RL.map (\memb -> PTrans_Eq $ nuMulti (RL.map (\_-> Proxy) ns) (PExpr_Var . RL.get memb)) -instance IsTermTrans (PermTrans ctx a) where - transTerms (PTrans_Eq _) = [] - transTerms (PTrans_Conj aps) = transTerms aps - transTerms (PTrans_Defined _ _ _ ptrans) = transTerms ptrans - transTerms (PTrans_Term _ t) = [t] - -instance IsTermTrans (PermTransCtx ctx ps) where - transTerms = concat . RL.mapToList transTerms - -instance IsTermTrans (AtomicPermTrans ctx a) where - transTerms (APTrans_LLVMField _ ptrans) = transTerms ptrans - transTerms (APTrans_LLVMArray arr_trans) = transTerms arr_trans - transTerms (APTrans_LLVMBlock _ ts) = ts - transTerms (APTrans_LLVMFree _) = [] - transTerms (APTrans_LLVMFunPtr _ trans) = transTerms trans - transTerms APTrans_IsLLVMPtr = [] - transTerms (APTrans_LLVMBlockShape _ ts) = ts - transTerms (APTrans_NamedConj _ _ _ t) = [t] - transTerms (APTrans_DefinedNamedConj _ _ _ ptrans) = transTerms ptrans - transTerms (APTrans_LLVMFrame _) = [] - transTerms (APTrans_LOwned _ _ _ eps_in _ lotr) = - [lownedTransTerm eps_in lotr] - transTerms (APTrans_LOwnedSimple _ _) = [] - transTerms (APTrans_LCurrent _) = [] - transTerms APTrans_LFinished = [] - transTerms (APTrans_Struct pctx) = transTerms pctx - transTerms (APTrans_Fun _ t) = [funTransTermToIx t] - transTerms (APTrans_BVProp prop) = transTerms prop - transTerms APTrans_Any = [] +instance TransInfoM info => IsTermTransM info ctx (PermTrans ctx a) where + transTermsCont (PTrans_Eq _) = return [] + transTermsCont (PTrans_Conj aps) = transTermsCont aps + transTermsCont (PTrans_Defined _ _ _ ptrans) = transTermsCont ptrans + transTermsCont (PTrans_Term _ t) = return [t] + +instance TransInfoM info => IsTermTransM info ctx (PermTransCtx ctx ps) where + transTermsCont = fmap concat . sequence . RL.mapToList transTermsCont + +instance TransInfoM info => IsTermTransM info ctx (AtomicPermTrans ctx a) where + transTermsCont (APTrans_LLVMField _ ptrans) = transTermsCont ptrans + transTermsCont (APTrans_LLVMArray arr_trans) = return $ transTerms arr_trans + transTermsCont (APTrans_LLVMBlock _ ts) = return ts + transTermsCont (APTrans_LLVMFree _) = return [] + transTermsCont (APTrans_LLVMFunPtr _ trans) = transTermsCont trans + transTermsCont APTrans_IsLLVMPtr = return [] + transTermsCont (APTrans_LLVMBlockShape _ ts) = return ts + transTermsCont (APTrans_NamedConj _ _ _ t) = return [t] + transTermsCont (APTrans_DefinedNamedConj _ _ _ ptrans) = + transTermsCont ptrans + transTermsCont (APTrans_LLVMFrame _) = return [] + transTermsCont (APTrans_LOwned _ _ _ eps_in _ lotr) = + ContT $ \k -> lownedTransTerm eps_in lotr (\t -> k [t]) + transTermsCont (APTrans_LOwnedSimple _ _) = return [] + transTermsCont (APTrans_LCurrent _) = return [] + transTermsCont APTrans_LFinished = return [] + transTermsCont (APTrans_Struct pctx) = transTermsCont pctx + transTermsCont (APTrans_Fun _ f) = + ContT $ \k -> funTransTermToIx f (\t -> k [t]) + transTermsCont (APTrans_BVProp prop) = return $ transTerms prop + transTermsCont APTrans_Any = return [] instance IsTermTrans (BVPropTrans ctx w) where transTerms (BVPropTrans _ t) = [t] @@ -2179,11 +2264,6 @@ instance IsTermTrans (LLVMArrayBorrowTrans ctx w) where -} --- | 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 = transTerms - -- | Extract out the permission of a permission translation result permTransPerm :: RAssign Proxy ctx -> PermTrans ctx a -> Mb ctx (ValuePerm a) permTransPerm _ (PTrans_Eq e) = fmap ValPerm_Eq e @@ -2495,17 +2575,20 @@ 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, TransInfoM info) => + LLVMArrayPermTrans ctx w -> OpenTerm -> AtomicPermTrans ctx (LLVMPointerType w) -> - LLVMArrayPermTrans ctx w -setLLVMArrayTransCell arr_trans cell_tm cell_value = + (LLVMArrayPermTrans ctx w -> TransM info ctx OpenTerm) -> + TransM info ctx OpenTerm +setLLVMArrayTransCell arr_trans cell_ix_tm cell_value k = let w = fromInteger $ natVal arr_trans in - arr_trans { + transTupleTermM cell_value $ \cell_value_t -> + k $ arr_trans { llvmArrayTransTerm = applyGlobalOpenTerm "Prelude.updBVVec" [natOpenTerm w, llvmArrayTransLen arr_trans, llvmArrayTransCellType arr_trans, llvmArrayTransTerm arr_trans, - cell_tm, transTupleTerm cell_value] } + cell_ix_tm, cell_value_t] } -- | Read a slice (= a sub-array) of the translation of an LLVM array permission @@ -2524,7 +2607,9 @@ getLLVMArrayTransSlice arr_trans sub_arr_tp rng_trans prop_transs = 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 @@ -2563,7 +2648,17 @@ data LOwnedInfo ps ctx = lownedInfoPCtx :: PermTransCtx ctx ps, lownedInfoPVars :: RAssign (Member ctx) ps, lownedInfoEvType :: EventType, - lownedInfoRetType :: OpenTerm } + lownedInfoRetType :: OpenTerm, + lownedInfoEnv :: PermEnv } + +instance TransInfo (LOwnedInfo ps) where + infoCtx = lownedInfoECtx + infoEnv = lownedInfoEnv + infoChecksFlag _ = noChecks + extTransInfo = extLOwnedInfo + +instance TransInfoM (LOwnedInfo ps) where + infoRetType = lownedInfoRetType -- | Convert an 'ImpTransInfo' to an 'LOwnedInfo' impInfoToLOwned :: ImpTransInfo ext blocks tops rets ps ctx -> LOwnedInfo ps ctx @@ -2572,7 +2667,8 @@ impInfoToLOwned (ImpTransInfo {..}) = lownedInfoPCtx = itiPermStack, lownedInfoPVars = itiPermStackVars, lownedInfoEvType = permEnvEventType itiPermEnv, - lownedInfoRetType = itiReturnType } + lownedInfoRetType = itiReturnType, + lownedInfoEnv = itiPermEnv } -- | Convert an 'LOwnedInfo' to an 'ImpTransInfo' using an existing -- 'ImpTransInfo', throwing away all permissions in the 'ImpTransInfo' @@ -2609,7 +2705,8 @@ loInfoAppend info1 info2 = , lownedInfoPVars = RL.append (lownedInfoPVars info1) (lownedInfoPVars info2) , lownedInfoEvType = lownedInfoEvType info1 - , lownedInfoRetType = lownedInfoRetType info1 } + , lownedInfoRetType = lownedInfoRetType info1 + , lownedInfoEnv = lownedInfoEnv info1 } extLOwnedInfoExt :: ExprCtxExt ctx1 ctx2 -> LOwnedInfo ps ctx1 -> LOwnedInfo ps ctx2 @@ -2619,6 +2716,8 @@ extLOwnedInfoExt cext@(ExprCtxExt ectx3) (LOwnedInfo {..}) = 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 @@ -2702,6 +2801,23 @@ extLOwnedTransM :: ExprCtxExt ctx ctx' -> LOwnedTransM ps_in ps_out ctx a -> extLOwnedTransM cext m = LOwnedTransM $ \cext' -> runLOwnedTransM m (transExprCtxExt cext cext') +-- | Get the SAW core terms stored in a 'PermTransCtx' +pctxTermsLOwnedTransM :: HasCallStack => PermTransCtx ctx ps -> + LOwnedTransM ps' ps' ctx [OpenTerm] +pctxTermsLOwnedTransM pctx = + LOwnedTransM $ \cext loInfo k -> + flip runTransM loInfo $ + transTermsM (extPermTransCtxExt cext pctx) $ \ts -> + return $ k reflExprCtxExt loInfo ts + +-- | Get the SAW core terms stored in the current 'PermTransCtx' +pctxInTermsLOwnedTransM :: HasCallStack => LOwnedTransM ps ps ctx [OpenTerm] +pctxInTermsLOwnedTransM = + LOwnedTransM $ \cext loInfo k -> + flip runTransM loInfo $ + transTermsM (lownedInfoPCtx loInfo) $ \ts -> + return $ k reflExprCtxExt loInfo ts + -- | 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 () @@ -2714,10 +2830,11 @@ mkLOwnedTransTermFromTerm :: DescPermsTpTrans ctx ps_in -> RAssign (Member ctx) ps_out -> OpenTerm -> LOwnedTransTerm ctx ps_in ps_out mkLOwnedTransTermFromTerm trans_in trans_out vars_out t = + pctxInTermsLOwnedTransM >>>= \pctx_ts -> LOwnedTransM $ \(ExprCtxExt ctx') loInfo k -> let ev = lownedInfoEvType loInfo d = arrowDescTrans trans_in trans_out - t_app = callSOpenTerm ev d t (transTerms $ lownedInfoPCtx loInfo) + t_app = callSOpenTerm ev d t pctx_ts t_ret_trans = tupleTypeTrans $ descTypeTrans trans_out t_ret_tp = typeTransTupleType $ descTypeTrans trans_out in bindSOpenTerm ev t_ret_tp (lownedInfoRetType loInfo) t_app $ @@ -2730,20 +2847,21 @@ mkLOwnedTransTermFromTerm trans_in trans_out vars_out t = -- | 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 -> +lownedTransTermFun :: PermEnv -> 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 = +lownedTransTermFun env ectx vars_in tps_in tps_out t = lambdaTrans "p" (descTypeTrans tps_in) $ \ps_in -> let ret_tp = typeTransTupleType $ descTypeTrans tps_out in let loInfo = LOwnedInfo { lownedInfoECtx = ectx, lownedInfoPCtx = ps_in, lownedInfoPVars = vars_in, - lownedInfoEvType = ev, lownedInfoRetType = ret_tp } in - runLOwnedTransM t reflExprCtxExt loInfo $ \_ loInfo_out () -> - transTupleTerm (lownedInfoPCtx loInfo_out) + lownedInfoEvType = permEnvEventType env, + lownedInfoRetType = ret_tp, lownedInfoEnv = env } in + runLOwnedTransM (t >>> pctxInTermsLOwnedTransM) reflExprCtxExt loInfo $ + \_ loInfo_out ts -> tupleOpenTerm' ts -- | Extend the expression context of an 'LOwnedTransTerm' extLOwnedTransTerm :: ExprTransCtx ctx2 -> @@ -2759,11 +2877,11 @@ idLOwnedTransTerm :: DescPermsTpTrans ctx ps_out -> RAssign (Member ctx) ps_out -> LOwnedTransTerm ctx ps_in ps_out idLOwnedTransTerm dtr_out vars_out = + pctxInTermsLOwnedTransM >>>= \pctx_ts -> gmodify $ \(ExprCtxExt ctx') loInfo -> loInfo { lownedInfoPVars = RL.map (weakenMemberR ctx') vars_out, lownedInfoPCtx = - descTypeTransF (fmap (extPermTransCtxMulti ctx') dtr_out) - (transTerms (lownedInfoPCtx loInfo)) } + descTypeTransF (fmap (extPermTransCtxMulti ctx') dtr_out) pctx_ts } -- | Partially apply an 'LOwnedTransTerm' to some of its input permissions @@ -2789,13 +2907,14 @@ weakenLOwnedTransTerm :: Desc1PermTpTrans ctx tp -> weakenLOwnedTransTerm tptr t = ggetting $ \cext info_top -> let (info_ps_in, info_tp) = loInfoSplit Proxy (MNil :>: Proxy) info_top in + pctxTermsLOwnedTransM (lownedInfoPCtx info_tp) >>>= \pctx_tp_ts -> gput info_ps_in >>> extLOwnedTransM cext t >>> gmodify (\cext' info' -> loInfoAppend info' $ extLOwnedInfoExt cext' $ info_tp { lownedInfoPCtx = - (MNil :>:) $ extPermTransExt cext $ descTypeTransF tptr $ - transTerms $ lownedInfoPCtx info_tp }) + (MNil :>:) $ extPermTransExt cext $ + descTypeTransF tptr pctx_tp_ts }) -- | Combine 'LOwnedTransTerm's for the 'SImpl_MapLifetime' rule mapLtLOwnedTransTerm :: @@ -2876,19 +2995,25 @@ weakenLOwnedTrans tp_in tp_out (LOwnedTrans {..}) = -- | Convert an 'LOwnedTrans' to a function index from @ps_in@ to @ps_out@ by -- partially applying its function to the @ps_extra@ permissions it already --- contains and then applying the @LambdaS@ spec combinator -lownedTransTerm :: Mb ctx (ExprPerms ps_in) -> - LOwnedTrans ctx ps_extra ps_in ps_out -> OpenTerm -lownedTransTerm (mbExprPermsMembers -> Just vars_in) lotr = - let d = arrowDescTrans (lotrTpTransIn lotr) (lotrTpTransOut lotr) - f = applyLOwnedTransTerm Proxy - (lotrPsExtra lotr) (lotrVarsExtra lotr) (lotrTerm lotr) in - applyGlobalOpenTerm "Prelude.LambdaS" - [evTypeTerm (lotrEvType lotr), d, - lownedTransTermFun (lotrEvType lotr) (lotrECtx lotr) - vars_in (lotrTpTransIn lotr) (lotrTpTransOut lotr) f] -lownedTransTerm _ _ = - failOpenTerm "FIXME HERE NOW: write this error message" +-- contains, applying the @LambdaS@ spec combinator to create a @SpecM@ +-- computation that produces the function index, and then building a monadic +-- bind to pass that function index to the supplied continuation +lownedTransTerm :: TransInfoM info => Mb ctx (ExprPerms ps_in) -> + LOwnedTrans ctx ps_extra ps_in ps_out -> + (OpenTerm -> TransM info ctx OpenTerm) -> + TransM info ctx OpenTerm +lownedTransTerm (mbExprPermsMembers -> Just vars_in) lotr k = + do env <-infoEnv <$> ask + let d = arrowDescTrans (lotrTpTransIn lotr) (lotrTpTransOut lotr) + lot = applyLOwnedTransTerm Proxy + (lotrPsExtra lotr) (lotrVarsExtra lotr) (lotrTerm lotr) + f = lownedTransTermFun env (lotrECtx lotr) + vars_in (lotrTpTransIn lotr) (lotrTpTransOut lotr) lot + ix_tptrans = openTermTypeTrans (funIxTypeOpenTerm d) + ev <- infoEvType <$> ask + bindTransM (lambdaSOpenTerm ev d f) ix_tptrans "f_lowned" return +lownedTransTerm _ _ _ = + return $ failOpenTerm "FIXME HERE NOW: write this error message" -- | Apply the 'SImpl_MapLifetime' rule to an 'LOwnedTrans' mapLtLOwnedTrans :: @@ -3462,6 +3587,9 @@ instance TransInfo (ImpTransInfo ext blocks tops rets ps) where , itiPermStackVars = RL.map Member_Step itiPermStackVars , .. } +instance TransInfoM (ImpTransInfo ext blocks tops rets ps) where + infoRetType = itiReturnType + -- | The monad for impure translations type ImpTransM ext blocks tops rets ps = TransM (ImpTransInfo ext blocks tops rets ps) @@ -3524,6 +3652,34 @@ 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 'transTermsM' +withPermStackTermsM :: + IsTermTransM (ImpTransInfo ext blocks tops rets ps_in) ctx 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 + transTermsM (f_sel pctx) $ \ts -> + withPermStackM f_vars (f_p ts) 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 +-- 'transTermsM'; 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)) @@ -3637,35 +3793,6 @@ clearVarPermsM = local $ \info -> info { itiPermCtx = RL.map (const PTrans_True) $ itiPermCtx info } --- | 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_tptrans str f = - do ev <- infoEvType <$> ask - ret_tp <- returnTypeM - k_tm <- lambdaTransM str m_tptrans f - let m_tp = typeTransTupleType m_tptrans - return $ bindSOpenTerm ev 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 - --- | Build the monadic return type @SpecM E ret@, where @ret@ is the current --- return type in 'itiReturnType' -compReturnTypeM :: ImpTransM ext blocks tops rets ps_out ctx OpenTerm -compReturnTypeM = - do ev <- infoEvType <$> ask - ret_tp <- returnTypeM - return $ applyGlobalOpenTerm "Prelude.SpecM" [evTypeTerm ev, ret_tp] - --- | Like 'compReturnTypeM' but build a 'TypeTrans' -compReturnTypeTransM :: - ImpTransM ext blocks tops rets ps_out ctx (TypeTrans OpenTerm) -compReturnTypeTransM = openTermTypeTrans <$> compReturnTypeM - -- | Build an @errorS@ computation with the given error message mkErrorComp :: String -> ImpTransM ext blocks tops rets ps_out ctx OpenTerm mkErrorComp msg = @@ -3968,18 +4095,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 |] -> @@ -3987,9 +4114,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 - withPermStackM id + sigmaPermTransM "x_ex" tp_trans (mbCombine RL.typeCtxProxies p) + etrans getTopPermM $ \trm -> + withPermStackM id (\(pctx :>: _) -> pctx :>: typeTransF out_trans [trm]) m @@ -4004,10 +4131,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 |] -> @@ -4114,14 +4243,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 @@ -4155,9 +4284,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 |] -> @@ -4167,9 +4295,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 |] -> @@ -4211,9 +4340,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 _ _ |] -> @@ -4314,19 +4442,21 @@ 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 - let arr_out_comp_tm = - applyGlobalOpenTerm "Prelude.appendCastBVVecS" - [evTypeTerm ev, 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' -> + transTerm1M ptrans1 $ \t1 -> + transTerm1M ptrans2 $ \t2 -> + let arr_out_comp_tm = + applyGlobalOpenTerm "Prelude.appendCastBVVecS" + [evTypeTerm ev, w_term, len1_tm, len2_tm, len3_tm, + elem_tp, t1, t2] in + 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 _ _ _ |] -> @@ -4348,7 +4478,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of let vec_cast_m = applyGlobalOpenTerm "Prelude.castVecS" [evTypeTerm ev, elem_tp, natOpenTerm 0, bvZero_nat_tm, vec_tm] - bindSpecMTransM vec_cast_m ap_tp_trans "empty_vec" $ \ptrans_arr -> + bindTransM vec_cast_m ap_tp_trans "empty_vec" $ \ptrans_arr -> withPermStackM (:>: translateVar x) (\pctx -> pctx :>: PTrans_Conj [APTrans_LLVMArray ptrans_arr]) m @@ -4356,11 +4486,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 = applyGlobalOpenTerm "Prelude.repeatBVVec" - [w_tm, len_tm, elem_tp, transTerm1 ptrans_block] in + [w_tm, len_tm, elem_tp, termsExpect1 ts] in pctx :>: PTrans_Conj [APTrans_LLVMArray $ typeTransF ap_tp_trans [arr_term]] :>: ptrans_block) @@ -4373,18 +4503,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] -} applyGlobalOpenTerm "Prelude.repeatBVVec" - [w_tm, len_tm, elem_tp, transTerm1 ptrans_cell] in + [w_tm, len_tm, elem_tp, tupleOpenTerm' ts] in pctx :>: PTrans_Conj [APTrans_LLVMArray $ typeTransF ap_tp_trans [arr_term]]) m @@ -4440,13 +4570,8 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of "translateSimplImpl: SImpl_LLVMArrayCellCopy" 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) - { llvmArrayTransPerm = - mbMap2 (\ap cell -> - llvmArrayRemBorrow (FieldBorrow cell) ap) mb_ap mb_cell } - withPermStackM RL.tail + setLLVMArrayTransCell arr_trans cell_tm aptrans_cell $ \arr_trans' -> + withPermStackM RL.tail (\(pctx :>: _ :>: _) -> pctx :>: PTrans_Conj [APTrans_LLVMArray arr_trans']) m @@ -4475,13 +4600,14 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of -- mapBVVecM monadic combinator ptrans_arr <- getTopPermM ev <- infoEvType <$> ask - let arr_out_comp_tm = - applyGlobalOpenTerm "Prelude.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' -> + transTerm1M ptrans_arr $ \ptrans_arr_t -> + let arr_out_comp_tm = + applyGlobalOpenTerm "Prelude.mapBVVecS" + [evTypeTerm ev, elem_tp, typeTransType1 cell_out_trans, impl_tm, + w_term, len_term, ptrans_arr_t] in + -- Now use bindS to bind the result of arr_out_comp_tm in the remaining + -- computation + bindTransM arr_out_comp_tm p_out_trans "mapped_array" $ \ptrans_arr' -> withPermStackM id (\(pctx :>: _) -> pctx :>: ptrans_arr') m [nuMP| SImpl_LLVMFieldIsPtr x _ |] -> @@ -4511,13 +4637,14 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of 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 - withPermStackM + withPermStackTermsM + (\ (_ :>: ptrans_x :>: _ :>: _) -> ptrans_x) (\(ns :>: x :>: _ :>: l2) -> ns :>: x :>: l2) - (\case + (\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 (transTerms ptrans_x) :>: + 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) @@ -4563,12 +4690,13 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of [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 _ mb_ls tps_in tps_out _ _ tps_in' tps_out' @@ -4638,8 +4766,9 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of ev <- infoEvType <$> ask case some_lotr of SomeLOwnedTrans lotr -> - bindSpecMTransM - (callSOpenTerm ev d (lownedTransTerm ps_in lotr) (transTerms pctx_in)) + transTermsM pctx_in $ \pctx_in_ts -> + lownedTransTerm ps_in lotr $ \funix -> + bindTransM (callSOpenTerm ev d funix pctx_in_ts) (descTypeTrans dtr_out) "endl_ps" (\pctx_out -> @@ -4652,10 +4781,13 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of [nuMP| SImpl_IntroLOwnedSimple _ _ _ |] -> do let prx_ps_l = mbRAssignProxies $ mbSimplImplIn mb_simpl ttrans <- translateSimplImplOut mb_simpl - withPermStackM id + withPermStackTermsM (\pctx -> + let (_, pctx_ps :>: _) = RL.split ps0 prx_ps_l pctx in pctx_ps) + id + (\ts pctx -> let (pctx0, pctx_ps :>: _) = RL.split ps0 prx_ps_l pctx in - RL.append pctx0 $ typeTransF ttrans (transTerms pctx_ps)) + RL.append pctx0 $ typeTransF ttrans ts) m [nuMP| SImpl_ElimLOwnedSimple mb_l mb_tps mb_ps |] -> @@ -4687,8 +4819,8 @@ 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 _ |] -> @@ -4718,16 +4850,15 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of [nuMP| SImpl_IntroLLVMBlockSeqEmpty _ _ |] -> 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_ElimLLVMBlockSeqEmpty _ _ |] -> 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_SplitLLVMBlockEmpty _ _ _ |] -> @@ -4745,19 +4876,18 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of do ttrans <- translateSimplImplOutHead mb_simpl let args_ctx = mbLift $ fmap namedShapeArgs nmsh' d <- substNamedIndTpDesc (mbLift mb_sh_id) args_ctx mb_args - withPermStackM id - (\(pctx :>: ptrans_x) -> + withPermStackTopTermsM id + (\ts (pctx :>: _) -> pctx :>: typeTransF ttrans [applyGlobalOpenTerm "Prelude.foldTpElem" - [d, transTupleTerm ptrans_x]]) + [d, tupleOpenTerm' ts]]) 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 (transTerms ptrans)) + withPermStackTopTermsM id + (\ts (pctx :>: _) -> pctx :>: typeTransF ttrans ts) m | otherwise -> @@ -4773,19 +4903,19 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of do ttrans <- translateSimplImplOutHead mb_simpl let args_ctx = mbLift $ fmap namedShapeArgs nmsh' d <- substNamedIndTpDesc (mbLift mb_sh_id) args_ctx mb_args - withPermStackM id - (\(pctx :>: ptrans_x) -> + withPermStackTopTermsM id + (\ts (pctx :>: _) -> pctx :>: typeTransF ttrans [applyGlobalOpenTerm "Prelude.unfoldTpElem" - [d, transTupleTerm ptrans_x]]) + [d, tupleOpenTerm' ts]]) m -- Elim for a defined named shape (the other case) is a no-op | [nuMP| DefinedShapeBody _ |] <- mbMatch $ fmap namedShapeBody nmsh -> do ttrans <- translateSimplImplOutHead mb_simpl - withPermStackM id - (\(pctx :>: ptrans) -> - pctx :>: typeTransF ttrans (transTerms ptrans)) + withPermStackTopTermsM id + (\ts (pctx :>: _) -> + pctx :>: typeTransF ttrans ts) m | otherwise -> @@ -4793,110 +4923,110 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of [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 (transTerms 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 (transTerms ptrans)) + withPermStackTopTermsM id + (\ts (pctx :>: _) -> + pctx :>: typeTransF ttrans ts) m [nuMP| SImpl_ElimLLVMBlockField _ _ |] -> 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_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) -> - pctx :>: typeTransF ttrans (transTerms ptrans1 - ++ transTerms ptrans2)) + withPermStackTermsM + (\(_ :>: ptrans1 :>: ptrans2) -> (ptrans1,ptrans2)) + RL.tail + (\ts (pctx :>: _ :>: _) -> pctx :>: typeTransF ttrans ts) m [nuMP| SImpl_ElimLLVMBlockSeq _ _ _ |] -> 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_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]) + withPermStackTopTermsM id + (\ts (pctx :>: _) -> pctx :>: typeTransF ttrans [termsExpect1 ts]) m [nuMP| SImpl_FoldNamed _ (NamedPerm_Rec mb_rp) mb_args _ |] -> @@ -4904,11 +5034,11 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of 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 - withPermStackM id - (\(pctx :>: ptrans_x) -> + withPermStackTopTermsM id + (\ts (pctx :>: _) -> pctx :>: typeTransF ttrans [applyGlobalOpenTerm "Prelude.foldTpElem" - [d, transTupleTerm ptrans_x]]) + [d, tupleOpenTerm' ts]]) m [nuMP| SImpl_UnfoldNamed _ (NamedPerm_Rec mb_rp) mb_args _ |] -> @@ -4916,25 +5046,23 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of 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 - withPermStackM id - (\(pctx :>: ptrans_x) -> + withPermStackTopTermsM id + (\ts (pctx :>: _) -> pctx :>: typeTransF ttrans [applyGlobalOpenTerm "Prelude.unfoldTpElem" - [d, transTupleTerm ptrans_x]]) + [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 {- @@ -4943,40 +5071,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 @@ -4984,16 +5113,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) [applyGlobalOpenTerm 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 _ _ _ |] -> @@ -5091,11 +5225,12 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o tps <- mapM translate $ mbOrListDisjs mb_or_list tp_ret <- compReturnTypeTransM top_ptrans <- getTopPermM - eithersElimTransM tps tp_ret + transTerm1M top_ptrans $ \top_t -> + eithersElimTransM tps tp_ret (flip map maybe_transs $ \maybe_trans ptrans -> withPermStackM id ((:>: ptrans) . RL.tail) $ popPImplTerm (forcePImplTerm maybe_trans) k) - (transTupleTerm top_ptrans) + top_t -- An existential elimination performs a pattern-match on a Sigma ([nuMP| Impl1_ElimExists x p |], _) -> @@ -5104,13 +5239,14 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o () <- assertTopPermM "Impl1_ElimExists" x (fmap ValPerm_Exists p) top_ptrans <- getTopPermM tp_trans <- translateClosed tp - sigmaElimPermTransM "x_elimEx" tp_trans + transTerm1M top_ptrans $ \top_t -> + sigmaElimPermTransM "x_elimEx" tp_trans (mbCombine RL.typeCtxProxies p) compReturnTypeTransM (\etrans ptrans -> inExtTransM etrans $ withPermStackM id ((:>: ptrans) . RL.tail) m) - (transTerm1 top_ptrans) + top_t -- A false elimination becomes a call to efq ([nuMP| Impl1_ElimFalse mb_x |], _) -> @@ -5118,8 +5254,8 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o do mb_false <- nuMultiTransM $ const ValPerm_False () <- assertTopPermM "Impl1_ElimFalse" mb_x mb_false top_ptrans <- getTopPermM - applyGlobalTransM "Prelude.efq" - [compReturnTypeM, return $ transTerm1 top_ptrans] + transTerm1M top_ptrans $ \top_t -> + applyGlobalTransM "Prelude.efq" [compReturnTypeM, return top_t] -- A SimplImpl is translated using translateSimplImpl ([nuMP| Impl1_Simpl simpl mb_prx |], _) -> @@ -5193,10 +5329,9 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o . Perm_LLVMBlockShape . modalizeBlockShape |]) $ extMb mb_bp tp_trans2 <- translate mb_p_out2 - withPermStackM (:>: Member_Base) - (\(pctx :>: ptrans) -> - pctx :>: typeTransF tp_trans1 [] :>: - typeTransF tp_trans2 (transTerms ptrans)) + withPermStackTopTermsM (:>: Member_Base) + (\ts (pctx :>: _) -> + pctx :>: typeTransF tp_trans1 [] :>: typeTransF tp_trans2 ts) m ([nuMP| Impl1_SplitLLVMWordField _ mb_fp mb_sz1 mb_endianness |], _) -> @@ -5505,7 +5640,8 @@ instance ImplTranslateF (LocalImplRet ps) ext blocks ps_in rets where do pctx <- itiPermStack <$> ask ev <- infoEvType <$> ask ret_tp <- returnTypeM - return $ retSOpenTerm ev ret_tp (transTupleTerm pctx) + transTupleTermM pctx $ \pctx_t -> + return $ retSOpenTerm ev ret_tp pctx_t -- | Translate a local implication to its output, adding an error message translateLocalPermImpl :: String -> Mb ctx (LocalPermImpl ps_in ps_out) -> @@ -5879,7 +6015,7 @@ translateCallEntry nm entry_trans mb_tops mb_args mb_ghosts = ectx_ag <- translate $ mbMap2 RL.append mb_args mb_ghosts ectx <- translate (mbMap2 RL.append (mbMap2 RL.append mb_tops mb_args) mb_ghosts) - stack <- itiPermStack <$> ask + pctx <- itiPermStack <$> ask let mb_tops_args = mbMap2 RL.append mb_tops mb_args let mb_s = mbMap2 (\args ghosts -> @@ -5895,19 +6031,20 @@ translateCallEntry nm entry_trans mb_tops mb_args mb_ghosts = -- If so, build the associated CallS term, which applies the function -- index to all the terms in the args and ghosts (but not the tops, -- which are free) plus all the permissions on the stack + transTermsM pctx $ \pctx_ts -> do ev <- infoEvType <$> ask - pctx <- itiPermStack <$> ask return (callSOpenTerm ev d funix - (exprCtxToTerms ectx_ag ++ permCtxToTerms pctx)) + (exprCtxToTerms ectx_ag ++ pctx_ts)) Nothing -> -- Otherwise, continue translating with the target entrypoint, with all -- the current expressions free but with only those permissions on top -- of the stack + transTermsM pctx $ \pctx_ts -> inEmptyEnvImpTransM $ inCtxTransM ectx $ do perms_trans <- translate $ typedEntryPermsIn entry withPermStackM (const $ RL.members ectx) - (const $ typeTransF perms_trans $ transTerms stack) + (const $ typeTransF perms_trans pctx_ts) (translate $ _mbBinding $ typedEntryBody entry) instance PermCheckExtC ext exprExt => @@ -5985,16 +6122,16 @@ translateStmt loc mb_stmt m = case mbMatch mb_stmt of openTermTypeTrans <$> sigmaTypeTransM "ret" rets_trans (\ectx -> inExtMultiTransM ectx (translate perms_out)) - let all_args = - exprCtxToTerms ectx_gexprs ++ exprCtxToTerms ectx_args ++ - permCtxToTerms pctx_ghosts_args - let fapp_trm = case f_trans of - PTrans_Fun _ f_trm -> applyFunTransTerm f_trm all_args - _ -> - panic "translateStmt" - ["TypedCall: unexpected function permission"] - bindSpecMTransM - fapp_trm fret_tp "call_ret_val" $ \ret_val -> + transTermsM pctx_ghosts_args $ \pctx_ghosts_ts -> + let all_args = + exprCtxToTerms ectx_gexprs ++ exprCtxToTerms ectx_args ++ + pctx_ghosts_ts + fapp_trm = case f_trans of + PTrans_Fun _ f_trm -> applyFunTransTerm f_trm all_args + _ -> + panic "translateStmt" + ["TypedCall: unexpected function permission"] in + 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 -> @@ -6196,12 +6333,11 @@ instance PermCheckExtC ext exprExt => let rets_prxs = cruCtxProxies $ mbLift mb_rets rets_ns_trans <- translate mb_rets_ns ret_tp <- returnTypeM - sigma_trm <- - sigmaTransM "r" rets_trans + sigmaTransM "r" rets_trans (flip inExtMultiTransM $ translate $ mbCombine rets_prxs mb_perms) rets_ns_trans (itiPermStack <$> ask) - return $ retSOpenTerm ev ret_tp sigma_trm + (return . retSOpenTerm ev ret_tp) instance PermCheckExtC ext exprExt => ImplTranslateF (TypedRet tops rets) ext blocks tops rets where @@ -6364,8 +6500,8 @@ translateTypedBlockMap ixs blkMap = -- | Build a nested lambda-abstraction over a sequence of function indexes of -- the given type descriptions and pass them to the supplied function lambdaFunIxsM :: String -> [OpenTerm] -> - ([OpenTerm] -> TypeTransM ctx OpenTerm) -> - TypeTransM ctx OpenTerm + ([OpenTerm] -> TransM info ctx OpenTerm) -> + TransM info ctx OpenTerm lambdaFunIxsM nm ds f = lambdaTransM nm (openTermsTypeTrans $ map funIxTypeOpenTerm ds) f @@ -6424,6 +6560,8 @@ translateCFGInitBody mapTrans cfg pctx = ghosts = typedFnHandleGhosts h retTypes = typedFnHandleRetTypes h in translateRetType retTypes (tpcfgOutputPerms cfg) >>= \retTypeTrans -> + impTransM (RL.members pctx) pctx mapTrans retTypeTrans $ + transTermsM pctx $ \pctx_ts -> -- Extend the expr context to contain another copy of the initial arguments -- inits, since the initial entrypoint for the entire function takes two @@ -6437,11 +6575,10 @@ translateCFGInitBody mapTrans cfg pctx = -- 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_membs = RL.members pctx' + let pctx' = typeTransF ps'_trans pctx_ts all_px = RL.map (\_ -> Proxy) pctx' init_entry = lookupEntryTransCast (tpcfgEntryID cfg) CruCtxNil mapTrans in - impTransM all_membs pctx' mapTrans retTypeTrans $ + 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) @@ -6566,11 +6703,13 @@ translateCFGFromBodies cfgs bodies i ectx <- infoCtx <$> ask ds <- mapM translateSomeCFGDesc cfgs ret_tp <- translateRetType (funPermRets fun_perm) (funPermOuts fun_perm) - body <- - lambdaFunIxsM "f" ds $ \funixs -> - return $ callSOpenTerm ev (ds!!i) (funixs!!i) (transTerms ectx ++ - transTerms pctx) - return $ letRecSOpenTerm ev ds ret_tp bodies body + specMTransM ret_tp $ + transTermsM pctx $ \pctx_ts -> + do body <- + lambdaFunIxsM "f" ds $ \funixs -> + return $ callSOpenTerm ev (ds!!i) (funixs!!i) (transTerms ectx + ++ pctx_ts) + 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 From 39e6f363aefa1706623368e8de842556671b45d4 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 26 Oct 2023 17:46:44 -0700 Subject: [PATCH 165/305] whoops, used pairTypeOpenTerm instead o9f pairOpenTerm in tupleOpenTerm' --- saw-core/src/Verifier/SAW/OpenTerm.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/saw-core/src/Verifier/SAW/OpenTerm.hs b/saw-core/src/Verifier/SAW/OpenTerm.hs index f13b12a42d..9c57542ffe 100644 --- a/saw-core/src/Verifier/SAW/OpenTerm.hs +++ b/saw-core/src/Verifier/SAW/OpenTerm.hs @@ -274,7 +274,7 @@ projTupleOpenTerm i t = projTupleOpenTerm (i-1) (pairRightOpenTerm t) -- as the right-most element tupleOpenTerm' :: [OpenTerm] -> OpenTerm tupleOpenTerm' [] = unitOpenTerm -tupleOpenTerm' ts = foldr1 pairTypeOpenTerm ts +tupleOpenTerm' ts = foldr1 pairOpenTerm ts -- | Build a right-nested tuple type as an 'OpenTerm' but without adding a final -- unit type as the right-most element From 012bb8bac599a718eca5f5852c5bcc4ad24adc32 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 26 Oct 2023 17:51:31 -0700 Subject: [PATCH 166/305] whoops, forgot to add a SpecM to the output type of LambdaS --- saw-core/prelude/Prelude.sawcore | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/saw-core/prelude/Prelude.sawcore b/saw-core/prelude/Prelude.sawcore index e139bc74ae..a505055e5e 100644 --- a/saw-core/prelude/Prelude.sawcore +++ b/saw-core/prelude/Prelude.sawcore @@ -2952,7 +2952,8 @@ specFun E env_top T_top = primitive CallS : (E:EvType) -> (T:TpDesc) -> FunIx T -> specFun E nilTpEnv T; -- Create a function index from a specification function in a specification -primitive LambdaS : (E:EvType) -> (T:TpDesc) -> specFun E nilTpEnv T -> FunIx T; +primitive LambdaS : (E:EvType) -> (T:TpDesc) -> specFun E nilTpEnv T -> + SpecM E (FunIx T); -- Create a lambda as a fixed-point that can call itself. Note that the type of -- f, FunIx T -> specFun E nil T, is the same as specFun E nil (Tp_Arr T T) when From e0cd677842bb449828a414113ca6c29533c47288 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 26 Oct 2023 18:15:01 -0700 Subject: [PATCH 167/305] small bug fixes --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 50ed8e78b1..a4221dfe7d 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -1091,10 +1091,10 @@ sigmaTransM x tp_l tp_r lhs rhs_m k = do info <- ask rhs <- rhs_m transTupleTermM rhs $ \rhs_tm -> - return (sigmaOpenTermMulti x (typeTransTypes tp_l) - (typeTransTupleType . flip runTransM info . tp_r . typeTransF tp_l) - (transTerms lhs) - rhs_tm) + k (sigmaOpenTermMulti x (typeTransTypes tp_l) + (typeTransTupleType . flip runTransM info . tp_r . typeTransF tp_l) + (transTerms lhs) + rhs_tm) -- | Like `sigmaTransM`, but translates `exists x.eq(y)` into just `x` sigmaPermTransM :: (TransInfo info, IsTermTransM info ctx trR2) => @@ -2639,6 +2639,8 @@ setLLVMArrayTransSlice arr_trans sub_arr_trans off_tm = -- * Translations of Lifetime Ownership Permissions ---------------------------------------------------------------------- +-- FIXME: lownedInfoEvType field is redundant now that we have lownedInfoEnv + -- | 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 @@ -2854,14 +2856,15 @@ lownedTransTermFun :: PermEnv -> ExprTransCtx ctx -> LOwnedTransTerm ctx ps_in ps_out -> OpenTerm lownedTransTermFun env ectx vars_in tps_in tps_out t = lambdaTrans "p" (descTypeTrans tps_in) $ \ps_in -> - let ret_tp = typeTransTupleType $ descTypeTrans tps_out in + let ret_tp = typeTransTupleType $ descTypeTrans tps_out + ev = permEnvEventType env in let loInfo = LOwnedInfo { lownedInfoECtx = ectx, lownedInfoPCtx = ps_in, lownedInfoPVars = vars_in, - lownedInfoEvType = permEnvEventType env, + lownedInfoEvType = ev, lownedInfoRetType = ret_tp, lownedInfoEnv = env } in runLOwnedTransM (t >>> pctxInTermsLOwnedTransM) reflExprCtxExt loInfo $ - \_ loInfo_out ts -> tupleOpenTerm' ts + \_ loInfo_out ts -> retSOpenTerm ev ret_tp $ tupleOpenTerm' ts -- | Extend the expression context of an 'LOwnedTransTerm' extLOwnedTransTerm :: ExprTransCtx ctx2 -> @@ -3011,7 +3014,7 @@ lownedTransTerm (mbExprPermsMembers -> Just vars_in) lotr k = vars_in (lotrTpTransIn lotr) (lotrTpTransOut lotr) lot ix_tptrans = openTermTypeTrans (funIxTypeOpenTerm d) ev <- infoEvType <$> ask - bindTransM (lambdaSOpenTerm ev d f) ix_tptrans "f_lowned" return + bindTransM (lambdaSOpenTerm ev d f) ix_tptrans "f_lowned" k lownedTransTerm _ _ _ = return $ failOpenTerm "FIXME HERE NOW: write this error message" From bf9212282a12dfa555cfcf2f6e09d5487d8932ea Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 27 Oct 2023 06:23:34 -0700 Subject: [PATCH 168/305] whoops, messed up the translation of the SImpl_LLVMArrayCellReturn rule when converting to monadic transTermsM --- .../src/Verifier/SAW/Heapster/SAWTranslation.hs | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index a4221dfe7d..85fc3f5100 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -4570,13 +4570,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 -} + let arr_trans' = arr_trans + { llvmArrayTransPerm = + mbMap2 (\ap cell -> + llvmArrayRemBorrow (FieldBorrow cell) ap) mb_ap mb_cell } cell_tm <- translate1 mb_cell - setLLVMArrayTransCell arr_trans cell_tm aptrans_cell $ \arr_trans' -> + setLLVMArrayTransCell arr_trans' cell_tm aptrans_cell $ \arr_trans'' -> 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 |] -> From 3e27d9c5a98337c55279849da7246f285b84fe5b Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 27 Oct 2023 11:02:26 -0700 Subject: [PATCH 169/305] bug fix in bindTransM to use lambdaTupleTransM; also added some FIXMEs for optimizing the translation of lifetimes --- heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 85fc3f5100..80c1640ae4 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -1187,7 +1187,7 @@ bindTransM :: TransInfoM info => OpenTerm -> TypeTrans tr -> String -> bindTransM m m_tptrans str f = do ev <- infoEvType <$> ask ret_tp <- returnTypeM - k_tm <- lambdaTransM str m_tptrans f + k_tm <- lambdaTupleTransM str m_tptrans f let m_tp = typeTransTupleType m_tptrans return $ bindSOpenTerm ev m_tp ret_tp m k_tm @@ -2936,6 +2936,10 @@ mapLtLOwnedTransTerm prx_extra1 prx_extra2 prx_in t1 t2 = loInfoAppend (extLOwnedInfoExt cext' info_extra2) info_out) >>> extLOwnedTransM cext t2 +-- FIXME HERE NOW: LOwnedTrans should have an extra constructor for a function +-- index that has not yet been converted to an LOwnedTransTerm; or maybe +-- LOwnedTransTerm should have the two constructors? + -- | The translation of an @lowned@ permission data LOwnedTrans ctx ps_extra ps_in ps_out = LOwnedTrans { @@ -6046,6 +6050,8 @@ translateCallEntry nm entry_trans mb_tops mb_args mb_ghosts = -- Otherwise, continue translating with the target entrypoint, with all -- the current expressions free but with only those permissions on top -- of the stack + -- + -- FIXME HERE NOW: can we avoid doing transTermsM here? transTermsM pctx $ \pctx_ts -> inEmptyEnvImpTransM $ inCtxTransM ectx $ do perms_trans <- translate $ typedEntryPermsIn entry From f62b49384e7d069eaa3e06641678dedd9856b8cf Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 27 Oct 2023 18:12:51 -0700 Subject: [PATCH 170/305] fixed projTupleOpenTerm' and its uses to be consistent --- .../Verifier/SAW/Heapster/LLVMGlobalConst.hs | 5 ++-- .../Verifier/SAW/Heapster/SAWTranslation.hs | 5 ++-- saw-core/src/Verifier/SAW/OpenTerm.hs | 29 +++++-------------- src/SAWScript/Crucible/LLVM/FFI.hs | 4 +-- 4 files changed, 16 insertions(+), 27 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/LLVMGlobalConst.hs b/heapster-saw/src/Verifier/SAW/Heapster/LLVMGlobalConst.hs index 1563399661..79edf1485e 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/LLVMGlobalConst.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/LLVMGlobalConst.hs @@ -301,9 +301,10 @@ permEnvAddGlobalConst sc mod_name dlevel endianness w env global = scInsertDef sc mod_name ident complete_tp complete_t let p = ValPerm_LLVMBlock $ llvmReadBlockOfShape sh let t_ident = globalOpenTerm ident + let tps_len = fromIntegral $ length tps let projs = - map (\i -> projTupleOpenTerm' tps i t_ident) - [0 .. toInteger (length ts - 1)] + map (\i -> projTupleOpenTerm' tps_len i t_ident) $ + take (length ts) [0 ..] return $ permEnvAddGlobalSyms env [PermEnvGlobalEntry (GlobalSymbol $ L.globalSym global) p (GlobalTransTerms projs)] diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 80c1640ae4..a520de58f6 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -502,8 +502,9 @@ tupleTypeTrans ttrans = TypeTrans [tupleTypeOpenTerm' tps] (\case [t] -> - typeTransF ttrans $ map (\i -> projTupleOpenTerm' tps i t) $ - take (length $ typeTransTypes ttrans) [0..] + 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 diff --git a/saw-core/src/Verifier/SAW/OpenTerm.hs b/saw-core/src/Verifier/SAW/OpenTerm.hs index 83e4d205b4..f942b0d213 100644 --- a/saw-core/src/Verifier/SAW/OpenTerm.hs +++ b/saw-core/src/Verifier/SAW/OpenTerm.hs @@ -103,7 +103,6 @@ import Numeric.Natural import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap -import Verifier.SAW.Utils (panic) import Verifier.SAW.Term.Functor import Verifier.SAW.Term.Pretty import Verifier.SAW.SharedTerm @@ -284,27 +283,15 @@ tupleTypeOpenTerm' [] = unitTypeOpenTerm tupleTypeOpenTerm' ts = foldr1 pairTypeOpenTerm ts -- | Project the @i@th element from a term of a right-nested tuple term that --- does not have a final unit type as the right-most type. Note that this --- requires knowing the length of @tps@. -projTupleOpenTerm' :: [OpenTerm] -> Integer -> OpenTerm -> OpenTerm -projTupleOpenTerm' [] _ _ = - panic "projTupleOpenTerm'" ["projection of empty tuple!"] -projTupleOpenTerm' [_] 0 tup = tup -projTupleOpenTerm' (_:_) 0 tup = pairLeftOpenTerm tup -projTupleOpenTerm' (_:tps) i tup = - projTupleOpenTerm' tps (i-1) $ pairRightOpenTerm tup - -======= --- | Given an index and total length, project out of a right-nested tuple --- without unit as the right-most element +-- 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"] ->>>>>>> master +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 diff --git a/src/SAWScript/Crucible/LLVM/FFI.hs b/src/SAWScript/Crucible/LLVM/FFI.hs index fff80c5186..38a7d62f66 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) From fbd3d74bde27b7cb7af7c43a244e1728aaf9c699 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Thu, 2 Nov 2023 14:14:26 -0700 Subject: [PATCH 171/305] make MRSolver debug commands uniformly named --- src/SAWScript/Prover/MRSolver/Monad.hs | 24 ++++++++++++------------ src/SAWScript/Prover/MRSolver/SMT.hs | 20 ++++++++++---------- src/SAWScript/Prover/MRSolver/Solver.hs | 8 ++++---- 3 files changed, 26 insertions(+), 26 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/Monad.hs b/src/SAWScript/Prover/MRSolver/Monad.hs index d0346b350c..d1168f17d9 100644 --- a/src/SAWScript/Prover/MRSolver/Monad.hs +++ b/src/SAWScript/Prover/MRSolver/Monad.hs @@ -688,8 +688,8 @@ mrFunOutType fname args = (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) + mrDebugPrint 0 "mrFunOutType: function does not have SpecM return type" + mrDebugPretty 0 ("Function:" <> pp_fname <> " with type: " <> pp_ftype) error "mrFunOutType" -- | Turn a 'LocalName' into one not in a list, adding a suffix if necessary @@ -932,7 +932,7 @@ 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) >> + mrDebugPretty 3 ("mrSetVarInfo" <+> ppInEmptyCtx var <+> "=" <+> ppInEmptyCtx info) >> (modify $ \st -> st { mrsVars = Map.alter (\case @@ -1073,7 +1073,7 @@ 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 mrDebugPretty 2 ("withCoIndHyp" <+> ppInEmptyCtx hyp) hyps' <- Map.insert (coIndHypLHSFun hyp, coIndHypRHSFun hyp) hyp <$> mrCoIndHyps local (\info -> info { mriCoIndHyps = hyps' }) m @@ -1209,19 +1209,19 @@ recordUsedFunAssump _ = return () ---------------------------------------------------------------------- -- | Print a 'String' if the debug level is at least the supplied 'Int' -debugPrint :: Int -> String -> MRM t () -debugPrint i str = +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 +mrDebugPretty :: Int -> SawDoc -> MRM t () +mrDebugPretty i pp = mrDebugPrint i $ renderSawDoc defaultPPOpts pp -- | Pretty-print an object in the current context 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) +mrDebugPrettyInCtx :: PrettyInCtx a => Int -> a -> MRM t () +mrDebugPrettyInCtx i a = mrUVars >>= \ctx -> mrDebugPrint i (showInCtx ctx a) -- | Pretty-print an object relative to the current context mrPPInCtx :: PrettyInCtx a => a -> MRM t SawDoc @@ -1232,7 +1232,7 @@ mrPPInCtx a = runPPInCtxM (prettyInCtx a) <$> mrUVars mrDebugPPPrefix :: PrettyInCtx a => Int -> String -> a -> MRM t () mrDebugPPPrefix i pre a = mrUVars >>= \ctx -> - debugPretty i $ + mrDebugPretty i $ runPPInCtxM (group <$> nest 2 <$> ppWithPrefix pre a) ctx -- | Pretty-print the result of 'ppWithPrefixSep' relative to the current uvar @@ -1241,5 +1241,5 @@ mrDebugPPPrefixSep :: (PrettyInCtx a, PrettyInCtx b) => Int -> String -> a -> String -> b -> MRM t () mrDebugPPPrefixSep i pre a1 sp a2 = mrUVars >>= \ctx -> - debugPretty i $ + mrDebugPretty i $ runPPInCtxM (group <$> nest 2 <$> ppWithPrefixSep pre a1 sp a2) ctx diff --git a/src/SAWScript/Prover/MRSolver/SMT.hs b/src/SAWScript/Prover/MRSolver/SMT.hs index 55f822e474..4c0813a561 100644 --- a/src/SAWScript/Prover/MRSolver/SMT.hs +++ b/src/SAWScript/Prover/MRSolver/SMT.hs @@ -360,8 +360,8 @@ smtNorm sc 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:" >> + mrDebugPrettyInCtx 2 t >> liftSC1 smtNorm t -- | Normalize an open term by wrapping it in lambdas, normalizing, and then @@ -394,8 +394,8 @@ 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) + mrDebugPrint 2 ("Calling SMT solver with proposition: " ++ + prettyProp defaultPPOpts 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 @@ -406,19 +406,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) -> + mrDebugPrint 2 "SMT solver response: not provable" >> + mrDebugPrint 3 ("Counterexample:" ++ concatMap (\(x,v) -> "\n - " ++ renderSawDoc defaultPPOpts (ppTerm defaultPPOpts (Unshared (FTermF (ExtCns x)))) ++ " = " ++ renderSawDoc defaultPPOpts (ppFirstOrderValue defaultPPOpts 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 @@ -824,7 +824,7 @@ mrProveRel het t1 t2 = 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" + mrDebugPrint 2 $ nm ++ ": " ++ if res then "Success" else "Failure" return res -- | Prove that two terms are related, heterogeneously iff the first argument, diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index 01214baeec..6cdbf38b22 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -755,7 +755,7 @@ proveCoIndHyp hyp = withFailureCtx (FailCtxCoIndHyp hyp) $ f2 = coIndHypRHSFun hyp args1 = coIndHypLHS hyp args2 = coIndHypRHS hyp - debugPretty 1 ("proveCoIndHyp" <+> ppInEmptyCtx hyp) + mrDebugPretty 1 ("proveCoIndHyp" <+> ppInEmptyCtx hyp) lhs <- fromMaybe (error "proveCoIndHyp") <$> mrFunBody f1 args1 rhs <- fromMaybe (error "proveCoIndHyp") <$> mrFunBody f2 args2 (invar1, invar2) <- applyCoIndHypInvariants hyp @@ -1106,7 +1106,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 mrDebugPretty 2 $ flip runPPInCtxM ctx $ prettyAppList [return "mrRefines using opaque FunAssump:", prettyInCtx ctx, return ".", prettyTermApp (funNameTerm f1) args1', @@ -1130,7 +1130,7 @@ 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 $ + do mrDebugPretty 2 $ flip runPPInCtxM ctx $ prettyAppList [return "mrRefines rewriting by FunAssump:", prettyInCtx ctx, return ".", prettyTermApp (funNameTerm f1) args1', @@ -1174,7 +1174,7 @@ mrRefines' m1@(FunBind f1 args1 isLifted1 k1) -- up _ -> do if isLifted1 /= isLifted2 - then debugPrint 1 "mrRefines: isLifted cases do not match" + then mrDebugPrint 1 "mrRefines: isLifted cases do not match" else mrDebugPPPrefixSep 1 "mrRefines: bind types not equal:" tp1 "/=" tp2 throwMRFailure (CompsDoNotRefine m1 m2) From 55be2bb9aaf67fd256d14bd7a7a606779eade754 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Fri, 3 Nov 2023 15:29:07 -0700 Subject: [PATCH 172/305] warn on Heapster implication failures --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 12 +++++++--- src/SAWScript/HeapsterBuiltins.hs | 24 ++++++++++++++++++- 2 files changed, 32 insertions(+), 4 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 7369ccecc6..1c60d46330 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -35,7 +35,7 @@ import Prelude hiding (pi) import Data.Maybe import Numeric.Natural import Data.List hiding (inits) -import Data.Text (pack) +import Data.Text (Text, pack, append) import GHC.TypeLits import Data.BitVector.Sized (BV) import qualified Data.BitVector.Sized as BV @@ -3627,6 +3627,10 @@ data ImplFailCont -- | An error message to print on failure | ImplFailContMsg String +-- | The prefix used in error strings for implication failures +implicationFailurePrefix :: Text +implicationFailurePrefix = "Heapster implication failure:\n" + -- | "Force" the translation of a possibly failing computation to always return -- a computation, even if it is just the failing computation forceImplTrans :: Maybe (ImplFailCont -> @@ -3637,7 +3641,8 @@ 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)] + let str' = implicationFailurePrefix `append` pack str in + applyNamedSpecOpM "Prelude.errorS" [tp, stringLitOpenTerm str'] -- | Perform a failure by jumping to a failure continuation or signaling an -- error, using an alternate error message in the latter case @@ -3646,7 +3651,8 @@ implTransAltErr :: String -> ImplFailCont -> implTransAltErr _ (ImplFailContTerm errM) = return errM implTransAltErr str (ImplFailContMsg _) = returnTypeM >>= \tp -> - applyNamedSpecOpM "Prelude.errorS" [tp, stringLitOpenTerm (pack str)] + let str' = "Failed to prove: " `append` pack str in + applyNamedSpecOpM "Prelude.errorS" [tp, stringLitOpenTerm str'] -- | Translate a normal unary 'PermImpl1' rule that succeeds and applies the -- translation function if the argument succeeds and fails if the translation of diff --git a/src/SAWScript/HeapsterBuiltins.hs b/src/SAWScript/HeapsterBuiltins.hs index 252b70c0dc..14a553e907 100644 --- a/src/SAWScript/HeapsterBuiltins.hs +++ b/src/SAWScript/HeapsterBuiltins.hs @@ -77,6 +77,7 @@ import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy.UTF8 as BL import GHC.TypeLits import Data.Text (Text) +import qualified Data.Text as T import Data.Binding.Hobbits hiding (sym) import qualified Data.Type.RList as RL @@ -90,6 +91,7 @@ import Verifier.SAW.Term.Functor import Verifier.SAW.Module as Mod import Verifier.SAW.Prelude import Verifier.SAW.SharedTerm +import Verifier.SAW.Recognizer import Verifier.SAW.OpenTerm import Verifier.SAW.Typechecker import Verifier.SAW.SCTypeCheck @@ -1154,7 +1156,7 @@ heapster_typecheck_mut_funs bic opts henv = 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) @@ -1199,6 +1201,26 @@ 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, _) -> liftIO $ + warnErrs nm_to =<< fmap (fromJust . defBody) + (scRequireDef sc $ mkSafeIdent saw_modname nm_to) + where warnErrs :: String -> Term -> IO () + warnErrs nm (asApplyAll -> (asGlobalDef -> Just "Prelude.errorS", + [_ev, _stk, _a, asStringLit -> Just str])) + | Just str' <- T.stripPrefix implicationFailurePrefix str + = let pref = "WARNING: Heapster implication failure while typechecking " + in printOutLn opts Warn (pref ++ nm ++ ":\n" ++ T.unpack str' ++ "\n") + warnErrs nm (asConstant -> Just (_, Just body)) = warnErrs nm body + 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 () heapster_typecheck_fun :: BuiltinContext -> Options -> HeapsterEnv -> From e2fb52353f97130d07877051759930ed57d6584f Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 6 Nov 2023 07:16:32 -0800 Subject: [PATCH 173/305] Changed tpElemEnv to no longer use function indices at all --- saw-core/prelude/Prelude.sawcore | 279 +++++++++++-------------------- 1 file changed, 97 insertions(+), 182 deletions(-) diff --git a/saw-core/prelude/Prelude.sawcore b/saw-core/prelude/Prelude.sawcore index a505055e5e..f5c2b2ce0e 100644 --- a/saw-core/prelude/Prelude.sawcore +++ b/saw-core/prelude/Prelude.sawcore @@ -2707,133 +2707,11 @@ unfoldIndTpDesc env T = -- Elements of type descriptions -- --- An identifier for a corecursive function in a SpecM computation. In the Coq --- model, this is just a natural number index (hence the name), but we leave its --- structure opaque in SAW because client code should not break the abstraction. -primitive FunIx : TpDesc -> sort 0; - --- A list of function indexes with the given types -FunIxs : List TpDesc -> sort 0; -FunIxs = List__rec TpDesc (\ (_:List TpDesc) -> sort 0) #() - (\ (T:TpDesc) (_:List TpDesc) (rec:sort 0) -> FunIx T * rec); - --- Inductively-defined elements of a type description relative to an --- environment, which acts as a substitution of values for the free variables -data indElem : TpEnv -> TpDesc -> sort 0 where { - -- Monadic and function types are just function indexes - Elem_M : (env:TpEnv) -> (R:TpDesc) -> FunIx (tpSubst 0 env (Tp_M R)) -> - indElem env (Tp_M R); - Elem_Pi : (env:TpEnv) -> (K:KindDesc) -> (T:TpDesc) -> - FunIx (tpSubst 0 env (Tp_Pi K T)) -> indElem env (Tp_Pi K T); - Elem_Arr : (env:TpEnv) -> (T U:TpDesc) -> - FunIx (tpSubst 0 env (Tp_Arr T U)) -> indElem env (Tp_Arr T U); - - -- Tp_Kind K is the type of elements of kind K, lowered to the object level - Elem_Kind : (env:TpEnv) -> (K:KindDesc) -> kindElem K -> indElem env (Tp_Kind K); - - -- Elements of pair and sum types are just pairs and sums - Elem_Pair : (env:TpEnv) -> (T U:TpDesc) -> indElem env T -> indElem env U -> - indElem env (Tp_Pair T U); - Elem_SumL : (env:TpEnv) -> (T U:TpDesc) -> indElem env T -> - indElem env (Tp_Sum T U); - Elem_SumR : (env:TpEnv) -> (T U:TpDesc) -> indElem env U -> - indElem env (Tp_Sum T U); - - -- An element of Tp_Sigma K T is an element e of K plus an element of [e/x]U - Elem_Sigma : (env:TpEnv) -> (K:KindDesc) -> (T:TpDesc) -> - (elem1:kindElem K) -> indElem (envConsElem K elem1 env) T -> - indElem env (Tp_Sigma K T); - - -- Elements of vector types are built using nil and cons constructors, to - -- build a vector of elements with a concrete size, along with a final cast - -- constructor, to cast the size to an expression equal to that concrete size - Elem_VecNil : (env:TpEnv) -> (T:TpDesc) -> indElem env (Tp_Vec T TpExprZ); - Elem_VecCons : (env:TpEnv) -> (T:TpDesc) -> (n:Nat) -> - indElem env T -> indElem env (Tp_Vec T (TpExprN n)) -> - indElem env (Tp_Vec T (TpExprN (Succ n))); - Elem_VecCast : (env:TpEnv) -> (T:TpDesc) -> (e1 e2:TpExpr Kind_nat) -> - Eq Nat (evalTpExpr env Kind_nat e1) - (evalTpExpr env Kind_nat e2) -> - indElem env (Tp_Vec T e1) -> indElem env (Tp_Vec T e2); - - -- An element of inductive type Tp_Ind T is an element of the one-step - -- unfolding [Tp_Ind T/x]T of the body of the inductive type. Note that we - -- perform the full substitution of env as part of this unfolding, rather than - -- just adding Tp_Ind T to the current environment, because the two are - -- equivalent, but this version is easier to use. - Elem_Ind : (env:TpEnv) -> (T:TpDesc) -> indElem nilTpEnv (unfoldIndTpDesc env T) -> - indElem env (Tp_Ind T); - - -- An element of a variable is an element of the evaluation of that variable - -- to a type (or of TP_Void if the variable is unbound or of the wrong kind) - Elem_Var : (env:TpEnv) -> (var:Nat) -> indElem nilTpEnv (evalVar 0 env Kind_Tp var) -> - indElem env (Tp_Var var); - - -- No constructor for Tp_Void -} - - --- Elements of a type description relative to an environment. This is isomorphic --- to indElem, above, but yields the types you would expect rather than a single --- inductive type. See indElem for a more detailed explanation of how the types --- are defined. -tpElemEnv : TpEnv -> TpDesc -> sort 0; -tpElemEnv env_top T_top = - TpDesc#rec (\ (_:TpDesc) -> TpEnv -> sort 0) - (\ (R:TpDesc) (_:TpEnv -> sort 0) (env:TpEnv) -> - FunIx (tpSubst 0 env (Tp_M R))) - (\ (K:KindDesc) (T:TpDesc) (_:TpEnv -> sort 0) (env:TpEnv) -> - FunIx (tpSubst 0 env (Tp_Pi K T))) - (\ (T:TpDesc) (_:TpEnv -> sort 0) (U:TpDesc) (_:TpEnv -> sort 0) (env:TpEnv) -> - FunIx (tpSubst 0 env (Tp_Arr T U))) - (\ (K:KindDesc) (_:TpEnv) -> kindElem K) - (\ (T:TpDesc) (recT:TpEnv -> sort 0) (U:TpDesc) (recU:TpEnv -> sort 0) - (env:TpEnv) -> - recT env * recU env) - (\ (T:TpDesc) (recT:TpEnv -> sort 0) (U:TpDesc) (recU:TpEnv -> sort 0) - (env:TpEnv) -> - Either (recT env) (recU env)) - (\ (K:KindDesc) (T:TpDesc) (rec:TpEnv -> sort 0) (env:TpEnv) -> - Sigma (kindElem K) (\ (v:kindElem K) -> rec (envConsElem K v env))) - (\ (_:TpDesc) (rec:TpEnv -> sort 0) (len:TpExpr Kind_nat) (env:TpEnv) -> - Vec (evalTpExpr env Kind_nat len) (rec env)) - (\ (_:TpEnv) -> Void) - (\ (T:TpDesc) (rec:TpEnv -> sort 0) (env:TpEnv) -> - indElem nilTpEnv (unfoldIndTpDesc env T)) - (\ (var:Nat) (env:TpEnv) -> - -- 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 nilTpEnv (evalVar 0 env Kind_Tp var)) - (\ (_:TpDesc) (rec:TpEnv -> sort 0) (U:TpDesc) (_:TpEnv -> sort 0) - (env:TpEnv) -> - rec (envConsElem Kind_Tp (tpSubst 0 env U) env)) - (\ (_:TpDesc) (rec:TpEnv -> sort 0) (EK:ExprKind) (e:TpExpr EK) - (env:TpEnv) -> - rec (envConsElem (Kind_Expr EK) (evalTpExpr env EK e) env)) - T_top env_top; - --- Elements of a type description = elements relative to the empty environment -tpElem : TpDesc -> sort 0; -tpElem = tpElemEnv nilTpEnv; - --- Convert an inductively-defined element to a recursively-defined one -primitive indToTpElem : (env:TpEnv) -> (T:TpDesc) -> - indElem env T -> tpElemEnv env T; - --- Convert a recursively-defined element to an inductively-defined one -primitive tpToIndElem : (env:TpEnv) -> (T:TpDesc) -> - tpElemEnv env T -> indElem env T; - --- Fold an element of [Tp_Ind T/x]T to an element of Tp_Ind T -foldTpElem : (T:TpDesc) -> tpElem (unfoldIndTpDesc nilTpEnv T) -> - tpElem (Tp_Ind T); -foldTpElem T = tpToIndElem nilTpEnv (unfoldIndTpDesc nilTpEnv T); - --- Unfold an element of Tp_Ind T to an element of [Tp_Ind T/x]T -unfoldTpElem : (T:TpDesc) -> tpElem (Tp_Ind T) -> - tpElem (unfoldIndTpDesc nilTpEnv T); -unfoldTpElem T = indToTpElem nilTpEnv (unfoldIndTpDesc nilTpEnv T); +-- 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; -------------------------------------------------------------------------------- @@ -2912,87 +2790,124 @@ 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); +-- 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))) + (\ (_:TpDesc) (rec:TpEnv -> FunFlag -> sort 0) (len:TpExpr Kind_nat) + (env:TpEnv) (isf:FunFlag) -> + ifFun (sort 0) isf #() (Vec (evalTpExpr env Kind_nat 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; + +-- 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); --- A monadic specification function of a given type description -specFun : (E:EvType) -> TpEnv -> TpDesc -> sort 0; -specFun E env_top T_top = - TpDesc#rec (\ (_:TpDesc) -> TpEnv -> sort 0) - - -- For Tp_M R, specFun returns SpecM E [env/xs]R - (\ (R:TpDesc) (_:TpEnv -> sort 0) (env:TpEnv) -> - SpecM E (tpElemEnv nilTpEnv (tpSubst 0 env R))) - - -- For Tp_Pi K T, specFun quantifies over all elem:kindElem K and adds elem - -- to the environment for the recursive call to specFun T - (\ (K:KindDesc) (T:TpDesc) (rec:TpEnv -> sort 0) (env:TpEnv) -> - (elem:kindElem K) -> rec (envConsElem K elem env)) - - -- For Tp_Arr T U, specFun returns the function type tpElem T -> specFun U - (\ (T:TpDesc) (_:TpEnv -> sort 0) (U:TpDesc) (rec:TpEnv -> sort 0) (env:TpEnv) -> - tpElemEnv env T -> rec env) - - -- Everything else is not a function type, so specFun returns the unit type - (\ (K:KindDesc) (_:TpEnv) -> #()) - (\ (T:TpDesc) (_:TpEnv -> sort 0) - (U:TpDesc) (_:TpEnv -> sort 0) (env:TpEnv) -> #()) - (\ (T:TpDesc) (_:TpEnv -> sort 0) - (U:TpDesc) (_:TpEnv -> sort 0) (env:TpEnv) -> #()) - (\ (K:KindDesc) (T:TpDesc) (_:TpEnv -> sort 0) (env:TpEnv) -> #()) - (\ (_:TpDesc) (_:TpEnv -> sort 0) (_:TpExpr Kind_nat) (env:TpEnv) -> #()) - (\ (_:TpEnv) -> #()) - (\ (T:TpDesc) (_:TpEnv -> sort 0) (env:TpEnv) -> #()) - (\ (var:Nat) (env:TpEnv) -> #()) - (\ (_:TpDesc) (_:TpEnv -> sort 0) (_:TpDesc) (_:TpEnv -> sort 0) - (_:TpEnv) -> #()) - (\ (_:TpDesc) (_:TpEnv -> sort 0) (EK:ExprKind) (e:TpExpr EK) (_:TpEnv) -> - #()) - T_top env_top; - --- Call a function index in a specification -primitive CallS : (E:EvType) -> (T:TpDesc) -> FunIx T -> specFun E nilTpEnv T; - --- Create a function index from a specification function in a specification -primitive LambdaS : (E:EvType) -> (T:TpDesc) -> specFun E nilTpEnv T -> - SpecM E (FunIx T); -- Create a lambda as a fixed-point that can call itself. Note that the type of --- f, FunIx T -> specFun E nil T, is the same as specFun E nil (Tp_Arr T T) when --- T is a monadic function type. +-- 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) -> - (FunIx T -> specFun E nilTpEnv T) -> SpecM E (FunIx T); + (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 multi-arity function type from FunIxs to a given output type -arrowIxs : List TpDesc -> sort 0 -> sort 0; -arrowIxs Ts_top a = - List__rec TpDesc (\ (_:List TpDesc) -> sort 0) a - (\ (T:TpDesc) (_:List TpDesc) (rec:sort 0) -> FunIx T -> rec) - Ts_top; - -- 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 nilTpEnv T * rec) + 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 = arrowIxs Ts (specFuns E Ts); +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 -> SpecM E (FunIxs Ts); + 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 -> (arrowIxs Ts (SpecM E a)) -> + MultiFixBodies E Ts -> arrowSpecFuns E Ts (SpecM E a) -> SpecM E a; -- From 45a0142d9317e81460a9563ad06342f0618e4e26 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Tue, 7 Nov 2023 07:39:49 -0800 Subject: [PATCH 174/305] moved SpecM and its related definitions to its own SAW core module --- cryptol-saw-core/cryptol-saw-core.cabal | 2 + cryptol-saw-core/saw/CryptolM.sawcore | 10 +- cryptol-saw-core/saw/SpecM.sawcore | 910 ++++++++++++++++++ cryptol-saw-core/src/Verifier/SAW/Cryptol.hs | 12 + .../src/Verifier/SAW/Cryptol/Monadify.hs | 13 +- .../src/Verifier/SAW/Cryptol/PreludeM.hs | 3 + saw-core/prelude/Prelude.sawcore | 862 ----------------- saw-core/src/Verifier/SAW.hs | 7 +- src/SAWScript/HeapsterBuiltins.hs | 5 + src/SAWScript/Prover/Exporter.hs | 3 +- 10 files changed, 942 insertions(+), 885 deletions(-) create mode 100644 cryptol-saw-core/saw/SpecM.sawcore 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 e3975c97c3..0c816c2bf3 100644 --- a/cryptol-saw-core/saw/CryptolM.sawcore +++ b/cryptol-saw-core/saw/CryptolM.sawcore @@ -4,7 +4,8 @@ module CryptolM where -- import Prelude; -import Cryptol; +-- import Cryptol; +import SpecM; -- 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; @@ -87,13 +88,6 @@ 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) -> Num -> sort 0 -> sort 0; -mseq E num a = - Num_rec (\ (_:Num) -> sort 0) (\ (n:Nat) -> Vec n a) - (Stream (SpecM E a)) num; - {- bvVecMapInvarBindM : (E:EvType) -> (stack:FunStack) -> (a b c : isort 0) -> (n : Nat) -> (len : Vec n Bool) -> diff --git a/cryptol-saw-core/saw/SpecM.sawcore b/cryptol-saw-core/saw/SpecM.sawcore new file mode 100644 index 0000000000..8e0c3c8dc2 --- /dev/null +++ b/cryptol-saw-core/saw/SpecM.sawcore @@ -0,0 +1,910 @@ +------------------------------------------------------------------------------- +-- 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); +} + +-- 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 + 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 : TpDesc -> TpExpr Kind_num -> 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 : TpDesc -> TpExpr Kind_nat -> TpDesc; +Tp_Vec d n = Tp_Seq d (TpExpr_UnOp Kind_nat Kind_num UnOp_NatToNum n); + +-- The type description for the type BVVec n len d +Tp_BVVec : TpDesc -> (n:Nat) -> TpExpr (Kind_bv n) -> TpDesc; +Tp_BVVec d n len = + Tp_Vec d (TpExpr_UnOp (Kind_bv n) Kind_nat (UnOp_BVToNat n) len); + +-- 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 substitue 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)) + (\ (_:TpDesc) (rec:Nat -> TpEnv -> TpDesc) (len:TpExpr Kind_num) + (n:Nat) (env:TpEnv) -> + Tp_Seq (rec n env) (substTpExpr n env Kind_num len)) + (\ (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); + +-- 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 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))) + (\ (_:TpDesc) (rec:TpEnv -> FunFlag -> sort 0) (len:TpExpr Kind_num) + (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; + +-- 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 +-- + +-- 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 = + maybe + (Eq Nat n1 n2) (SpecM E (Vec n2 a)) + (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)) + (proveEqNat n1 n2); + +-- 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 = + maybe + (Eq (Vec n Bool) (bvAdd n len1 len2) len3) (SpecM E (BVVec n len3 a)) + (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))) + (bvEqWithProof n (bvAdd n len1 len2) len3); + + +-- +-- Defining refinement on SpecM computations +-- + +{- + +-- 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 E1 stack1 -> FunStackE 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 E1 stack1) -> (e2:FunStackE E2 stack2) -> + FunStackERet E1 stack1 e1 -> FunStackERet 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 StackCalls 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 E stack) e1 e2; + +-- The postcondition stating that errors, event encodings, and return values +-- of StackCalls 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 E stack) (FunStackERet 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); +-} diff --git a/cryptol-saw-core/src/Verifier/SAW/Cryptol.hs b/cryptol-saw-core/src/Verifier/SAW/Cryptol.hs index 7a2a621bef..9f214919d7 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, 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 39b32169d9..31b3cb8fe6 100644 --- a/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs +++ b/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs @@ -101,17 +101,6 @@ import GHC.Stack import Debug.Trace --- Type-check the Prelude, Cryptol, and CryptolM modules at compile time -{- -import Language.Haskell.TH -import Verifier.SAW.Cryptol.Prelude - -$(runIO (mkSharedContext >>= \sc -> - scLoadPreludeModule sc >> scLoadCryptolModule sc >> - scLoadCryptolMModule sc >> return [])) --} - - ---------------------------------------------------------------------- -- * Typing All Subterms ---------------------------------------------------------------------- @@ -1502,7 +1491,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 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/saw-core/prelude/Prelude.sawcore b/saw-core/prelude/Prelude.sawcore index f5c2b2ce0e..d773350598 100644 --- a/saw-core/prelude/Prelude.sawcore +++ b/saw-core/prelude/Prelude.sawcore @@ -2234,868 +2234,6 @@ nth_default1 a d l = l; --------------------------------------------------------------------------------- --- 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_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 (\ (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); -} - --- 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) - 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); -} - --- 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 - 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; - - -- Vector types - Tp_Vec : TpDesc -> TpExpr Kind_nat -> 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 a bitvector type -Tp_bitvector : Nat -> TpDesc; -Tp_bitvector w = Tp_Kind (Kind_Expr (Kind_bv w)); - --- The type description for the type BVVec n len d -Tp_BVVec : TpDesc -> (n:Nat) -> TpExpr (Kind_bv n) -> TpDesc; -Tp_BVVec d n len = - Tp_Vec d (TpExpr_UnOp (Kind_bv n) Kind_nat (UnOp_BVToNat n) len); - --- 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)) - (\ (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)) - (\ (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)) - (\ (w:Nat) -> Nothing (Eq ExprKind Kind_nat (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)) - (\ (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 (\ (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 substitue 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)) - (\ (_:TpDesc) (rec:Nat -> TpEnv -> TpDesc) (len:TpExpr Kind_nat) - (n:Nat) (env:TpEnv) -> - Tp_Vec (rec n env) (substTpExpr n env Kind_nat len)) - (\ (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); - --- 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 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); - --- 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))) - (\ (_:TpDesc) (rec:TpEnv -> FunFlag -> sort 0) (len:TpExpr Kind_nat) - (env:TpEnv) (isf:FunFlag) -> - ifFun (sort 0) isf #() (Vec (evalTpExpr env Kind_nat 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; - --- 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 --- - --- 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 = - maybe - (Eq Nat n1 n2) (SpecM E (Vec n2 a)) - (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)) - (proveEqNat n1 n2); - --- 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 = - maybe - (Eq (Vec n Bool) (bvAdd n len1 len2) len3) (SpecM E (BVVec n len3 a)) - (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))) - (bvEqWithProof n (bvAdd n len1 len2) len3); - - --- --- Defining refinement on SpecM computations --- - -{- - --- 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 E1 stack1 -> FunStackE 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 E1 stack1) -> (e2:FunStackE E2 stack2) -> - FunStackERet E1 stack1 e1 -> FunStackERet 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 StackCalls 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 E stack) e1 e2; - --- The postcondition stating that errors, event encodings, and return values --- of StackCalls 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 E stack) (FunStackERet 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); --} - -------------------------------------------------------------------------------- -- SMT Array diff --git a/saw-core/src/Verifier/SAW.hs b/saw-core/src/Verifier/SAW.hs index 86f61bb115..ddf5db8575 100644 --- a/saw-core/src/Verifier/SAW.hs +++ b/saw-core/src/Verifier/SAW.hs @@ -22,5 +22,8 @@ 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 [])) +-- NOTE: this is now done in Verifier.SAW.Cryptol, which also type-checks the +-- Cryptol-related SAW core modules as well +-- +-- import Language.Haskell.TH +-- $(runIO (mkSharedContext >>= \sc -> scLoadPreludeModule sc >> return [])) diff --git a/src/SAWScript/HeapsterBuiltins.hs b/src/SAWScript/HeapsterBuiltins.hs index 72620986ca..12c2406168 100644 --- a/src/SAWScript/HeapsterBuiltins.hs +++ b/src/SAWScript/HeapsterBuiltins.hs @@ -88,6 +88,7 @@ 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.OpenTerm import Verifier.SAW.Typechecker @@ -338,6 +339,7 @@ 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 @@ -352,6 +354,7 @@ 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 @@ -372,6 +375,7 @@ heapster_init_env_from_file_gen :: BuiltinContext -> Options -> DebugLevel -> heapster_init_env_from_file_gen _bic _opts dlevel mod_filename llvm_filename = do llvm_mod <- llvm_load_module llvm_filename sc <- getSharedContext + liftIO $ ensureCryptolMLoaded sc (saw_mod, saw_mod_name) <- readModuleFromFile mod_filename liftIO $ tcInsertModule sc saw_mod mkHeapsterEnv dlevel saw_mod_name [llvm_mod] @@ -382,6 +386,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 diff --git a/src/SAWScript/Prover/Exporter.hs b/src/SAWScript/Prover/Exporter.hs index 39d56f3455..5869fe31f9 100644 --- a/src/SAWScript/Prover/Exporter.hs +++ b/src/SAWScript/Prover/Exporter.hs @@ -70,7 +70,7 @@ 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, scLoadSpecMModule, scLoadCryptolMModule) import Verifier.SAW.Cryptol.Monadify (defaultMonEnv, monadifyCryptolModule) import Verifier.SAW.ExternalFormat(scWriteExternal) import Verifier.SAW.FiniteValue @@ -547,6 +547,7 @@ writeCoqCryptolPrimitivesForSAWCore outputFile outputFileM notations skips = do sc <- mkSharedContext () <- scLoadPreludeModule sc () <- scLoadCryptolModule sc + () <- scLoadSpecMModule sc () <- scLoadCryptolMModule sc () <- scLoadModule sc (emptyModule (mkModuleName ["CryptolPrimitivesForSAWCore"])) m <- scFindModule sc nameOfCryptolPrimitivesForSAWCoreModule From 9a6d36f5cd19eea0b88be1f3bbaf1af2b0838f9a Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 8 Nov 2023 06:55:40 -0800 Subject: [PATCH 175/305] updated Heapster to use the new version of SpecM that does not use FunIxs and is contained in a separate SpecM SAW core module --- .../Verifier/SAW/Heapster/LLVMGlobalConst.hs | 7 +- .../src/Verifier/SAW/Heapster/Permissions.hs | 21 +- .../Verifier/SAW/Heapster/SAWTranslation.hs | 746 +++++++----------- 3 files changed, 313 insertions(+), 461 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/LLVMGlobalConst.hs b/heapster-saw/src/Verifier/SAW/Heapster/LLVMGlobalConst.hs index 79edf1485e..98d39c0728 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/LLVMGlobalConst.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/LLVMGlobalConst.hs @@ -105,10 +105,7 @@ translateLLVMValue w _ (L.ValSymbol sym) = do env <- llvmTransInfoEnv <$> ask -- (p, ts) <- lift (lookupGlobalSymbol env (GlobalSymbol sym) w) (p, ts) <- case lookupGlobalSymbol env (GlobalSymbol sym) w of - Just (p, GlobalTransTerms ts) -> return (p,ts) - Just (_, _) -> - traceAndZeroM ("Could not translate recursive function symbol: " - ++ show sym) + Just (p, GlobalTrans ts) -> return (p, ts) Nothing -> traceAndZeroM ("Could not find symbol: " ++ show sym) return (PExpr_FieldShape (LLVMFieldShape p), ts) translateLLVMValue w _ (L.ValArray tp elems) = @@ -307,4 +304,4 @@ permEnvAddGlobalConst sc mod_name dlevel endianness w env global = take (length ts) [0 ..] return $ permEnvAddGlobalSyms env [PermEnvGlobalEntry (GlobalSymbol $ L.globalSym global) p - (GlobalTransTerms projs)] + (GlobalTrans projs)] diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs index 9c181861d4..607e45048d 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs @@ -860,19 +860,10 @@ data SomeNamedShape where SomeNamedShape :: (1 <= w, KnownNat w) => NamedShape b args w -> SomeNamedShape --- | The result of translating a global symbol to SAW core terms -data GlobalTrans - -- | A translation to a list of terms, as defined in @SAWTranslation.hs@ - = GlobalTransTerms [OpenTerm] - -- | A translation to a list of specification functions, i.e., to SAW core - -- terms of type @specFun E T@ for some type description @T@. This case is - -- here because this is different than the normal translation of a function, - -- which is to a SAW core term of type @FunIx T@. Accordingly, this is only - -- applicable to function permissions. The reason this is a list of terms - -- instead of just a single term is to support a single symbol having - -- multiple different function permissions, each with its own specification - -- function - | GlobalTransFuns [OpenTerm] +-- | 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 @@ -8286,7 +8277,7 @@ permEnvAddGlobalSymFun :: (1 <= w, KnownNat w) => PermEnv -> GlobalSymbol -> permEnvAddGlobalSymFun env sym (w :: f w) fun_perm t = let p = ValPerm_Conj1 $ mkPermLLVMFunPtr w fun_perm in env { permEnvGlobalSyms = - PermEnvGlobalEntry sym p (GlobalTransFuns [t]) + PermEnvGlobalEntry sym p (GlobalTrans [t]) : permEnvGlobalSyms env } -- | Add a global symbol with 0 or more function permissions to a 'PermEnv' @@ -8296,7 +8287,7 @@ 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 (GlobalTransFuns $ map snd ps_ts) + PermEnvGlobalEntry sym p (GlobalTrans $ map snd ps_ts) : permEnvGlobalSyms env } -- | Add some 'PermEnvGlobalEntry's to a 'PermEnv' diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index a520de58f6..007fa9ba0e 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -140,10 +140,6 @@ listOpenTerm tp elems = foldr (\x l -> ctorOpenTerm "Prelude.Cons" [tp, x, l]) (ctorOpenTerm "Prelude.Nil" [tp]) elems --- | Build the type @FunIx T@ from a type description @T@ -funIxTypeOpenTerm :: OpenTerm -> OpenTerm -funIxTypeOpenTerm t = applyGlobalOpenTerm "Prelude.FunIx" [t] - -- | Build the type @Either a b@ from types @a@ and @b@ eitherTypeOpenTerm :: OpenTerm -> OpenTerm -> OpenTerm eitherTypeOpenTerm a b = dataTypeOpenTerm "Prelude.Either" [a,b] @@ -193,53 +189,53 @@ sigmaElimOpenTermMulti x (tp:tps) tp_f sig f_elim = -- | The kind description for the unit type unitKindDesc :: OpenTerm -unitKindDesc = ctorOpenTerm "Prelude.Kind_Expr" [ctorOpenTerm - "Prelude.Kind_unit" []] +unitKindDesc = ctorOpenTerm "SpecM.Kind_Expr" [ctorOpenTerm + "SpecM.Kind_unit" []] -- | The @ExprKind@ for the bitvector type with width @w@ bvExprKind :: Natural -> OpenTerm -bvExprKind w = ctorOpenTerm "Prelude.Kind_bv" [natOpenTerm w] +bvExprKind w = ctorOpenTerm "SpecM.Kind_bv" [natOpenTerm w] -- | The type @TpDesc@ of type descriptions tpDescTypeOpenTerm :: OpenTerm -tpDescTypeOpenTerm = dataTypeOpenTerm "Prelude.TpDesc" [] +tpDescTypeOpenTerm = dataTypeOpenTerm "SpecM.TpDesc" [] -- | Convert a kind description to a type description with the @Tp_Kind@ -- constructor kindToTpDesc :: OpenTerm -> OpenTerm -kindToTpDesc d = ctorOpenTerm "Prelude.Tp_Kind" [d] +kindToTpDesc d = ctorOpenTerm "SpecM.Tp_Kind" [d] -- | The type description for the unit type unitTpDesc :: OpenTerm -unitTpDesc = ctorOpenTerm "Prelude.Tp_Kind" [unitKindDesc] +unitTpDesc = ctorOpenTerm "SpecM.Tp_Kind" [unitKindDesc] -- | The expression kind for the Boolean type boolExprKind :: OpenTerm -boolExprKind = ctorOpenTerm "Prelude.Kind_bool" [] +boolExprKind = ctorOpenTerm "SpecM.Kind_bool" [] -- | The kind description for the Boolean type boolKindDesc :: OpenTerm -boolKindDesc = ctorOpenTerm "Prelude.Kind_Expr" [boolExprKind] +boolKindDesc = ctorOpenTerm "SpecM.Kind_Expr" [boolExprKind] -- | The expression kind for the Nat type natExprKind :: OpenTerm -natExprKind = ctorOpenTerm "Prelude.Kind_nat" [] +natExprKind = ctorOpenTerm "SpecM.Kind_nat" [] -- | The kind description for the Nat type natKindDesc :: OpenTerm -natKindDesc = ctorOpenTerm "Prelude.Kind_Expr" [natExprKind] +natKindDesc = ctorOpenTerm "SpecM.Kind_Expr" [natExprKind] -- | The kind description for the type @bitvector w@ bvKindDesc :: Natural -> OpenTerm -bvKindDesc w = ctorOpenTerm "Prelude.Kind_Expr" [bvExprKind w] +bvKindDesc w = ctorOpenTerm "SpecM.Kind_Expr" [bvExprKind w] -- | The kind description for the type of type descriptions tpKindDesc :: OpenTerm -tpKindDesc = ctorOpenTerm "Prelude.Kind_Tp" [] +tpKindDesc = ctorOpenTerm "SpecM.Kind_Tp" [] -- | Build a pair type description from two type descriptions pairTpDesc :: OpenTerm -> OpenTerm -> OpenTerm -pairTpDesc d1 d2 = ctorOpenTerm "Prelude.Tp_Pair" [d1,d2] +pairTpDesc d1 d2 = ctorOpenTerm "SpecM.Tp_Pair" [d1,d2] -- | Build a tuple type description from a list of type descriptions tupleTpDesc :: [OpenTerm] -> OpenTerm @@ -249,19 +245,19 @@ tupleTpDesc (d : ds) = pairTpDesc d (tupleTpDesc ds) -- | Build a sum type description from two type descriptions sumTpDesc :: OpenTerm -> OpenTerm -> OpenTerm -sumTpDesc d1 d2 = ctorOpenTerm "Prelude.Tp_Sum" [d1,d2] +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 "Prelude.Tp_BVVec" [elem_d, w_term, len_term] + applyGlobalOpenTerm "SpecM.Tp_BVVec" [elem_d, w_term, len_term] -- | 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 "Prelude.TpExpr_Const" [k_d, v] +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 @@ -273,22 +269,22 @@ bvSumTpExprs :: Natural -> [OpenTerm] -> OpenTerm bvSumTpExprs w [] = bvConstTpExpr w (natOpenTerm 0) bvSumTpExprs _ [bv] = bv bvSumTpExprs w (bv:bvs) = - ctorOpenTerm "Prelude.TpExpr_BinOp" + ctorOpenTerm "SpecM.TpExpr_BinOp" [bvExprKind w, bvExprKind w, bvExprKind w, - ctorOpenTerm "Prelude.BinOp_AddBV" [natOpenTerm w], bv, bvSumTpExprs w bvs] + 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 "Prelude.TpExpr_BinOp" + ctorOpenTerm "SpecM.TpExpr_BinOp" [bvExprKind w, bvExprKind w, bvExprKind w, - ctorOpenTerm "Prelude.BinOp_MulBV" [natOpenTerm w], bv1, bv2] + 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 "Prelude.Tp_Sigma" [k,d] +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 @@ -298,7 +294,7 @@ sigmaTpDescMulti (k:ks) d = sigmaTpDesc k $ sigmaTpDescMulti ks d -- | Build an arrow type description for left- and right-hand type descriptions arrowTpDesc :: OpenTerm -> OpenTerm -> OpenTerm -arrowTpDesc d_in d_out = ctorOpenTerm "Prelude.Tp_Arr" [d_in, d_out] +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 @@ -309,11 +305,11 @@ arrowTpDescMulti ds_in d_out = foldr arrowTpDesc d_out ds_in -- returns the type described by @d_ret@ funTpDesc :: [OpenTerm] -> OpenTerm -> OpenTerm funTpDesc ds_in d_ret = - arrowTpDescMulti ds_in (ctorOpenTerm "Prelude.Tp_M" [d_ret]) + arrowTpDescMulti ds_in (ctorOpenTerm "SpecM.Tp_M" [d_ret]) -- | Build the type description for a pi-abstraction over a kind description piTpDesc :: OpenTerm -> OpenTerm -> OpenTerm -piTpDesc kd tpd = ctorOpenTerm "Prelude.Tp_Pi" [kd, tpd] +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@ @@ -322,28 +318,28 @@ piTpDescMulti ks tp = foldr piTpDesc tp ks -- | The type description for the @Void@ type voidTpDesc :: OpenTerm -voidTpDesc = ctorOpenTerm "Prelude.Tp_Void" [] +voidTpDesc = ctorOpenTerm "SpecM.Tp_Void" [] -- | Build a type description for a free deBruijn index varTpDesc :: Natural -> OpenTerm -varTpDesc ix = ctorOpenTerm "Prelude.Tp_Var" [natOpenTerm ix] +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 "Prelude.TpExpr_Var" [ek, natOpenTerm ix] +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 "Prelude.varKindExpr" [d,natOpenTerm ix] +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 "Prelude.constKindExpr" [d,e] +constKindExpr d e = applyGlobalOpenTerm "SpecM.constKindExpr" [d,e] -- | 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 "Prelude.Tp_Subst" [d,k_d,e] +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 @@ -361,53 +357,43 @@ substIdTpDescMulti i = substTpDescMulti (globalOpenTerm i) -- | Map from type description @T@ to the type @T@ describes tpElemTypeOpenTerm :: OpenTerm -> OpenTerm tpElemTypeOpenTerm d = - applyGlobalOpenTerm "Prelude.tpElem" [d] + applyGlobalOpenTerm "SpecM.tpElem" [d] -- | Build the computation type @SpecM E A@ specMTypeOpenTerm :: EventType -> OpenTerm -> OpenTerm specMTypeOpenTerm ev tp = - applyGlobalOpenTerm "Prelude.SpecM" [evTypeTerm 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 "Prelude.retS" [evTypeTerm 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 "Prelude.bindS" [evTypeTerm 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 "Prelude.errorS" + applyGlobalOpenTerm "SpecM.errorS" [evTypeTerm ev, ret_tp, stringLitOpenTerm (pack msg)] --- | Build a @SpecM@ computation that calls a function index -callSOpenTerm :: EventType -> OpenTerm -> OpenTerm -> [OpenTerm] -> OpenTerm -callSOpenTerm ev d ix args = - applyGlobalOpenTerm "Prelude.CallS" ([evTypeTerm ev, d, ix] ++ args) - --- | Build a @SpecM@ computation that creates a function index using @LambdaS@ -lambdaSOpenTerm :: EventType -> OpenTerm -> OpenTerm -> OpenTerm -lambdaSOpenTerm ev d f = - applyGlobalOpenTerm "Prelude.LambdaS" [evTypeTerm ev, d, f] - -- | 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 "Prelude.LetRecS" + 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 "Prelude.MultiFixBodies" + applyGlobalOpenTerm "SpecM.MultiFixBodies" [evTypeTerm ev, listOpenTerm tpDescTypeOpenTerm ds] -- | Build a SAW core term for a type-level environment, i.e., a term of type @@ -415,16 +401,16 @@ multiFixBodiesOpenTerm ev ds = -- descriptions tpEnvOpenTerm :: [(OpenTerm,OpenTerm)] -> OpenTerm tpEnvOpenTerm = - foldr (\(k,v) env -> applyGlobalOpenTerm "Prelude.envConsElem" [k,v,env]) - (ctorOpenTerm "Prelude.Nil" [globalOpenTerm "Prelude.TpEnvElem"]) + foldr (\(k,v) env -> applyGlobalOpenTerm "SpecM.envConsElem" [k,v,env]) + (ctorOpenTerm "Prelude.Nil" [globalOpenTerm "SpecM.TpEnvElem"]) -- | 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 "Prelude.tpSubst" [natOpenTerm n, - tpEnvOpenTerm ks_elems, d] + applyGlobalOpenTerm "SpecM.tpSubst" [natOpenTerm n, + tpEnvOpenTerm ks_elems, d] ---------------------------------------------------------------------- @@ -579,34 +565,11 @@ unETransPerm (ETrans_Perm ds tps) = (ds, tps) unETransPerm (ETrans_Term _ _) = panic "unETransPerm" ["Incorrect translation of a shape expression"] - -- | Describes a Haskell type that represents the translation of a term-like -- construct that corresponds to 0 or more SAW terms class IsTermTrans tr where transTerms :: HasCallStack => tr -> [OpenTerm] --- | A translation monad enriched with a continuation returning a SAW core term. --- This is used to generate monadic binds in the @SpecM@ monad by shifting the --- current continuation and using it as the function argument of the bind -type ContTransM info ctx = ContT OpenTerm (TransM info ctx) - --- | Describes a Haskell type that represents the translation of a term-like --- construct that corresponds to 0 or more SAW core terms, but where the SAW --- core terms can only be recovered by performing a bind in the @SpecM@ monad. --- This is represented as a continuation-passing computation, which takes in the --- continuation that will consume the SAW core terms inside any binds that need --- to be inserted into the overall computation. -class IsTermTransM info ctx tr where - transTermsCont :: HasCallStack => tr -> - ContTransM info ctx [OpenTerm] - --- | Pass the 0 or more SAW core terms corresponding to a monadic term --- translation to a continuation that uses them to build a @SpecM@ computation -transTermsM :: IsTermTransM info ctx tr => HasCallStack => - tr -> ([OpenTerm] -> TransM info ctx OpenTerm) -> - TransM info ctx OpenTerm -transTermsM tr k = runContT (transTermsCont tr) k - -- | Build a tuple of the terms contained in a translation, with 0 terms mapping -- to the unit term and one term mapping to itself. If @ttrans@ is a 'TypeTrans' -- describing the SAW types associated with a @tr@ translation, then this @@ -614,13 +577,6 @@ transTermsM tr k = runContT (transTermsCont tr) k transTupleTerm :: IsTermTrans tr => tr -> OpenTerm transTupleTerm = tupleOpenTerm' . transTerms --- | Use 'transTermsM' to monadically translate a @tr@ to list of SAW core terms --- and then tuple those terms to get a single term -transTupleTermM :: IsTermTransM info ctx tr => tr -> - (OpenTerm -> TransM info ctx OpenTerm) -> - TransM info ctx OpenTerm -transTupleTermM tr f = transTermsM tr (f . tupleOpenTerm') - -- | 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 @@ -634,24 +590,12 @@ termsExpect1 ts = panic "termsExpect1" ["Expected at most one term, but found " transTerm1 :: HasCallStack => IsTermTrans tr => tr -> OpenTerm transTerm1 = termsExpect1 . transTerms --- | Like 'transTupleTermM' but raise an error if there are more than 1 terms -transTerm1M :: IsTermTransM info ctx tr => tr -> - (OpenTerm -> TransM info ctx OpenTerm) -> - TransM info ctx OpenTerm -transTerm1M tr f = transTermsM tr (f . termsExpect1) - +instance (IsTermTrans tr1, IsTermTrans tr2) => IsTermTrans (tr1,tr2) where + transTerms (tr1, tr2) = transTerms tr1 ++ transTerms tr2 instance IsTermTrans tr => IsTermTrans [tr] where transTerms = concatMap transTerms -instance IsTermTransM info ctx tr => IsTermTransM info ctx [tr] where - transTermsCont = fmap concat . mapM transTermsCont - -instance (IsTermTransM info ctx tr1, IsTermTransM info ctx tr2) => - IsTermTransM info ctx (tr1,tr2) where - transTermsCont (tr1,tr2) = - (++) <$> transTermsCont tr1 <*> transTermsCont tr2 - instance IsTermTrans (TypeTrans tr) where transTerms = typeTransTypes @@ -1080,33 +1024,29 @@ sigmaTypePermTransM x ttrans mb_p = case mbMatch mb_p of -- 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, IsTermTransM info ctx trR2) => +sigmaTransM :: (IsTermTrans trL, IsTermTrans trR2) => LocalName -> TypeTrans trL -> (trL -> TransM info ctx (TypeTrans trR1)) -> trL -> TransM info ctx trR2 -> - (OpenTerm -> TransM info ctx OpenTerm) -> TransM info ctx OpenTerm -sigmaTransM _ (typeTransTypes -> []) _ _ rhs_m k = - rhs_m >>= \rhs -> transTupleTermM rhs k -sigmaTransM x tp_l tp_r lhs rhs_m k = +sigmaTransM _ (typeTransTypes -> []) _ _ rhs_m = transTupleTerm <$> rhs_m +sigmaTransM x tp_l tp_r lhs rhs_m = do info <- ask rhs <- rhs_m - transTupleTermM rhs $ \rhs_tm -> - k (sigmaOpenTermMulti x (typeTransTypes tp_l) - (typeTransTupleType . flip runTransM info . tp_r . typeTransF tp_l) - (transTerms lhs) - rhs_tm) + 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, IsTermTransM info ctx trR2) => +sigmaPermTransM :: (TransInfo info, IsTermTrans trR2) => LocalName -> TypeTrans (ExprTrans trL) -> Mb (ctx :> trL) (ValuePerm trR1) -> ExprTrans trL -> TransM info ctx trR2 -> - (OpenTerm -> TransM info ctx OpenTerm) -> TransM info ctx OpenTerm -sigmaPermTransM x ttrans mb_p etrans rhs_m k = case mbMatch mb_p of - [nuMP| ValPerm_Eq _ |] -> k (transTupleTerm etrans) - _ -> sigmaTransM x ttrans (flip inExtTransM $ translate mb_p) etrans rhs_m k +sigmaPermTransM x ttrans mb_p etrans rhs_m = case mbMatch mb_p of + [nuMP| ValPerm_Eq _ |] -> return $ transTupleTerm etrans + _ -> sigmaTransM x ttrans (flip inExtTransM $ translate mb_p) etrans rhs_m -- | Eliminate a dependent pair of the type returned by 'sigmaTypeTransM' @@ -1174,7 +1114,7 @@ compReturnTypeM :: TransInfoM info => TransM info ctx OpenTerm compReturnTypeM = do ev <- infoEvType <$> ask ret_tp <- returnTypeM - return $ applyGlobalOpenTerm "Prelude.SpecM" [evTypeTerm ev, ret_tp] + return $ specMTypeOpenTerm ev ret_tp -- | Like 'compReturnTypeM' but build a 'TypeTrans' compReturnTypeTransM :: TransInfoM info => TransM info ctx (TypeTrans OpenTerm) @@ -2045,10 +1985,9 @@ data AtomicPermTrans ctx a where APTrans_Struct :: PermTransCtx ctx (CtxToRList args) -> AtomicPermTrans ctx (StructType args) - -- | The translation of functional permission is a SAW term of @FunIx@ type + -- | The translation of functional permission is a SAW term of @specFun@ type APTrans_Fun :: Mb ctx (FunPerm ghosts (CtxToRList cargs) gouts ret) -> - FunTransTerm -> - 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 -> @@ -2096,36 +2035,21 @@ pattern PTrans_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) -> - FunTransTerm -> PermTrans ctx a + 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 -data FunTransTerm - -- | A function represented as a corecursive function index, i.e., a term - -- of type @FunIx T@, where @T@ is a type description of the type of the - -- function. The first term is the event type, the second is @T@, and the - -- third is the function index. - = FunTransIx EventType OpenTerm OpenTerm - -- | A monadic function represented as a monadic function, i.e., a term of - -- type @specFun E nil T@, where @E@ is the current event type and @T@ is a - -- type description of the type of the function - | FunTransFun EventType OpenTerm OpenTerm - --- | Convert a 'FunTransTerm' to an index, i.e., term of type @FunIx T@, passing --- the index to the supplied continuation function -funTransTermToIx :: TransInfoM info => FunTransTerm -> - (OpenTerm -> TransM info ctx OpenTerm) -> - TransM info ctx OpenTerm -funTransTermToIx (FunTransIx _ _ funix) k = k funix -funTransTermToIx (FunTransFun ev d f) k = - bindTransM (lambdaSOpenTerm ev d f) (openTermTypeTrans $ - funIxTypeOpenTerm d) "funix" k +-- | 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 -applyFunTransTerm :: FunTransTerm -> [OpenTerm] -> OpenTerm -applyFunTransTerm (FunTransIx ev d funix) = callSOpenTerm ev d funix -applyFunTransTerm (FunTransFun _ _ f) = applyOpenTermMulti f - +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 @@ -2216,37 +2140,35 @@ eqPermTransCtx ns = RL.map (\memb -> PTrans_Eq $ nuMulti (RL.map (\_-> Proxy) ns) (PExpr_Var . RL.get memb)) -instance TransInfoM info => IsTermTransM info ctx (PermTrans ctx a) where - transTermsCont (PTrans_Eq _) = return [] - transTermsCont (PTrans_Conj aps) = transTermsCont aps - transTermsCont (PTrans_Defined _ _ _ ptrans) = transTermsCont ptrans - transTermsCont (PTrans_Term _ t) = return [t] - -instance TransInfoM info => IsTermTransM info ctx (PermTransCtx ctx ps) where - transTermsCont = fmap concat . sequence . RL.mapToList transTermsCont - -instance TransInfoM info => IsTermTransM info ctx (AtomicPermTrans ctx a) where - transTermsCont (APTrans_LLVMField _ ptrans) = transTermsCont ptrans - transTermsCont (APTrans_LLVMArray arr_trans) = return $ transTerms arr_trans - transTermsCont (APTrans_LLVMBlock _ ts) = return ts - transTermsCont (APTrans_LLVMFree _) = return [] - transTermsCont (APTrans_LLVMFunPtr _ trans) = transTermsCont trans - transTermsCont APTrans_IsLLVMPtr = return [] - transTermsCont (APTrans_LLVMBlockShape _ ts) = return ts - transTermsCont (APTrans_NamedConj _ _ _ t) = return [t] - transTermsCont (APTrans_DefinedNamedConj _ _ _ ptrans) = - transTermsCont ptrans - transTermsCont (APTrans_LLVMFrame _) = return [] - transTermsCont (APTrans_LOwned _ _ _ eps_in _ lotr) = - ContT $ \k -> lownedTransTerm eps_in lotr (\t -> k [t]) - transTermsCont (APTrans_LOwnedSimple _ _) = return [] - transTermsCont (APTrans_LCurrent _) = return [] - transTermsCont APTrans_LFinished = return [] - transTermsCont (APTrans_Struct pctx) = transTermsCont pctx - transTermsCont (APTrans_Fun _ f) = - ContT $ \k -> funTransTermToIx f (\t -> k [t]) - transTermsCont (APTrans_BVProp prop) = return $ transTerms prop - transTermsCont APTrans_Any = return [] +instance IsTermTrans (PermTrans ctx a) where + transTerms (PTrans_Eq _) = [] + transTerms (PTrans_Conj aps) = transTerms aps + transTerms (PTrans_Defined _ _ _ ptrans) = transTerms ptrans + transTerms (PTrans_Term _ t) = [t] + +instance IsTermTrans (PermTransCtx ctx ps) where + transTerms = concat . RL.mapToList transTerms + +instance IsTermTrans (AtomicPermTrans ctx a) where + transTerms (APTrans_LLVMField _ ptrans) = transTerms ptrans + transTerms (APTrans_LLVMArray arr_trans) = transTerms arr_trans + transTerms (APTrans_LLVMBlock _ ts) = ts + transTerms (APTrans_LLVMFree _) = [] + transTerms (APTrans_LLVMFunPtr _ trans) = transTerms trans + transTerms APTrans_IsLLVMPtr = [] + transTerms (APTrans_LLVMBlockShape _ ts) = ts + transTerms (APTrans_NamedConj _ _ _ t) = [t] + transTerms (APTrans_DefinedNamedConj _ _ _ ptrans) = transTerms ptrans + transTerms (APTrans_LLVMFrame _) = [] + transTerms (APTrans_LOwned _ _ _ eps_in _ lotr) = + [lownedTransTerm eps_in lotr] + transTerms (APTrans_LOwnedSimple _ _) = [] + transTerms (APTrans_LCurrent _) = [] + transTerms APTrans_LFinished = [] + transTerms (APTrans_Struct pctx) = transTerms pctx + transTerms (APTrans_Fun _ f) = [funTransTerm f] + transTerms (APTrans_BVProp prop) = transTerms prop + transTerms APTrans_Any = [] instance IsTermTrans (BVPropTrans ctx w) where transTerms (BVPropTrans _ t) = [t] @@ -2576,20 +2498,18 @@ getLLVMArrayTransCell _ _ _ _ = -- | Write an array cell of the translation of an LLVM array permission at a -- given index -setLLVMArrayTransCell :: (1 <= w, KnownNat w, TransInfoM info) => +setLLVMArrayTransCell :: (1 <= w, KnownNat w) => LLVMArrayPermTrans ctx w -> OpenTerm -> AtomicPermTrans ctx (LLVMPointerType w) -> - (LLVMArrayPermTrans ctx w -> TransM info ctx OpenTerm) -> - TransM info ctx OpenTerm -setLLVMArrayTransCell arr_trans cell_ix_tm cell_value k = + LLVMArrayPermTrans ctx w +setLLVMArrayTransCell arr_trans cell_ix_tm cell_value = let w = fromInteger $ natVal arr_trans in - transTupleTermM cell_value $ \cell_value_t -> - k $ arr_trans { + arr_trans { llvmArrayTransTerm = applyGlobalOpenTerm "Prelude.updBVVec" [natOpenTerm w, llvmArrayTransLen arr_trans, llvmArrayTransCellType arr_trans, llvmArrayTransTerm arr_trans, - cell_ix_tm, cell_value_t] } + cell_ix_tm, transTupleTerm cell_value] } -- | Read a slice (= a sub-array) of the translation of an LLVM array permission @@ -2640,8 +2560,6 @@ setLLVMArrayTransSlice arr_trans sub_arr_trans off_tm = -- * Translations of Lifetime Ownership Permissions ---------------------------------------------------------------------- --- FIXME: lownedInfoEvType field is redundant now that we have lownedInfoEnv - -- | 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 @@ -2651,17 +2569,25 @@ data LOwnedInfo ps ctx = lownedInfoPCtx :: PermTransCtx ctx ps, lownedInfoPVars :: RAssign (Member ctx) ps, lownedInfoEvType :: EventType, - lownedInfoRetType :: OpenTerm, - lownedInfoEnv :: PermEnv } + 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 = lownedInfoEnv + 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 @@ -2670,8 +2596,7 @@ impInfoToLOwned (ImpTransInfo {..}) = lownedInfoPCtx = itiPermStack, lownedInfoPVars = itiPermStackVars, lownedInfoEvType = permEnvEventType itiPermEnv, - lownedInfoRetType = itiReturnType, - lownedInfoEnv = itiPermEnv } + lownedInfoRetType = itiReturnType } -- | Convert an 'LOwnedInfo' to an 'ImpTransInfo' using an existing -- 'ImpTransInfo', throwing away all permissions in the 'ImpTransInfo' @@ -2708,8 +2633,7 @@ loInfoAppend info1 info2 = , lownedInfoPVars = RL.append (lownedInfoPVars info1) (lownedInfoPVars info2) , lownedInfoEvType = lownedInfoEvType info1 - , lownedInfoRetType = lownedInfoRetType info1 - , lownedInfoEnv = lownedInfoEnv info1 } + , lownedInfoRetType = lownedInfoRetType info1 } extLOwnedInfoExt :: ExprCtxExt ctx1 ctx2 -> LOwnedInfo ps ctx1 -> LOwnedInfo ps ctx2 @@ -2804,40 +2728,22 @@ extLOwnedTransM :: ExprCtxExt ctx ctx' -> LOwnedTransM ps_in ps_out ctx a -> extLOwnedTransM cext m = LOwnedTransM $ \cext' -> runLOwnedTransM m (transExprCtxExt cext cext') --- | Get the SAW core terms stored in a 'PermTransCtx' -pctxTermsLOwnedTransM :: HasCallStack => PermTransCtx ctx ps -> - LOwnedTransM ps' ps' ctx [OpenTerm] -pctxTermsLOwnedTransM pctx = - LOwnedTransM $ \cext loInfo k -> - flip runTransM loInfo $ - transTermsM (extPermTransCtxExt cext pctx) $ \ts -> - return $ k reflExprCtxExt loInfo ts - --- | Get the SAW core terms stored in the current 'PermTransCtx' -pctxInTermsLOwnedTransM :: HasCallStack => LOwnedTransM ps ps ctx [OpenTerm] -pctxInTermsLOwnedTransM = - LOwnedTransM $ \cext loInfo k -> - flip runTransM loInfo $ - transTermsM (lownedInfoPCtx loInfo) $ \ts -> - return $ k reflExprCtxExt loInfo ts - -- | 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 term of type @FunIx T@ as the --- transformation, where type description @T@ is defined by 'arrowDescTrans'. +-- 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 = - pctxInTermsLOwnedTransM >>>= \pctx_ts -> +mkLOwnedTransTermFromTerm _trans_in trans_out vars_out t = LOwnedTransM $ \(ExprCtxExt ctx') loInfo k -> let ev = lownedInfoEvType loInfo - d = arrowDescTrans trans_in trans_out - t_app = callSOpenTerm ev d t pctx_ts + 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 $ @@ -2850,22 +2756,20 @@ mkLOwnedTransTermFromTerm trans_in trans_out vars_out t = -- | 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 :: PermEnv -> ExprTransCtx ctx -> +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 env ectx vars_in tps_in tps_out t = +lownedTransTermFun ev ectx vars_in tps_in tps_out t = lambdaTrans "p" (descTypeTrans tps_in) $ \ps_in -> let ret_tp = typeTransTupleType $ descTypeTrans tps_out - ev = permEnvEventType env in - let loInfo = + loInfo = LOwnedInfo { lownedInfoECtx = ectx, lownedInfoPCtx = ps_in, lownedInfoPVars = vars_in, - lownedInfoEvType = ev, - lownedInfoRetType = ret_tp, lownedInfoEnv = env } in - runLOwnedTransM (t >>> pctxInTermsLOwnedTransM) reflExprCtxExt loInfo $ - \_ loInfo_out ts -> retSOpenTerm ev ret_tp $ tupleOpenTerm' ts + 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 -> @@ -2881,11 +2785,11 @@ idLOwnedTransTerm :: DescPermsTpTrans ctx ps_out -> RAssign (Member ctx) ps_out -> LOwnedTransTerm ctx ps_in ps_out idLOwnedTransTerm dtr_out vars_out = - pctxInTermsLOwnedTransM >>>= \pctx_ts -> gmodify $ \(ExprCtxExt ctx') loInfo -> loInfo { lownedInfoPVars = RL.map (weakenMemberR ctx') vars_out, lownedInfoPCtx = - descTypeTransF (fmap (extPermTransCtxMulti ctx') dtr_out) pctx_ts } + descTypeTransF (fmap (extPermTransCtxMulti ctx') dtr_out) + (lownedInfoPCtxTerms loInfo) } -- | Partially apply an 'LOwnedTransTerm' to some of its input permissions @@ -2911,14 +2815,13 @@ weakenLOwnedTransTerm :: Desc1PermTpTrans ctx tp -> weakenLOwnedTransTerm tptr t = ggetting $ \cext info_top -> let (info_ps_in, info_tp) = loInfoSplit Proxy (MNil :>: Proxy) info_top in - pctxTermsLOwnedTransM (lownedInfoPCtx info_tp) >>>= \pctx_tp_ts -> gput info_ps_in >>> extLOwnedTransM cext t >>> gmodify (\cext' info' -> loInfoAppend info' $ extLOwnedInfoExt cext' $ info_tp { lownedInfoPCtx = (MNil :>:) $ extPermTransExt cext $ - descTypeTransF tptr pctx_tp_ts }) + descTypeTransF tptr (lownedInfoPCtxTerms info_tp) }) -- | Combine 'LOwnedTransTerm's for the 'SImpl_MapLifetime' rule mapLtLOwnedTransTerm :: @@ -2937,10 +2840,6 @@ mapLtLOwnedTransTerm prx_extra1 prx_extra2 prx_in t1 t2 = loInfoAppend (extLOwnedInfoExt cext' info_extra2) info_out) >>> extLOwnedTransM cext t2 --- FIXME HERE NOW: LOwnedTrans should have an extra constructor for a function --- index that has not yet been converted to an LOwnedTransTerm; or maybe --- LOwnedTransTerm should have the two constructors? - -- | The translation of an @lowned@ permission data LOwnedTrans ctx ps_extra ps_in ps_out = LOwnedTrans { @@ -3001,27 +2900,18 @@ weakenLOwnedTrans tp_in tp_out (LOwnedTrans {..}) = lotrTpTransOut = liftA2 (:>:) lotrTpTransOut tp_out, lotrTerm = weakenLOwnedTransTerm tp_out lotrTerm, .. } --- | Convert an 'LOwnedTrans' to a function index from @ps_in@ to @ps_out@ by +-- | 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, applying the @LambdaS@ spec combinator to create a @SpecM@ --- computation that produces the function index, and then building a monadic --- bind to pass that function index to the supplied continuation -lownedTransTerm :: TransInfoM info => Mb ctx (ExprPerms ps_in) -> - LOwnedTrans ctx ps_extra ps_in ps_out -> - (OpenTerm -> TransM info ctx OpenTerm) -> - TransM info ctx OpenTerm -lownedTransTerm (mbExprPermsMembers -> Just vars_in) lotr k = - do env <-infoEnv <$> ask - let d = arrowDescTrans (lotrTpTransIn lotr) (lotrTpTransOut lotr) - lot = applyLOwnedTransTerm Proxy - (lotrPsExtra lotr) (lotrVarsExtra lotr) (lotrTerm lotr) - f = lownedTransTermFun env (lotrECtx lotr) - vars_in (lotrTpTransIn lotr) (lotrTpTransOut lotr) lot - ix_tptrans = openTermTypeTrans (funIxTypeOpenTerm d) - ev <- infoEvType <$> ask - bindTransM (lambdaSOpenTerm ev d f) ix_tptrans "f_lowned" k -lownedTransTerm _ _ _ = - return $ failOpenTerm "FIXME HERE NOW: write this error message" +-- 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 :: @@ -3241,10 +3131,12 @@ instance TransInfo info => Just vars_out -> do ev <- infoEvType <$> ask ectx <- infoCtx <$> ask - dtr_in <- tpTransM $ translateDescType ps_in - dtr_out <- tpTransM $ translateDescType ps_out - let d = arrowDescTrans dtr_in dtr_out - return $ mkTypeTrans1 (funIxTypeOpenTerm d) $ \t -> + 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 -> @@ -3258,11 +3150,10 @@ instance TransInfo info => [nuMP| Perm_Struct ps |] -> fmap APTrans_Struct <$> translate ps [nuMP| Perm_Fun fun_perm |] -> - do tp_desc <- descTransM (translateDesc fun_perm) + do tp <- translate fun_perm + d <- descTransM $ translateDesc1 fun_perm ev <- infoEvType <$> ask - return $ - mkTypeTrans1 (funIxTypeOpenTerm tp_desc) - (APTrans_Fun fun_perm . FunTransIx ev tp_desc) + 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 @@ -3502,15 +3393,14 @@ translateEntryRetType (TypedEntry {..} -- * The Implication Translation Monad ---------------------------------------------------------------------- --- | A mapping from a block entrypoint to a corresponding SAW function index --- (including the type description @T@ and the SAW core term of type @FunIx T@) +-- | 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, - typedEntryTransIx :: Maybe (OpenTerm, OpenTerm) } + typedEntryTransFun :: Maybe OpenTerm } -- | A mapping from a block to the SAW functions for each entrypoint data TypedBlockTrans ext blocks tops rets args = @@ -3662,9 +3552,9 @@ withPermStackM f_vars f_p = -- | 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 'transTermsM' +-- the SAW core terms it represents using 'transTerms' withPermStackTermsM :: - IsTermTransM (ImpTransInfo ext blocks tops rets ps_in) ctx tr => + IsTermTrans tr => (PermTransCtx ctx ps_in -> tr) -> (RAssign (Member ctx) ps_in -> RAssign (Member ctx) ps_out) -> ([OpenTerm] -> PermTransCtx ctx ps_in -> @@ -3673,12 +3563,11 @@ withPermStackTermsM :: ImpTransM ext blocks tops rets ps_in ctx OpenTerm withPermStackTermsM f_sel f_vars f_p m = do pctx <- itiPermStack <$> ask - transTermsM (f_sel pctx) $ \ts -> - withPermStackM f_vars (f_p ts) m + 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 --- 'transTermsM'; i.e., perform 'withPermStackTermsM' with the top of the stack +-- '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) -> @@ -4122,9 +4011,10 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of tp_trans <- translateClosed tp out_trans <- translateSimplImplOutHead mb_simpl etrans <- translate e - sigmaPermTransM "x_ex" tp_trans (mbCombine RL.typeCtxProxies p) - etrans getTopPermM $ \trm -> - withPermStackM id + trm <- + sigmaPermTransM "x_ex" tp_trans (mbCombine RL.typeCtxProxies p) + etrans getTopPermM + withPermStackM id (\(pctx :>: _) -> pctx :>: typeTransF out_trans [trm]) m @@ -4450,13 +4340,11 @@ 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 - transTerm1M ptrans1 $ \t1 -> - transTerm1M ptrans2 $ \t2 -> - let arr_out_comp_tm = - applyGlobalOpenTerm "Prelude.appendCastBVVecS" - [evTypeTerm ev, w_term, len1_tm, len2_tm, len3_tm, - elem_tp, t1, t2] in - bindTransM 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 @@ -4484,7 +4372,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of [w_tm, bvLitOpenTerm (replicate w False)] ev <- infoEvType <$> ask let vec_cast_m = - applyGlobalOpenTerm "Prelude.castVecS" + 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) @@ -4582,8 +4470,8 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of mbMap2 (\ap cell -> llvmArrayRemBorrow (FieldBorrow cell) ap) mb_ap mb_cell } cell_tm <- translate1 mb_cell - setLLVMArrayTransCell arr_trans' cell_tm aptrans_cell $ \arr_trans'' -> - withPermStackM RL.tail + let arr_trans'' = setLLVMArrayTransCell arr_trans' cell_tm aptrans_cell + withPermStackM RL.tail (\(pctx :>: _ :>: _) -> pctx :>: PTrans_Conj [APTrans_LLVMArray arr_trans'']) m @@ -4612,14 +4500,13 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of -- mapBVVecM monadic combinator ptrans_arr <- getTopPermM ev <- infoEvType <$> ask - transTerm1M ptrans_arr $ \ptrans_arr_t -> - let arr_out_comp_tm = - applyGlobalOpenTerm "Prelude.mapBVVecS" - [evTypeTerm ev, elem_tp, typeTransType1 cell_out_trans, impl_tm, - w_term, len_term, ptrans_arr_t] in - -- Now use bindS to bind the result of arr_out_comp_tm in the remaining - -- computation - bindTransM arr_out_comp_tm p_out_trans "mapped_array" $ \ptrans_arr' -> + let arr_out_comp_tm = + applyGlobalOpenTerm "SpecM.mapBVVecS" + [evTypeTerm ev, elem_tp, typeTransType1 cell_out_trans, impl_tm, + w_term, len_term, transTerm1 ptrans_arr] + -- Now use bindS to bind the result of arr_out_comp_tm in the remaining + -- computation + bindTransM arr_out_comp_tm p_out_trans "mapped_array" $ \ptrans_arr' -> withPermStackM id (\(pctx :>: _) -> pctx :>: ptrans_arr') m [nuMP| SImpl_LLVMFieldIsPtr x _ |] -> @@ -4754,10 +4641,8 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of [nuMP| SImpl_EndLifetime _ tps_in tps_out ps_in ps_out |] -> -- First, translate the in and out permissions of the lowned permission - do dtr_in <- tpTransM $ translateDescType ps_in - dtr_out <- tpTransM $ translateDescType ps_out + do tr_out <- translate ps_out let prxs_in = mbRAssignProxies ps_in :>: Proxy - let d = arrowDescTrans dtr_in dtr_out -- Next, split out the ps_in permissions from the rest of the pctx pctx <- itiPermStack <$> ask @@ -4775,20 +4660,16 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of -- Now we apply the lifetime ownerhip function to ps_in and bind its output -- in the rest of the computation - ev <- infoEvType <$> ask case some_lotr of SomeLOwnedTrans lotr -> - transTermsM pctx_in $ \pctx_in_ts -> - lownedTransTerm ps_in lotr $ \funix -> - bindTransM (callSOpenTerm ev d funix pctx_in_ts) - (descTypeTrans dtr_out) - "endl_ps" - (\pctx_out -> - withPermStackM - (\(_ :>: l) -> RL.append ps_vars vars_out :>: l) - (\_ -> RL.append pctx_ps pctx_out :>: - PTrans_Conj [APTrans_LFinished]) - m) + let lotr_f = lownedTransTerm ps_in lotr in + bindTransM (applyOpenTermMulti lotr_f $ + transTerms pctx_in) tr_out "endl_ps" $ \pctx_out -> + withPermStackM + (\(_ :>: l) -> RL.append ps_vars vars_out :>: l) + (\_ -> RL.append pctx_ps pctx_out :>: + PTrans_Conj [APTrans_LFinished]) + m [nuMP| SImpl_IntroLOwnedSimple _ _ _ |] -> do let prx_ps_l = mbRAssignProxies $ mbSimplImplIn mb_simpl @@ -4798,7 +4679,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of let (_, pctx_ps :>: _) = RL.split ps0 prx_ps_l pctx in pctx_ps) id (\ts pctx -> - let (pctx0, pctx_ps :>: _) = RL.split ps0 prx_ps_l pctx in + let (pctx0, _) = RL.split ps0 prx_ps_l pctx in RL.append pctx0 $ typeTransF ttrans ts) m @@ -4891,7 +4772,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of withPermStackTopTermsM id (\ts (pctx :>: _) -> pctx :>: - typeTransF ttrans [applyGlobalOpenTerm "Prelude.foldTpElem" + typeTransF ttrans [applyGlobalOpenTerm "SpecM.foldTpElem" [d, tupleOpenTerm' ts]]) m @@ -4918,7 +4799,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of withPermStackTopTermsM id (\ts (pctx :>: _) -> pctx :>: - typeTransF ttrans [applyGlobalOpenTerm "Prelude.unfoldTpElem" + typeTransF ttrans [applyGlobalOpenTerm "SpecM.unfoldTpElem" [d, tupleOpenTerm' ts]]) m @@ -5049,7 +4930,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of withPermStackTopTermsM id (\ts (pctx :>: _) -> pctx :>: - typeTransF ttrans [applyGlobalOpenTerm "Prelude.foldTpElem" + typeTransF ttrans [applyGlobalOpenTerm "SpecM.foldTpElem" [d, tupleOpenTerm' ts]]) m @@ -5061,7 +4942,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of withPermStackTopTermsM id (\ts (pctx :>: _) -> pctx :>: - typeTransF ttrans [applyGlobalOpenTerm "Prelude.unfoldTpElem" + typeTransF ttrans [applyGlobalOpenTerm "SpecM.unfoldTpElem" [d, tupleOpenTerm' ts]]) m @@ -5237,12 +5118,11 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o tps <- mapM translate $ mbOrListDisjs mb_or_list tp_ret <- compReturnTypeTransM top_ptrans <- getTopPermM - transTerm1M top_ptrans $ \top_t -> - eithersElimTransM tps tp_ret + eithersElimTransM tps tp_ret (flip map maybe_transs $ \maybe_trans ptrans -> withPermStackM id ((:>: ptrans) . RL.tail) $ popPImplTerm (forcePImplTerm maybe_trans) k) - top_t + (transTerm1 top_ptrans) -- An existential elimination performs a pattern-match on a Sigma ([nuMP| Impl1_ElimExists x p |], _) -> @@ -5251,14 +5131,13 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o () <- assertTopPermM "Impl1_ElimExists" x (fmap ValPerm_Exists p) top_ptrans <- getTopPermM tp_trans <- translateClosed tp - transTerm1M top_ptrans $ \top_t -> - sigmaElimPermTransM "x_elimEx" tp_trans + sigmaElimPermTransM "x_elimEx" tp_trans (mbCombine RL.typeCtxProxies p) compReturnTypeTransM (\etrans ptrans -> inExtTransM etrans $ withPermStackM id ((:>: ptrans) . RL.tail) m) - top_t + (transTerm1 top_ptrans) -- A false elimination becomes a call to efq ([nuMP| Impl1_ElimFalse mb_x |], _) -> @@ -5266,8 +5145,8 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o do mb_false <- nuMultiTransM $ const ValPerm_False () <- assertTopPermM "Impl1_ElimFalse" mb_x mb_false top_ptrans <- getTopPermM - transTerm1M top_ptrans $ \top_t -> - applyGlobalTransM "Prelude.efq" [compReturnTypeM, return top_t] + applyGlobalTransM "Prelude.efq" [compReturnTypeM, + return (transTerm1 top_ptrans)] -- A SimplImpl is translated using translateSimplImpl ([nuMP| Impl1_Simpl simpl mb_prx |], _) -> @@ -5652,8 +5531,7 @@ instance ImplTranslateF (LocalImplRet ps) ext blocks ps_in rets where do pctx <- itiPermStack <$> ask ev <- infoEvType <$> ask ret_tp <- returnTypeM - transTupleTermM pctx $ \pctx_t -> - return $ retSOpenTerm ev ret_tp pctx_t + 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) -> @@ -6037,28 +5915,23 @@ translateCallEntry nm entry_trans mb_tops mb_args mb_ghosts = typedEntryPermsIn entry) mb_s () <- assertPermStackEqM nm mb_perms - -- Now check if entryID has an associated recursive function index - case typedEntryTransIx entry_trans of - Just (d, funix) -> - -- If so, build the associated CallS term, which applies the function - -- index to all the terms in the args and ghosts (but not the tops, - -- which are free) plus all the permissions on the stack - transTermsM pctx $ \pctx_ts -> - do ev <- infoEvType <$> ask - return (callSOpenTerm ev d funix - (exprCtxToTerms ectx_ag ++ pctx_ts)) + -- Now check if entryID has an associated recursive function + case typedEntryTransFun entry_trans of + Just f -> + -- If so, apply the function to all the terms in the args and ghosts + -- (but not the tops, which are free) plus all the permissions on the + -- stack + return (applyOpenTermMulti f + (exprCtxToTerms ectx_ag ++ transTerms pctx)) Nothing -> -- Otherwise, continue translating with the target entrypoint, with all -- the current expressions free but with only those permissions on top -- of the stack - -- - -- FIXME HERE NOW: can we avoid doing transTermsM here? - transTermsM pctx $ \pctx_ts -> inEmptyEnvImpTransM $ inCtxTransM ectx $ do perms_trans <- translate $ typedEntryPermsIn entry withPermStackM (const $ RL.members ectx) - (const $ typeTransF perms_trans pctx_ts) + (const $ typeTransF perms_trans $ transTerms pctx) (translate $ _mbBinding $ typedEntryBody entry) instance PermCheckExtC ext exprExt => @@ -6136,29 +6009,28 @@ translateStmt loc mb_stmt m = case mbMatch mb_stmt of openTermTypeTrans <$> sigmaTypeTransM "ret" rets_trans (\ectx -> inExtMultiTransM ectx (translate perms_out)) - transTermsM pctx_ghosts_args $ \pctx_ghosts_ts -> - let all_args = - exprCtxToTerms ectx_gexprs ++ exprCtxToTerms ectx_args ++ - pctx_ghosts_ts - fapp_trm = case f_trans of - PTrans_Fun _ f_trm -> applyFunTransTerm f_trm all_args - _ -> - panic "translateStmt" - ["TypedCall: unexpected function permission"] in - bindTransM fapp_trm fret_tp "call_ret_val" $ \ret_val -> + let all_args = + exprCtxToTerms ectx_gexprs ++ exprCtxToTerms ectx_args ++ + transTerms pctx_ghosts_args + fapp_trm = case f_trans of + PTrans_Fun _ f_trm -> applyFunTrans f_trm all_args + _ -> + panic "translateStmt" + ["TypedCall: unexpected function permission"] + bindTransM fapp_trm fret_tp "call_ret_val" $ \ret_val -> sigmaElimTransM "elim_call_ret_val" rets_trans - (flip inExtMultiTransM (translate perms_out)) compReturnTypeTransM - (\rets_ectx pctx -> - inExtMultiTransM rets_ectx $ - withPermStackM - (\(vars :>: _) -> - RL.append - (fst (RL.split - (RL.append ectx_gexprs ectx_args) ectx_gexprs vars)) $ - suffixMembers ectx_outer rets_prxs) - (const pctx) - m) - ret_val + (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 _ |] -> @@ -6299,20 +6171,7 @@ translateLLVMStmt mb_stmt m = case mbMatch mb_stmt of panic "translateLLVMStmt" ["TypedLLVMResolveGlobal: no translation of symbol " ++ globalSymbolName (mbLift gsym)] - Just (_, GlobalTransFuns [f]) - | [nuP| ValPerm_LLVMFunPtr fun_tp (ValPerm_Fun fun_perm) |] <- p -> - do d <- descTransM $ translateDesc (extMb fun_perm) - let ptrans = - PTrans_Conj [APTrans_LLVMFunPtr (mbLift fun_tp) $ - PTrans_Fun fun_perm $ FunTransFun ev d f] - withPermStackM (:>: Member_Base) - (:>: extPermTrans ETrans_LLVM ptrans) m - Just (_, GlobalTransFuns _) -> - -- FIXME: make this handle multiple function translations - panic "translateLLVMStmt" - ["TypedLLVMResolveGlobal: unexpected function translation for symbol " - ++ globalSymbolName (mbLift gsym)] - Just (_, GlobalTransTerms ts) -> + Just (_, GlobalTrans ts) -> do ptrans <- translate (extMb p) withPermStackM (:>: Member_Base) (:>: typeTransF ptrans ts) m @@ -6337,8 +6196,7 @@ instance PermCheckExtC ext exprExt => Translate (ImpTransInfo ext blocks tops rets ps) ctx (TypedRet tops rets ps) OpenTerm where translate (mbMatch -> [nuMP| TypedRet Refl mb_rets mb_rets_ns mb_perms |]) = - do ev <- infoEvType <$> ask - let perms = + do let perms = mbMap2 (\rets_ns ps -> varSubst (permVarSubstOfNames rets_ns) ps) mb_rets_ns mb_perms @@ -6346,12 +6204,10 @@ instance PermCheckExtC ext exprExt => rets_trans <- translate mb_rets let rets_prxs = cruCtxProxies $ mbLift mb_rets rets_ns_trans <- translate mb_rets_ns - ret_tp <- returnTypeM sigmaTransM "r" rets_trans (flip inExtMultiTransM $ translate $ mbCombine rets_prxs mb_perms) rets_ns_trans (itiPermStack <$> ask) - (return . retSOpenTerm ev ret_tp) instance PermCheckExtC ext exprExt => ImplTranslateF (TypedRet tops rets) ext blocks tops rets where @@ -6418,17 +6274,30 @@ foldBlockMapIx f r = -- | Map a function over each 'TypedEntry' in a 'TypedBlockMap' that -- corresponds to a letrec-bound variable -mapBlockMapIx :: +mapBlockMapRecs :: (forall args ghosts. TypedEntry TransPhase ext blocks tops rets args ghosts -> b) -> TypedBlockMap TransPhase ext blocks tops rets -> [b] -mapBlockMapIx f = +mapBlockMapRecs f = map (\(SomeTypedEntry entry) -> f entry) . typedBlockIxEntries --- | Build a type description for the type of the translation of a 'TypedEntry' --- to a function. This type will pi-abstract over the real and ghost arguments --- of the entrypoint, but should have exactly the top-level arguments --- of the function free. +-- | 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 {..}) = @@ -6442,12 +6311,19 @@ translateEntryDesc (TypedEntry {..}) = return $ piTpDescMulti (args_kdescs ++ ghosts_kdescs) $ funTpDesc ds_in d_out --- | Build a list of type descriptions that describe the types of all of the --- entrypoints in a 'TypedBlockMap' that will be translated to functions +-- | 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 $ mapBlockMapIx translateEntryDesc 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 @@ -6459,25 +6335,24 @@ translateCFGDesc cfg = nuMultiTransM (const $ tpcfgFunPerm cfg) >>= descTransM . translateDesc --- | Translate a 'TypedEntry' to a 'TypedEntryTrans' by associating a function --- index term with it if it has one, i.e., if its in-degree is greater than 1. --- The state tracks all the @LetRecS@-bound function indexes for entrypoints --- that have not already been used, so if this 'TypedEntry' does need a function --- index, it should take it from the head of that list. +-- | Translate a 'TypedEntry' to a 'TypedEntryTrans' by associating a monadic +-- function with it if it has one, i.e., if its in-degree is greater than 1. The +-- state tracks all the @LetRecS@-bound functions for entrypoints that have not +-- already been used, so if this 'TypedEntry' does need a function, it should +-- take it from the head of that list. translateTypedEntry :: Some (TypedEntry TransPhase ext blocks tops rets args) -> StateT [OpenTerm] (TypeTransM tops) (Some (TypedEntryTrans ext blocks tops rets args)) translateTypedEntry (Some entry) = if typedEntryHasMultiInDegree entry then - do ixs <- get - let ix = - case ixs of - [] -> panic "translateTypedEntry" ["Ran out of function indices"] - _ -> head ixs - put $ tail ixs - d <- lift $ translateEntryDesc entry - return (Some (TypedEntryTrans entry $ Just (d, ix))) + 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) -- | Translate a 'TypedBlock' to a 'TypedBlockTrans' by translating each @@ -6501,35 +6376,27 @@ translateTypedBlockMapH (blkMap :>: blk) = return (blkMapTrans :>: blkTrans) -- | Translate a 'TypedBlockMap' to a 'TypedBlockMapTrans' by translating every --- entrypoint using 'translateTypedEntry'; see 'translateTypedEntry' for an --- explanation of the monad-in-monad type +-- entrypoint using 'translateTypedEntry', using the supplied SAW core terms as +-- the recursive functions for those entrypoints that have them translateTypedBlockMap :: [OpenTerm] -> TypedBlockMap TransPhase ext blocks tops rets -> TypeTransM tops (TypedBlockMapTrans ext blocks tops rets) -translateTypedBlockMap ixs blkMap = - runStateT (translateTypedBlockMapH blkMap) ixs >>= \case +translateTypedBlockMap fs blkMap = + runStateT (translateTypedBlockMapH blkMap) fs >>= \case (ret, []) -> return ret (_, _) -> panic "translateTypedBlockMap" ["Unused function indices"] --- | Build a nested lambda-abstraction over a sequence of function indexes of --- the given type descriptions and pass them to the supplied function -lambdaFunIxsM :: String -> [OpenTerm] -> - ([OpenTerm] -> TransM info ctx OpenTerm) -> - TransM info ctx OpenTerm -lambdaFunIxsM nm ds f = - lambdaTransM nm (openTermsTypeTrans $ map funIxTypeOpenTerm ds) f - --- | Lambda-abstract over function indexes for all the entrypoints that have one --- in a 'TypedBlockMap', whose type descriptions are given as the first --- argument, and then use those function indexes to translate the block map to a --- 'TypedBlockMapTrans' and pass it to the supplied function +-- | 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_ds blkMap f = - lambdaFunIxsM "f_loop" blk_ds $ \funixs -> - translateTypedBlockMap funixs blkMap >>= f +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 @@ -6557,7 +6424,7 @@ translateBlockMapBodies :: PermCheckExtC ext exprExt => TypedBlockMap TransPhase ext blocks tops rets -> TypeTransM tops [OpenTerm] translateBlockMapBodies mapTrans blkMap = - sequence $ mapBlockMapIx (translateEntryBody 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 @@ -6575,7 +6442,6 @@ translateCFGInitBody mapTrans cfg pctx = retTypes = typedFnHandleRetTypes h in translateRetType retTypes (tpcfgOutputPerms cfg) >>= \retTypeTrans -> impTransM (RL.members pctx) pctx mapTrans retTypeTrans $ - transTermsM pctx $ \pctx_ts -> -- Extend the expr context to contain another copy of the initial arguments -- inits, since the initial entrypoint for the entire function takes two @@ -6589,7 +6455,7 @@ translateCFGInitBody mapTrans cfg pctx = -- 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 pctx_ts + let pctx' = typeTransF ps'_trans $ transTerms pctx all_px = RL.map (\_ -> Proxy) pctx' init_entry = lookupEntryTransCast (tpcfgEntryID cfg) CruCtxNil mapTrans in withPermStackM (const $ RL.members pctx') (const pctx') $ @@ -6601,12 +6467,12 @@ translateCFGInitBody mapTrans cfg pctx = -- | 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 --- function indices have been bound for the function itself and any other --- functions it is mutually recursive with, and that these function indexes are --- in the current permissions environment. That is, this translation is --- happening for the body of a @LetRecS@ definition that has bound function --- indexes for the function itself and all functions it is mutually recursive +-- 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 -> @@ -6618,12 +6484,13 @@ translateCFGBody cfg = 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_ds blkMap $ \mapTrans -> + lambdaBlockMap blk_tps blkMap $ \mapTrans -> tupleOpenTerm <$> translateBlockMapBodies mapTrans blkMap body <- - lambdaBlockMap blk_ds blkMap $ \mapTrans -> + lambdaBlockMap blk_tps blkMap $ \mapTrans -> translateCFGInitBody mapTrans cfg pctx return $ letRecSOpenTerm ev blk_ds ret_tp bodies body @@ -6665,16 +6532,13 @@ 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 index term -someTypedCFGIxEntry :: HasPtrWidth w => SomeTypedCFG LLVM -> OpenTerm -> - PermEnvGlobalEntry -someTypedCFGIxEntry some_cfg@(SomeTypedCFG sym _ _) funix = - -- NOTE: we use GlobalTransTerms instead of GlobalTransFuns because a function - -- index is the "normal" translation of a function permission, while - -- GlobalTransFuns specifies a specFun +-- '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) - (GlobalTransTerms [funix]) + (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 @@ -6683,9 +6547,9 @@ someTypedCFGIxEntry some_cfg@(SomeTypedCFG sym _ _) funix = lambdaCFGPermEnv :: HasPtrWidth w => [SomeTypedCFG LLVM] -> TypeTransM ctx OpenTerm -> TypeTransM ctx OpenTerm lambdaCFGPermEnv some_cfgs m = - mapM translateSomeCFGDesc some_cfgs >>= \ds -> - lambdaFunIxsM "f" ds $ \funixs -> - let entries = zipWith someTypedCFGIxEntry some_cfgs funixs in + 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 @@ -6716,13 +6580,13 @@ translateCFGFromBodies cfgs bodies i 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 $ - transTermsM pctx $ \pctx_ts -> do body <- - lambdaFunIxsM "f" ds $ \funixs -> - return $ callSOpenTerm ev (ds!!i) (funixs!!i) (transTerms ectx - ++ pctx_ts) + 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 @@ -6824,7 +6688,7 @@ tcTranslateAddCFGs sc mod_name env checks endianness dlevel cfgs_and_perms = let ident = mkSafeIdent mod_name nm scInsertDef sc mod_name ident tp_trm f_trm let perm = mkPtrFunPerm $ tpcfgFunPerm cfg - return $ PermEnvGlobalEntry sym perm (GlobalTransFuns + return $ PermEnvGlobalEntry sym perm (GlobalTrans [globalOpenTerm ident])) tc_cfgs (trans_f $ globalOpenTerm bodies_id) @@ -6903,6 +6767,6 @@ translateIndTypeFun sc env ctx d = lambdaExprCtx ctx $ do args_tms <- transTerms <$> infoCtx <$> ask let ks = snd $ translateCruCtx ctx - return $ applyGlobalOpenTerm "Prelude.tpElemEnv" + return $ applyGlobalOpenTerm "SpecM.tpElemEnv" [tpEnvOpenTerm (zip ks args_tms), - ctorOpenTerm "Prelude.Tp_Ind" [d]] + ctorOpenTerm "SpecM.Tp_Ind" [d]] From 8656ca009ab8bec7ef41865011c3ec1703ad9241 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 8 Nov 2023 09:25:16 -0800 Subject: [PATCH 176/305] whoops, forgot to update an identifier from the Prelude to the SpecM module --- heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs index 607e45048d..f08fb7980e 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs @@ -907,7 +907,7 @@ evTypeTerm = globalOpenTerm . evTypeToIdent -- | The default event type uses the @Void@ type for events defaultSpecMEventType :: EventType -defaultSpecMEventType = EventType $ fromString "Prelude.VoidEv" +defaultSpecMEventType = EventType $ fromString "SpecM.VoidEv" -- | A permission environment that maps function names, permission names, and -- 'GlobalSymbols' to their respective permission structures From 9d9bc3719fc0ac8715ad29f0679301f13e7e9e07 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 8 Nov 2023 09:25:45 -0800 Subject: [PATCH 177/305] small bug fixes in the translation --- .../src/Verifier/SAW/Heapster/SAWTranslation.hs | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 007fa9ba0e..b2d672b62f 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -6196,7 +6196,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 @@ -6204,7 +6205,9 @@ instance PermCheckExtC ext exprExt => rets_trans <- translate mb_rets let rets_prxs = cruCtxProxies $ mbLift mb_rets rets_ns_trans <- translate mb_rets_ns - sigmaTransM "r" rets_trans + ret_tp <- returnTypeM + retSOpenTerm ev ret_tp <$> + sigmaTransM "r" rets_trans (flip inExtMultiTransM $ translate $ mbCombine rets_prxs mb_perms) rets_ns_trans (itiPermStack <$> ask) @@ -6768,5 +6771,6 @@ translateIndTypeFun sc env ctx d = do args_tms <- transTerms <$> infoCtx <$> ask let ks = snd $ translateCruCtx ctx return $ applyGlobalOpenTerm "SpecM.tpElemEnv" - [tpEnvOpenTerm (zip ks args_tms), + [evTypeTerm (permEnvEventType env), + tpEnvOpenTerm (zip ks args_tms), ctorOpenTerm "SpecM.Tp_Ind" [d]] From b74a972357edb9c45bf88d056abb6d44887689b0 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 8 Nov 2023 09:26:11 -0800 Subject: [PATCH 178/305] updated Coq translation to work with the new definition of SpecM --- saw-core-coq/coq/_CoqProject | 1 + .../CryptolPrimitivesForSAWCoreExtra.v | 7 +- .../coq/handwritten/CryptolToCoq/SpecM.v | 24 +++-- saw-core-coq/saw/generate_scaffolding.saw | 5 +- .../src/Verifier/SAW/Translation/Coq.hs | 1 + .../SAW/Translation/Coq/SpecialTreatment.hs | 92 +++++++++++-------- src/SAWScript/Interpreter.hs | 12 +-- src/SAWScript/Prover/Exporter.hs | 36 ++++++-- 8 files changed, 111 insertions(+), 67 deletions(-) diff --git a/saw-core-coq/coq/_CoqProject b/saw-core-coq/coq/_CoqProject index d6a70468c6..410aba5b65 100644 --- a/saw-core-coq/coq/_CoqProject +++ b/saw-core-coq/coq/_CoqProject @@ -3,6 +3,7 @@ generated/CryptolToCoq/SAWCorePrelude.v generated/CryptolToCoq/CryptolPrimitivesForSAWCore.v +generated/CryptolToCoq/SpecMPrimitivesForSAWCore.v # generated/CryptolToCoq/CryptolMPrimitivesForSAWCore.v handwritten/CryptolToCoq/SpecM.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/SpecM.v b/saw-core-coq/coq/handwritten/CryptolToCoq/SpecM.v index 6786f3562b..645d006e4c 100644 --- a/saw-core-coq/coq/handwritten/CryptolToCoq/SpecM.v +++ b/saw-core-coq/coq/handwritten/CryptolToCoq/SpecM.v @@ -12,6 +12,7 @@ From EnTree Require Import EnTreeSpecs TpDesc. 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} := @@ -33,6 +34,7 @@ Definition evalUnOp {EK1 EK2} (op: TpExprUnOp EK1 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) : @@ -60,6 +62,14 @@ Global Instance SAWTpExprOps : TpExprOps := ** Now we re-export all of TpDesc using the above instance **) +(* Num: note that the Num type has to be defined in the TpDesc module, so its +type descriptions can refer to it, so we map the definition in Cryptol.sawcore +to that definition *) +Definition Num := TpDesc.Num. +Definition Num_rect := TpDesc.Num_rect. +Definition TCNum := TpDesc.TCNum. +Definition TCInf := TpDesc.TCInf. + (* EvType *) Definition EvType := FixTree.EvType. Definition Build_EvType := FixTree.Build_EvType. @@ -72,6 +82,7 @@ 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 *) @@ -98,7 +109,7 @@ Definition Tp_Kind := Tp_Kind. Definition Tp_Pair := Tp_Pair. Definition Tp_Sum := Tp_Sum. Definition Tp_Sigma := Tp_Sigma. -Definition Tp_Vec := Tp_Vec. +Definition Tp_Seq := Tp_Seq. Definition Tp_Void := Tp_Void. Definition Tp_Ind := Tp_Ind. Definition Tp_Var := Tp_Var. @@ -106,16 +117,17 @@ 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 indElem_rect := indElem_rect. -Definition indToTpElem := indToTpElem. -Definition tpToIndElem := tpToIndElem. +Definition foldTpElem := @foldTpElem. +Definition unfoldTpElem := @unfoldTpElem. (* SpecM and its operations *) -Definition FunIx := @FixTree.FunIx TpDesc. Definition SpecM := @SpecM.SpecM SAWTpExprOps. Definition retS := @SpecM.RetS SAWTpExprOps. Definition bindS := @SpecM.BindS SAWTpExprOps. @@ -125,8 +137,6 @@ Definition forallS := @SpecM.ForallS SAWTpExprOps. Definition existsS := @SpecM.ExistsS SAWTpExprOps. Definition assumeS := @SpecM.AssumeS SAWTpExprOps. Definition assertS := @SpecM.AssertS SAWTpExprOps. -Definition CallS := @SpecM.CallS SAWTpExprOps. -Definition LambdaS := @SpecM.LambdaS SAWTpExprOps. Definition FixS := @SpecM.FixS SAWTpExprOps. Definition MultiFixS := @SpecM.MultiFixS SAWTpExprOps. Definition LetRecS := @SpecM.LetRecS SAWTpExprOps. 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.hs b/saw-core-coq/src/Verifier/SAW/Translation/Coq.hs index 78ea6593fe..a7dd096b85 100644 --- a/saw-core-coq/src/Verifier/SAW/Translation/Coq.hs +++ b/saw-core-coq/src/Verifier/SAW/Translation/Coq.hs @@ -106,6 +106,7 @@ From Coq Require Import String. From Coq Require Import Vectors.Vector. From CryptolToCoq Require Import SAWCoreScaffolding. From CryptolToCoq Require Import SpecM. +From CryptolToCoq Require Import SpecMPrimitivesForSAWCore. From CryptolToCoq Require Import #{vectorModule}. Import VectorNotations. 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 894eeb84e6..05f2e056ca 100644 --- a/saw-core-coq/src/Verifier/SAW/Translation/Coq/SpecialTreatment.hs +++ b/saw-core-coq/src/Verifier/SAW/Translation/Coq/SpecialTreatment.hs @@ -200,9 +200,10 @@ sawDefinitionsModule = mkModuleName ["SAWCoreScaffolding"] specMModule :: ModuleName specMModule = mkModuleName ["SpecM"] --- FIXME: I don't think we are even importing PolyList any more... +{- polyListModule :: ModuleName polyListModule = mkModuleName ["PolyList"] +-} sawVectorDefinitionsModule :: TranslationConfiguration -> ModuleName sawVectorDefinitionsModule (TranslationConfiguration {..}) = @@ -214,21 +215,26 @@ 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 $ [] ++ - [ ("Num_rec", mapsTo cryptolPrimitivesModule "Num_rect") -- automatically defined + [ ("Num", mapsTo specMModule "Num") + , ("TCNum", mapsTo specMModule "TCNum") + , ("TCInf", mapsTo specMModule "TCInf") + , ("Num_rec", mapsTo specMModule "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 +243,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 $ @@ -507,26 +514,57 @@ sawCorePreludeSpecialTreatmentMap configuration = , ("Right", mapsToExpl datatypesModule "inr") ] - -- Type descriptions + -- Dependent pairs + ++ + [ ("Sigma", replace (Coq.ExplVar "sigT")) + , ("exists", replace (Coq.ExplVar "existT")) + , ("Sigma__rec", replace (Coq.ExplVar "sigT_rect")) + , ("Sigma_proj1", replace (Coq.ExplVar "projT1")) + , ("Sigma_proj2", replace (Coq.ExplVar "projT2")) + ] + + -- Lists + ++ + [ ("List", mapsToExpl datatypesModule "list") + , ("Nil", mapsToExpl datatypesModule "nil") + , ("Cons", mapsToExpl datatypesModule "cons") + , ("List__rec", mapsToExpl datatypesModule "list_rect") + ] + + -- Lists at sort 1 + {- FIXME: in order to support lists at a higher sort, we need a universe + polymorphic version of them ++ - map (\str -> (str, mapsToExpl specMModule str)) + [ ("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_Vec", "Tp_Void", "Tp_Ind", "Tp_Var", "Tp_TpSubst" + , "Tp_Sigma", "Tp_Seq", "Tp_Void", "Tp_Ind", "Tp_Var", "Tp_TpSubst" , "Tp_ExprSubst" , "tpSubst", "elimTpEnvElem", "tpElemEnv" , "indElem", "indToTpElem", "tpToIndElem" + , "FunFlag", "IsFun", "IsData" ] -- The specification monad ++ [ ("EvType", mapsTo specMModule "EvType") , ("Build_EvType", mapsTo specMModule "Build_EvType") - , ("FunIx", mapsTo specMModule "FunIx") , ("evTypeType", mapsTo specMModule "evTypeType") , ("evRetType", mapsTo specMModule "evRetType") , ("SpecM", mapsTo specMModule "SpecM") @@ -538,12 +576,9 @@ sawCorePreludeSpecialTreatmentMap configuration = , ("existsS", mapsToExplInferArg "SpecM.existsS" 2) , ("assumeS", mapsToExpl specMModule "assumeS") , ("assertS", mapsToExpl specMModule "assertS") - , ("CallS", mapsToExpl specMModule "CallS") - , ("LambdaS", mapsToExpl specMModule "LambdaS") , ("FixS", mapsToExpl specMModule "FixS") , ("MultiFixS", mapsToExpl specMModule "MultiFixS") , ("LetRecS", mapsToExpl specMModule "LetRecS") - , ("specFun", mapsTo specMModule "specFun") {- , ("SpecPreRel", mapsToExpl entreeSpecsModule "SpecPreRel") , ("SpecPostRel", mapsToExpl entreeSpecsModule "SpecPostRel") @@ -553,29 +588,6 @@ sawCorePreludeSpecialTreatmentMap configuration = , ("refinesS_eq", skip) ] - -- Dependent pairs - ++ - [ ("Sigma", replace (Coq.ExplVar "sigT")) - , ("exists", replace (Coq.ExplVar "existT")) - , ("Sigma__rec", replace (Coq.ExplVar "sigT_rect")) - , ("Sigma_proj1", replace (Coq.ExplVar "projT1")) - , ("Sigma_proj2", replace (Coq.ExplVar "projT2")) - ] - - -- Lists - ++ - [ ("List", mapsToExpl datatypesModule "list") - , ("Nil", mapsToExpl datatypesModule "nil") - , ("Cons", mapsToExpl datatypesModule "cons") - , ("List__rec", mapsToExpl datatypesModule "list_rect") - ] - - -- Lists at sort 1 - ++ - [ ("List1", mapsToExpl polyListModule "plist") - , ("Nil1", mapsToExpl polyListModule "pnil") - , ("Cons1", mapsToExpl polyListModule "pcons") - ] escapeIdent :: String -> String diff --git a/src/SAWScript/Interpreter.hs b/src/SAWScript/Interpreter.hs index fa900efc36..b732d70c8b 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 ()" @@ -4345,7 +4345,7 @@ primitives = Map.fromList "HeapsterEnv -> String -> String -> String -> String -> TopLevel HeapsterEnv" (bicVal heapster_define_recursive_perm) Experimental - [ "heapster_define_recursive_perm env nm arg_ctx tp p defined a recursive" + [ "heapster_define_recursive_perm env nm arg_ctx tp p defines a recursive" , " Heapster permission named nm with arguments parsed from args_ctx and" , " type parsed from tp that translates to permissions p, which can" , " resurively use nm (with no arguments) in those permissions" diff --git a/src/SAWScript/Prover/Exporter.hs b/src/SAWScript/Prover/Exporter.hs index 5869fe31f9..4499b1e321 100644 --- a/src/SAWScript/Prover/Exporter.hs +++ b/src/SAWScript/Prover/Exporter.hs @@ -70,7 +70,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, scLoadSpecMModule, 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 @@ -436,6 +437,14 @@ withImportCryptolPrimitivesForSAWCore config@(Coq.TranslationConfiguration { Coq ] } +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 @@ -539,11 +548,11 @@ 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 @@ -551,21 +560,28 @@ writeCoqCryptolPrimitivesForSAWCore outputFile outputFileM notations skips = do () <- 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_mon = + let configuration_spec = withImportCryptolPrimitivesForSAWCore configuration + let configuration_mon = + 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) From 1dcab38d9637821a1d6f74466098ab24484b3c9f Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 8 Nov 2023 09:49:27 -0800 Subject: [PATCH 179/305] more small bug fixes to the translation --- .../src/Verifier/SAW/Heapster/SAWTranslation.hs | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index b2d672b62f..114d9e75cd 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -4769,11 +4769,12 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of do ttrans <- translateSimplImplOutHead mb_simpl let args_ctx = mbLift $ fmap namedShapeArgs nmsh' d <- substNamedIndTpDesc (mbLift mb_sh_id) args_ctx mb_args + ev <- infoEvType <$> ask withPermStackTopTermsM id (\ts (pctx :>: _) -> pctx :>: typeTransF ttrans [applyGlobalOpenTerm "SpecM.foldTpElem" - [d, tupleOpenTerm' ts]]) + [evTypeTerm ev, d, tupleOpenTerm' ts]]) m -- Intro for a defined named shape (the other case) is a no-op @@ -4796,11 +4797,12 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of do ttrans <- translateSimplImplOutHead mb_simpl let args_ctx = mbLift $ fmap namedShapeArgs nmsh' d <- substNamedIndTpDesc (mbLift mb_sh_id) args_ctx mb_args + ev <- infoEvType <$> ask withPermStackTopTermsM id (\ts (pctx :>: _) -> pctx :>: typeTransF ttrans [applyGlobalOpenTerm "SpecM.unfoldTpElem" - [d, tupleOpenTerm' ts]]) + [evTypeTerm ev, d, tupleOpenTerm' ts]]) m -- Elim for a defined named shape (the other case) is a no-op @@ -4927,11 +4929,12 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of let args_ctx = mbLift $ fmap (namedPermNameArgs . recPermName) mb_rp let d_id = mbLift $ fmap recPermTransDesc mb_rp d <- substNamedIndTpDesc d_id args_ctx mb_args + ev <- infoEvType <$> ask withPermStackTopTermsM id (\ts (pctx :>: _) -> pctx :>: typeTransF ttrans [applyGlobalOpenTerm "SpecM.foldTpElem" - [d, tupleOpenTerm' ts]]) + [evTypeTerm ev, d, tupleOpenTerm' ts]]) m [nuMP| SImpl_UnfoldNamed _ (NamedPerm_Rec mb_rp) mb_args _ |] -> @@ -4939,11 +4942,12 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of let args_ctx = mbLift $ fmap (namedPermNameArgs . recPermName) mb_rp let d_id = mbLift $ fmap recPermTransDesc mb_rp d <- substNamedIndTpDesc d_id args_ctx mb_args + ev <- infoEvType <$> ask withPermStackTopTermsM id (\ts (pctx :>: _) -> pctx :>: typeTransF ttrans [applyGlobalOpenTerm "SpecM.unfoldTpElem" - [d, tupleOpenTerm' ts]]) + [evTypeTerm ev, d, tupleOpenTerm' ts]]) m [nuMP| SImpl_FoldNamed _ (NamedPerm_Defined _) _ _ |] -> @@ -6771,6 +6775,5 @@ translateIndTypeFun sc env ctx d = 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.Tp_Ind" [d]] + [evTypeTerm (permEnvEventType env), tpEnvOpenTerm (zip ks args_tms), + ctorOpenTerm "SpecM.IsData" [], ctorOpenTerm "SpecM.Tp_Ind" [d]] From 44dd134bcc93610a6c0d156b2d2198aa47903b66 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 8 Nov 2023 10:57:03 -0800 Subject: [PATCH 180/305] bug fixes to get folding of inductive types to work properly --- .../src/Verifier/SAW/Heapster/Permissions.hs | 5 ++- .../Verifier/SAW/Heapster/SAWTranslation.hs | 44 +++++++++++-------- 2 files changed, 29 insertions(+), 20 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs index f08fb7980e..efa719ff79 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs @@ -667,8 +667,9 @@ data NamedShapeBody b args w where -- | A recursive shape body has a one-step unfolding to a shape, which can -- refer to the shape itself via the last bound variable. It also has two -- identifiers, one for a function from translations of the @args@ to the type - -- to use as the translation of the shape applied to @args@ and one for - -- a type description with @args@ as free variables. + -- to use as the translation of the shape applied to @args@ and one for a type + -- description with @args@ plus a variable for the shape itself (for + -- recursively referring to itself) as free variables. RecShapeBody :: Mb (args :> LLVMShapeType w) (PermExpr (LLVMShapeType w)) -> Ident -> Ident -> NamedShapeBody 'True args w diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 114d9e75cd..64c3cd6bed 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -336,6 +336,11 @@ varKindExpr d ix = applyGlobalOpenTerm "SpecM.varKindExpr" [d,natOpenTerm ix] 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 @@ -350,10 +355,16 @@ substTpDescMulti _ _ _ = panic "substTpDescMulti" ["Mismatched number of kinds versus expressions"] -- | Build the type description that performs 0 or more explicit substitutions --- from a type description given by an identifier +-- 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 :: OpenTerm -> OpenTerm tpElemTypeOpenTerm d = @@ -1636,7 +1647,7 @@ instance TransInfo info => args_terms <- transTerms <$> translate args args_ds <- descTransM $ translateDescs args return $ - ETrans_Shape [substIdTpDescMulti (mbLift desc_id) k_ds args_ds] + ETrans_Shape [substIndIdTpDescMulti (mbLift desc_id) k_ds args_ds] [applyGlobalOpenTerm (mbLift tp_id) args_terms] [nuMP| RecShapeBody _ tp_id desc_id |] -> do let (_, k_ds) = translateCruCtx (mbLift $ fmap namedShapeArgs nmsh) @@ -1819,7 +1830,7 @@ instance TranslateDescs (PermExpr a) where [nuMP| RecShapeBody _ _ desc_id |] -> do let (_, k_ds) = translateCruCtx (mbLift $ fmap namedShapeArgs nmsh) args_ds <- translateDescs args - return [substIdTpDescMulti (mbLift desc_id) k_ds args_ds] + return [substIndIdTpDescMulti (mbLift desc_id) k_ds args_ds] [nuMP| PExpr_EqShape _ _ |] -> return [] [nuMP| PExpr_PtrShape _ _ sh |] -> translateDescs sh [nuMP| PExpr_FieldShape fsh |] -> translateDescs fsh @@ -3077,7 +3088,7 @@ instance TranslateDescs (ValuePerm a) where Just (NamedPerm_Opaque op) -> return [substIdTpDescMulti (opaquePermTransDesc op) k_ds args_ds] Just (NamedPerm_Rec rp) -> - return [substIdTpDescMulti (recPermTransDesc rp) k_ds args_ds] + return [substIndIdTpDescMulti (recPermTransDesc rp) k_ds args_ds] Just (NamedPerm_Defined dp) -> translateDescs (mbMap2 (unfoldDefinedPerm dp) args off) Nothing -> panic "translate" ["Unknown permission name!"] @@ -4770,12 +4781,11 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of 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.foldTpElem" - [evTypeTerm ev, d, tupleOpenTerm' ts]]) - m + 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 -> @@ -4930,12 +4940,11 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of let d_id = mbLift $ fmap recPermTransDesc mb_rp d <- substNamedIndTpDesc d_id args_ctx mb_args ev <- infoEvType <$> ask - withPermStackTopTermsM id - (\ts (pctx :>: _) -> - pctx :>: - typeTransF ttrans [applyGlobalOpenTerm "SpecM.foldTpElem" - [evTypeTerm ev, d, tupleOpenTerm' ts]]) - m + 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 @@ -6168,7 +6177,6 @@ translateLLVMStmt mb_stmt m = case mbMatch mb_stmt of withKnownNat ?ptrWidth $ inExtTransM ETrans_LLVM $ do env <- infoEnv <$> ask - ev <- infoEvType <$> ask let w :: NatRepr w = knownRepr case lookupGlobalSymbol env (mbLift gsym) w of Nothing -> @@ -6776,4 +6784,4 @@ translateIndTypeFun sc env ctx d = let ks = snd $ translateCruCtx ctx return $ applyGlobalOpenTerm "SpecM.tpElemEnv" [evTypeTerm (permEnvEventType env), tpEnvOpenTerm (zip ks args_tms), - ctorOpenTerm "SpecM.IsData" [], ctorOpenTerm "SpecM.Tp_Ind" [d]] + ctorOpenTerm "SpecM.IsData" [], indTpDesc d] From 31e886284a35bb909c38080c69671aec574f7606 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 8 Nov 2023 10:57:35 -0800 Subject: [PATCH 181/305] updated the arrays and linked_list examples to work with the new version of SpecM --- heapster-saw/examples/arrays.sawcore | 29 ++++++------- heapster-saw/examples/linked_list.saw | 22 +++++----- heapster-saw/examples/linked_list.sawcore | 50 ++--------------------- 3 files changed, 25 insertions(+), 76 deletions(-) diff --git a/heapster-saw/examples/arrays.sawcore b/heapster-saw/examples/arrays.sawcore index f1c7398f1e..c7c86879b5 100644 --- a/heapster-saw/examples/arrays.sawcore +++ b/heapster-saw/examples/arrays.sawcore @@ -1,7 +1,7 @@ module arrays where -import Prelude; +import SpecM; noErrorsHDesc : TpDesc; noErrorsHDesc = @@ -21,26 +21,21 @@ noErrorsHDesc = -- The helper function for noErrorsContains0 -- -- noErrorsContains0H len i v = -<<<<<<< HEAD -- orS existsS (noErrorsContains0H len (i+1) v) noErrorsContains0H : (len i:Vec 64 Bool) -> BVVec 64 len (Vec 64 Bool) -> SpecM VoidEv (BVVec 64 len (Vec 64 Bool) * Vec 64 Bool); noErrorsContains0H len_top i_top v_top = - bindS VoidEv - (FunIx noErrorsHDesc) (BVVec 64 len_top (Vec 64 Bool) * Vec 64 Bool) - (FixS VoidEv noErrorsHDesc - (\ (rec : FunIx noErrorsHDesc) (len:Vec 64 Bool) (i:Vec 64 Bool) - (v:BVVec 64 len (Vec 64 Bool)) -> - invariantHint - (SpecM VoidEv (BVVec 64 len (Vec 64 Bool) * Vec 64 Bool)) - (and (bvsle 64 0x0000000000000000 i) - (bvsle 64 i 0x0fffffffffffffff)) - (orS VoidEv (BVVec 64 len (Vec 64 Bool) * Vec 64 Bool) - (existsS VoidEv (BVVec 64 len (Vec 64 Bool) * Vec 64 Bool)) - (CallS VoidEv noErrorsHDesc rec - len (bvAdd 64 i 0x0000000000000001) v)))) - (\ (f : FunIx noErrorsHDesc) -> - CallS VoidEv noErrorsHDesc f len_top i_top v_top); + (FixS VoidEv noErrorsHDesc + (\ (rec : specFun VoidEv noErrorsHDesc) (len:Vec 64 Bool) (i:Vec 64 Bool) + (v:BVVec 64 len (Vec 64 Bool)) -> + invariantHint + (SpecM VoidEv (BVVec 64 len (Vec 64 Bool) * Vec 64 Bool)) + (and (bvsle 64 0x0000000000000000 i) + (bvsle 64 i 0x0fffffffffffffff)) + (orS VoidEv (BVVec 64 len (Vec 64 Bool) * Vec 64 Bool) + (existsS VoidEv (BVVec 64 len (Vec 64 Bool) * Vec 64 Bool)) + (rec len (bvAdd 64 i 0x0000000000000001) v)))) + len_top i_top v_top; -- The specification that contains0 has no errors noErrorsContains0 : (len:Vec 64 Bool) -> BVVec 64 len (Vec 64 Bool) -> 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 6c59f0331f..025fdea7d3 100644 --- a/heapster-saw/examples/linked_list.sawcore +++ b/heapster-saw/examples/linked_list.sawcore @@ -1,53 +1,9 @@ module linked_list where -import Prelude; +import SpecM; -test : Nat -> Sigma Nat (\ (n:Nat) -> (m:Nat) -> IsLeNat n (Succ m) -> Nat); -test x = - exists Nat (\ (n:Nat) -> (m:Nat) -> IsLeNat n (Succ m) -> Nat) - (addNat (Succ x) (Succ x)) - (\ (m:Nat) (pf:IsLeNat (addNat (Succ x) (Succ x)) (Succ m)) -> m); - -List_def : (a:sort 0) -> sort 0; -List_def a = List a; - --- The empty list of spec imports -emptyImps : (E:EvType) -> List1 (SpecImp E); -emptyImps E = Nil1 (SpecImp E); - --- The function stack for simpleSpecDef -simpleSpecStack : (E:EvType) -> FunStack; -simpleSpecStack E = defineSpecStack E emptyFunStack (emptyImps E); - --- Build a specification definition with no imports and no recursive functions --- from its body -simpleSpecDef : (E:EvType) -> (lrt:LetRecType) -> - ((stk':FunStack) -> SpecFun E stk' lrt) -> - SpecDef E lrt; -simpleSpecDef E lrt bodyF = - defineSpec - E emptyFunStack lrt (Nil1 (SpecImp E)) - (\ (stk':FunStack) (incl:stackIncl (simpleSpecStack E) stk') -> ()) - (\ (stk':FunStack) (_:stackIncl (simpleSpecStack E) stk') -> bodyF stk'); - -{- -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) -> ())); --} - --- Build a LetRecType for a dependent function type of 1 argument -lrtFromPi1 : (A:sort 0) -> (B:A -> sort 0) -> LetRecType; -lrtFromPi1 A B = LRT_FunDep A (\ (a:A) -> LRT_SpecM (LRT_Type (B a))); - -mallocLRT : LetRecType; -mallocLRT = lrtFromPi1 (Vec 64 Bool) (\ (sz:Vec 64 Bool) -> BVVec 64 sz #()); - -mallocSpec : SpecDef VoidEv mallocLRT; -mallocSpec = - simpleSpecDef VoidEv mallocLRT - (\ (stk':FunStack) (sz:Vec 64 Bool) -> - retS VoidEv stk' (BVVec 64 sz #()) - (genBVVec 64 sz #() (\ (i:Vec 64 Bool) (_:is_bvult 64 i sz) -> ()))); From 0f276fcd1ed3da9b93da9788a0da1643f9a0d660 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 8 Nov 2023 12:08:56 -0800 Subject: [PATCH 182/305] whoops, tpElem needs to be applied to an event type --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 97 +++++++++++++------ 1 file changed, 66 insertions(+), 31 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 64c3cd6bed..18211fed59 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -366,9 +366,9 @@ substIndIdTpDescMulti :: Ident -> [OpenTerm] -> [OpenTerm] -> OpenTerm substIndIdTpDescMulti i = substTpDescMulti (indTpDesc (globalOpenTerm i)) -- | Map from type description @T@ to the type @T@ describes -tpElemTypeOpenTerm :: OpenTerm -> OpenTerm -tpElemTypeOpenTerm d = - applyGlobalOpenTerm "SpecM.tpElem" [d] +tpElemTypeOpenTerm :: EventType -> OpenTerm -> OpenTerm +tpElemTypeOpenTerm ev d = + applyGlobalOpenTerm "SpecM.tpElem" [evTypeTerm ev, d] -- | Build the computation type @SpecM E A@ specMTypeOpenTerm :: EventType -> OpenTerm -> OpenTerm @@ -634,7 +634,7 @@ exprCtxToTerms :: ExprTransCtx tps -> [OpenTerm] exprCtxToTerms = transTerms -- | Map an 'ExprTrans' to its type translation -exprTransType :: ExprTrans tp -> TypeTrans (ExprTrans tp) +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 @@ -646,15 +646,16 @@ exprTransType ETrans_Unit = mkTypeTrans0 ETrans_Unit exprTransType ETrans_AnyVector = mkTypeTrans0 ETrans_AnyVector exprTransType (ETrans_Shape _ _) = mkTypeTrans1 tpDescTypeOpenTerm (\d -> - ETrans_Shape [d] [tpElemTypeOpenTerm d]) + ETrans_Shape [d] [tpElemTypeOpenTerm ?ev d]) exprTransType (ETrans_Perm _ _) = - mkTypeTrans1 tpDescTypeOpenTerm (\d -> ETrans_Perm [d] [tpElemTypeOpenTerm d]) + 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 :: ExprTransCtx ctx -> TypeTrans (ExprTransCtx ctx) +exprCtxType :: (?ev :: EventType) => ExprTransCtx ctx -> + TypeTrans (ExprTransCtx ctx) exprCtxType MNil = mkTypeTrans0 MNil exprCtxType (ectx :>: e) = (:>:) <$> exprCtxType ectx <*> exprTransType e @@ -662,7 +663,7 @@ 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 :: ExprTrans a -> [OpenTerm] +exprTransDescs :: (?ev :: EventType) => ExprTrans a -> [OpenTerm] exprTransDescs ETrans_LLVM = [] exprTransDescs ETrans_LLVMBlock = [] exprTransDescs ETrans_LLVMFrame = [] @@ -1261,7 +1262,8 @@ 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 :: TypeRepr a -> (TypeTrans (ExprTrans a), [OpenTerm]) +translateType :: (?ev :: EventType) => TypeRepr a -> + (TypeTrans (ExprTrans a), [OpenTerm]) translateType UnitRepr = (mkTypeTrans0 ETrans_Unit, []) translateType BoolRepr = (mkTermType1 (globalOpenTerm "Prelude.Bool"), [boolKindDesc]) @@ -1286,11 +1288,11 @@ translateType RWModalityRepr = (mkTypeTrans0 ETrans_RWModality, []) -- Permissions and LLVM shapes translate to type descriptions translateType (ValuePermRepr _) = (mkTypeTrans1 tpDescTypeOpenTerm (\d -> - ETrans_Perm [d] [tpElemTypeOpenTerm d]), + ETrans_Perm [d] [tpElemTypeOpenTerm ?ev d]), [tpKindDesc]) translateType (LLVMShapeRepr _) = (mkTypeTrans1 tpDescTypeOpenTerm (\d -> - ETrans_Shape [d] [tpElemTypeOpenTerm d]), + ETrans_Shape [d] [tpElemTypeOpenTerm ?ev d]), [tpKindDesc]) translateType tp@(FloatRepr _) = @@ -1318,7 +1320,8 @@ translateType tp = -- | Translate a 'CruCtx' to a 'TypeTrans' and to a list of kind descriptions -- that describe the types in the 'TypeTrans' -translateCruCtx :: CruCtx ctx -> (TypeTrans (ExprTransCtx ctx), [OpenTerm]) +translateCruCtx :: (?ev :: EventType) => CruCtx ctx -> + (TypeTrans (ExprTransCtx ctx), [OpenTerm]) translateCruCtx CruCtxNil = (mkTypeTrans0 MNil, []) translateCruCtx (CruCtxCons ctx tp) = let (ctx_trans, ds1) = translateCruCtx ctx @@ -1326,7 +1329,7 @@ translateCruCtx (CruCtxCons ctx tp) = ((:>:) <$> ctx_trans <*> tp_trans, ds1 ++ ds2) -- | Translate a permission expression type to a list of kind descriptions -translateKindDescs :: TypeRepr a -> [OpenTerm] +translateKindDescs :: (?ev :: EventType) => TypeRepr a -> [OpenTerm] translateKindDescs = snd . translateType -- Translate an expression type to a 'TypeTrans', which both gives a list of 0 @@ -1334,11 +1337,15 @@ translateKindDescs = snd . translateType -- translation from SAW core terms of those types instance TransInfo info => Translate info ctx (TypeRepr a) (TypeTrans (ExprTrans a)) where - translate = return . fst . translateType . mbLift + 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 = return . fst . translateCruCtx . mbLift + 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 -> @@ -1392,6 +1399,10 @@ data DescTransInfo ctx where 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 _ _) = @@ -1440,9 +1451,12 @@ inExtCtxDescTransM :: CruCtx ctx2 -> ([OpenTerm] -> DescTransM (ctx1 :++: ctx2) a) -> DescTransM ctx1 a inExtCtxDescTransM ctx m = - let kdesc_ctx = RL.map (Constant . translateKindDescs) $ cruCtxToTypes ctx - kdescs = concat $ RL.toList kdesc_ctx in - inExtDescTransMultiM kdesc_ctx $ m kdescs + 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 deBruij indices.Pass the concatenated list of all the kind @@ -1643,14 +1657,20 @@ instance TransInfo info => [nuMP| DefinedShapeBody _ |] -> translate (mbMap2 unfoldNamedShape nmsh args) [nuMP| OpaqueShapeBody _ tp_id desc_id |] -> - do let (_, k_ds) = translateCruCtx (mbLift $ fmap namedShapeArgs nmsh) + 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 [substIndIdTpDescMulti (mbLift desc_id) k_ds args_ds] [applyGlobalOpenTerm (mbLift tp_id) args_terms] [nuMP| RecShapeBody _ tp_id desc_id |] -> - do let (_, k_ds) = translateCruCtx (mbLift $ fmap namedShapeArgs nmsh) + 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 $ @@ -1683,7 +1703,8 @@ instance TransInfo info => [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 - let (tptrans, _) = translateType tp_repr + ev <- infoEvType <$> ask + let (tptrans, _) = let ?ev = ev in translateType tp_repr d <- descTransM $ inExtCtxDescTransM (singletonCruCtx tp_repr) $ \kdescs -> sigmaTpDescMulti kdescs <$> translateDesc mb_sh @@ -1783,8 +1804,9 @@ translateBVDesc mb_e = -- 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 $ exprTransDescs etrans + 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 @@ -1824,11 +1846,17 @@ instance TranslateDescs (PermExpr a) where [nuMP| DefinedShapeBody _ |] -> translateDescs (mbMap2 unfoldNamedShape nmsh args) [nuMP| OpaqueShapeBody _ _ desc_id |] -> - do let (_, k_ds) = translateCruCtx (mbLift $ fmap namedShapeArgs nmsh) + 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 let (_, k_ds) = translateCruCtx (mbLift $ fmap namedShapeArgs nmsh) + 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 [] @@ -1872,7 +1900,8 @@ substNamedIndTpDesc :: TransInfo info => Ident -> CruCtx tps -> Mb ctx (PermExprs tps) -> TransM info ctx OpenTerm substNamedIndTpDesc d_id tps args = - do let ks = snd $ translateCruCtx tps + 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) @@ -3071,9 +3100,10 @@ instance TranslateDescs (ValuePerm a) where (:[]) <$> (sumTpDesc <$> translateDesc p1 <*> translateDesc p2) [nuMP| ValPerm_Exists mb_mb_p' |] | [nuP| ValPerm_Eq _ |] <- mbCombine RL.typeCtxProxies mb_mb_p' -> - let tp_repr = mbLift $ fmap bindingType mb_mb_p' - (_, k_ds) = translateType tp_repr in - return [tupleTpDesc $ map kindToTpDesc k_ds] + 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' @@ -3083,7 +3113,9 @@ instance TranslateDescs (ValuePerm a) where do let npn = mbLift mb_npn env <- dtiEnv <$> ask args_ds <- translateDescs args - let (_, k_ds) = translateCruCtx (namedPermNameArgs npn) + 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] @@ -6726,8 +6758,9 @@ translateCompleteFunPerm sc env fun_perm = -- | Translate a 'TypeRepr' to the SAW core type it represents, raising an error -- if it translates to more than one type -translateCompleteType :: SharedContext -> TypeRepr tp -> IO Term -translateCompleteType sc tp = +translateCompleteType :: SharedContext -> PermEnv -> TypeRepr tp -> IO Term +translateCompleteType sc env tp = + let ?ev = permEnvEventType env in completeNormOpenTerm sc $ typeTransType1 $ fst $ translateType tp -- | Translate a 'TypeRepr' within the given context of type arguments to the @@ -6735,6 +6768,7 @@ translateCompleteType sc tp = translateCompleteTypeInCtx :: SharedContext -> PermEnv -> CruCtx args -> Mb args (TypeRepr a) -> IO Term translateCompleteTypeInCtx sc env args ret = + let ?ev = permEnvEventType env in completeNormOpenTerm sc $ runNilTypeTransM env noChecks $ piExprCtx args (return $ typeTransType1 $ fst $ translateType $ mbLift ret) @@ -6778,6 +6812,7 @@ translateExprTypeFunType sc env ctx = translateIndTypeFun :: SharedContext -> PermEnv -> CruCtx ctx -> OpenTerm -> IO Term translateIndTypeFun sc env ctx d = + let ?ev = permEnvEventType env in liftIO $ completeOpenTerm sc $ runNilTypeTransM env noChecks $ lambdaExprCtx ctx $ do args_tms <- transTerms <$> infoCtx <$> ask From 35a2a8dd978b942574ea3f5cbd2d76d134c3e74a Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 8 Nov 2023 12:09:21 -0800 Subject: [PATCH 183/305] uncommented a bunch of the old rust_data functions, and got them working --- heapster-saw/examples/rust_data.saw | 67 +++++++++++-------------- heapster-saw/examples/rust_data.sawcore | 16 +++--- 2 files changed, 38 insertions(+), 45 deletions(-) diff --git a/heapster-saw/examples/rust_data.saw b/heapster-saw/examples/rust_data.saw index a234d515c7..5b6e3ab892 100644 --- a/heapster-saw/examples/rust_data.saw +++ b/heapster-saw/examples/rust_data.saw @@ -103,14 +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:TpDesc) -> List (tpElem T)" - "ListDesc (Tp_Var 1)"; + "\\ (T:TpDesc) -> ListDescType T" + "ListDesc"; // Opaque type for HashMap heapster_define_opaque_llvmshape env "HashMap" 64 "T:llvmshape 64, U:llvmshape 64" "56" - "\\ (T:TpDesc) (U:TpDesc) -> List (tpElem T * tpElem U)" - "ListDesc (Tp_Pair (Tp_Var 2) (Tp_Var 1))"; + "\\ (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 @@ -256,7 +256,7 @@ heapster_assume_fun env "llvm.memcpy.p0i8.p0i8.i64" \ arg0:[l1]memblock(W,0,len,sh), 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:TpDesc) (len:Vec 64 Bool) (x:tpElem X) -> \ + "\\ (X:TpDesc) (len:Vec 64 Bool) (x:tpElem VoidEv X) -> \ \ retS VoidEv #() ()"; // Box>::clone @@ -543,15 +543,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 @@ -567,32 +565,28 @@ 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 LList) -> 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 LList) -> 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: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 LList) -> 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:LList),8,rw,always> -o \ // \ ret:(struct(eq(llvmword(0)), exists z:bv 64. eq(llvmword(z)))) or \ @@ -600,39 +594,34 @@ list_head_impl_sym <- heapster_find_symbol env "14list_head_impl"; // 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"; diff --git a/heapster-saw/examples/rust_data.sawcore b/heapster-saw/examples/rust_data.sawcore index b0b5ad063d..81f3f8e49a 100644 --- a/heapster-saw/examples/rust_data.sawcore +++ b/heapster-saw/examples/rust_data.sawcore @@ -1,10 +1,14 @@ module rust_data where -import Prelude; +import SpecM; --- A type description for the list type over a type description T, which should --- only use free deBruijn indices starting at 1 because it is being substituted --- inside a Tp_Ind constructor -ListDesc : TpDesc -> TpDesc; -ListDesc T = Tp_Ind (Tp_Ind (Tp_Sum Tp_Unit (Tp_Pair T (Tp_Var 0)))); +-- A type description for the list type over a type description T contained in +-- deBruijn index 0 (which is index 1 inside the Tp_Ind constructor) +ListDesc : TpDesc; +ListDesc = Tp_Ind (Tp_Sum Tp_Unit (Tp_Pair (Tp_Var 1) (Tp_Var 0))); + +-- Convert ListDesc applied to a type argument given by type description to a +-- type +ListDescType : TpDesc -> sort 0; +ListDescType T = tpElem VoidEv (Tp_TpSubst ListDesc T); From dc862fd05e6017f9483311b2a55147d47fc369fe Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 8 Nov 2023 13:57:31 -0800 Subject: [PATCH 184/305] changed translateCallEntry to not convert permissions to terms and then back again when it calls non-recursive entrypoints --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 36 +++++++++++-------- 1 file changed, 21 insertions(+), 15 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 18211fed59..0b05ad5af4 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -3570,6 +3570,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 @@ -5972,12 +5982,8 @@ translateCallEntry nm entry_trans mb_tops mb_args mb_ghosts = -- Otherwise, continue translating with the target entrypoint, with all -- the current expressions free but with only those permissions on top -- of the stack - inEmptyEnvImpTransM $ inCtxTransM ectx $ - do perms_trans <- translate $ typedEntryPermsIn entry - withPermStackM - (const $ RL.members ectx) - (const $ typeTransF perms_trans $ transTerms pctx) - (translate $ _mbBinding $ typedEntryBody entry) + withEmptyPermsImpTransM $ translate $ + fmap (\s -> varSubst s $ _mbBinding $ typedEntryBody entry) mb_s instance PermCheckExtC ext exprExt => Translate (ImpTransInfo ext blocks tops rets ps) ctx @@ -6300,11 +6306,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 function --- indices, which is all entrypoints with in-degree > 1 -typedBlockIxEntries :: TypedBlockMap TransPhase ext blocks tops rets -> - [SomeTypedEntry ext blocks tops rets] -typedBlockIxEntries = +-- | 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) @@ -6312,12 +6318,12 @@ typedBlockIxEntries = -- | Fold a function over each 'TypedEntry' in a 'TypedBlockMap' that -- corresponds to a letrec-bound variable -foldBlockMapIx :: +foldBlockMapRec :: (forall args ghosts. TypedEntry TransPhase ext blocks tops rets args ghosts -> b -> b) -> b -> TypedBlockMap TransPhase ext blocks tops rets -> b -foldBlockMapIx f r = - foldr (\(SomeTypedEntry entry) -> f entry) r . typedBlockIxEntries +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 @@ -6326,7 +6332,7 @@ mapBlockMapRecs :: TypedEntry TransPhase ext blocks tops rets args ghosts -> b) -> TypedBlockMap TransPhase ext blocks tops rets -> [b] mapBlockMapRecs f = - map (\(SomeTypedEntry entry) -> f entry) . typedBlockIxEntries + 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 From 0ea6c18fd783c1576df65577493db0e53b79dc59 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Tue, 14 Nov 2023 06:50:02 -0800 Subject: [PATCH 185/305] moved the SpecM OpenTerm operations to OpenTerm.hs --- .../src/Verifier/SAW/Heapster/Permissions.hs | 11 - .../Verifier/SAW/Heapster/SAWTranslation.hs | 302 ---------------- saw-core/src/Verifier/SAW/OpenTerm.hs | 338 +++++++++++++++++- 3 files changed, 334 insertions(+), 317 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs index efa719ff79..36060c9d77 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs @@ -899,17 +899,6 @@ data BlockHint blocks init ret args where data Hint where Hint_Block :: BlockHint blocks init ret args -> Hint --- | A SAW core identifier that indicates an event type for the @SpecM@ monad -newtype EventType = EventType { evTypeToIdent :: Ident } - --- | Convert an 'EventType' to a SAW core term -evTypeTerm :: EventType -> OpenTerm -evTypeTerm = globalOpenTerm . evTypeToIdent - --- | The default event type uses the @Void@ type for events -defaultSpecMEventType :: EventType -defaultSpecMEventType = EventType $ fromString "SpecM.VoidEv" - -- | A permission environment that maps function names, permission names, and -- 'GlobalSymbols' to their respective permission structures data PermEnv = PermEnv { diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 0b05ad5af4..9d13f9874f 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -122,308 +122,6 @@ memberLength Member_Base = 0 memberLength (Member_Step memb) = 1 + memberLength memb --- FIXME HERE NOWNOW: move these to OpenTerm.hs - --- | 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 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:)) - --- | 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 expression kind for the Nat type -natExprKind :: OpenTerm -natExprKind = ctorOpenTerm "SpecM.Kind_nat" [] - --- | The kind description for the Nat type -natKindDesc :: OpenTerm -natKindDesc = ctorOpenTerm "SpecM.Kind_Expr" [natExprKind] - --- | The kind description for the type @bitvector w@ -bvKindDesc :: Natural -> OpenTerm -bvKindDesc w = ctorOpenTerm "SpecM.Kind_Expr" [bvExprKind 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" [elem_d, w_term, len_term] - --- | 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 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 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 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 (ctorOpenTerm "SpecM.Tp_M" [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] - --- | 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] - --- | 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"]) - --- | 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] - - ---------------------------------------------------------------------- -- * Type Translations ---------------------------------------------------------------------- diff --git a/saw-core/src/Verifier/SAW/OpenTerm.hs b/saw-core/src/Verifier/SAW/OpenTerm.hs index f942b0d213..0196ea23f6 100644 --- a/saw-core/src/Verifier/SAW/OpenTerm.hs +++ b/saw-core/src/Verifier/SAW/OpenTerm.hs @@ -68,8 +68,21 @@ module Verifier.SAW.OpenTerm ( ctorOpenTerm, dataTypeOpenTerm, globalOpenTerm, identOpenTerm, extCnsOpenTerm, applyOpenTerm, applyOpenTermMulti, applyGlobalOpenTerm, applyPiOpenTerm, piArgOpenTerm, lambdaOpenTerm, lambdaOpenTermMulti, - piOpenTerm, piOpenTermMulti, - arrowOpenTerm, letOpenTerm, sawLetOpenTerm, list1OpenTerm, + piOpenTerm, piOpenTermMulti, arrowOpenTerm, letOpenTerm, sawLetOpenTerm, + bitvectorTypeOpenTerm, bvVecTypeOpenTerm, listOpenTerm, list1OpenTerm, + eitherTypeOpenTerm, sigmaTypeOpenTerm, sigmaTypeOpenTermMulti, sigmaOpenTerm, + sigmaOpenTermMulti, sigmaElimOpenTermMulti, + -- * Operations for building @SpecM@ computations + EventType (..), evTypeTerm, defaultSpecMEventType, unitKindDesc, bvExprKind, + tpDescTypeOpenTerm, kindToTpDesc, unitTpDesc, boolExprKind, boolKindDesc, + natExprKind, natKindDesc, bvKindDesc, tpKindDesc, pairTpDesc, tupleTpDesc, + sumTpDesc, bvVecTpDesc, constTpExpr, bvConstTpExpr, bvSumTpExprs, + bvMulTpExpr, sigmaTpDesc, sigmaTpDescMulti, arrowTpDesc, arrowTpDescMulti, + 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, @@ -84,7 +97,7 @@ module Verifier.SAW.OpenTerm ( pairTermLike, pairTypeTermLike, pairLeftTermLike, pairRightTermLike, tupleTermLike, tupleTypeTermLike, projTupleTermLike, letTermLike, sawLetTermLike, - -- * Building SpecM computations + -- * Old approach to building SpecM computations SpecTerm(), defineSpecOpenTerm, lambdaPureSpecTerm, lambdaPureSpecTermMulti, lrtClosTypeSpecTerm, sawLetPureSpecTerm, lrtToTypeSpecTerm, mkBaseClosSpecTerm, mkFreshClosSpecTerm, callClosSpecTerm, applyClosSpecTerm, @@ -476,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 = @@ -483,6 +512,307 @@ 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 identifier that indicates an event type for the @SpecM@ monad +newtype EventType = EventType { evTypeToIdent :: Ident } + +-- | Convert an 'EventType' to a SAW core term +evTypeTerm :: EventType -> OpenTerm +evTypeTerm = globalOpenTerm . evTypeToIdent + +-- | The default event type uses the @Void@ type for events +defaultSpecMEventType :: EventType +defaultSpecMEventType = EventType $ fromString "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 expression kind for the Nat type +natExprKind :: OpenTerm +natExprKind = ctorOpenTerm "SpecM.Kind_nat" [] + +-- | The kind description for the Nat type +natKindDesc :: OpenTerm +natKindDesc = ctorOpenTerm "SpecM.Kind_Expr" [natExprKind] + +-- | The kind description for the type @bitvector w@ +bvKindDesc :: Natural -> OpenTerm +bvKindDesc w = ctorOpenTerm "SpecM.Kind_Expr" [bvExprKind 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" [elem_d, w_term, len_term] + +-- | 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 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 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 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 (ctorOpenTerm "SpecM.Tp_M" [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 @@ -742,7 +1072,7 @@ sawLetTermLike x tp tp_ret rhs body_f = -------------------------------------------------------------------------------- --- Building SpecM computations +-- Building SpecM computations (old stuff; remove) -- | When creating a SAW core term of type @PolySpecFun@ or @PolyStackTuple@, -- the body or bodies are relative to: the current event type (or @EvType@); the From 60c4c550aabbb42609949f21e15a36d2404a42e2 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Wed, 15 Nov 2023 14:33:37 -0500 Subject: [PATCH 186/305] add case for unset variable plus offset to proveEqH --- heapster-saw/src/Verifier/SAW/Heapster/Implication.hs | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs b/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs index 7315c6aae1..a7a92c2183 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs @@ -6141,6 +6141,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 From c5a46c64e08b0d25faecb248c27d3b3fb9b2b76c Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Wed, 15 Nov 2023 14:37:55 -0500 Subject: [PATCH 187/305] make minor tweaks to refinement in MRSolver, errors in Heapster --- .../src/Verifier/SAW/Cryptol/Monadify.hs | 2 +- .../Verifier/SAW/Heapster/TypedCrucible.hs | 30 ++++++++++++------- src/SAWScript/Prover/MRSolver/Solver.hs | 24 +++++++++++---- 3 files changed, 39 insertions(+), 17 deletions(-) diff --git a/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs b/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs index b6702e8dfb..b18c425b17 100644 --- a/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs +++ b/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs @@ -98,7 +98,7 @@ import Verifier.SAW.Recognizer 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 diff --git a/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs b/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs index 38c95b1e24..2e1d739619 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs @@ -2502,9 +2502,20 @@ stmtRecombinePerms = 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)] +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 @@ -2514,7 +2525,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 @@ -2525,7 +2536,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 @@ -2537,7 +2548,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) @@ -2548,7 +2559,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) @@ -4121,7 +4132,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 -> @@ -4232,8 +4243,7 @@ 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) (handleUnitVars ns >>> diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index 6cdbf38b22..4c9781745f 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -1118,12 +1118,12 @@ mrRefines' m1@(FunBind f1 args1 isLifted1 k1) zipWithM_ mrAssertProveEq 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' -> - recordUsedFunAssump fa >> mrRefines m1 m2' + -- -- 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' -> + -- recordUsedFunAssump fa >> mrRefines m1 m2' -- If we have a rewrite FunAssump, or we have an opaque FunAssump that -- f1 args1' refines some f args where f /= f2 and f2 does not match the @@ -1283,6 +1283,18 @@ mrRefinesFun tp1 f1 tp2 f2 = mrRefinesFunH :: (Term -> Term -> MRM t a) -> [Term] -> Term -> Term -> Term -> Term -> MRM 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 = liftSC2 scBoolEq b1 b2 >>= \eq -> From ca12e4b2f669be7bdce8d18320bf9b76aac4a0cb Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Sat, 18 Nov 2023 17:22:50 -0800 Subject: [PATCH 188/305] started updating monadification to work with the new SpecM type --- cryptol-saw-core/saw/SpecM.sawcore | 4 +- .../src/Verifier/SAW/Cryptol/Monadify.hs | 888 +++++++++--------- saw-core/src/Verifier/SAW/OpenTerm.hs | 54 +- 3 files changed, 510 insertions(+), 436 deletions(-) diff --git a/cryptol-saw-core/saw/SpecM.sawcore b/cryptol-saw-core/saw/SpecM.sawcore index 8e0c3c8dc2..809bf8317f 100644 --- a/cryptol-saw-core/saw/SpecM.sawcore +++ b/cryptol-saw-core/saw/SpecM.sawcore @@ -51,6 +51,8 @@ data TpExprBinOp : ExprKind -> ExprKind -> ExprKind -> sort 0 where { 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 @@ -59,7 +61,7 @@ evalBinOp : (EK1 EK2 EK3:ExprKind) -> TpExprBinOp EK1 EK2 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 + addNat mulNat bvAdd bvMul tcAdd tcMul EK1 EK2 EK3 op; diff --git a/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs b/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs index 31b3cb8fe6..50c7c62d81 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,6 +101,7 @@ Mon(cnst) = cnst otherwise module Verifier.SAW.Cryptol.Monadify where +import Numeric.Natural import Data.Maybe import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map @@ -85,7 +115,9 @@ import qualified Control.Monad.Fail as Fail 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 @@ -101,6 +133,51 @@ import GHC.Stack import Debug.Trace +-- FIXME: move to OpenTerm.hs + +-- | 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 ---------------------------------------------------------------------- @@ -151,6 +228,7 @@ instance ToTerm TypedSubsTerm where unsharedApply :: Term -> Term -> Term unsharedApply f arg = Unshared $ App f arg +-} ---------------------------------------------------------------------- @@ -163,220 +241,215 @@ 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 + -- | A @Num@ expression that cannot be described as a @TpExpr@ + | NExpr_Indesc OpenTerm + +-- | 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 | 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 an indescribable type-level expression of a given kind +kindIndesc :: KindRepr k -> OpenTerm -> TpExpr k +kindIndesc MKTypeRepr = MTyIndesc +kindIndesc MKNumRepr = NExpr_Indesc -- | 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] +numExprVal (NExpr_Indesc n) = n + +-- | 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 (sortOpenTerm $ mkSort 0) (\e -> toCompType (body $ kindIndesc 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] + [evTypeTerm ?specMEvType, numExprVal n, toArgType t] +toArgType MTyUnit = unitTypeOpenTerm +toArgType MTyBool = boolTypeOpenTerm 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 '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) +numExprExpr _ (NExpr_Indesc trm) = + bindPPOpenTerm trm $ \pp_trm -> + failOpenTerm ("numExprExpr: indescribable numeric expression:\n" ++ pp_trm) + +-- | 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. +toTpDesc :: Natural -> Bool -> MonType -> OpenTerm +toTpDesc lvl _ (MTyForall _ k body) = + piTpDesc (toKindDesc k) $ toTpDesc (lvl+1) True $ body $ kindVar k lvl +toTpDesc lvl _ (MTyArrow mtp1 mtp2) = + arrowTpDesc (toTpDesc lvl False mtp1) (toTpDesc lvl True mtp2) +toTpDesc 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 $ toTpDesc lvl False mtp +toTpDesc lvl False (MTySeq n mtp) = + seqTpDesc (numExprExpr lvl n) (toTpDesc lvl False mtp) +toTpDesc _ False MTyUnit = unitTpDesc +toTpDesc _ False MTyBool = boolTpDesc +toTpDesc lvl False (MTyPair mtp1 mtp2) = + pairTpDesc (toTpDesc lvl False mtp1) (toTpDesc lvl False mtp2) +toTpDesc lvl False (MTySum mtp1 mtp2) = + sumTpDesc (toTpDesc lvl False mtp1) (toTpDesc lvl False mtp2) +toTpDesc _ _ (MTyIndesc trm) = + bindPPOpenTerm trm $ \pp_trm -> + failOpenTerm ("toTpDesc: indescribable type:\n" ++ pp_trm) +toTpDesc lvl False (MTyVarLvl l) = + -- Convert a deBruijn level to a deBruijn index; see comments in numExprExpr + varTpDesc (lvl - l - 1) + -- | The mapping for monadifying Cryptol typeclasses -- FIXME: this is no longer needed, as it is now the identity @@ -391,21 +464,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 @@ -416,69 +493,82 @@ 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 +-- | Check if a type-level operation, given by identifier, matching a 'NumBinOp' +monadifyNumBinOp :: Ident -> Maybe NumBinOp +monadifyNumBinOp i = lookup i numBinOpMonMap + -- | 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 :: HasCallStack => MonType -> Either SomeTpExpr ArgMonTerm -> + MonType applyMonType (MTyArrow _ tp_ret) (Right _) = tp_ret -applyMonType (MTyForall _ _ f) (Left mtp) = f mtp +applyMonType (MTyForall _ k1 f) (Left (SomeTpExpr k2 t)) + | Just Refl <- testEquality k1 k2 = f t applyMonType _ _ = error "applyMonType: application at incorrect type" + -- | Convert a SAW core 'Term' to a monadification type -monadifyType :: (HasCallStack, HasSpecMParams) => MonadifyTypeCtx -> Term -> +monadifyType :: (HasCallStack, HasSpecMEvType) => MonadifyTypeCtx -> Term -> MonType {- monadifyType ctx t | trace ("\nmonadifyType:\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) + | Just (SomeKindRepr k) <- monadifyKind tp_in + = MTyForall x k (\tp' -> + let ctx' = (x,tp_in,Just (SomeTpExpr k tp')):ctx in + monadifyType ctx' tp_out) monadifyType 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 _ (asTupleType -> Just []) = MTyUnit monadifyType ctx (asPairType -> Just (tp1, tp2)) = 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) + MTyIndesc $ dataTypeOpenTerm "Prelude.Eq" [monadifyTypeArgType ctx tp1, + monadifyTypeArgType ctx tp2] +-} +monadifyType ctx (asDataType -> Just (pn, args)) = + -- NOTE: this case only recognizes data types whose arguments are all types + -- and/or Nums + MTyIndesc $ dataTypeOpenTerm (primName pn) (map (toArgType . + monadifyType ctx) args) +{- FIXME: if we need finite Vecs, then we need Nat tp exprs 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])) | seq_id == "Cryptol.seq" = - let nOT = monadifyTypeArgType ctx n in - MTySeq nOT $ monadifyType ctx a + MTySeq (monadifyNum ctx n) (monadifyType ctx a) monadifyType ctx (asApp -> Just ((asGlobalDef -> Just f), arg)) | Just f_trans <- lookup f typeclassMonMap = - MTyBase (MKType $ mkSort 1) $ + MTyIndesc $ applyOpenTerm (globalOpenTerm f_trans) $ monadifyTypeArgType ctx arg monadifyType _ (asGlobalDef -> Just bool_id) - | bool_id == "Prelude.Bool" = - mkMonType0 (globalOpenTerm "Prelude.Bool") + | bool_id == "Prelude.Bool" = MTyBool {- monadifyType ctx (asApplyAll -> (f, args)) | Just glob <- asTypedGlobalDef f @@ -488,33 +578,31 @@ monadifyType ctx (asApplyAll -> (f, args)) MTyBase k_out (applyOpenTermMulti (globalDefOpenTerm glob) $ map toArgType margs) -} -monadifyType _ (asCtor -> Just (pn, [])) - | primName pn == "Cryptol.TCInf" - = MTyNum $ ctorOpenTerm "Cryptol.TCInf" [] -monadifyType ctx (asCtor -> Just (pn, [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) | i < length ctx - , (_,_,Just tp) <- ctx!!i = tp + , (_,_,Just (SomeTpExpr MKTypeRepr 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) + panic "monadifyType" ["not a valid type for monadification: " + ++ ppTermInTypeCtx ctx tp] + + +monadifyNum :: (HasCallStack, HasSpecMEvType) => MonadifyTypeCtx -> Term -> + NumTpExpr +monadifyNum _ (asCtor -> Just (pn, [])) + | primName pn == "Cryptol.TCInf" + = NExpr_Const $ ctorOpenTerm "Cryptol.TCInf" [] +monadifyNum _ (asCtor -> Just (pn, [asNat -> Just n])) + | primName pn == "Cryptol.TCNum" + = NExpr_Const $ ctorOpenTerm "Cryptol.TCNum" [natOpenTerm n] +monadifyNum ctx (asApplyAll -> ((asGlobalDef -> Just f), [arg1, arg2])) + | Just op <- monadifyNumBinOp f + = NExpr_BinOp op (monadifyNum ctx arg1) (monadifyNum ctx arg2) +monadifyNum 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 MKNumRepr tp)) <- ctx!!i = tp +monadifyNum ctx t = + panic "monadifyNum" ["not a valid numeric expression for monadification: " + ++ ppTermInTypeCtx ctx t] ---------------------------------------------------------------------- @@ -529,7 +617,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)@ @@ -537,6 +625,7 @@ data MonTerm = ArgMonTerm ArgMonTerm | CompMonTerm MonType OpenTerm + -- | Get the monadification type of a monadification term class GetMonType a where getMonType :: a -> MonType @@ -553,16 +642,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 . kindIndesc k) instance ToCompTerm MonTerm where toCompTerm (ArgMonTerm amtrm) = toCompTerm amtrm @@ -570,19 +658,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 @@ -591,37 +679,22 @@ 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] + +{- +FIXME HERE NOWNOW: +- remove lrtFromMonType, add descFromMonType +- how to generate deBruijn indices in TpDescs? + + option 1: leave it higher-order, but add a MTyVar ctor to track indices when + converting to TpDescs + + option 2: remove HOAS representation from types and MonTerms +- MTyBase -> MTyIndesc +- remove functional kinds +- FIXME: what about type-level expressions that might have deBruijn indices? +- FIXME: remove MTyRecord -- | Test if a monadification type @tp@ is pure, meaning @MT(tp)=tp@ monTypeIsPure :: MonType -> Bool @@ -662,7 +735,7 @@ 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 -> @@ -673,15 +746,15 @@ fromSemiPureTermFun (MTyArrow t1 t2) f = 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 a 'MonTerm' that 'fail's when converted to a term -failMonTerm :: HasSpecMParams => MonType -> String -> MonTerm -failMonTerm mtp str = fromArgTerm mtp (failOpenTerm str) +failMonTerm :: HasSpecMEvType => OpenTerm -> String -> MonTerm +failMonTerm tp str = BaseMonTerm (MTyIndesc tp) (failOpenTerm str) -- | Build an 'ArgMonTerm' that 'fail's when converted to a term -failArgMonTerm :: HasSpecMParams => MonType -> String -> ArgMonTerm +failArgMonTerm :: HasSpecMEvType => MonType -> String -> ArgMonTerm failArgMonTerm tp str = fromArgTerm tp (failOpenTerm str) -- | Apply a monadified term to a type or term argument @@ -703,26 +776,24 @@ applyMonTermMulti :: HasCallStack => MonTerm -> [Either MonType ArgMonTerm] -> 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 'SpecMParams' 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 +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) @@ -742,11 +813,9 @@ 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 @@ -755,11 +824,11 @@ monMacro0 mtrm = MonMacro 0 $ \_ _ -> usingSpecMParams $ -- be passed as the first two arguments 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") @@ -773,7 +842,7 @@ semiPureGlobalMacro from to params_p = -- @liftStackS@ if the outer stack is non-empty. 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 @@ -785,13 +854,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) @@ -840,8 +905,6 @@ 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 } @@ -858,31 +921,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 EvType +askEvType = monEnvEvType <$> 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 @@ -896,8 +949,7 @@ shiftMonadifyM f = MonadifyM $ lift $ lift $ cont f resetMonadifyM :: OpenTerm -> 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 @@ -906,10 +958,10 @@ topRetType = monStTopRetType <$> ask -- | Run a monadification computation -- -- FIXME: document the arguments -runMonadifyM :: MonadifyEnv -> MonadifyCtx -> OpenTerm -> +runMonadifyM :: MonadifyEnv -> MonadifyCtx -> OpenTerm -> MonadifyM MonTerm -> MonTerm -runMonadifyM env ctx stack top_ret_tp m = - let ro_st = MonadifyROState env ctx stack top_ret_tp in +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 @@ -918,9 +970,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 [] (toArgType $ monadifyType [] top_ret_tp) m -- | Memoize a computation of the monadified term associated with a 'TermIndex' memoMonTerm :: TermIndex -> MonadifyM MonTerm -> MonadifyM MonTerm @@ -957,24 +1009,23 @@ 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 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 :: HasSpecMEvType => MonType -> MonadifyM ArgMonTerm assertIsFinite (MTyNum n) = argifyMonTerm (CompMonTerm - (mkMonType0 (applyOpenTerm - (globalOpenTerm "CryptolM.isFinite") n)) + (MTyIndesc (applyOpenTerm + (globalOpenTerm "CryptolM.isFinite") n)) (applyGlobalOpenTerm "CryptolM.assertFiniteS" - [specMEvType ?specMParams, specMStack ?specMParams, n])) + [evTypeTerm ?specMEvType, n])) assertIsFinite _ = fail ("assertIsFinite applied to non-Num argument") @@ -986,7 +1037,7 @@ assertIsFinite _ = -- | Monadify a type in the context of the 'MonadifyM' monad monadifyTypeM :: HasCallStack => Term -> MonadifyM MonType monadifyTypeM tp = - usingSpecMParams $ + usingEvType $ do ctx <- monStCtx <$> ask return $ monadifyType (ctxToTypeCtx ctx) tp @@ -998,13 +1049,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 @@ -1014,21 +1065,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 -> @@ -1062,8 +1112,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, n, toArgType mtp_elem, flatOpenTerm $ ArrayValue (toArgType mtp_elem) trms'] monadifyTerm' _ (asPairSelector -> Just (trm, True)) = do mtrm <- monadifyArg Nothing trm @@ -1085,8 +1134,7 @@ monadifyTerm' _ (asLocalVar -> Just ix) = ctx | (_,_,Right mtrm) <- ctx !! ix -> return 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)) = @@ -1127,35 +1175,35 @@ 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 -> +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,Left 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 [] + monadifyLambdas env ((x,x_tp,Right (ArgMonTerm arg)) : ctx) tp_out body +monadifyLambdas env ctx tp t = + monadifyEtaExpand env ctx tp tp t [] -- | FIXME: documentation -monadifyEtaExpand :: HasCallStack => MonadifyEnv -> MonadifyCtx -> OpenTerm -> +monadifyEtaExpand :: HasCallStack => MonadifyEnv -> MonadifyCtx -> MonType -> MonType -> Term -> [Either MonType ArgMonTerm] -> MonTerm -monadifyEtaExpand env ctx stack top_mtp (MTyForall x k tp_f) t args = +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 ++ [Left 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 + monadifyEtaExpand env ctx top_mtp tp_out t (args ++ [Right arg]) +monadifyEtaExpand env ctx top_mtp mtp t args = + let ?specMEvType = monEnvEvType env in applyMonTermMulti - (runMonadifyM env ctx stack (toArgType mtp) (monadifyTerm (Just top_mtp) t)) + (runMonadifyM env ctx (toArgType mtp) (monadifyTerm (Just top_mtp) t)) args @@ -1167,7 +1215,7 @@ 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 -> @@ -1186,12 +1234,12 @@ 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 @@ -1210,7 +1258,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) @@ -1225,13 +1273,13 @@ eitherMacro = MonMacro 3 $ \_ args -> 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) @@ -1242,20 +1290,19 @@ 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 return $ fromCompTerm mtp $ @@ -1268,21 +1315,20 @@ 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 + ev <- askEvType let ident = if doAsserting then "Prelude.assertingS" else "Prelude.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 @@ -1292,7 +1338,7 @@ assertingOrAssumingMacro doAsserting = MonMacro 3 $ \_ args -> -- current 'SpecMParams' should be passed as the first two arguments 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 ++ @@ -1311,13 +1357,12 @@ finMacro isSemiPure i j from to params_p = let glob_tp_app = foldl applyMonType glob_tp (map Left (init_args_mtps ++ fin_args_mtps)) let to_app = applyOpenTermMulti (globalOpenTerm to) - ((if params_p then (paramsToTerms ?specMParams ++) else id) + ((if params_p then (evTypeTerm ?specMEvType :) else id) init_args_m ++ concatMap (\(n,pf) -> [n, toArgTerm pf]) (zip fin_args_m fin_pfs)) -- 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 -- | The macro for fix -- @@ -1325,14 +1370,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 orig_params <- 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] + [specMEvType orig_params, lrtFromMonType mtp, toCompTerm amtrm_f] [(asRecordType -> Just _), _] -> fail "Monadification failed: cannot yet handle mutual recursion" _ -> error "fixMacro: malformed arguments!" @@ -1501,22 +1545,21 @@ monadifyCompleteArgType :: SharedContext -> MonadifyEnv -> Term -> Bool -> monadifyCompleteArgType sc env tp poly_p = completeOpenTerm sc $ if poly_p then - -- Parameter polymorphism means pi-quantification over E and stack + -- Parameter polymorphism means pi-quantification over E (piOpenTerm "E" (dataTypeOpenTerm "Prelude.EvType" []) $ \e -> - piOpenTerm "stack" (globalOpenTerm "Prelude.FunStack") $ \st -> - let ?specMParams = SpecMParams { specMEvType = e, specMStack = st } in + let ?specMEvType = e 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 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 $ + runCompleteMonadifyM sc env tp $ usingEvType $ monadifyTerm (Just $ monadifyType [] tp) trm -- | Convert a name of a definition to the name of its monadified version @@ -1534,7 +1577,7 @@ 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 + get >>= \env -> let ?specMEvType = monEnvEvType env in do let mtp = monadifyType [] tp nmi' <- lift $ monadifyName nmi comp_tp <- lift $ completeOpenTerm sc $ toCompType mtp @@ -1604,3 +1647,4 @@ monadifyCryptolModule :: SharedContext -> Env -> MonadifyEnv -> CryptolModule -> IO (CryptolModule, MonadifyEnv) monadifyCryptolModule sc cry_env top_env cry_mod = flip runStateT top_env $ monadifyCryptolModuleH sc cry_env cry_mod +-} diff --git a/saw-core/src/Verifier/SAW/OpenTerm.hs b/saw-core/src/Verifier/SAW/OpenTerm.hs index 0196ea23f6..b422f806f1 100644 --- a/saw-core/src/Verifier/SAW/OpenTerm.hs +++ b/saw-core/src/Verifier/SAW/OpenTerm.hs @@ -74,13 +74,15 @@ module Verifier.SAW.OpenTerm ( sigmaOpenTermMulti, sigmaElimOpenTermMulti, -- * Operations for building @SpecM@ computations EventType (..), evTypeTerm, defaultSpecMEventType, unitKindDesc, bvExprKind, - tpDescTypeOpenTerm, kindToTpDesc, unitTpDesc, boolExprKind, boolKindDesc, - natExprKind, natKindDesc, bvKindDesc, tpKindDesc, pairTpDesc, tupleTpDesc, - sumTpDesc, bvVecTpDesc, constTpExpr, bvConstTpExpr, bvSumTpExprs, - bvMulTpExpr, sigmaTpDesc, sigmaTpDescMulti, arrowTpDesc, arrowTpDescMulti, - funTpDesc, piTpDesc, piTpDescMulti, voidTpDesc, varTpDesc, varTpExpr, - varKindExpr, constKindExpr, indTpDesc, substTpDesc, substTpDescMulti, - substIdTpDescMulti, substIndIdTpDescMulti, tpElemTypeOpenTerm, + tpDescTypeOpenTerm, kindToTpDesc, unitTpDesc, + boolExprKind, boolKindDesc, boolTpDesc, natExprKind, natKindDesc, + numExprKind, numKindDesc, bvKindDesc, 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 @@ -110,7 +112,7 @@ import Control.Monad import Control.Monad.State import Control.Monad.Writer import Control.Monad.Reader -import Data.Text (Text) +import Data.Text (Text, pack) import Numeric.Natural import Data.IntMap.Strict (IntMap) @@ -572,7 +574,7 @@ evTypeTerm = globalOpenTerm . evTypeToIdent -- | The default event type uses the @Void@ type for events defaultSpecMEventType :: EventType -defaultSpecMEventType = EventType $ fromString "SpecM.VoidEv" +defaultSpecMEventType = EventType "SpecM.VoidEv" -- | The kind description for the unit type unitKindDesc :: OpenTerm @@ -604,14 +606,26 @@ boolExprKind = ctorOpenTerm "SpecM.Kind_bool" [] boolKindDesc :: OpenTerm boolKindDesc = ctorOpenTerm "SpecM.Kind_Expr" [boolExprKind] --- | The expression kind for the Nat type +-- | 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 kind description for the Nat type +-- | 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] @@ -650,6 +664,13 @@ constTpExpr k_d v = ctorOpenTerm "SpecM.TpExpr_Const" [k_d, v] 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 @@ -679,6 +700,10 @@ 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] @@ -687,12 +712,15 @@ arrowTpDesc d_in d_out = ctorOpenTerm "SpecM.Tp_Arr" [d_in, d_out] 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 (ctorOpenTerm "SpecM.Tp_M" [d_ret]) +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 From a8c9e54c303462ab7d6e64c92cb75617b113d2a7 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 20 Nov 2023 10:16:11 -0800 Subject: [PATCH 189/305] combined monadifyType and monadifyNum into a single monadifyTpExpr function; replaced the Either type used for type- vs term-level arguments with a new helper type MonArg --- .../src/Verifier/SAW/Cryptol/Monadify.hs | 213 ++++++++++-------- 1 file changed, 123 insertions(+), 90 deletions(-) diff --git a/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs b/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs index 50c7c62d81..834b3fe37b 100644 --- a/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs +++ b/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs @@ -393,6 +393,11 @@ 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 @@ -503,40 +508,36 @@ monadifyTypeArgType ctx t = toArgType $ monadifyType ctx t monadifyNumBinOp :: Ident -> Maybe NumBinOp monadifyNumBinOp i = lookup i numBinOpMonMap --- | 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 SomeTpExpr ArgMonTerm -> - MonType -applyMonType (MTyArrow _ tp_ret) (Right _) = tp_ret -applyMonType (MTyForall _ k1 f) (Left (SomeTpExpr k2 t)) - | Just Refl <- testEquality k1 k2 = f t -applyMonType _ _ = error "applyMonType: application at incorrect type" - --- | Convert a SAW core 'Term' to a monadification type -monadifyType :: (HasCallStack, HasSpecMEvType) => 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 (SomeKindRepr k) <- monadifyKind tp_in - = MTyForall x k (\tp' -> + +-- 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) -monadifyType ctx tp@(asPi -> Just (_, _, 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 []) = MTyUnit -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) = @@ -550,25 +551,26 @@ monadifyType ctx (asDataType -> Just (eq_pn, [k_trm, tp1, tp2])) MTyIndesc $ dataTypeOpenTerm "Prelude.Eq" [monadifyTypeArgType ctx tp1, monadifyTypeArgType ctx tp2] -} -monadifyType ctx (asDataType -> Just (pn, args)) = +monadifyTpExpr ctx (asDataType -> Just (pn, args)) = -- NOTE: this case only recognizes data types whose arguments are all types -- and/or Nums - MTyIndesc $ dataTypeOpenTerm (primName pn) (map (toArgType . - monadifyType ctx) args) + SomeTpExpr MKTypeRepr $ + MTyIndesc $ dataTypeOpenTerm (primName pn) (map (someTpExprVal . + monadifyTpExpr ctx) args) {- FIXME: if we need finite Vecs, then we need Nat tp exprs 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])) +monadifyTpExpr ctx (asApplyAll -> ((asGlobalDef -> Just seq_id), [n, a])) | seq_id == "Cryptol.seq" = - MTySeq (monadifyNum ctx n) (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 = - MTyIndesc $ + SomeTpExpr MKTypeRepr $ MTyIndesc $ applyOpenTerm (globalOpenTerm f_trans) $ monadifyTypeArgType ctx arg -monadifyType _ (asGlobalDef -> Just bool_id) - | bool_id == "Prelude.Bool" = MTyBool +monadifyTpExpr _ (asGlobalDef -> Just bool_id) + | bool_id == "Prelude.Bool" = SomeTpExpr MKTypeRepr $ MTyBool {- monadifyType ctx (asApplyAll -> (f, args)) | Just glob <- asTypedGlobalDef f @@ -578,31 +580,42 @@ monadifyType ctx (asApplyAll -> (f, args)) MTyBase k_out (applyOpenTermMulti (globalDefOpenTerm glob) $ map toArgType margs) -} -monadifyType ctx (asLocalVar -> Just i) - | i < length ctx - , (_,_,Just (SomeTpExpr MKTypeRepr tp)) <- ctx!!i = tp -monadifyType ctx tp = - panic "monadifyType" ["not a valid type for monadification: " - ++ ppTermInTypeCtx ctx tp] - -monadifyNum :: (HasCallStack, HasSpecMEvType) => MonadifyTypeCtx -> Term -> - NumTpExpr -monadifyNum _ (asCtor -> Just (pn, [])) +-- Num cases +monadifyTpExpr _ (asCtor -> Just (pn, [])) | primName pn == "Cryptol.TCInf" - = NExpr_Const $ ctorOpenTerm "Cryptol.TCInf" [] -monadifyNum _ (asCtor -> Just (pn, [asNat -> Just n])) + = SomeTpExpr MKNumRepr $ NExpr_Const $ ctorOpenTerm "Cryptol.TCInf" [] +monadifyTpExpr _ (asCtor -> Just (pn, [asNat -> Just n])) | primName pn == "Cryptol.TCNum" - = NExpr_Const $ ctorOpenTerm "Cryptol.TCNum" [natOpenTerm n] -monadifyNum ctx (asApplyAll -> ((asGlobalDef -> Just f), [arg1, arg2])) + = SomeTpExpr MKNumRepr $ NExpr_Const $ ctorOpenTerm "Cryptol.TCNum" [natOpenTerm n] +monadifyTpExpr ctx (asApplyAll -> ((asGlobalDef -> Just f), [arg1, arg2])) | Just op <- monadifyNumBinOp f - = NExpr_BinOp op (monadifyNum ctx arg1) (monadifyNum ctx arg2) -monadifyNum ctx (asLocalVar -> Just i) + = SomeTpExpr MKNumRepr $ NExpr_BinOp op (monadifyNum ctx arg1) (monadifyNum ctx arg2) +monadifyTpExpr ctx (asLocalVar -> Just i) | i < length ctx - , (_,_,Just (SomeTpExpr MKNumRepr tp)) <- ctx!!i = tp + , (_,_,Just (SomeTpExpr k e)) <- ctx!!i = SomeTpExpr k e +monadifyTpExpr ctx tp = + panic "monadifyTpExpr" + ["not a valid type or numberic 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 valid numeric expression for monadification: " - ++ ppTermInTypeCtx ctx t] + panic "monadifyNum" ["Not a numeric expression: " ++ ppTermInTypeCtx ctx t] ---------------------------------------------------------------------- @@ -625,6 +638,12 @@ 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 -- | Get the monadification type of a monadification term class GetMonType a where @@ -683,48 +702,41 @@ fromCompTerm :: HasSpecMEvType => MonType -> OpenTerm -> MonTerm fromCompTerm mtp t | isBaseType mtp = CompMonTerm mtp t fromCompTerm mtp t = ArgMonTerm $ fromArgTerm mtp t - -{- -FIXME HERE NOWNOW: -- remove lrtFromMonType, add descFromMonType -- how to generate deBruijn indices in TpDescs? - + option 1: leave it higher-order, but add a MTyVar ctor to track indices when - converting to TpDescs - + option 2: remove HOAS representation from types and MonTerms -- MTyBase -> MTyIndesc -- remove functional kinds -- FIXME: what about type-level expressions that might have deBruijn indices? -- FIXME: remove MTyRecord - -- | 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 (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 $ kindIndesc 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 = False +monTypeIsSemiPure MTyBool = False 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 @@ -738,8 +750,8 @@ monTypeIsSemiPure (MTyNum _) = True 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:)) @@ -751,28 +763,37 @@ fromSemiPureTerm mtp t = fromSemiPureTermFun mtp (applyOpenTermMulti t) -- | Build a 'MonTerm' that 'fail's when converted to a term failMonTerm :: HasSpecMEvType => OpenTerm -> String -> MonTerm -failMonTerm tp str = BaseMonTerm (MTyIndesc tp) (failOpenTerm str) +failMonTerm tp str = ArgMonTerm $ BaseMonTerm (MTyIndesc tp) (failOpenTerm str) -- | Build an 'ArgMonTerm' that 'fail's when converted to a term failArgMonTerm :: HasSpecMEvType => 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 @@ -803,6 +824,18 @@ mkCtorArgMonTerm pn = fromSemiPureTermFun (monadifyType [] $ primType pn) (ctorOpenTerm $ primName pn) +{- +FIXME HERE NOWNOW: +- remove lrtFromMonType, add descFromMonType +- how to generate deBruijn indices in TpDescs? + + option 1: leave it higher-order, but add a MTyVar ctor to track indices when + converting to TpDescs + + option 2: remove HOAS representation from types and MonTerms +- MTyBase -> MTyIndesc +- remove functional kinds +- FIXME: what about type-level expressions that might have deBruijn indices? +- FIXME: remove MTyRecord + ---------------------------------------------------------------------- -- * Monadification Environments and Contexts ---------------------------------------------------------------------- @@ -870,7 +903,7 @@ 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 From db9cc4e6ac460bd5542af21f3921c3b82bf5eec1 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 20 Nov 2023 10:31:38 -0800 Subject: [PATCH 190/305] updated a bit more of Monadify.hs --- .../src/Verifier/SAW/Cryptol/Monadify.hs | 72 +++++++++---------- 1 file changed, 36 insertions(+), 36 deletions(-) diff --git a/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs b/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs index 834b3fe37b..ba25a6dc8f 100644 --- a/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs +++ b/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs @@ -761,13 +761,13 @@ fromSemiPureTermFun tp f = BaseMonTerm tp (f []) fromSemiPureTerm :: HasSpecMEvType => MonType -> OpenTerm -> ArgMonTerm fromSemiPureTerm mtp t = fromSemiPureTermFun mtp (applyOpenTermMulti t) --- | Build a 'MonTerm' that 'fail's when converted to a term -failMonTerm :: HasSpecMEvType => OpenTerm -> String -> MonTerm -failMonTerm tp str = ArgMonTerm $ BaseMonTerm (MTyIndesc tp) (failOpenTerm str) - -- | Build an 'ArgMonTerm' that 'fail's when converted to a term failArgMonTerm :: HasSpecMEvType => MonType -> String -> ArgMonTerm -failArgMonTerm tp str = fromArgTerm tp (failOpenTerm str) +failArgMonTerm tp str = BaseMonTerm tp (failOpenTerm str) + +-- | Build a 'MonTerm' that 'fail's when converted to a term +failMonTerm :: HasSpecMEvType => MonType -> String -> MonTerm +failMonTerm tp str = ArgMonTerm $ failArgMonTerm tp str -- | Apply a monadified type to a type or term argument in the sense of -- 'applyPiOpenTerm', meaning give the type of applying @f@ of a type to a @@ -824,18 +824,6 @@ mkCtorArgMonTerm pn = fromSemiPureTermFun (monadifyType [] $ primType pn) (ctorOpenTerm $ primName pn) -{- -FIXME HERE NOWNOW: -- remove lrtFromMonType, add descFromMonType -- how to generate deBruijn indices in TpDescs? - + option 1: leave it higher-order, but add a MTyVar ctor to track indices when - converting to TpDescs - + option 2: remove HOAS representation from types and MonTerms -- MTyBase -> MTyIndesc -- remove functional kinds -- FIXME: what about type-level expressions that might have deBruijn indices? -- FIXME: remove MTyRecord - ---------------------------------------------------------------------- -- * Monadification Environments and Contexts ---------------------------------------------------------------------- @@ -909,8 +897,8 @@ type MonadifyCtx = [(LocalName,Term,MonArg)] 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 @@ -938,8 +926,10 @@ data MonadifyROState = MonadifyROState { monStEnv :: MonadifyEnv, -- | The monadification context monStCtx :: MonadifyCtx, - -- | 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' @@ -955,8 +945,8 @@ newtype MonadifyM a = MonadReader MonadifyROState, MonadState MonadifyMemoTable) -- | Get the current 'EventType' in a 'MonadifyM' computation -askEvType :: MonadifyM EvType -askEvType = monEnvEvType <$> ask +askEvType :: MonadifyM EventType +askEvType = monEnvEvType <$> monStEnv <$> ask -- | Run a 'MonadifyM' computation with the current 'EventType' usingEvType :: (HasSpecMEvType => MonadifyM a) -> MonadifyM a @@ -979,20 +969,20 @@ 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) 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 -> MonadifyM MonTerm -> MonTerm +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 @@ -1005,7 +995,7 @@ runCompleteMonadifyM :: MonadIO m => SharedContext -> MonadifyEnv -> runCompleteMonadifyM sc env top_ret_tp m = let ?specMEvType = monEnvEvType env in liftIO $ completeOpenTerm sc $ toCompTerm $ - runMonadifyM env [] (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 @@ -1047,22 +1037,33 @@ argifyMonTerm (CompMonTerm mtp trm) = top_ret_tp <- topRetType shiftMonadifyM $ \k -> CompMonTerm top_ret_tp $ - bindSOpenTerm ?specMEvType tp top_ret_tp trm $ + bindSOpenTerm ?specMEvType tp (toArgType top_ret_tp) trm $ lambdaOpenTerm "x" tp (toCompTerm . k . fromArgTerm mtp) -- | Build a proof of @isFinite n@ by calling @assertFiniteS@ and binding the -- result to an 'ArgMonTerm' -assertIsFinite :: HasSpecMEvType => MonType -> MonadifyM ArgMonTerm -assertIsFinite (MTyNum n) = +assertIsFinite :: HasSpecMEvType => NumTpExpr -> MonadifyM ArgMonTerm +assertIsFinite e = + let n = numExprVal e in argifyMonTerm (CompMonTerm (MTyIndesc (applyOpenTerm (globalOpenTerm "CryptolM.isFinite") n)) (applyGlobalOpenTerm "CryptolM.assertFiniteS" [evTypeTerm ?specMEvType, n])) -assertIsFinite _ = - fail ("assertIsFinite applied to non-Num argument") +{- +FIXME HERE NOWNOW: +- remove lrtFromMonType, add descFromMonType +- how to generate deBruijn indices in TpDescs? + + option 1: leave it higher-order, but add a MTyVar ctor to track indices when + converting to TpDescs + + option 2: remove HOAS representation from types and MonTerms +- MTyBase -> MTyIndesc +- remove functional kinds +- FIXME: what about type-level expressions that might have deBruijn indices? +- FIXME: remove MTyRecord + ---------------------------------------------------------------------- -- * Monadification ---------------------------------------------------------------------- @@ -1235,9 +1236,8 @@ monadifyEtaExpand env ctx top_mtp (MTyArrow tp_in tp_out) t args = monadifyEtaExpand env ctx top_mtp tp_out t (args ++ [Right arg]) monadifyEtaExpand env ctx top_mtp mtp t args = let ?specMEvType = monEnvEvType env in - applyMonTermMulti - (runMonadifyM env ctx (toArgType mtp) (monadifyTerm (Just top_mtp) t)) - args + applyMonTermMulti (runMonadifyM env ctx mtp + (monadifyTerm (Just top_mtp) t)) args ---------------------------------------------------------------------- From e9230820b59bfd2672cd1d46af8096ad0cc84952 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 20 Nov 2023 18:08:44 -0800 Subject: [PATCH 191/305] mostly finished updating monadification, other than quantifying over event types --- .../src/Verifier/SAW/Cryptol/Monadify.hs | 167 ++++++++++-------- 1 file changed, 91 insertions(+), 76 deletions(-) diff --git a/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs b/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs index ba25a6dc8f..6ff70bf016 100644 --- a/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs +++ b/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs @@ -427,34 +427,38 @@ numExprExpr _ (NExpr_Indesc trm) = bindPPOpenTerm trm $ \pp_trm -> failOpenTerm ("numExprExpr: indescribable numeric expression:\n" ++ pp_trm) --- | 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. -toTpDesc :: Natural -> Bool -> MonType -> OpenTerm -toTpDesc lvl _ (MTyForall _ k body) = - piTpDesc (toKindDesc k) $ toTpDesc (lvl+1) True $ body $ kindVar k lvl -toTpDesc lvl _ (MTyArrow mtp1 mtp2) = - arrowTpDesc (toTpDesc lvl False mtp1) (toTpDesc lvl True mtp2) -toTpDesc lvl True mtp = +-- | 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 $ toTpDesc lvl False mtp -toTpDesc lvl False (MTySeq n mtp) = - seqTpDesc (numExprExpr lvl n) (toTpDesc lvl False mtp) -toTpDesc _ False MTyUnit = unitTpDesc -toTpDesc _ False MTyBool = boolTpDesc -toTpDesc lvl False (MTyPair mtp1 mtp2) = - pairTpDesc (toTpDesc lvl False mtp1) (toTpDesc lvl False mtp2) -toTpDesc lvl False (MTySum mtp1 mtp2) = - sumTpDesc (toTpDesc lvl False mtp1) (toTpDesc lvl False mtp2) -toTpDesc _ _ (MTyIndesc trm) = + 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 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 ("toTpDesc: indescribable type:\n" ++ pp_trm) -toTpDesc lvl False (MTyVarLvl l) = + 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 @@ -645,6 +649,14 @@ data MonArg -- | 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 @@ -1052,28 +1064,30 @@ assertIsFinite e = [evTypeTerm ?specMEvType, n])) -{- -FIXME HERE NOWNOW: -- remove lrtFromMonType, add descFromMonType -- how to generate deBruijn indices in TpDescs? - + option 1: leave it higher-order, but add a MTyVar ctor to track indices when - converting to TpDescs - + option 2: remove HOAS representation from types and MonTerms -- MTyBase -> MTyIndesc -- remove functional kinds -- FIXME: what about type-level expressions that might have deBruijn indices? -- FIXME: remove MTyRecord - ---------------------------------------------------------------------- -- * Monadification ---------------------------------------------------------------------- --- | Monadify a type in the context of the 'MonadifyM' monad -monadifyTypeM :: HasCallStack => Term -> MonadifyM MonType -monadifyTypeM tp = +-- | 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 $ monadifyType (ctxToTypeCtx ctx) tp + return $ f (ctxToTypeCtx ctx) tm + +-- | Monadify a type-level expression in the context of the 'MonadifyM' monad +monadifyTpExprM :: HasCallStack => Term -> MonadifyM SomeTpExpr +monadifyTpExprM = monadifyOpM monadifyTpExpr + +-- | Monadify a type in the context of the 'MonadifyM' monad +monadifyTypeM :: HasCallStack => Term -> MonadifyM MonType +monadifyTypeM = monadifyOpM monadifyType + +-- | Monadify a numeric expression in the context of the 'MonadifyM' monad +monadifyNumM :: HasCallStack => Term -> MonadifyM NumTpExpr +monadifyNumM = monadifyOpM monadifyNum -- | Monadify a term to a monadified term of argument type monadifyArg :: HasCallStack => Maybe MonType -> Term -> MonadifyM ArgMonTerm @@ -1128,12 +1142,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 @@ -1146,7 +1162,7 @@ monadifyTerm' (Just mtp@(MTySeq n mtp_elem)) (asFTermF -> do trms' <- traverse (monadifyArgTerm $ Just mtp_elem) trms return $ fromArgTerm mtp $ applyOpenTermMulti (globalOpenTerm "CryptolM.seqToMseq") - [evTypeTerm ?specMEvType, 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 @@ -1155,6 +1171,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 @@ -1162,10 +1179,11 @@ 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 MTyUnit unitOpenTerm @@ -1198,11 +1216,11 @@ 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 @@ -1215,25 +1233,24 @@ 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) (tp_f mtp) 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) tp_out body + monadifyLambdas env ((x,x_tp,TrmArg arg) : ctx) tp_out body monadifyLambdas env ctx tp t = monadifyEtaExpand env ctx tp tp t [] -- | FIXME: documentation monadifyEtaExpand :: HasCallStack => MonadifyEnv -> MonadifyCtx -> - MonType -> MonType -> Term -> - [Either MonType ArgMonTerm] -> MonTerm + MonType -> MonType -> Term -> [MonArg] -> MonTerm monadifyEtaExpand env ctx top_mtp (MTyForall x k tp_f) t args = ArgMonTerm $ ForallMonTerm x k $ \mtp -> - monadifyEtaExpand env ctx top_mtp (tp_f mtp) t (args ++ [Left mtp]) + monadifyEtaExpand env ctx top_mtp (tp_f mtp) t (args ++ [TpArg k mtp]) monadifyEtaExpand env ctx top_mtp (MTyArrow tp_in tp_out) t args = ArgMonTerm $ FunMonTerm "_" tp_in tp_out $ \arg -> - monadifyEtaExpand env ctx top_mtp tp_out t (args ++ [Right arg]) + monadifyEtaExpand env ctx top_mtp tp_out t (args ++ [TrmArg arg]) monadifyEtaExpand env ctx top_mtp mtp t args = let ?specMEvType = monEnvEvType env in applyMonTermMulti (runMonadifyM env ctx mtp @@ -1250,9 +1267,8 @@ unsafeAssertMacro :: MonMacro unsafeAssertMacro = MonMacro 1 $ \_ ts -> usingEvType $ let numFunType = - MTyForall "n" (MKType $ mkSort 0) $ \n -> - MTyForall "m" (MKType $ mkSort 0) $ \m -> - MTyBase (MKType $ mkSort 0) $ + MTyForall "n" MKTypeRepr $ \n -> MTyForall "m" MKTypeRepr $ \m -> + MTyIndesc $ dataTypeOpenTerm "Prelude.Eq" [dataTypeOpenTerm "Cryptol.Num" [], toArgType n, toArgType m] in @@ -1274,8 +1290,8 @@ iteMacro = MonMacro 4 $ \_ args -> usingEvType $ _ -> error "iteMacro: wrong number of arguments!" 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 $ @@ -1302,8 +1318,6 @@ 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 (MTySum mtp_a mtp_b) mtp_c))) eith_app @@ -1337,7 +1351,7 @@ invariantHintMacro = MonMacro 3 $ \_ args -> usingEvType $ _ -> error "invariantHintMacro: wrong number of arguments!" 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") [toCompType mtp, toArgTerm atrm_cond, toCompTerm mtrm] @@ -1355,7 +1369,7 @@ assertingOrAssumingMacro doAsserting = MonMacro 3 $ \_ args -> _ -> error "assertingOrAssumingMacro: wrong number of arguments!" atrm_cond <- monadifyArg (Just MTyBool) cond mtp <- monadifyTypeM tp - mtrm <- resetMonadifyM (toArgType mtp) $ monadifyTerm (Just mtp) m + mtrm <- resetMonadifyM mtp $ monadifyTerm (Just mtp) m ev <- askEvType let ident = if doAsserting then "Prelude.assertingS" else "Prelude.assumingS" @@ -1376,22 +1390,24 @@ finMacro isSemiPure i j from to params_p = 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 (evTypeTerm ?specMEvType :) 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 @@ -1403,13 +1419,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 <- askEvType + do ev <- askEvType mtp <- monadifyTypeM tp usingEvType $ do amtrm_f <- monadifyArg (Just $ MTyArrow mtp mtp) f return $ fromCompTerm mtp $ - applyOpenTermMulti (globalOpenTerm "Prelude.multiArgFixS") - [specMEvType 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!" @@ -1457,7 +1473,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 @@ -1580,10 +1596,10 @@ monadifyCompleteArgType sc env tp poly_p = if poly_p then -- Parameter polymorphism means pi-quantification over E (piOpenTerm "E" (dataTypeOpenTerm "Prelude.EvType" []) $ \e -> - let ?specMEvType = e 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 + let ?specMEvType = error "FIXME HERE NOW: cannot handle event polymorphism yet" in + -- NOTE: even though E is a free variable here, it can not be free in tp, + -- which is a closed term, so we do not list it in the MonadifyTypeCtx + -- argument of monadifyTypeArgType monadifyTypeArgType [] tp) else let ?specMEvType = monEnvEvType env in monadifyTypeArgType [] tp @@ -1680,4 +1696,3 @@ monadifyCryptolModule :: SharedContext -> Env -> MonadifyEnv -> CryptolModule -> IO (CryptolModule, MonadifyEnv) monadifyCryptolModule sc cry_env top_env cry_mod = flip runStateT top_env $ monadifyCryptolModuleH sc cry_env cry_mod --} From edd56e48ef935dbc998fb4eacd76bc927f1470db Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 20 Nov 2023 18:14:46 -0800 Subject: [PATCH 192/305] changed the EventType type to hold an arbitrary term, rather than just an identifier, in order to support event type polymorphism in monadification --- .../src/Verifier/SAW/Cryptol/Monadify.hs | 2 +- saw-core/src/Verifier/SAW/OpenTerm.hs | 12 ++++-------- 2 files changed, 5 insertions(+), 9 deletions(-) diff --git a/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs b/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs index 6ff70bf016..4adc0efda3 100644 --- a/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs +++ b/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs @@ -1596,7 +1596,7 @@ monadifyCompleteArgType sc env tp poly_p = if poly_p then -- Parameter polymorphism means pi-quantification over E (piOpenTerm "E" (dataTypeOpenTerm "Prelude.EvType" []) $ \e -> - let ?specMEvType = error "FIXME HERE NOW: cannot handle event polymorphism yet" in + 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 diff --git a/saw-core/src/Verifier/SAW/OpenTerm.hs b/saw-core/src/Verifier/SAW/OpenTerm.hs index b422f806f1..5ac308cf81 100644 --- a/saw-core/src/Verifier/SAW/OpenTerm.hs +++ b/saw-core/src/Verifier/SAW/OpenTerm.hs @@ -73,7 +73,7 @@ module Verifier.SAW.OpenTerm ( eitherTypeOpenTerm, sigmaTypeOpenTerm, sigmaTypeOpenTermMulti, sigmaOpenTerm, sigmaOpenTermMulti, sigmaElimOpenTermMulti, -- * Operations for building @SpecM@ computations - EventType (..), evTypeTerm, defaultSpecMEventType, unitKindDesc, bvExprKind, + EventType (..), defaultSpecMEventType, unitKindDesc, bvExprKind, tpDescTypeOpenTerm, kindToTpDesc, unitTpDesc, boolExprKind, boolKindDesc, boolTpDesc, natExprKind, natKindDesc, numExprKind, numKindDesc, bvKindDesc, tpKindDesc, pairTpDesc, tupleTpDesc, @@ -565,16 +565,12 @@ sigmaElimOpenTermMulti x (tp:tps) tp_f sig f_elim = -------------------------------------------------------------------------------- -- Operations for building SpecM computations --- | A SAW core identifier that indicates an event type for the @SpecM@ monad -newtype EventType = EventType { evTypeToIdent :: Ident } - --- | Convert an 'EventType' to a SAW core term -evTypeTerm :: EventType -> OpenTerm -evTypeTerm = globalOpenTerm . evTypeToIdent +-- | 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 "SpecM.VoidEv" +defaultSpecMEventType = EventType $ globalOpenTerm "SpecM.VoidEv" -- | The kind description for the unit type unitKindDesc :: OpenTerm From ef693fa1b59a11c03e04f8cf5a547043d24fb06d Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 20 Nov 2023 18:28:49 -0800 Subject: [PATCH 193/305] added documentation for monadifyLambdas and monadifyEtaExpand --- .../src/Verifier/SAW/Cryptol/Monadify.hs | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs b/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs index 4adc0efda3..708f5512ca 100644 --- a/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs +++ b/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs @@ -1225,8 +1225,9 @@ 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 +-- | 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 (MTyForall _ k tp_f) (asLambda -> @@ -1242,7 +1243,15 @@ monadifyLambdas env ctx (MTyArrow tp_in tp_out) (asLambda -> monadifyLambdas env ctx tp t = monadifyEtaExpand env ctx tp tp t [] --- | FIXME: documentation +-- | 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 = From 8fee78a17b7033d3f66ce2b9054a457d54171e6d Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Tue, 21 Nov 2023 06:59:13 -0800 Subject: [PATCH 194/305] updated comments to remove SpecMParams --- .../src/Verifier/SAW/Cryptol/Monadify.hs | 18 ++++++++---------- 1 file changed, 8 insertions(+), 10 deletions(-) diff --git a/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs b/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs index 708f5512ca..40c3d37253 100644 --- a/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs +++ b/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs @@ -809,15 +809,15 @@ 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' +-- the current 'EventType' if the 'Bool' flag is 'True' mkGlobalArgMonTerm :: HasSpecMEvType => MonType -> Ident -> Bool -> ArgMonTerm mkGlobalArgMonTerm tp ident params_p = fromArgTerm tp (if params_p then applyGlobalOpenTerm ident [evTypeTerm ?specMEvType] else globalOpenTerm ident) --- | Build a 'MonTerm' from a 'GlobalDef' of semi-pure type, applying it to --- the current 'SpecMParams' if the 'Bool' flag is 'True' +-- | 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) @@ -853,8 +853,8 @@ 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 -> usingEvType $ @@ -869,10 +869,8 @@ 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 -> usingEvType $ @@ -1391,7 +1389,7 @@ assertingOrAssumingMacro doAsserting = MonMacro 3 $ \_ args -> -- 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 -> usingEvType $ From c245e10fa2377f6d3229d665e2d7be61a5886517 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 22 Nov 2023 18:00:44 -0800 Subject: [PATCH 195/305] re-added an updated version of refinesS --- cryptol-saw-core/saw/SpecM.sawcore | 60 ++++-------------------------- 1 file changed, 7 insertions(+), 53 deletions(-) diff --git a/cryptol-saw-core/saw/SpecM.sawcore b/cryptol-saw-core/saw/SpecM.sawcore index 809bf8317f..6126e39941 100644 --- a/cryptol-saw-core/saw/SpecM.sawcore +++ b/cryptol-saw-core/saw/SpecM.sawcore @@ -855,58 +855,12 @@ appendCastBVVecS E n len1 len2 len3 a v1 v2 = -- Defining refinement on SpecM computations -- -{- - --- 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 E1 stack1 -> FunStackE 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 E1 stack1) -> (e2:FunStackE E2 stack2) -> - FunStackERet E1 stack1 e1 -> FunStackERet 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 StackCalls 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 E stack) e1 e2; - --- The postcondition stating that errors, event encodings, and return values --- of StackCalls 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 E stack) (FunStackERet 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; +-- 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; --- 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); --} +-- 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; From 4d6332f3497b5d3c27fee1bae6420320898eccd5 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 22 Nov 2023 18:23:43 -0800 Subject: [PATCH 196/305] updated MR solver to work with the new definition of SpecM --- src/SAWScript/HeapsterBuiltins.hs | 2 +- src/SAWScript/Prover/MRSolver/Monad.hs | 14 +- src/SAWScript/Prover/MRSolver/Solver.hs | 458 +++++++++--------------- src/SAWScript/Prover/MRSolver/Term.hs | 66 ++-- 4 files changed, 202 insertions(+), 338 deletions(-) diff --git a/src/SAWScript/HeapsterBuiltins.hs b/src/SAWScript/HeapsterBuiltins.hs index 12c2406168..a9bede05b7 100644 --- a/src/SAWScript/HeapsterBuiltins.hs +++ b/src/SAWScript/HeapsterBuiltins.hs @@ -1128,7 +1128,7 @@ heapster_set_event_type _bic _opts henv term_string = liftIO $ completeOpenTerm sc $ dataTypeOpenTerm "Prelude.EvType" [] ev_id <- parseAndInsDef henv "HeapsterEv" ev_tp term_string liftIO $ modifyIORef' (heapsterEnvPermEnvRef henv) $ \env -> - env { permEnvEventType = EventType ev_id } + env { permEnvEventType = EventType (globalOpenTerm ev_id) } -- | Fetch the SAW core definition associated with a name and print it heapster_print_fun_trans :: BuiltinContext -> Options -> HeapsterEnv -> diff --git a/src/SAWScript/Prover/MRSolver/Monad.hs b/src/SAWScript/Prover/MRSolver/Monad.hs index f7b4663444..ee1cd7f5a0 100644 --- a/src/SAWScript/Prover/MRSolver/Monad.hs +++ b/src/SAWScript/Prover/MRSolver/Monad.hs @@ -80,7 +80,7 @@ data MRFailure | FunsNotEq FunName FunName | CannotLookupFunDef FunName | RecursiveUnfold FunName - | MalformedLetRecTypes Term + | MalformedTpDescList Term | MalformedDefs Term | MalformedComp Term | NotCompFunType Term @@ -158,8 +158,8 @@ instance PrettyInCtx MRFailure where ppWithPrefix "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 + prettyInCtx (MalformedTpDescList t) = + ppWithPrefix "Not a list of type descriptions:" t prettyInCtx (MalformedDefs t) = ppWithPrefix "Cannot handle multiFixS recursive definitions term:" t prettyInCtx (MalformedComp t) = @@ -655,11 +655,11 @@ 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 + (asSpecM -> Just (ev, tp)) -> (ev,) <$> liftSC1 scWhnf tp _ -> do pp_ftype <- funNameType fname >>= mrPPInCtx pp_fname <- mrPPInCtx fname debugPrint 0 "mrFunOutType: function does not have SpecM return type" @@ -1090,7 +1090,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 diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index 20f2d2254f..50e8c6e668 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -20,9 +20,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 +33,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 +52,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: @@ -95,18 +79,17 @@ we are trying to prove @m1@ refines @m2@ in context @C@. This proceeds by cases: > C |- m |= existsS f: make a new existential variable x and recurse > > C |- forallS f |= m: make a new existential variable x and recurse -> +> > C |- m |= orS m1 m2: try to prove C |- m |= m1, and if that fails, backtrack and > prove C |- m |= m2 -> +> > C |- orS m1 m2 |= m: prove both C |- m1 |= m and C |- m2 |= m +> + +> C |- FixS fdef args |= m: create a FixS-bound variable F bound to (fdef F) and +> recurse on fdef F args |= m > -> C |- 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 |- 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,11 +118,6 @@ 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 @@ -176,6 +154,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] @@ -183,80 +168,28 @@ 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 +-- | 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 + +-- | Bind fresh function variables for a @MultiFixS@ with the first 'Term' as +-- the event type, the second as a list of the type descriptions for the +-- recursive functions being defined, and the third a function of the form -- --- > CallS _ _ _ (mkFrameCall _ i arg1 ... argn) --- --- with the term @tmi arg1 ... argn@, where @tmi@ is the @i@th term in the list --- --- 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 = +-- > \F1 F2 ... Fn -> (f1, (f2, ... (fn, ()))) +mrFreshCallVars :: Term -> Term -> Term -> MRM t [MRVar] +mrFreshCallVars ev tp_ds_tm defs_tm = 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] + -- 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_tm of + Just ds -> mapM (\d -> mrApplyAll tpElem_fun [ev, d]) ds + Nothing -> throwMRFailure (MalformedTpDescList tp_ds_tm) fun_vars <- mapM (mrFreshVar "F") fun_tps -- Next, match on the tuple of recursive function definitions and convert @@ -265,9 +198,9 @@ mrFreshCallVars ev stack frame defs_tm = -- 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 + defs_app <- mrApplyAll defs_tm fun_tms + bodies <- case asNestedPairs defs_app of + Just defs -> mapM lambdaUVarsM defs Nothing -> throwMRFailure (MalformedDefs defs_tm) -- Remember the body associated with each fresh function constant @@ -295,26 +228,24 @@ 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.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) @@ -322,40 +253,26 @@ 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 fresh function vars for the new recursive functions - fun_vars <- mrFreshCallVars ev stack frame 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 - - (isGlobalDef "Prelude.multiArgFixS" -> Just (), _ev:_stack:_lrt:body:args) -> - do - -- Bind a fresh function var for the new recursive function + -- 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 @@ -372,9 +289,24 @@ normComp (CompTerm t) = -- well as the args let var = CallSName fun_var all_args <- (++ args) <$> getAllUVarTerms - FunBind var all_args Unlifted <$> mkCompFunReturn <$> + FunBind var all_args <$> mkCompFunReturn <$> mrFunOutType var all_args +{- +FIXME HERE NOW: match a tuple projection of a MultiFixS + + (isGlobalDef "Prelude.MultiFixS" -> Just (), ev:tp_ds:defs:args) -> + do + -- Bind fresh function vars for the new recursive functions + fun_vars <- mrFreshCallVars ev tp_ds defs + -- Return the @i@th variable to args as a normalized computation, noting + -- that it must be applied to all of the uvars as well as the args + let var = CallSName (fun_vars !! (fromIntegral i)) + all_args <- (++ args) <$> getAllUVarTerms + FunBind var all_args <$> mkCompFunReturn <$> + mrFunOutType var all_args +-} + -- Convert `vecMapM (bvToNat ...)` into `bvVecMapInvarM`, with the -- invariant being the current set of assumptions (asGlobalDef -> Just "CryptolM.vecMapM", [_a, _b, (asBvToNat -> Just (_w, _n)), @@ -388,19 +320,19 @@ normComp (CompTerm t) = -- Convert `atM (bvToNat ...) ... (bvToNat ...)` into the unfolding of -- `bvVecAtM` - (asGlobalDef -> Just "CryptolM.atM", [ev, stack, + (asGlobalDef -> Just "CryptolM.atM", [ev, (asBvToNat -> Just (w1, n)), a, xs, (asBvToNat -> Just (w2, i))]) -> 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 + mrApplyAll body [ev, w1, n, a, xs, i] >>= normCompTerm else 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, + (asGlobalDef -> Just "CryptolM.atM", [ev, n_tm@(asNat -> Just n), a, xs, (asBvToNat -> Just (w_tm@(asNat -> Just w), @@ -409,24 +341,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 + 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, + (asGlobalDef -> Just "CryptolM.updateM", [ev, (asBvToNat -> Just (w1, n)), a, xs, (asBvToNat -> Just (w2, i)), 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 + mrApplyAll body [ev, w1, n, a, xs, i, x] >>= normCompTerm else 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, + (asGlobalDef -> Just "CryptolM.updateM", [ev, n_tm@(asNat -> Just n), a, xs, (asBvToNat -> Just (w_tm@(asNat -> Just w), @@ -436,7 +368,7 @@ 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) @@ -468,11 +400,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) @@ -495,7 +427,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 @@ -512,73 +444,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' @@ -607,19 +477,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 -- 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 "Prelude.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 "Prelude.retS" [unEvTerm ev, a', ret_val] {- -- | Convert a 'Comp' into a 'Term' @@ -646,7 +516,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 @@ -655,8 +525,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 @@ -698,7 +568,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 -} @@ -1042,9 +912,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 = @@ -1055,15 +925,15 @@ 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 = +mrRefines' (FunBind (CallSName f) args1 k1) + (FunBind (CallSName f') args2 k2) + | f == f' && length args1 == length args2 = zipWithM_ mrAssertProveEq args1 args2 >> mrFunOutType (CallSName f) args1 >>= \(_, tp) -> mrRefinesFun tp k1 tp k2 -mrRefines' m1@(FunBind f1 args1 isLifted1 k1) - m2@(FunBind f2 args2 isLifted2 k2) = +mrRefines' m1@(FunBind f1 args1 k1) + m2@(FunBind f2 args2 k2) = mrFunOutType f1 args1 >>= \(_, tp1) -> mrFunOutType f2 args2 >>= \(_, tp2) -> findInjConvs tp1 Nothing tp2 Nothing >>= \mb_convs -> @@ -1102,7 +972,7 @@ mrRefines' m1@(FunBind f1 args1 isLifted1 k1) -- 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 @@ -1124,27 +994,25 @@ mrRefines' m1@(FunBind f1 args1 isLifted1 k1) evars <- mrFreshEVars ctx (args1'', rhs'') <- substTermLike 0 evars (args1', rhs') zipWithM_ mrAssertProveEq args1'' args1 - m1' <- normBindLiftStack isLifted1 rhs'' k1 + 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 + -- assumption that f1 refines some specification, 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 -> + , Just _ <- maybe_f2_body -> mrRefinesCoInd f1 args1 f2 args2 >> mrRefinesFun tp1 k1 tp2 k2 -- If we cannot line up f1 and f2, then making progress here would require us @@ -1153,12 +1021,10 @@ mrRefines' m1@(FunBind f1 args1 isLifted1 k1) -- 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 + do mrDebugPPPrefixSep 1 "mrRefines: bind types not equal:" tp1 "/=" tp2 throwMRFailure (CompsDoNotRefine m1 m2) -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 @@ -1168,7 +1034,7 @@ mrRefines' m1@(FunBind f1 args1 isLifted1 k1) m2 = evars <- mrFreshEVars ctx (args1'', rhs'') <- substTermLike 0 evars (args1', rhs') zipWithM_ mrAssertProveEq args1'' args1 - m1' <- normBindLiftStack isLifted1 rhs'' k1 + m1' <- normBind rhs'' k1 recordUsedFunAssump fa >> mrRefines m1' m2 -- Otherwise, see if we can unfold f1 @@ -1177,19 +1043,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 @@ -1252,19 +1118,31 @@ mrRefinesFun tp1 f1 tp2 f2 = piTp2 <- mrTypeOf f2'' 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. + +-- | The main loop of 'mrRefinesFun' and '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 +-- heterogeneously related as in 'HetRelated'. mrRefinesFunH :: (Term -> Term -> MRM t a) -> [Term] -> Term -> Term -> Term -> Term -> MRM t a -- 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) @@ -1273,7 +1151,8 @@ mrRefinesFunH k vars (asPi -> Just (nm1, tp1@(asEq -> Just (asBoolType -> Just ( 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) @@ -1334,6 +1213,8 @@ mrRefinesFunH _ _ tp1@(asSpecM -> Nothing) _ _ _ = mrRefinesFunH _ _ _ _ tp2@(asSpecM -> Nothing) _ = throwMRFailure (NotCompFunType tp2) +-- 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 @@ -1369,30 +1250,23 @@ askMRSolver sc env timeout askSMT rs args t1 t2 = 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, tp) <- fromJust . asSpecM <$> mrTypeOf t1 + rr <- liftSC2 scGlobalApply "Prelude.eqRR" [tp] + ref_tm <- liftSC2 scGlobalApply "Prelude.refinesS" [ev, tp, tp, 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 -} -> diff --git a/src/SAWScript/Prover/MRSolver/Term.hs b/src/SAWScript/Prover/MRSolver/Term.hs index 3b6d2399b3..cd9e76e1e1 100644 --- a/src/SAWScript/Prover/MRSolver/Term.hs +++ b/src/SAWScript/Prover/MRSolver/Term.hs @@ -47,6 +47,7 @@ import Verifier.SAW.Term.CtxTerm (MonadTerm(..)) import Verifier.SAW.Term.Pretty import Verifier.SAW.SharedTerm import Verifier.SAW.Recognizer hiding ((:*:)) +import Verifier.SAW.OpenTerm import Verifier.SAW.Cryptol.Monadify @@ -168,14 +169,6 @@ 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" data NormComp = RetS Term -- ^ A term @retS _ _ a x@ @@ -188,7 +181,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) @@ -197,19 +190,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 @@ -232,23 +228,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 "Prelude.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 @@ -425,8 +419,7 @@ instance TermLike Natural where substTermLike _ _ = return deriving anyclass instance TermLike Type -deriving instance TermLike (SpecMParams Term) -deriving instance TermLike IsLifted +deriving instance TermLike EvTerm deriving instance TermLike NormComp deriving instance TermLike CompFun deriving instance TermLike Comp @@ -586,21 +579,18 @@ instance PrettyInCtx NormComp where prettyInCtx (ForallBind tp k) = prettyAppList [return "forallS", return "_", 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 From d1a24dffc691e93cb9b4a2c5a707db96e19c1baf Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 23 Nov 2023 08:21:18 -0800 Subject: [PATCH 197/305] whoops, changed some identifiers from the Prelude to the new SpecM SAW core module; also made sure the SpecM and CryptolM modules are loaded when needed --- .../src/Verifier/SAW/Cryptol/Monadify.hs | 20 ++++++++++++------- 1 file changed, 13 insertions(+), 7 deletions(-) diff --git a/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs b/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs index 40c3d37253..4ed2cad35a 100644 --- a/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs +++ b/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs @@ -1360,7 +1360,7 @@ invariantHintMacro = MonMacro 3 $ \_ args -> usingEvType $ mtp <- monadifyTypeM tp 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 @@ -1378,8 +1378,8 @@ assertingOrAssumingMacro doAsserting = MonMacro 3 $ \_ args -> mtp <- monadifyTypeM tp mtrm <- resetMonadifyM mtp $ monadifyTerm (Just mtp) m ev <- askEvType - let ident = if doAsserting then "Prelude.assertingS" - else "Prelude.assumingS" + let ident = if doAsserting then "SpecM.assertingS" + else "SpecM.assumingS" return $ fromCompTerm mtp $ applyOpenTermMulti (globalOpenTerm ident) [evTypeTerm ev, toArgType mtp, toArgTerm atrm_cond, toCompTerm mtrm] @@ -1420,6 +1420,9 @@ finMacro isSemiPure i j from to params_p = then ArgMonTerm $ fromSemiPureTerm glob_tp_app to_app else ArgMonTerm $ fromArgTerm glob_tp_app to_app +-- FIXME HERE NOW: add a case for a fix of a record type of functions, which +-- should translate to MultiFixS + -- | The macro for fix -- -- FIXME: does not yet handle mutual recursion @@ -1493,9 +1496,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 @@ -1599,10 +1602,11 @@ 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 - (piOpenTerm "E" (dataTypeOpenTerm "Prelude.EvType" []) $ \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 @@ -1615,6 +1619,7 @@ monadifyCompleteArgType sc env tp poly_p = -- '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 = + (ensureCryptolMLoaded sc >>) $ runCompleteMonadifyM sc env tp $ usingEvType $ monadifyTerm (Just $ monadifyType [] tp) trm @@ -1655,6 +1660,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 From 0aa46dd9c3b8821cd2bd0e5cc31d8694962c5abe Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 23 Nov 2023 08:23:23 -0800 Subject: [PATCH 198/305] updated a use of EvType from the Prelude to the SpecM SAW core module --- src/SAWScript/HeapsterBuiltins.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/SAWScript/HeapsterBuiltins.hs b/src/SAWScript/HeapsterBuiltins.hs index a9bede05b7..47ab09cb4a 100644 --- a/src/SAWScript/HeapsterBuiltins.hs +++ b/src/SAWScript/HeapsterBuiltins.hs @@ -1125,7 +1125,7 @@ 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 { permEnvEventType = EventType (globalOpenTerm ev_id) } From 9deee50ccd2e19e6fb0add167c787377a1c48c1e Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 23 Nov 2023 08:42:48 -0800 Subject: [PATCH 199/305] whoops, forgot to monadify the bitvector type --- .../src/Verifier/SAW/Cryptol/Monadify.hs | 15 +++++++++++---- saw-core/src/Verifier/SAW/OpenTerm.hs | 9 +++++++-- 2 files changed, 18 insertions(+), 6 deletions(-) diff --git a/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs b/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs index 4ed2cad35a..3e9db733db 100644 --- a/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs +++ b/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs @@ -302,6 +302,7 @@ data MonType | MTySeq NumTpExpr MonType | MTyUnit | MTyBool + | MTyBV Natural | MTyPair MonType MonType | MTySum MonType MonType -- | A type with no type description, meaning it cannot be used in a @@ -374,6 +375,7 @@ toArgType (MTySeq n t) = [evTypeTerm ?specMEvType, numExprVal n, toArgType t] toArgType MTyUnit = unitTypeOpenTerm toArgType MTyBool = boolTypeOpenTerm +toArgType (MTyBV n) = bitvectorTypeOpenTerm $ natOpenTerm n toArgType (MTyPair mtp1 mtp2) = pairTypeOpenTerm (toArgType mtp1) (toArgType mtp2) toArgType (MTySum mtp1 mtp2) = @@ -445,6 +447,7 @@ 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) = @@ -561,7 +564,9 @@ monadifyTpExpr ctx (asDataType -> Just (pn, args)) = SomeTpExpr MKTypeRepr $ MTyIndesc $ dataTypeOpenTerm (primName pn) (map (someTpExprVal . monadifyTpExpr ctx) args) -{- FIXME: if we need finite Vecs, then we need Nat tp exprs +monadifyTpExpr _ (asBitvectorType -> Just w) = + SomeTpExpr MKTypeRepr $ MTyBV w +{- FIXME: if we need general finite Vecs, then we need Nat tp exprs monadifyType ctx (asVectorType -> Just (len, tp)) = let lenOT = monadifyTypeNat ctx len in MTySeq (ctorOpenTerm "Cryptol.TCNum" [lenOT]) $ monadifyType ctx tp @@ -600,7 +605,7 @@ monadifyTpExpr ctx (asLocalVar -> Just i) , (_,_,Just (SomeTpExpr k e)) <- ctx!!i = SomeTpExpr k e monadifyTpExpr ctx tp = panic "monadifyTpExpr" - ["not a valid type or numberic expression for monadification: " + ["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 @@ -721,6 +726,7 @@ monTypeIsPure (MTyArrow _ _) = False monTypeIsPure (MTySeq _ _) = False monTypeIsPure MTyUnit = True monTypeIsPure MTyBool = True +monTypeIsPure (MTyBV _) = True monTypeIsPure (MTyPair mtp1 mtp2) = monTypeIsPure mtp1 && monTypeIsPure mtp2 monTypeIsPure (MTySum mtp1 mtp2) = monTypeIsPure mtp1 && monTypeIsPure mtp2 monTypeIsPure (MTyIndesc _) = True @@ -737,8 +743,9 @@ monTypeIsSemiPure (MTyForall _ k tp_f) = monTypeIsSemiPure (MTyArrow tp_in tp_out) = monTypeIsPure tp_in && monTypeIsSemiPure tp_out monTypeIsSemiPure (MTySeq _ _) = False -monTypeIsSemiPure MTyUnit = False -monTypeIsSemiPure MTyBool = 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 diff --git a/saw-core/src/Verifier/SAW/OpenTerm.hs b/saw-core/src/Verifier/SAW/OpenTerm.hs index 5ac308cf81..e2bac03318 100644 --- a/saw-core/src/Verifier/SAW/OpenTerm.hs +++ b/saw-core/src/Verifier/SAW/OpenTerm.hs @@ -76,8 +76,9 @@ module Verifier.SAW.OpenTerm ( EventType (..), defaultSpecMEventType, unitKindDesc, bvExprKind, tpDescTypeOpenTerm, kindToTpDesc, unitTpDesc, boolExprKind, boolKindDesc, boolTpDesc, natExprKind, natKindDesc, - numExprKind, numKindDesc, bvKindDesc, tpKindDesc, pairTpDesc, tupleTpDesc, - sumTpDesc, bvVecTpDesc, constTpExpr, bvConstTpExpr, binOpTpExpr, bvSumTpExprs, + 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, @@ -626,6 +627,10 @@ numKindDesc = ctorOpenTerm "SpecM.Kind_Expr" [numExprKind] 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" [] From a1d71a1f95edb46195847ffde4047204539249f7 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 24 Nov 2023 08:13:59 -0800 Subject: [PATCH 200/305] updated monadify example to work with the new SpecM --- examples/mr_solver/monadify.saw | 147 +++++++++++++++----------------- 1 file changed, 71 insertions(+), 76 deletions(-) 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; From 3e17ce88cb59dbdd64f552f9d00397871ea1f702 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Sat, 25 Nov 2023 07:14:54 -0800 Subject: [PATCH 201/305] whoops, forgot to update a number of SpecM identifiers to the new SpecM module --- src/SAWScript/Builtins.hs | 11 +++---- src/SAWScript/Prover/MRSolver/Evidence.hs | 38 +++++++---------------- src/SAWScript/Prover/MRSolver/Solver.hs | 17 +++++----- src/SAWScript/Prover/MRSolver/Term.hs | 2 +- 4 files changed, 25 insertions(+), 43 deletions(-) diff --git a/src/SAWScript/Builtins.hs b/src/SAWScript/Builtins.hs index 279c3acddd..390b75673c 100644 --- a/src/SAWScript/Builtins.hs +++ b/src/SAWScript/Builtins.hs @@ -2274,11 +2274,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 @@ -2313,7 +2312,7 @@ mrSolverSetDebug dlvl = -- | 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/Prover/MRSolver/Evidence.hs b/src/SAWScript/Prover/MRSolver/Evidence.hs index bc627954f5..b7a57fb690 100644 --- a/src/SAWScript/Prover/MRSolver/Evidence.hs +++ b/src/SAWScript/Prover/MRSolver/Evidence.hs @@ -47,20 +47,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 +71,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,7 +108,7 @@ 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@, @@ -129,9 +116,6 @@ data FunAssump t = FunAssump { 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") _ _ (asApplyAll -> (asGlobalFunName -> Just f1, args1)) t2@(asApplyAll -> (asGlobalFunName -> mb_f2, args2)))) = let rhs = maybe (RewriteFunAssump t2) (\f2 -> OpaqueFunAssump f2 args2) mb_f2 diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index 50e8c6e668..fbe5bc592b 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -372,11 +372,10 @@ FIXME HERE NOW: match a tuple projection of a MultiFixS >>= normCompTerm else throwMRFailure (MalformedComp t) - -- Always unfold: sawLet, multiArgFixM, invariantHint, Num_rec + -- Always unfold: sawLet, invariantHint, Num_rec (f@(asGlobalDef -> Just ident), args) - | ident `elem` ["Prelude.sawLet", "Prelude.invariantHint", - "Cryptol.Num_rec", "Prelude.multiArgFixS", - "Prelude.lrtLambda"] + | ident `elem` ["Prelude.sawLet", "SpecM.invariantHint", + "Cryptol.Num_rec"] , Just (_, Just body) <- asConstant f -> mrApplyAll body args >>= normCompTerm @@ -484,12 +483,12 @@ compFunToTerm (CompFunComp f g) = 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" [unEvTerm ev, - 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 ev (Type a)) = mrLambdaLift1 ("ret_val", a) a $ \ret_val a' -> - liftSC2 scGlobalApply "Prelude.retS" [unEvTerm ev, a', ret_val] + liftSC2 scGlobalApply "SpecM.retS" [unEvTerm ev, a', ret_val] {- -- | Convert a 'Comp' into a 'Term' @@ -1257,8 +1256,8 @@ askMRSolver sc env timeout askSMT rs args t1 t2 = refinementTermH :: Term -> Term -> MRM t Term refinementTermH t1 t2 = do (EvTerm ev, tp) <- fromJust . asSpecM <$> mrTypeOf t1 - rr <- liftSC2 scGlobalApply "Prelude.eqRR" [tp] - ref_tm <- liftSC2 scGlobalApply "Prelude.refinesS" [ev, tp, tp, rr, t1, t2] + rr <- liftSC2 scGlobalApply "SpecM.eqRR" [tp] + ref_tm <- liftSC2 scGlobalApply "SpecM.refinesS" [ev, tp, tp, rr, t1, t2] uvars <- mrUVarsOuterToInner liftSC2 scPiList uvars ref_tm diff --git a/src/SAWScript/Prover/MRSolver/Term.hs b/src/SAWScript/Prover/MRSolver/Term.hs index cd9e76e1e1..3f23905f71 100644 --- a/src/SAWScript/Prover/MRSolver/Term.hs +++ b/src/SAWScript/Prover/MRSolver/Term.hs @@ -240,7 +240,7 @@ data Comp = CompTerm Term | CompBind Comp CompFun | CompReturn Term -- | Match a type as being of the form @SpecM E a@ for some @E@ and @a@ asSpecM :: Term -> Maybe (EvTerm, Term) -asSpecM (asApplyAll -> (isGlobalDef "Prelude.SpecM" -> Just (), [ev, tp])) = +asSpecM (asApplyAll -> (isGlobalDef "SpecM.SpecM" -> Just (), [ev, tp])) = return (EvTerm ev, tp) asSpecM _ = fail "not a SpecM type, or event type is not closed!" From 1bc0121b1fff7d5282295a9daf6288dcc6110dbb Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Sun, 26 Nov 2023 06:37:18 -0800 Subject: [PATCH 202/305] added a case to the MR solver normalizer to recognize LetRecS terms --- src/SAWScript/Prover/MRSolver/Solver.hs | 21 ++++++++++++++++++--- 1 file changed, 18 insertions(+), 3 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index fbe5bc592b..a77b2afdf5 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -176,12 +176,17 @@ asList (asCtor -> Just (nm, [_, hd, tl])) | primName nm == "Prelude.Cons" = (hd:) <$> asList tl asList _ = Nothing --- | Bind fresh function variables for a @MultiFixS@ with the first 'Term' as --- the event type, the second as a list of the type descriptions for the --- recursive functions being defined, and the third a function of the form +-- | Bind fresh function variables for a @LetRecS@ or @MultiFixS@ with the first +-- 'Term' as the event type, the second as a list of the type descriptions for +-- the recursive functions being defined, and the third a function of the form -- -- > \F1 F2 ... Fn -> (f1, (f2, ... (fn, ()))) +-- +-- that defines the bodies of those recursive functions. mrFreshCallVars :: Term -> Term -> Term -> MRM t [MRVar] +mrFreshCallVars ev tp_ds_tm (asConstant -> Just (_, Just defs_tm)) = + -- If defs is a constant, unfold it + mrFreshCallVars ev tp_ds_tm defs_tm mrFreshCallVars ev tp_ds_tm defs_tm = do -- First compute the types of the recursive functions being bound by mapping @@ -307,6 +312,16 @@ FIXME HERE NOW: match a tuple projection of a MultiFixS mrFunOutType var all_args -} + (isGlobalDef "SpecM.LetRecS" -> Just (), [ev,tp_ds,_,defs,body]) -> + do + -- Bind fresh function vars for the new recursive functions + fun_vars <- mrFreshCallVars ev tp_ds defs + fun_tms <- mapM mrVarTerm fun_vars + + -- Continue normalizing body applied to those fresh function vars + body_app <- mrApplyAll body fun_tms + normCompTerm body_app + -- Convert `vecMapM (bvToNat ...)` into `bvVecMapInvarM`, with the -- invariant being the current set of assumptions (asGlobalDef -> Just "CryptolM.vecMapM", [_a, _b, (asBvToNat -> Just (_w, _n)), From 37d0a5e26cadf5aa2d26dcfa844c0074f8cc36ae Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Sun, 26 Nov 2023 07:15:08 -0800 Subject: [PATCH 203/305] whoops, updated two more identifiers to point to the new SpecM module --- src/SAWScript/Prover/MRSolver/Monad.hs | 6 +++--- src/SAWScript/Prover/MRSolver/Solver.hs | 1 - 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/Monad.hs b/src/SAWScript/Prover/MRSolver/Monad.hs index ee1cd7f5a0..83a0cdc33d 100644 --- a/src/SAWScript/Prover/MRSolver/Monad.hs +++ b/src/SAWScript/Prover/MRSolver/Monad.hs @@ -1125,8 +1125,8 @@ mrGetInvariantBody tm = case asApplyAll tm of do tm' <- mrApplyAll f args mrGetInvariantBody tm' -- go inside any top-level applications of of bindM ... (assertFiniteM ...) - (isGlobalDef "Prelude.bindM" -> Just (), - [_, _, + (isGlobalDef "SpecM.bindS" -> Just (), + [_, _, _, asApp -> Just (isGlobalDef "CryptolM.assertFiniteM" -> Just (), asCtor -> Just (primName -> "Cryptol.TCNum", _)), k]) -> @@ -1134,7 +1134,7 @@ mrGetInvariantBody tm = case asApplyAll tm of 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 diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index a77b2afdf5..f9f126af98 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -85,7 +85,6 @@ 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 |- FixS fdef args |= m: create a FixS-bound variable F bound to (fdef F) and > recurse on fdef F args |= m > From 197cfae6c7801c3d52ef99ad0ddbe207879399b4 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Sun, 26 Nov 2023 07:22:45 -0800 Subject: [PATCH 204/305] small bug fixes --- cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs b/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs index 3e9db733db..c654f973d6 100644 --- a/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs +++ b/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs @@ -367,11 +367,11 @@ numExprVal (NExpr_Indesc n) = n -- i.e., one not containing 'MTyNum' or 'MTyVarLvl' toArgType :: HasSpecMEvType => MonType -> OpenTerm toArgType (MTyForall x k body) = - piOpenTerm x (sortOpenTerm $ mkSort 0) (\e -> toCompType (body $ kindIndesc k e)) + piOpenTerm x (kindReprOpenTerm k) (\e -> toCompType (body $ kindIndesc k e)) toArgType (MTyArrow t1 t2) = arrowOpenTerm "_" (toArgType t1) (toCompType t2) toArgType (MTySeq n t) = - applyOpenTermMulti (globalOpenTerm "CryptolM.mseq") + applyOpenTermMulti (globalOpenTerm "SpecM.mseq") [evTypeTerm ?specMEvType, numExprVal n, toArgType t] toArgType MTyUnit = unitTypeOpenTerm toArgType MTyBool = boolTypeOpenTerm From 5a66180855d3f94f1791ad42079043a2f585d568 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Sun, 26 Nov 2023 12:09:28 -0800 Subject: [PATCH 205/305] updated SpecPrims to work with the new SpecM monad --- cryptol-saw-core/saw/SpecM.sawcore | 10 ++++++---- heapster-saw/examples/SpecPrims.cry | 16 ++++------------ heapster-saw/examples/arrays.cry | 2 +- heapster-saw/examples/arrays_mr_solver.saw | 1 - heapster-saw/examples/specPrims.saw | 10 +++++----- 5 files changed, 16 insertions(+), 23 deletions(-) diff --git a/cryptol-saw-core/saw/SpecM.sawcore b/cryptol-saw-core/saw/SpecM.sawcore index 6126e39941..9eb2ef3a6b 100644 --- a/cryptol-saw-core/saw/SpecM.sawcore +++ b/cryptol-saw-core/saw/SpecM.sawcore @@ -572,8 +572,9 @@ 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); +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; -- Assert a proposition holds primitive assertS : (E:EvType) -> (p:Prop) -> SpecM E #(); @@ -584,8 +585,9 @@ 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); +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 computation that nondeterministically chooses one computation or another. -- As a specification, represents the disjunction of two specifications. diff --git a/heapster-saw/examples/SpecPrims.cry b/heapster-saw/examples/SpecPrims.cry index f62cf9782a..ffe5aa6cc3 100644 --- a/heapster-saw/examples/SpecPrims.cry +++ b/heapster-saw/examples/SpecPrims.cry @@ -14,23 +14,15 @@ 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 -asserting b x = if b then x else error "Assertion failed" +asserting : {a} Bit -> (() -> a) -> a +asserting b x = if b then x () else error "Assertion failed" // The specification which assumes that the first argument is True and then // returns the second argument -assuming : {a} Bit -> a -> a -assuming b x = if b then x else anySpec +assuming : {a} Bit -> (() -> a) -> a +assuming _ x = x () // A hint to Mr Solver that a recursive function has the given loop invariant invariantHint : {a} Bit -> a -> a diff --git a/heapster-saw/examples/arrays.cry b/heapster-saw/examples/arrays.cry index 4b7ce92922..bc7d5140f0 100644 --- a/heapster-saw/examples/arrays.cry +++ b/heapster-saw/examples/arrays.cry @@ -12,4 +12,4 @@ zero_array_loop_spec ys = loop 0 ys zero_array_spec : {n} Literal n [64] => [n][64] -> [n][64] zero_array_spec xs = assuming (`n <= 0x0fffffffffffffff) - [ 0 | _ <- xs ] + (\ _ -> [ 0 | _ <- xs ]) diff --git a/heapster-saw/examples/arrays_mr_solver.saw b/heapster-saw/examples/arrays_mr_solver.saw index c70ab7c986..c492453fb0 100644 --- a/heapster-saw/examples/arrays_mr_solver.saw +++ b/heapster-saw/examples/arrays_mr_solver.saw @@ -7,7 +7,6 @@ prove_extcore mrsolver (refines [] contains0 contains0); noErrorsContains0 <- parse_core_mod "arrays" "noErrorsContains0"; prove_extcore mrsolver (refines [] contains0 noErrorsContains0); - include "specPrims.saw"; import "arrays.cry"; diff --git a/heapster-saw/examples/specPrims.saw b/heapster-saw/examples/specPrims.saw index cd57da322a..847d2c760f 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.assertingS" true; +set_monadification "assuming" "SpecM.assumingS" true; +set_monadification "invariantHint" "SpecM.invariantHint" true; From a25fd49721a1181e37e98dfb4c9454c002324b1c Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Sun, 26 Nov 2023 14:28:13 -0800 Subject: [PATCH 206/305] fixed the printing for NormComp and friends to have the correct number of underscores for the new SpecM --- src/SAWScript/Prover/MRSolver/Term.hs | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/Term.hs b/src/SAWScript/Prover/MRSolver/Term.hs index 3f23905f71..d5d3f0fbba 100644 --- a/src/SAWScript/Prover/MRSolver/Term.hs +++ b/src/SAWScript/Prover/MRSolver/Term.hs @@ -534,50 +534,50 @@ 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 (CompFunReturn _ _)) = snd $ prettyInCtxFunBindH f args From 4e89f3074596bc4ebc62a62037526a6fbbe250fc Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 27 Nov 2023 07:07:47 -0800 Subject: [PATCH 207/305] removed the notion of an indescribable num expression, replacing it with just Num terms --- .../src/Verifier/SAW/Cryptol/Monadify.hs | 20 +++++++------------ 1 file changed, 7 insertions(+), 13 deletions(-) diff --git a/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs b/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs index c654f973d6..08a6c1a08a 100644 --- a/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs +++ b/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs @@ -289,8 +289,6 @@ data NumTpExpr | NExpr_Const OpenTerm -- | A binary operation on @Num@s | NExpr_BinOp NumBinOp NumTpExpr NumTpExpr - -- | A @Num@ expression that cannot be described as a @TpExpr@ - | NExpr_Indesc OpenTerm -- | The internal (to monadification) representation of a SAW core type that is -- being monadified. Most of these constructors have corresponding constructors @@ -328,10 +326,10 @@ kindVar :: KindRepr k -> Natural -> TpExpr k kindVar MKTypeRepr = MTyVarLvl kindVar MKNumRepr = NExpr_VarLvl --- | Build an indescribable type-level expression of a given kind -kindIndesc :: KindRepr k -> OpenTerm -> TpExpr k -kindIndesc MKTypeRepr = MTyIndesc -kindIndesc MKNumRepr = NExpr_Indesc +-- | 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)@ @@ -360,14 +358,13 @@ numExprVal (NExpr_VarLvl _) = numExprVal (NExpr_Const n) = n numExprVal (NExpr_BinOp op e1 e2) = applyOpenTermMulti (numBinOpOp op) [numExprVal e1, numExprVal e2] -numExprVal (NExpr_Indesc n) = n -- | Convert a 'MonType' to the argument type @MT(tp)@ it represents; should -- only ever be applied to a 'MonType' that represents a valid SAW core type, -- i.e., one not containing 'MTyNum' or 'MTyVarLvl' toArgType :: HasSpecMEvType => MonType -> OpenTerm toArgType (MTyForall x k body) = - piOpenTerm x (kindReprOpenTerm k) (\e -> toCompType (body $ kindIndesc k e)) + piOpenTerm x (kindReprOpenTerm k) (\e -> toCompType (body $ kindOfVal k e)) toArgType (MTyArrow t1 t2) = arrowOpenTerm "_" (toArgType t1) (toCompType t2) toArgType (MTySeq n t) = @@ -425,9 +422,6 @@ 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) -numExprExpr _ (NExpr_Indesc trm) = - bindPPOpenTerm trm $ \pp_trm -> - failOpenTerm ("numExprExpr: indescribable numeric expression:\n" ++ pp_trm) -- | Main implementation of 'toTpDesc'. Convert a 'MonType' to the type -- description it represents, assuming the supplied number of bound deBruijn @@ -686,7 +680,7 @@ instance ToCompTerm ArgMonTerm where toCompTerm (FunMonTerm x tp_in _ body) = lambdaOpenTerm x (toArgType tp_in) (toCompTerm . body . fromArgTerm tp_in) toCompTerm (ForallMonTerm x k body) = - lambdaOpenTerm x (kindReprOpenTerm k) (toCompTerm . body . kindIndesc k) + lambdaOpenTerm x (kindReprOpenTerm k) (toCompTerm . body . kindOfVal k) instance ToCompTerm MonTerm where toCompTerm (ArgMonTerm amtrm) = toCompTerm amtrm @@ -737,7 +731,7 @@ monTypeIsPure (MTyVarLvl _) = -- where @SemiP@ is defined in the documentation for 'fromSemiPureTermFun' below monTypeIsSemiPure :: MonType -> Bool monTypeIsSemiPure (MTyForall _ k tp_f) = - monTypeIsSemiPure $ tp_f $ kindIndesc 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) = From a9faa65fbf3f91c9e857520f7cd08fcf232555ae Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 27 Nov 2023 07:08:09 -0800 Subject: [PATCH 208/305] reordered to arguments of Tp_Seq to match the definition of Vec, seq, and mseq --- cryptol-saw-core/saw/SpecM.sawcore | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/cryptol-saw-core/saw/SpecM.sawcore b/cryptol-saw-core/saw/SpecM.sawcore index 9eb2ef3a6b..12017a0109 100644 --- a/cryptol-saw-core/saw/SpecM.sawcore +++ b/cryptol-saw-core/saw/SpecM.sawcore @@ -123,7 +123,7 @@ data TpDesc : sort 0 where { Tp_Sigma : KindDesc -> TpDesc -> TpDesc; -- Sequence types - Tp_Seq : TpDesc -> TpExpr Kind_num -> TpDesc; + Tp_Seq : TpExpr Kind_num -> TpDesc -> TpDesc; -- The empty type Tp_Void : TpDesc; @@ -160,7 +160,7 @@ Tp_bitvector w = Tp_Kind (Kind_Expr (Kind_bv w)); -- The type description for a vector type Tp_Vec : TpDesc -> TpExpr Kind_nat -> TpDesc; -Tp_Vec d n = Tp_Seq d (TpExpr_UnOp Kind_nat Kind_num UnOp_NatToNum n); +Tp_Vec d n = Tp_Seq (TpExpr_UnOp Kind_nat Kind_num UnOp_NatToNum n) d; -- The type description for the type BVVec n len d Tp_BVVec : TpDesc -> (n:Nat) -> TpExpr (Kind_bv n) -> TpDesc; @@ -481,9 +481,9 @@ tpSubst n_top env_top T_top = 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)) - (\ (_:TpDesc) (rec:Nat -> TpEnv -> TpDesc) (len:TpExpr Kind_num) + (\ (len:TpExpr Kind_num) (_:TpDesc) (rec:Nat -> TpEnv -> TpDesc) (n:Nat) (env:TpEnv) -> - Tp_Seq (rec n env) (substTpExpr n env Kind_num len)) + 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)) @@ -647,7 +647,7 @@ tpElemEnv E env_top isf_top T_top = ifFun (sort 0) isf #() (Sigma (kindElem K) (\ (v:kindElem K) -> rec (envConsElem K v env) IsData))) - (\ (_:TpDesc) (rec:TpEnv -> FunFlag -> sort 0) (len:TpExpr Kind_num) + (\ (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) From 5e8c31f92cb2316024549cb43fe7cc80b7994a0a Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 27 Nov 2023 07:47:40 -0800 Subject: [PATCH 209/305] updated the SMT solver part of MR solver to use the new SpecM in the new SpecM SAW core module --- src/SAWScript/Prover/MRSolver/SMT.hs | 15 +++++---------- 1 file changed, 5 insertions(+), 10 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/SMT.hs b/src/SAWScript/Prover/MRSolver/SMT.hs index 5856d252d3..cefe9eda6b 100644 --- a/src/SAWScript/Prover/MRSolver/SMT.hs +++ b/src/SAWScript/Prover/MRSolver/SMT.hs @@ -322,21 +322,16 @@ smtNormPrims sc = Map.fromList return $ VExtra $ VExtraTerm a tm') ), -- Don't normalize applications of @SpecM@ and its arguments - ("Prelude.SpecM", - PrimStrict $ \ev -> PrimStrict $ \stack -> PrimStrict $ \tp -> + ("SpecM.SpecM", + PrimStrict $ \ev -> PrimStrict $ \tp -> Prim $ - do ev_tp <- VTyTerm (mkSort 1) <$> scDataTypeApp sc "Prelude.EvType" [] + do ev_tp <- VTyTerm (mkSort 1) <$> scDataTypeApp sc "SpecM.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] + ret_tm <- scGlobalApply sc "SpecM.SpecM" [ev_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") + ("SpecM.VoidEv", primGlobal sc "SpecM.VoidEv") ] -- | A version of 'mrNormTerm' in the 'IO' monad, and which does not add any From a5b0f0fbcfd6a77811d4101091c108ce79ee8a01 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 27 Nov 2023 12:40:06 -0800 Subject: [PATCH 210/305] whoops, updated mrGetInvariant to use the new version of assertFiniteS --- src/SAWScript/Prover/MRSolver/Monad.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/Monad.hs b/src/SAWScript/Prover/MRSolver/Monad.hs index 83a0cdc33d..d3302e3074 100644 --- a/src/SAWScript/Prover/MRSolver/Monad.hs +++ b/src/SAWScript/Prover/MRSolver/Monad.hs @@ -1105,7 +1105,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 @@ -1124,11 +1124,11 @@ 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 ...) + -- go inside any top-level applications of of bindS ... (assertFiniteS ...) (isGlobalDef "SpecM.bindS" -> Just (), [_, _, _, - asApp -> Just (isGlobalDef "CryptolM.assertFiniteM" -> Just (), - asCtor -> Just (primName -> "Cryptol.TCNum", _)), + asApplyAll -> (isGlobalDef "CryptolM.assertFiniteS" -> Just (), + [_, asCtor -> Just (primName -> "Cryptol.TCNum", _)]), k]) -> do pf <- liftSC1 scGlobalDef "Prelude.TrueI" body <- mrApplyAll k [pf] From 313c1acefbbb88feb82fdb81d2601a4e88bd62a8 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 30 Nov 2023 07:02:51 -0800 Subject: [PATCH 211/305] whoops, fixed the argument order when constructing a Tp_BVVec --- saw-core/src/Verifier/SAW/OpenTerm.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/saw-core/src/Verifier/SAW/OpenTerm.hs b/saw-core/src/Verifier/SAW/OpenTerm.hs index e2bac03318..e08e6df3ab 100644 --- a/saw-core/src/Verifier/SAW/OpenTerm.hs +++ b/saw-core/src/Verifier/SAW/OpenTerm.hs @@ -654,7 +654,7 @@ sumTpDesc d1 d2 = ctorOpenTerm "SpecM.Tp_Sum" [d1,d2] -- description @d@ for the element type bvVecTpDesc :: OpenTerm -> OpenTerm -> OpenTerm -> OpenTerm bvVecTpDesc w_term len_term elem_d = - applyGlobalOpenTerm "SpecM.Tp_BVVec" [elem_d, w_term, len_term] + 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@ From 1c83a4a57963dc053e407e6dcc5138628d621cd1 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 30 Nov 2023 11:45:21 -0800 Subject: [PATCH 212/305] added support to MR solver for a new fixpoint operation forNatLtThenS that is defined by induction on Nat instead of via FixS; added MR solver reasoning about vector maps using forNatLtThenS --- cryptol-saw-core/saw/CryptolM.sawcore | 190 ++++++++++-------------- cryptol-saw-core/saw/SpecM.sawcore | 49 +++++- src/SAWScript/Prover/MRSolver/Solver.hs | 133 ++++++++++++----- 3 files changed, 218 insertions(+), 154 deletions(-) diff --git a/cryptol-saw-core/saw/CryptolM.sawcore b/cryptol-saw-core/saw/CryptolM.sawcore index 0c816c2bf3..49a74c2932 100644 --- a/cryptol-saw-core/saw/CryptolM.sawcore +++ b/cryptol-saw-core/saw/CryptolM.sawcore @@ -88,6 +88,67 @@ Num_rec_fin p f = -------------------------------------------------------------------------------- -- Monadic Sequences +bvVecAtM : (E:EvType) -> (n : Nat) -> (len : Vec n Bool) -> (a : sort 0) -> + BVVec n len a -> Vec n Bool -> SpecM E a; +bvVecAtM E n len a xs i = + maybe (is_bvult n i len) (SpecM E a) + (errorS E a "bvVecAtM: invalid sequence index") + (\ (pf:is_bvult n i len) -> retS E a (atBVVec n len a xs i pf)) + (bvultWithProof n i len); + +atM : (E:EvType) -> (n : Nat) -> (a : sort 0) -> Vec n a -> Nat -> SpecM E a; +atM E n a xs i = + maybe (IsLtNat i n) (SpecM E a) + (errorS E a "atM: invalid sequence index") + (\ (pf:IsLtNat i n) -> retS E a (atWithProof n a xs i pf)) + (proveLtNat i n); + +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 = + maybe (is_bvult n i len) (SpecM E (BVVec n len a)) + (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)) + (bvultWithProof n i len); + +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 = + maybe (is_bvult n i len) (SpecM E (Vec m a)) + (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)) + (bvultWithProof n i len); + +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 = + maybe (IsLtNat i n) (SpecM E (Vec n a)) + (errorS E (Vec n a) "updateM: invalid sequence index") + (\ (pf:IsLtNat i n) -> retS E (Vec n a) (updWithProof n a xs i x pf)) + (proveLtNat i n); + +eListSelM : (E:EvType) -> (a : sort 0) -> (n : Num) -> mseq E n a -> Nat -> + SpecM E a; +eListSelM E a = + Num_rec (\ (n:Num) -> mseq E n a -> Nat -> SpecM E a) + (\ (n:Nat) -> atM E n a) + (streamGet (SpecM E a)); + +streamJoinM : (E:EvType) -> (a : isort 0) -> (n : Nat) -> + Stream (SpecM E (Vec (Succ n) a)) -> + Stream (SpecM E a); +streamJoinM E a n s = + MkStream (SpecM E a) (\ (i:Nat) -> + fmapS E (Vec (Succ n) a) a + (\ (xs:Vec (Succ n) a) -> at (Succ n) a xs (modNat i (Succ n))) + (streamGet (SpecM E (Vec (Succ n) a)) s + (divNat i (Succ n))) ); + {- bvVecMapInvarBindM : (E:EvType) -> (stack:FunStack) -> (a b c : isort 0) -> (n : Nat) -> (len : Vec n Bool) -> @@ -146,55 +207,33 @@ bvVecMapM : (E:EvType) -> (stack:FunStack) -> bvVecMapM E stack a b n len f xs = bvVecMapInvarM E stack a b n len f xs True; -} -primitive -vecMapInvarBindM : (E:EvType) -> (a : sort 0) -> (b : qsort 0) -> - (c : sort 0) -> (n : Nat) -> (Nat -> a -> SpecM E b) -> - Vec n a -> Bool -> (Vec n b -> SpecM E c) -> - SpecM E c; - --- FIXME: get the defined one to work! -{- -vecMapInvarBindM : (E:EvType) -> (a : sort 0) -> (b : qsort 0) -> - (c : sort 0) -> (n : Nat) -> (Nat -> a -> SpecM E b) -> - Vec n a -> Bool -> (Vec n b -> SpecM E c) -> - SpecM E c; -vecMapInvarBindM E a b c n f xs invar cont = - bindS E (Vec n b) c - (existsS E (Vec n b)) (\ (ys0:Vec n b) -> - multiArgFixS E - (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))))) 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))))) 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))))) c) - (pushStackS E (singletonFrame (LRT_Fun Nat (\ (_:Nat) -> LRT_Fun (Vec n b) (\ (_:Vec n b) -> LRT_Ret c)))) 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))))) b c - (pushStackS E (singletonFrame (LRT_Fun Nat (\ (_:Nat) -> LRT_Fun (Vec n b) (\ (_:Vec n b) -> LRT_Ret c)))) 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) -> (a : sort 0) -> (b : qsort 0) -> - (n : Nat) -> (Nat -> a -> SpecM E b) -> - Vec n a -> Bool -> SpecM E (Vec n b); -vecMapInvarM E a b n f xs invar = - vecMapInvarBindM E a b (Vec n b) n f xs invar (retS E (Vec n b)); - -vecMapBindM : (E:EvType) -> (a : sort 0) -> (b : qsort 0) -> (c : sort 0) -> - (n : Nat) -> (Nat -> a -> SpecM E b) -> +-- 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 = vecMapInvarBindM E a b c n f xs True; +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 = vecMapInvarM E a b n f xs True; +vecMapM E a b n f xs = vecMapBindM E a b (Vec n b) n f xs (retS E (Vec n b)); -- Computational version of seqMap seqMapM : (E:EvType) -> (a : sort 0) -> (b : qsort 0) -> (n : Num) -> @@ -227,71 +266,6 @@ vecSequenceM E a n = vecMapM E (SpecM E a) a n (\(i:Nat) (x:SpecM E a) -> x); --------------------------------------------------------------------------------- --- Auxiliary functions - -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 = - maybe (is_bvult n i len) (SpecM E a) - (errorS E a "bvVecAtM: invalid sequence index") - (\ (pf:is_bvult n i len) -> retS E a (atBVVec n len a xs i pf)) - (bvultWithProof n i len); - -atM : (E:EvType) -> (n : Nat) -> (a : sort 0) -> Vec n a -> Nat -> SpecM E a; -atM E n a xs i = - maybe (IsLtNat i n) (SpecM E a) - (errorS E a "atM: invalid sequence index") - (\ (pf:IsLtNat i n) -> retS E a (atWithProof n a xs i pf)) - (proveLtNat i n); - -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 = - maybe (is_bvult n i len) (SpecM E (BVVec n len a)) - (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)) - (bvultWithProof n i len); - -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 = - maybe (is_bvult n i len) (SpecM E (Vec m a)) - (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)) - (bvultWithProof n i len); - -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 = - maybe (IsLtNat i n) (SpecM E (Vec n a)) - (errorS E (Vec n a) "updateM: invalid sequence index") - (\ (pf:IsLtNat i n) -> retS E (Vec n a) (updWithProof n a xs i x pf)) - (proveLtNat i n); - -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))) ); - - -------------------------------------------------------------------------------- -- List comprehensions diff --git a/cryptol-saw-core/saw/SpecM.sawcore b/cryptol-saw-core/saw/SpecM.sawcore index 12017a0109..7692e42420 100644 --- a/cryptol-saw-core/saw/SpecM.sawcore +++ b/cryptol-saw-core/saw/SpecM.sawcore @@ -159,13 +159,13 @@ Tp_bitvector : Nat -> TpDesc; Tp_bitvector w = Tp_Kind (Kind_Expr (Kind_bv w)); -- The type description for a vector type -Tp_Vec : TpDesc -> TpExpr Kind_nat -> TpDesc; -Tp_Vec d n = Tp_Seq (TpExpr_UnOp Kind_nat Kind_num UnOp_NatToNum n) d; +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 : TpDesc -> (n:Nat) -> TpExpr (Kind_bv n) -> TpDesc; -Tp_BVVec d n len = - Tp_Vec d (TpExpr_UnOp (Kind_bv n) Kind_nat (UnOp_BVToNat n) len); +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; @@ -731,6 +731,45 @@ primitive LetRecS : (E:EvType) -> (Ts:List TpDesc) -> (a:sort 0) -> -- 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)); diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index f9f126af98..c93a29e5eb 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -135,6 +135,7 @@ import Data.Set (Set) import Prettyprinter +import Verifier.SAW.Utils (panic) import Verifier.SAW.Term.Functor import Verifier.SAW.SharedTerm import Verifier.SAW.Recognizer @@ -175,37 +176,41 @@ asList (asCtor -> Just (nm, [_, hd, tl])) | primName nm == "Prelude.Cons" = (hd:) <$> asList tl asList _ = Nothing --- | Bind fresh function variables for a @LetRecS@ or @MultiFixS@ with the first --- 'Term' as the event type, the second as a list of the type descriptions for --- the recursive functions being defined, and the third a function of the form +-- | Apply a SAW core term of type @MultiFixBodies@ to a list of monadic +-- functions bound for the functions it is defining, and return the bodies for +-- those definitions. That is, take a term of the form -- -- > \F1 F2 ... Fn -> (f1, (f2, ... (fn, ()))) -- --- that defines the bodies of those recursive functions. -mrFreshCallVars :: Term -> Term -> Term -> MRM t [MRVar] -mrFreshCallVars ev tp_ds_tm (asConstant -> Just (_, Just 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 - mrFreshCallVars ev tp_ds_tm defs_tm -mrFreshCallVars ev tp_ds_tm defs_tm = + 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 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_tm of - Just ds -> mapM (\d -> mrApplyAll tpElem_fun [ev, d]) ds - Nothing -> throwMRFailure (MalformedTpDescList tp_ds_tm) + -- 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_app <- mrApplyAll defs_tm fun_tms - bodies <- case asNestedPairs defs_app of - Just defs -> mapM 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 @@ -214,6 +219,19 @@ mrFreshCallVars ev tp_ds_tm 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 @@ -281,12 +299,7 @@ normComp (CompTerm t) = 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 - - -- Set the new function var to have body applied to it - body_app <- mrApply body fun_tm >>= lambdaUVarsM - mrSetVarInfo fun_var (CallVarInfo body_app) + 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 @@ -296,7 +309,7 @@ normComp (CompTerm t) = FunBind var all_args <$> mkCompFunReturn <$> mrFunOutType var all_args -{- + {- FIXME HERE NOW: match a tuple projection of a MultiFixS (isGlobalDef "Prelude.MultiFixS" -> Just (), ev:tp_ds:defs:args) -> @@ -308,19 +321,54 @@ FIXME HERE NOW: match a tuple projection of a MultiFixS let var = CallSName (fun_vars !! (fromIntegral i)) all_args <- (++ args) <$> getAllUVarTerms FunBind var all_args <$> mkCompFunReturn <$> - mrFunOutType var all_args --} + mrFunOutType var all_args -} (isGlobalDef "SpecM.LetRecS" -> Just (), [ev,tp_ds,_,defs,body]) -> do + -- First compute the types of the recursive functions being bound by + -- mapping @tpElem@ to the type descriptions, and bind functions of + -- those types + tpElem_fun <- mrGlobalTerm "SpecM.tpElem" + fun_tps <- case asList tp_ds of + Just ds -> mapM (\d -> mrApplyAll tpElem_fun [ev, d]) ds + Nothing -> throwMRFailure (MalformedTpDescList tp_ds) + -- Bind fresh function vars for the new recursive functions - fun_vars <- mrFreshCallVars ev tp_ds defs + fun_vars <- mrFreshCallVars fun_tps (mrApplyMFixBodies defs) fun_tms <- mapM mrVarTerm fun_vars -- Continue normalizing body applied to those fresh function vars body_app <- mrApplyAll body fun_tms normCompTerm body_app + -- Treat forNatLtThenS like FixS with a body of forNatLtThenSBody + (isGlobalDef "SpecM.forNatLtThenS" -> Just (), [ev,st,ret,n,f,k,s0]) -> + do + -- Bind a fresh function with type Nat -> st -> SpecM E ret + type_f <- mrGlobalTerm "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 <- mrGlobalTerm "SpecM.forNatLtThenSBody" + let body_f rec_fun = + mrApplyAll body_fun_tm [ev,st,ret,n,f,k,invar,rec_fun] + + -- Bind a fresh function var for the new recursive function + fun_var <- mrFreshCallVar fun_tp body_f + + -- Return the function variable applied to 0 and s0 as a normalized + -- computation, noting that it must be applied to all of the uvars as + -- well as the args + let var = CallSName fun_var + z <- liftSC1 scNat 0 + all_args <- (++ [z,s0]) <$> getAllUVarTerms + FunBind var all_args <$> mkCompFunReturn <$> + mrFunOutType var all_args + + -- Convert `vecMapM (bvToNat ...)` into `bvVecMapInvarM`, with the -- invariant being the current set of assumptions (asGlobalDef -> Just "CryptolM.vecMapM", [_a, _b, (asBvToNat -> Just (_w, _n)), @@ -341,7 +389,7 @@ FIXME HERE NOW: match a tuple projection of a MultiFixS ws_are_eq <- mrConvertible w1 w2 if ws_are_eq then mrApplyAll body [ev, w1, n, a, xs, i] >>= normCompTerm - else throwMRFailure (MalformedComp t) + else throwMRFailure (MalformedComp t) -- Convert `atM n ... xs (bvToNat ...)` for a constant `n` into the -- unfolding of `bvVecAtM` after converting `n` to a bitvector constant @@ -356,7 +404,7 @@ FIXME HERE NOW: match a tuple projection of a MultiFixS n' <- liftSC2 scBvLit w (toInteger n) xs' <- mrGenBVVecFromVec n_tm a xs "normComp (atM)" w_tm n' mrApplyAll body [ev, w_tm, n', a, xs', i] >>= normCompTerm - else throwMRFailure (MalformedComp t) + else throwMRFailure (MalformedComp t) -- Convert `updateM (bvToNat ...) ... (bvToNat ...)` into the unfolding of -- `bvVecUpdateM` @@ -367,7 +415,7 @@ FIXME HERE NOW: match a tuple projection of a MultiFixS ws_are_eq <- mrConvertible w1 w2 if ws_are_eq then mrApplyAll body [ev, w1, n, a, xs, i, x] >>= normCompTerm - else throwMRFailure (MalformedComp t) + else throwMRFailure (MalformedComp t) -- Convert `updateM n ... xs (bvToNat ...)` for a constant `n` into the -- unfolding of `bvVecUpdateM` after converting `n` to a bitvector constant @@ -384,12 +432,15 @@ FIXME HERE NOW: match a tuple projection of a MultiFixS err_tm <- mrErrorTerm a "normComp (updateM)" mrApplyAll body [ev, w_tm, n', a, xs', i, x, err_tm, n_tm] >>= normCompTerm - else throwMRFailure (MalformedComp t) + else throwMRFailure (MalformedComp t) - -- Always unfold: sawLet, invariantHint, Num_rec + -- Always unfold: sawLet, invariantHint, Num_rec, vecMapM, vecMapBindM, + -- seqMapM, forNatLtThenSBody (f@(asGlobalDef -> Just ident), args) - | ident `elem` ["Prelude.sawLet", "SpecM.invariantHint", - "Cryptol.Num_rec"] + | ident `elem` + ["Prelude.sawLet", "SpecM.invariantHint", "Cryptol.Num_rec", + "CryptolM.vecMapM", "CryptolM.vecMapBindM", "CryptolM.seqMapM", + "SpecM.forNatLtThenSBody"] , Just (_, Just body) <- asConstant f -> mrApplyAll body args >>= normCompTerm From e57b6906ebd5fc131ae83c1405a1ea134e7a5c98 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 30 Nov 2023 17:04:58 -0800 Subject: [PATCH 213/305] refactored the MaybeElim cases by defining a function asDecProp that checks if a proposition can be decided by MR solver --- src/SAWScript/Prover/MRSolver/Solver.hs | 152 +++++++++++++++--------- 1 file changed, 93 insertions(+), 59 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index c93a29e5eb..34fc926d33 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' @@ -123,7 +124,6 @@ module SAWScript.Prover.MRSolver.Solver where import Data.Maybe import Data.Either -import Numeric.Natural (Natural) import Data.List (find, findIndices) import Data.Foldable (foldlM) import Data.Bits (shiftL) @@ -139,7 +139,6 @@ 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) @@ -795,6 +794,73 @@ generalizeCoIndHyp hyp all_specs@(arg_spec_0:arg_specs) = generalizeCoIndHyp hyp'' uneq_specs +---------------------------------------------------------------------- +-- * 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 (tp,e1,e2)) = Just $ mrEq' tp e1 e2 +asBoolProp (asApplyAll -> (isGlobalDef "Prelude.IsLtNat" -> Just (), [n,m])) = + Just $ liftSC2 scLtNat n m +asBoolProp _ = Nothing + +-- | Test if a 'Term' is a propostion that MR solver can decide, i.e., test if +-- it or its negation holds. If so, return: a function to decide the propostion, +-- that returns 'Just' of a Boolean iff the proposition definitely does or does +-- not hold; and a function to assume the proposition or its negation in a +-- sub-computation. This latter function also takes a 'TermLike' that it will +-- lift in the sense of 'withUVarLift' in the sub-computation. +asDecProp :: Term -> Maybe (MRM t (Maybe Bool, AssumpFun t)) +asDecProp (asBoolProp -> Just condM) = + Just $ + do cond <- condM + not_cond <- liftSC1 scNot cond + let assumeM b tm m = withAssumption (if b then cond else not_cond) (m tm) + mrProvable cond >>= \case + True -> return (Just True, AssumpFun assumeM) + False -> + mrProvable not_cond >>= \case + True -> return (Just False, AssumpFun assumeM) + False -> return (Nothing, AssumpFun assumeM) +asDecProp (asIsFinite -> Just n) = + Just $ + do n_norm <- mrNormOpenTerm n + maybe_assump <- mrGetDataTypeAssump n_norm + -- The assumption function that requires b == req, in which case it is just + -- the identity, and otherwise panics + let requireIdAssumeM req b tm m = + if req == b then m tm else + panic "asDecProp" ["Unexpected inconsistent assumption"] + case (maybe_assump, asNum n_norm) of + (_, Just (Left _)) -> + return (Just True, AssumpFun (requireIdAssumeM True)) + (_, Just (Right _)) -> + return (Just False, AssumpFun (requireIdAssumeM False)) + (Just (IsNum _), _) -> + return (Just True, AssumpFun (requireIdAssumeM True)) + (Just IsInf, _) -> + return (Just False, AssumpFun (requireIdAssumeM False)) + _ -> + return (Nothing, + AssumpFun $ \b tm m -> + if b then + (liftSC0 scNatType >>= \nat_tp -> + (withUVarLift "n" (Type nat_tp) (n_norm, tm) $ \n_nat (n', tm') -> + withDataTypeAssump n' (IsNum n_nat) (m tm'))) + else + withDataTypeAssump n_norm IsInf (m tm)) +asDecProp _ = Nothing + + ---------------------------------------------------------------------- -- * Mr Solver Himself (He Identifies as Male) ---------------------------------------------------------------------- @@ -821,6 +887,10 @@ 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 () @@ -829,63 +899,27 @@ 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' (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 -> From 497997f6f36fe343fc7d77a3fc8cf2a50edea1f1 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 30 Nov 2023 17:24:14 -0800 Subject: [PATCH 214/305] updated the MR solver normalizer to unfold forNatLtThenSBody when it applies that function to form the body of a forNatLtThenS corecursive function --- src/SAWScript/Prover/MRSolver/Monad.hs | 14 ++++++++++++-- src/SAWScript/Prover/MRSolver/Solver.hs | 4 ++-- 2 files changed, 14 insertions(+), 4 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/Monad.hs b/src/SAWScript/Prover/MRSolver/Monad.hs index d3302e3074..2684ed7577 100644 --- a/src/SAWScript/Prover/MRSolver/Monad.hs +++ b/src/SAWScript/Prover/MRSolver/Monad.hs @@ -45,11 +45,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 @@ -622,6 +624,14 @@ 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"] + -- | Like 'scBvConst', but if given a bitvector literal it is converted to a -- natural number literal mrBvToNat :: Term -> Term -> MRM t Term @@ -1127,8 +1137,8 @@ mrGetInvariantBody tm = case asApplyAll tm of -- go inside any top-level applications of of bindS ... (assertFiniteS ...) (isGlobalDef "SpecM.bindS" -> Just (), [_, _, _, - asApplyAll -> (isGlobalDef "CryptolM.assertFiniteS" -> Just (), - [_, asCtor -> Just (primName -> "Cryptol.TCNum", _)]), + (asApplyAll -> (isGlobalDef "CryptolM.assertFiniteS" -> Just (), + [_, (asCtor -> Just (primName -> "Cryptol.TCNum", _))])), k]) -> do pf <- liftSC1 scGlobalDef "Prelude.TrueI" body <- mrApplyAll k [pf] diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index 34fc926d33..44df4f99e9 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -344,14 +344,14 @@ FIXME HERE NOW: match a tuple projection of a MultiFixS (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 <- mrGlobalTerm "SpecM.forNatLtThenSBodyType" + 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 <- mrGlobalTerm "SpecM.forNatLtThenSBody" + body_fun_tm <- mrGlobalTermUnfold "SpecM.forNatLtThenSBody" let body_f rec_fun = mrApplyAll body_fun_tm [ev,st,ret,n,f,k,invar,rec_fun] From 2c39941ea5a1a4f10b4597d6f8f28798c8f1433b Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 4 Dec 2023 07:36:22 -0800 Subject: [PATCH 215/305] added refinesS_eq combinator --- cryptol-saw-core/saw/SpecM.sawcore | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/cryptol-saw-core/saw/SpecM.sawcore b/cryptol-saw-core/saw/SpecM.sawcore index 7692e42420..47b9daeb7a 100644 --- a/cryptol-saw-core/saw/SpecM.sawcore +++ b/cryptol-saw-core/saw/SpecM.sawcore @@ -905,3 +905,7 @@ eqRR R r1 r2 = Eq R r1 r2; -- 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; From 7544ab3647b4fdcda38bebac12767e2d0185080e Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 4 Dec 2023 07:36:57 -0800 Subject: [PATCH 216/305] finished updating arrays_mr_solver.saw example to work --- heapster-saw/examples/arrays.sawcore | 8 ++++---- heapster-saw/examples/arrays_mr_solver.saw | 6 +++--- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/heapster-saw/examples/arrays.sawcore b/heapster-saw/examples/arrays.sawcore index c7c86879b5..750a4ae7f9 100644 --- a/heapster-saw/examples/arrays.sawcore +++ b/heapster-saw/examples/arrays.sawcore @@ -10,11 +10,11 @@ noErrorsHDesc = (Tp_Arr (Tp_Kind (Kind_Expr (Kind_bv 64))) (Tp_Arr - (Tp_BVVec (Tp_Kind (Kind_Expr (Kind_bv 64))) 64 - (TpExpr_Var (Kind_bv 64) 0)) + (Tp_BVVec 64 (TpExpr_Var (Kind_bv 64) 0) + (Tp_Kind (Kind_Expr (Kind_bv 64)))) (Tp_M (Tp_Pair - (Tp_BVVec (Tp_Kind (Kind_Expr (Kind_bv 64))) 64 - (TpExpr_Var (Kind_bv 64) 0)) + (Tp_BVVec 64 (TpExpr_Var (Kind_bv 64) 0) + (Tp_Kind (Kind_Expr (Kind_bv 64)))) (Tp_Kind (Kind_Expr (Kind_bv 64))))))); diff --git a/heapster-saw/examples/arrays_mr_solver.saw b/heapster-saw/examples/arrays_mr_solver.saw index c492453fb0..a67d31ec6a 100644 --- a/heapster-saw/examples/arrays_mr_solver.saw +++ b/heapster-saw/examples/arrays_mr_solver.saw @@ -13,6 +13,6 @@ 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 }}); From d361c284f54204b2c2f23b5626423ac4f3291b1f Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 4 Dec 2023 07:37:16 -0800 Subject: [PATCH 217/305] updated mr_solver_unit_tests.saw example to work --- .../mr_solver/mr_solver_test_funs.sawcore | 24 +++--- examples/mr_solver/mr_solver_unit_tests.saw | 77 +++++++++---------- 2 files changed, 48 insertions(+), 53 deletions(-) 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; From 1673f40653931d39ecac5846a3a053ae5e0ac486 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Wed, 6 Dec 2023 16:35:41 -0500 Subject: [PATCH 218/305] add PPOpts to MREnv, make naming of P.P. fns. consistent (see PPInCtxM docs) --- src/SAWScript/Builtins.hs | 4 +- src/SAWScript/Prover/MRSolver/Evidence.hs | 8 +- src/SAWScript/Prover/MRSolver/Monad.hs | 135 +++++++++++++--------- src/SAWScript/Prover/MRSolver/SMT.hs | 12 +- src/SAWScript/Prover/MRSolver/Solver.hs | 17 +-- src/SAWScript/Prover/MRSolver/Term.hs | 68 ++++++----- src/SAWScript/Value.hs | 4 +- 7 files changed, 150 insertions(+), 98 deletions(-) diff --git a/src/SAWScript/Builtins.hs b/src/SAWScript/Builtins.hs index 279c3acddd..14e7293555 100644 --- a/src/SAWScript/Builtins.hs +++ b/src/SAWScript/Builtins.hs @@ -2255,11 +2255,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 diff --git a/src/SAWScript/Prover/MRSolver/Evidence.hs b/src/SAWScript/Prover/MRSolver/Evidence.hs index bc627954f5..1d5c59e97e 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 @@ -181,12 +182,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 d1168f17d9..ef18c28d3a 100644 --- a/src/SAWScript/Prover/MRSolver/Monad.hs +++ b/src/SAWScript/Prover/MRSolver/Monad.hs @@ -112,13 +112,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)) @@ -130,68 +131,68 @@ 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] instance PrettyInCtx MRFailure where prettyInCtx (TermsNotRel False t1 t2) = - ppWithPrefixSep "Could not prove terms equal:" t1 "and" t2 + prettyPrefixSep "Could not prove terms equal:" t1 "and" t2 prettyInCtx (TermsNotRel True t1 t2) = - ppWithPrefixSep "Could not prove terms heterogeneously related:" t1 "and" t2 + prettyPrefixSep "Could not prove terms heterogeneously related:" t1 "and" t2 prettyInCtx (TypesNotRel False tp1 tp2) = - ppWithPrefixSep "Types not equal:" tp1 "and" tp2 + prettyPrefixSep "Types not equal:" tp1 "and" tp2 prettyInCtx (TypesNotRel True tp1 tp2) = - ppWithPrefixSep "Types not heterogeneously related:" tp1 "and" tp2 + prettyPrefixSep "Types not heterogeneously related:" tp1 "and" tp2 prettyInCtx (CompsDoNotRefine m1 m2) = - ppWithPrefixSep "Could not prove refinement: " m1 "|=" m2 + prettyPrefixSep "Could not prove refinement: " m1 "|=" m2 prettyInCtx (ReturnNotError eith_terr t) = let (lr_s, terr) = either ("left",) ("right",) eith_terr in - ppWithPrefixSep "errorS:" terr (" on the " ++ lr_s ++ " does not match retS:") t + 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 + prettyPrefix "Recursive unfolding of function inside its own body:" nm prettyInCtx (MalformedLetRecTypes t) = - ppWithPrefix "Not a ground LetRecTypes list:" t + prettyPrefix "Not a ground LetRecTypes list:" 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 + prettyPrefix "Could not handle computation:" t prettyInCtx (NotCompFunType tp) = - ppWithPrefix "Not a computation or computational function type:" tp + prettyPrefix "Not a computation or computational function type:" tp 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 ---------------------------------------------------------------------- @@ -282,8 +283,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 @@ -302,9 +302,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 @@ -405,6 +405,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 @@ -421,6 +425,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 :: @@ -784,7 +806,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 @@ -932,7 +955,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 = - mrDebugPretty 3 ("mrSetVarInfo" <+> ppInEmptyCtx var <+> "=" <+> ppInEmptyCtx info) >> + mrDebugPPInCtxM 3 (prettyWithCtx emptyMRVarCtx $ + prettyPrefixSep "mrSetVarInfo" var "=" info) >> (modify $ \st -> st { mrsVars = Map.alter (\case @@ -1073,7 +1097,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 mrDebugPretty 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 @@ -1208,38 +1233,42 @@ recordUsedFunAssump _ = return () -- * Functions for Debug Output ---------------------------------------------------------------------- --- | Print a 'String' if the debug level is at least the supplied 'Int' +-- | 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' +-- | Print a document to 'stderr' if the debug level is at least the supplied +-- 'Int' mrDebugPretty :: Int -> SawDoc -> MRM t () -mrDebugPretty i pp = mrDebugPrint i $ renderSawDoc defaultPPOpts pp +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' -mrDebugPrettyInCtx :: PrettyInCtx a => Int -> a -> MRM t () -mrDebugPrettyInCtx i a = mrUVars >>= \ctx -> mrDebugPrint 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 -> - mrDebugPretty 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 -> - mrDebugPretty 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 4c0813a561..867aa2ce3c 100644 --- a/src/SAWScript/Prover/MRSolver/SMT.hs +++ b/src/SAWScript/Prover/MRSolver/SMT.hs @@ -135,7 +135,8 @@ primGenBVVecFilter sc n (asGenCryMTerm -> Just (asBvToNat -> Just (asNat -> Just 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 + error $ "primGenBVVec could not handle: " ++ + showInCtx defaultPPOpts emptyMRVarCtx t -- | An implementation of a primitive function that expects a term of the form -- @genCryM _ a _@, @genFromBVVec ... (genBVVec _ _ a _) ...@, or @@ -361,7 +362,7 @@ smtNorm sc t = mrNormTerm :: Term -> MRM t Term mrNormTerm t = mrDebugPrint 2 "Normalizing term:" >> - mrDebugPrettyInCtx 2 t >> + mrDebugPPInCtx 2 t >> liftSC1 smtNorm t -- | Normalize an open term by wrapping it in lambdas, normalizing, and then @@ -394,8 +395,9 @@ mrProvableRaw prop_term = prop <- liftSC1 termToProp prop_term unints <- Set.map ecVarIndex <$> getAllExtSet <$> liftSC1 propToTerm prop nenv <- liftIO (scGetNamingEnv sc) + opts <- mrPPOpts mrDebugPrint 2 ("Calling SMT solver with proposition: " ++ - prettyProp defaultPPOpts nenv prop) + 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 @@ -414,8 +416,8 @@ mrProvableRaw prop_term = Right (stats, SolveCounterexample cex) -> mrDebugPrint 2 "SMT solver response: not provable" >> mrDebugPrint 3 ("Counterexample:" ++ concatMap (\(x,v) -> - "\n - " ++ renderSawDoc defaultPPOpts (ppTerm defaultPPOpts (Unshared (FTermF (ExtCns x)))) ++ - " = " ++ renderSawDoc defaultPPOpts (ppFirstOrderValue defaultPPOpts v)) cex) >> + "\n - " ++ renderSawDoc opts (ppTerm opts (Unshared (FTermF (ExtCns x)))) ++ + " = " ++ renderSawDoc opts (ppFirstOrderValue opts v)) cex) >> recordUsedSolver stats prop_term >> return False Right (stats, SolveSuccess _) -> mrDebugPrint 2 "SMT solver response: provable" >> diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index 4c9781745f..aedb71f844 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -157,8 +157,6 @@ import qualified Data.Map as Map import qualified Data.Text as Text import Data.Set (Set) -import Prettyprinter - import Verifier.SAW.Term.Functor import Verifier.SAW.SharedTerm import Verifier.SAW.Recognizer @@ -755,7 +753,8 @@ proveCoIndHyp hyp = withFailureCtx (FailCtxCoIndHyp hyp) $ f2 = coIndHypRHSFun hyp args1 = coIndHypLHS hyp args2 = coIndHypRHS hyp - mrDebugPretty 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 @@ -1033,7 +1032,7 @@ mrRefines' m1 (AssumeBoolBind cond2 k2) = _ -> withAssumption cond2 $ mrRefines m1 m2 mrRefines' (AssertBoolBind cond1 k1) m2 = do m1 <- liftSC0 scUnitValue >>= applyCompFun k1 - cond1_str <- flip showInCtx cond1 <$> mrUVars + 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 @@ -1106,7 +1105,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 mrDebugPretty 2 $ flip runPPInCtxM ctx $ + do mrDebugPPInCtxM 2 $ prettyWithCtx ctx $ prettyAppList [return "mrRefines using opaque FunAssump:", prettyInCtx ctx, return ".", prettyTermApp (funNameTerm f1) args1', @@ -1130,8 +1129,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 mrDebugPretty 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 "|=", diff --git a/src/SAWScript/Prover/MRSolver/Term.hs b/src/SAWScript/Prover/MRSolver/Term.hs index 807aea9a76..f14a04d609 100644 --- a/src/SAWScript/Prover/MRSolver/Term.hs +++ b/src/SAWScript/Prover/MRSolver/Term.hs @@ -439,25 +439,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 @@ -465,7 +474,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 @@ -476,20 +486,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 diff --git a/src/SAWScript/Value.hs b/src/SAWScript/Value.hs index 25a8c46421..1cce6f2d40 100644 --- a/src/SAWScript/Value.hs +++ b/src/SAWScript/Value.hs @@ -325,10 +325,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 From fe6678a58d694734c89b9a3920beaf9661f6971f Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Wed, 6 Dec 2023 16:39:50 -0500 Subject: [PATCH 219/305] add mrsolver_set_debug_printing_depth --- src/SAWScript/Builtins.hs | 7 +++++++ src/SAWScript/Interpreter.hs | 6 ++++++ 2 files changed, 13 insertions(+) diff --git a/src/SAWScript/Builtins.hs b/src/SAWScript/Builtins.hs index 14e7293555..4de1d9b3d0 100644 --- a/src/SAWScript/Builtins.hs +++ b/src/SAWScript/Builtins.hs @@ -2310,6 +2310,13 @@ 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 diff --git a/src/SAWScript/Interpreter.hs b/src/SAWScript/Interpreter.hs index 0315b978b7..9e7c2eb3fd 100644 --- a/src/SAWScript/Interpreter.hs +++ b/src/SAWScript/Interpreter.hs @@ -4198,6 +4198,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 From a805bd0bed81dc66489510f0f44567d6a53c3112 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Wed, 6 Dec 2023 16:46:24 -0500 Subject: [PATCH 220/305] only check fn body, not arg values, when checking whether a fn is recursive --- src/SAWScript/Prover/MRSolver/Monad.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/Monad.hs b/src/SAWScript/Prover/MRSolver/Monad.hs index ef18c28d3a..be181db76a 100644 --- a/src/SAWScript/Prover/MRSolver/Monad.hs +++ b/src/SAWScript/Prover/MRSolver/Monad.hs @@ -919,8 +919,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 From 7b429261d34952e50fb3f68f77bb9a4fa517bff5 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Wed, 6 Dec 2023 16:58:12 -0500 Subject: [PATCH 221/305] expand `FunBind |= FunBind` case to include all `FunName`s --- src/SAWScript/Prover/MRSolver/Solver.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index aedb71f844..1848b32146 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -1074,11 +1074,10 @@ 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 = +mrRefines' (FunBind f args1 _ k1) (FunBind f' args2 _ k2) + | f == f' && length args1 == length args2 = zipWithM_ mrAssertProveEq args1 args2 >> - mrFunOutType (CallSName f) args1 >>= \(_, tp) -> + mrFunOutType f args1 >>= \(_, tp) -> mrRefinesFun tp k1 tp k2 mrRefines' m1@(FunBind f1 args1 isLifted1 k1) From ce04ec7d375d482cc005ed76b13626b5cbd36234 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Wed, 6 Dec 2023 17:43:53 -0500 Subject: [PATCH 222/305] add check for reflexivity in mrProveRel --- src/SAWScript/Prover/MRSolver/SMT.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/SMT.hs b/src/SAWScript/Prover/MRSolver/SMT.hs index 867aa2ce3c..40ae6b6625 100644 --- a/src/SAWScript/Prover/MRSolver/SMT.hs +++ b/src/SAWScript/Prover/MRSolver/SMT.hs @@ -824,8 +824,10 @@ mrProveRel het t1 t2 = 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 + else do ts_eq <- mrConvertible t1 t2 + res <- if ts_eq then return True + else do cond_in_ctx <- mrProveRelH het tp1 tp2 t1 t2 + withTermInCtx cond_in_ctx mrProvable mrDebugPrint 2 $ nm ++ ": " ++ if res then "Success" else "Failure" return res From fb569f72a44bd61d74b821f13782f0c8a01cfdfb Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Wed, 6 Dec 2023 17:48:15 -0500 Subject: [PATCH 223/305] improve error messages for `FunBind |= FunBind` case --- src/SAWScript/Prover/MRSolver/Monad.hs | 13 +++++++++++++ src/SAWScript/Prover/MRSolver/Solver.hs | 16 ++++++---------- 2 files changed, 19 insertions(+), 10 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/Monad.hs b/src/SAWScript/Prover/MRSolver/Monad.hs index be181db76a..4e95dfd728 100644 --- a/src/SAWScript/Prover/MRSolver/Monad.hs +++ b/src/SAWScript/Prover/MRSolver/Monad.hs @@ -75,6 +75,8 @@ data FailCtx data MRFailure = TermsNotRel Bool Term Term | TypesNotRel Bool Type Type + | BindTypesNotEq Type Type + | FunNamesDoNotRefine FunName [Term] FunName [Term] | CompsDoNotRefine NormComp NormComp | ReturnNotError (Either Term Term) Term | FunsNotEq FunName FunName @@ -148,6 +150,17 @@ instance PrettyInCtx MRFailure where prettyPrefixSep "Types not equal:" tp1 "and" tp2 prettyInCtx (TypesNotRel True tp1 tp2) = prettyPrefixSep "Types not heterogeneously related:" tp1 "and" tp2 + prettyInCtx (BindTypesNotEq tp1 tp2) = + prettyPrefixSep "Could not start co-induction because bind types are not equal:" tp1 "and" tp2 + prettyInCtx (FunNamesDoNotRefine f1 args1 f2 args2) = + snd (prettyInCtxFunBindH f1 args1 Unlifted) >>= \d1 -> + snd (prettyInCtxFunBindH f2 args2 Unlifted) >>= \d2 -> + let prefix = "Could not prove function refinement:" in + let postfix = ["because:", + "- No matching assumptions could be found", + "- At least one side cannot be unfolded without fix"] in + return $ group (prefix <> nest 2 (line <> d1) <> line <> + "|=" <> nest 2 (line <> d2) <> line <> vsep postfix) prettyInCtx (CompsDoNotRefine m1 m2) = prettyPrefixSep "Could not prove refinement: " m1 "|=" m2 prettyInCtx (ReturnNotError eith_terr t) = diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index 1848b32146..1ee41d3013 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -1163,22 +1163,18 @@ mrRefines' m1@(FunBind f1 args1 isLifted1 k1) -- 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 + _ | Just _ <- maybe_f1_body + , Just _ <- maybe_f2_body -> + case mb_convs of + Just _ -> mrRefinesCoInd f1 args1 f2 args2 >> mrRefinesFun tp1 k1 tp2 k2 + _ -> throwMRFailure (BindTypesNotEq (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 mrDebugPrint 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 = mrGetFunAssump f1 >>= \case From 80450909f6f7f814da9243d9d2b4cebb83c535aa Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Wed, 6 Dec 2023 17:51:05 -0500 Subject: [PATCH 224/305] add error handling for return types not being equal to refinementTermH --- src/SAWScript/Prover/MRSolver/Monad.hs | 3 +++ src/SAWScript/Prover/MRSolver/Solver.hs | 2 ++ 2 files changed, 5 insertions(+) diff --git a/src/SAWScript/Prover/MRSolver/Monad.hs b/src/SAWScript/Prover/MRSolver/Monad.hs index 4e95dfd728..001aacc7d1 100644 --- a/src/SAWScript/Prover/MRSolver/Monad.hs +++ b/src/SAWScript/Prover/MRSolver/Monad.hs @@ -76,6 +76,7 @@ data MRFailure = TermsNotRel Bool Term Term | TypesNotRel Bool Type Type | BindTypesNotEq Type Type + | ReturnTypesNotEq Type Type | FunNamesDoNotRefine FunName [Term] FunName [Term] | CompsDoNotRefine NormComp NormComp | ReturnNotError (Either Term Term) Term @@ -152,6 +153,8 @@ instance PrettyInCtx MRFailure where prettyPrefixSep "Types not heterogeneously related:" tp1 "and" tp2 prettyInCtx (BindTypesNotEq tp1 tp2) = prettyPrefixSep "Could not start co-induction because bind types are not equal:" 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 Unlifted) >>= \d1 -> snd (prettyInCtxFunBindH f2 args2 Unlifted) >>= \d2 -> diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index 1ee41d3013..311df83715 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -1408,6 +1408,8 @@ 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 + tps_eq <- mrConvertible tp1 tp2 + unless tps_eq $ throwMRFailure (ReturnTypesNotEq (Type tp1) (Type tp2)) rpre <- liftSC2 scGlobalApply "Prelude.eqPreRel" [ev2, stack2] rpost <- liftSC2 scGlobalApply "Prelude.eqPostRel" [ev2, stack2] rr <- liftSC2 scGlobalApply "Prelude.eqRR" [tp2] From 79f26d13b2607f60c187609952dad556cbc912e8 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Wed, 6 Dec 2023 17:56:09 -0500 Subject: [PATCH 225/305] when applying a FunAssump, always substEvars in the rewritten RHS --- src/SAWScript/Prover/MRSolver/Solver.hs | 10 +++- src/SAWScript/Prover/MRSolver/Term.hs | 66 ++++++++++++------------- 2 files changed, 39 insertions(+), 37 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index 311df83715..6c9f9ebcc1 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -1146,7 +1146,10 @@ mrRefines' m1@(FunBind f1 args1 isLifted1 k1) evars <- mrFreshEVars ctx (args1'', rhs'') <- substTermLike 0 evars (args1', rhs') zipWithM_ mrAssertProveEq args1'' args1 - m1' <- normBindLiftStack isLifted1 rhs'' k1 + -- It's important to instantiate the evars here so that rhs is well-typed + -- when bound with k1 + rhs''' <- mapTermLike mrSubstEVars rhs'' + m1' <- normBindLiftStack isLifted1 rhs''' k1 recordUsedFunAssump fa >> mrRefines m1' m2 -- If f1 unfolds and is not recursive in itself, unfold it and recurse @@ -1186,7 +1189,10 @@ mrRefines' m1@(FunBind f1 args1 isLifted1 k1) m2 = evars <- mrFreshEVars ctx (args1'', rhs'') <- substTermLike 0 evars (args1', rhs') zipWithM_ mrAssertProveEq args1'' args1 - m1' <- normBindLiftStack isLifted1 rhs'' k1 + -- It's important to instantiate the evars here so that rhs is well-typed + -- when bound with k1 + rhs''' <- mapTermLike mrSubstEVars rhs'' + m1' <- normBindLiftStack isLifted1 rhs''' k1 recordUsedFunAssump fa >> mrRefines m1' m2 -- Otherwise, see if we can unfold f1 diff --git a/src/SAWScript/Prover/MRSolver/Term.hs b/src/SAWScript/Prover/MRSolver/Term.hs index f14a04d609..0e025c9c51 100644 --- a/src/SAWScript/Prover/MRSolver/Term.hs +++ b/src/SAWScript/Prover/MRSolver/Term.hs @@ -350,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) @@ -411,18 +411,14 @@ deriving instance _ => TermLike (a,b,c,d,e,f,g) deriving instance _ => TermLike [a] 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) From f8ab0a1d814c13952355e6af0c1347df6b44a540 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Wed, 6 Dec 2023 18:01:29 -0500 Subject: [PATCH 226/305] have both arguments to mrLambdaLift2 be in the same context --- src/SAWScript/Prover/MRSolver/Monad.hs | 23 +++++++++++++++-------- 1 file changed, 15 insertions(+), 8 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/Monad.hs b/src/SAWScript/Prover/MRSolver/Monad.hs index 001aacc7d1..17f43234e2 100644 --- a/src/SAWScript/Prover/MRSolver/Monad.hs +++ b/src/SAWScript/Prover/MRSolver/Monad.hs @@ -45,6 +45,7 @@ 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 @@ -749,6 +750,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 @@ -769,20 +773,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 @@ -790,7 +797,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 From ba83966ad4a5b433912c42f7243ce0d4ef81d4bb Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 13 Dec 2023 14:36:50 -0800 Subject: [PATCH 227/305] added genBVVecNoPf and atBVVecNoPf primitives to the SAW core prelude --- saw-core/prelude/Prelude.sawcore | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/saw-core/prelude/Prelude.sawcore b/saw-core/prelude/Prelude.sawcore index d773350598..034851618f 100644 --- a/saw-core/prelude/Prelude.sawcore +++ b/saw-core/prelude/Prelude.sawcore @@ -2031,6 +2031,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 = + genBVVec n len a (\ (i:Vec n Bool) (_:is_bvult n i len) -> f 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 -> @@ -2077,6 +2084,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) -> From 5c7dedca1d69403c808ff7e5cae05ad3dcf0284a Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 13 Dec 2023 14:38:29 -0800 Subject: [PATCH 228/305] updated MR solver to use a more general notion of injective representation in place of the previously-used injective conversions; note that this change is not yet complete... --- src/SAWScript/Prover/MRSolver/Monad.hs | 21 + src/SAWScript/Prover/MRSolver/SMT.hs | 682 ++++++++++++++---------- src/SAWScript/Prover/MRSolver/Solver.hs | 133 ++--- src/SAWScript/Prover/MRSolver/Term.hs | 12 + 4 files changed, 495 insertions(+), 353 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/Monad.hs b/src/SAWScript/Prover/MRSolver/Monad.hs index 2684ed7577..585100db3a 100644 --- a/src/SAWScript/Prover/MRSolver/Monad.hs +++ b/src/SAWScript/Prover/MRSolver/Monad.hs @@ -349,6 +349,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 @@ -632,6 +637,22 @@ mrGlobalTermUnfold ident = 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 + -- | Like 'scBvConst', but if given a bitvector literal it is converted to a -- natural number literal mrBvToNat :: Term -> Term -> MRM t Term diff --git a/src/SAWScript/Prover/MRSolver/SMT.hs b/src/SAWScript/Prover/MRSolver/SMT.hs index cefe9eda6b..0ce2fd2dd7 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,18 +29,22 @@ 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.Except import Control.Monad.Catch (throwM, catch) 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 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 @@ -58,6 +69,11 @@ import SAWScript.Prover.MRSolver.Monad -- * Various SMT-specific Functions on Terms ---------------------------------------------------------------------- +-- | Recognize a bitvector type with a potentially symbolic length +asSymBVType :: Recognizer Term Term +asSymBVType (asVectorType -> Just (n, asBoolType -> Just ())) = Just n +asSymBVType _ = Nothing + -- | 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 @@ -128,7 +144,8 @@ primGenBVVecFilter sc n (asGenBVVecTerm -> Just (asNat -> Just n', _, _, f)) | n 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 $ +primGenBVVecFilter sc n (asGenCryMTerm -> Just (asBvToNatKnownW -> + 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 @@ -455,260 +472,369 @@ mrProvable bool_tm = ---------------------------------------------------------------------- --- * 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) + + +-- | The length of a vector, given either as a bitvector 'Term' of a +-- statically-known bitwidth or as a natural number 'Term' +data VecLength = BVVecLen Natural Term | NatVecLen Term + deriving (Generic, Show) + +-- | 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) + +deriving instance TermLike InjectiveRepr +deriving instance TermLike InjNumRepr +deriving instance TermLike VecLength + +-- | Convert a natural number expression to a 'VecLength' +asVecLen :: Term -> VecLength +asVecLen (asBvToNatKnownW -> Just (n, len)) = BVVecLen n len +asVecLen n = NatVecLen n + +-- | Convert a 'VecLength' to a natural number expression +vecLenToNat :: VecLength -> MRM t Term +vecLenToNat (BVVecLen n len) = liftSC2 scBvToNat n len +vecLenToNat (NatVecLen n) = return n + +-- | Get the type of an index bounded by a 'VecLength' +vecLenIxType :: VecLength -> MRM t Term +vecLenIxType (BVVecLen n _) = liftSC1 scBitvector n +vecLenIxType (NatVecLen _) = liftSC0 scNatType + +-- | Test if two vector lengths are equal, and if so, generalize them to use the +-- same index type as returned by 'vecLenIxType' +vecLenUnify :: VecLength -> VecLength -> MRM t (Maybe (VecLength, VecLength)) +vecLenUnify vlen1@(BVVecLen n1 len1) vlen2@(BVVecLen n2 len2) + | n1 == n2 = + do lens_eq <- mrProveEq len1 len2 + if lens_eq then return (Just (vlen1,vlen2)) + else return Nothing +vecLenUnify (BVVecLen _ _) (BVVecLen _ _) = return Nothing +vecLenUnify len1 len2 = + do n1 <- vecLenToNat len1 + n2 <- vecLenToNat len2 + mrProveEq n1 n2 >>= \case + True -> return $ Just (NatVecLen n1, NatVecLen n2) + False -> return Nothing + +-- | Given a vector length, element type, vector of that length and type, and an +-- index of type 'vecLenIxType', index into the vector +vecLenIx :: VecLength -> Term -> Term -> Term -> MRM t Term +vecLenIx (BVVecLen n len) tp v ix = + do n_tm <- liftSC1 scNat n + mrApplyGlobal "Prelude.atBVVecNoPf" [n_tm, len, tp, v, ix] +vecLenIx (NatVecLen n) tp v ix = mrApplyGlobal "Prelude.at" [n, tp, v, ix] + +-- | 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 (NatVecLen n) tp repr) t = + do nat_tp <- liftSC0 scNatType + f <- mrLambdaLift1 ("ix", nat_tp) repr $ \x repr' -> + mrApplyRepr repr' =<< mrApply t x + mrApplyGlobal "Prelude.gen" [n, tp, f] +mrApplyRepr (InjReprVec (BVVecLen n len) tp repr) t = + do bv_tp <- liftSC1 scBitvector n + f <- mrLambdaLift1 ("ix", bv_tp) repr $ \x repr' -> + mrApplyRepr repr' =<< mrApply t x + n_tm <- liftSC1 scNat n + mrApplyGlobal "Prelude.genBVVecNoPf" [n_tm, len, 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 + liftTermLike n i = mapMaybeTermM given (liftTermLike n i) + substTermLike n s = mapMaybeTermM given (substTermLike n s) + +-- | 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 (asVectorType -> Just (len, tp@(asBoolType -> Nothing))) tm = + do let vlen = asVecLen len + ix_tp <- vecLenIxType 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'' -> vecLenIx 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 $ vecLenUnify len1 len2 + ix_tp <- lift $ vecLenIxType 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)) +-- injUnifyRepr tp_r1 tm1 r1 tp2 tm2 +injUnifyRepr = error "FIXME HERE NOWNOW" + ---------------------------------------------------------------------- @@ -730,9 +856,8 @@ mrEq' :: Term -> Term -> Term -> MRM t Term 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 = +mrEq' (asSymBVType -> Just n) t1 t2 = liftSC3 scBvEq n t1 t2 +mrEq' (asNumType -> Just ()) 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' @@ -821,9 +946,9 @@ mrAssertProveRel het t1 t2 = 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 +-- over zero or more universally quantified variables 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 = do varmap <- mrVars @@ -872,13 +997,10 @@ mrProveRelH' var_map _ tp1 tp2 t1 (asEVarApp var_map -> Just (evar, args, Nothin 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 +-- For nat, bitvector, Boolean, and integer types, call mrProveEqSimple 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 = +mrProveRelH' _ _ tp1@(asSymBVType -> Just n1) tp2@(asSymBVType -> Just n2) t1 t2 = do ns_are_eq <- mrConvertible n1 n2 if ns_are_eq then return () else throwMRFailure (TypesNotEq (Type tp1) (Type tp2)) @@ -888,6 +1010,20 @@ mrProveRelH' _ _ (asBoolType -> Just _) (asBoolType -> Just _) t1 t2 = mrProveRelH' _ _ (asIntegerType -> Just _) (asIntegerType -> Just _) t1 t2 = mrProveEqSimple (liftSC2 scIntEq) t1 t2 +-- If one side is a finite Num, treat it as a natural number +mrProveRelH' _ het _ tp2 (asNum -> Just (Left t1)) t2 = + liftSC0 scNatType >>= \nat_tp -> mrProveRelH het nat_tp tp2 t1 t2 +mrProveRelH' _ het tp1 _ t1 (asNum -> Just (Left t2)) = + liftSC0 scNatType >>= \nat_tp -> mrProveRelH het tp1 nat_tp t1 t2 + +-- If one side is a bvToNat term, treat it as a bitvector +mrProveRelH' _ het _ tp2 (asBvToNat -> Just (n, t1)) t2 = + mrBvType n >>= \bv_tp -> mrProveRelH het bv_tp tp2 t1 t2 +mrProveRelH' _ het tp1 _ t1 (asBvToNat -> Just (n, t2)) = + mrBvType n >>= \bv_tp -> mrProveRelH het tp1 bv_tp t1 t2 + +-- FIXME HERE NOWNOW: generalize Vec = Vec relation + -- 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)) @@ -923,22 +1059,12 @@ mrProveRelH' _ het (asPairType -> Just (tpL1, tpR1)) 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 +mrProveRelH' _ _ tp1 tp2 t1 t2 = + do success <- mrConvertible t1 t2 + if success then return () else + do tps_eq <- mrConvertible tp1 tp2 + if 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 diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index 44df4f99e9..dda22ba0b3 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -714,84 +714,67 @@ matchCoIndHyp hyp args1 args2 = (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) + (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 + 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) + hyp'' <- foldlM (\hyp_i (arg_spec_i, repr_i) -> + coIndHypSetArg hyp_i arg_spec_i <$> mrApplyRepr repr_i var) + hyp' ((arg_spec_0,repr) : zip eq_args arg_reprs) -- We finish by recursing on any remaining arg_specs - generalizeCoIndHyp hyp'' uneq_specs + generalizeCoIndHyp hyp'' uneq_args ---------------------------------------------------------------------- @@ -1034,7 +1017,7 @@ mrRefines' m1@(FunBind f1 args1 k1) m2@(FunBind f2 args2 k2) = mrFunOutType f1 args1 >>= \(_, tp1) -> mrFunOutType f2 args2 >>= \(_, tp2) -> - findInjConvs tp1 Nothing tp2 Nothing >>= \mb_convs -> + injUnifyTypes tp1 tp2 >>= \mb_convs -> mrFunBodyRecInfo f1 args1 >>= \maybe_f1_body -> mrFunBodyRecInfo f2 args2 >>= \maybe_f2_body -> mrGetCoIndHyp f1 f2 >>= \maybe_coIndHyp -> @@ -1275,19 +1258,19 @@ mrRefinesFunH k vars (asPi -> Just (nm1, asPairType -> Just (tpL1, tpR1), _)) t1 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) $ [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 diff --git a/src/SAWScript/Prover/MRSolver/Term.hs b/src/SAWScript/Prover/MRSolver/Term.hs index d5d3f0fbba..416f3389d5 100644 --- a/src/SAWScript/Prover/MRSolver/Term.hs +++ b/src/SAWScript/Prover/MRSolver/Term.hs @@ -261,6 +261,12 @@ 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) asEither (asCtor -> Just (c, [_, _, x])) @@ -268,6 +274,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])) @@ -403,6 +414,7 @@ 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) deriving instance _ => TermLike [a] +deriving instance TermLike () instance TermLike Term where liftTermLike = liftTerm From 5669365eb85bb2bc4957cd978d381ba3592eae45 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 13 Dec 2023 17:42:30 -0800 Subject: [PATCH 229/305] finished implementing injUnifyRepr --- src/SAWScript/Prover/MRSolver/SMT.hs | 32 ++++++++++++++++++++++++++-- 1 file changed, 30 insertions(+), 2 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/SMT.hs b/src/SAWScript/Prover/MRSolver/SMT.hs index 0ce2fd2dd7..ea48468903 100644 --- a/src/SAWScript/Prover/MRSolver/SMT.hs +++ b/src/SAWScript/Prover/MRSolver/SMT.hs @@ -832,9 +832,37 @@ injReprRestrict _ _ _ r2 = return r2 -- where @r1'@ is the composition of @r1''@ and @r1@. injUnifyRepr :: Term -> Term -> InjectiveRepr -> Term -> Term -> MRM t (Maybe (Term, Term, InjectiveRepr, InjectiveRepr)) --- injUnifyRepr tp_r1 tm1 r1 tp2 tm2 -injUnifyRepr = error "FIXME HERE NOWNOW" +-- 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 <- mrProveRel True r1_tm1 tm2 + if rel then return (Just (tp_r1, tm1, r1, r2)) else + return Nothing ---------------------------------------------------------------------- From b79f215c42cdb65aeda0a0eb94a9ca9150e9d59e Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 13 Dec 2023 17:54:29 -0800 Subject: [PATCH 230/305] fixed lifting bug in mrApplyRepr --- src/SAWScript/Prover/MRSolver/SMT.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/SMT.hs b/src/SAWScript/Prover/MRSolver/SMT.hs index ea48468903..4efe37a339 100644 --- a/src/SAWScript/Prover/MRSolver/SMT.hs +++ b/src/SAWScript/Prover/MRSolver/SMT.hs @@ -608,13 +608,13 @@ mrApplyRepr (InjReprPair repr1 repr2) t = liftSC2 scPairValueReduced t1 t2 mrApplyRepr (InjReprVec (NatVecLen n) tp repr) t = do nat_tp <- liftSC0 scNatType - f <- mrLambdaLift1 ("ix", nat_tp) repr $ \x repr' -> - mrApplyRepr repr' =<< mrApply t x + f <- mrLambdaLift1 ("ix", nat_tp) (repr, t) $ \x (repr', t') -> + mrApplyRepr repr' =<< mrApply t' x mrApplyGlobal "Prelude.gen" [n, tp, f] mrApplyRepr (InjReprVec (BVVecLen n len) tp repr) t = do bv_tp <- liftSC1 scBitvector n - f <- mrLambdaLift1 ("ix", bv_tp) repr $ \x repr' -> - mrApplyRepr repr' =<< mrApply t x + f <- mrLambdaLift1 ("ix", bv_tp) (repr, t) $ \x (repr', t') -> + mrApplyRepr repr' =<< mrApply t' x n_tm <- liftSC1 scNat n mrApplyGlobal "Prelude.genBVVecNoPf" [n_tm, len, tp, f] From ef82d738fde2721b2dbfee74096e90f6d76de275 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 13 Dec 2023 18:27:45 -0800 Subject: [PATCH 231/305] fixed mrTrySetAppliedEVar to correctly handle higher-order variables --- src/SAWScript/Prover/MRSolver/Monad.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/Monad.hs b/src/SAWScript/Prover/MRSolver/Monad.hs index 585100db3a..22a7b29660 100644 --- a/src/SAWScript/Prover/MRSolver/Monad.hs +++ b/src/SAWScript/Prover/MRSolver/Monad.hs @@ -1002,8 +1002,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 From 833ec1a7058cd904772dccc0db2dcd6aaed734b5 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 13 Dec 2023 20:28:28 -0800 Subject: [PATCH 232/305] changed genBVVecNoPf to use gen instead of genBVVec --- saw-core/prelude/Prelude.sawcore | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/saw-core/prelude/Prelude.sawcore b/saw-core/prelude/Prelude.sawcore index 034851618f..2c04957ef7 100644 --- a/saw-core/prelude/Prelude.sawcore +++ b/saw-core/prelude/Prelude.sawcore @@ -2036,7 +2036,7 @@ genBVVec n len a f = genBVVecNoPf : (n : Nat) -> (len : Vec n Bool) -> (a : sort 0) -> (Vec n Bool -> a) -> BVVec n len a; genBVVecNoPf n len a f = - genBVVec n len a (\ (i:Vec n Bool) (_:is_bvult n i len) -> f i); + 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 From 0cec5c5c2d2c4e92e53013493687e8cc08384075 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 13 Dec 2023 20:29:06 -0800 Subject: [PATCH 233/305] changed the normalizer to prefer caller-supplied primitives over its default primitive implementations --- saw-core/src/Verifier/SAW/Simulator/TermModel.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/saw-core/src/Verifier/SAW/Simulator/TermModel.hs b/saw-core/src/Verifier/SAW/Simulator/TermModel.hs index c92fe468fe..270c907b1b 100644 --- a/saw-core/src/Verifier/SAW/Simulator/TermModel.hs +++ b/saw-core/src/Verifier/SAW/Simulator/TermModel.hs @@ -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 @@ -137,7 +137,7 @@ normalizeSharedTerm :: IO Term normalizeSharedTerm sc m addlPrims 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 (Map.union addlPrims (constMap sc cfg)) (extcns cfg) (constants cfg) (neutral cfg) (primHandler cfg)) v <- Sim.evalSharedTerm cfg t tv <- evalType cfg =<< scTypeOf sc t @@ -420,7 +420,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 From 0f695b149f33187514f63e90a5cb020157798b8d Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 13 Dec 2023 20:30:10 -0800 Subject: [PATCH 234/305] updated implementations of the primitives to work directly with gen and at --- src/SAWScript/Prover/MRSolver/SMT.hs | 105 +++++++++++++++++++++++++-- 1 file changed, 100 insertions(+), 5 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/SMT.hs b/src/SAWScript/Prover/MRSolver/SMT.hs index 4efe37a339..29dd7ace04 100644 --- a/src/SAWScript/Prover/MRSolver/SMT.hs +++ b/src/SAWScript/Prover/MRSolver/SMT.hs @@ -74,6 +74,27 @@ asSymBVType :: Recognizer Term Term asSymBVType (asVectorType -> Just (n, asBoolType -> Just ())) = Just n asSymBVType _ = Nothing +-- | Match a term of the form @gen n a f@ or @genWithProof n a (\i _ -> e)@, +-- where the latter case means that the function ignores its proof argument. In +-- this latter case, return just the function @\i -> e@. +asGenVecTerm :: SharedContext -> Recognizer Term (Term, Term, IO Term) +asGenVecTerm _ (asApplyAll -> + (isGlobalDef "Prelude.gen" -> Just _, [n, a, f])) + = Just (n, a, return f) +asGenVecTerm sc (asApplyAll -> + (isGlobalDef "Prelude.genWithProof" -> Just _, + [n, a, (asLambda -> Just (ix_nm, ix_tp, + asLambda -> Just (_, _, e)))])) + | not $ inBitSet 0 $ looseVars e + = Just (n, a, + 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 "asGenVecTerm: unexpected var occurrence", ix_var] + e' <- instantiateVarList sc 0 s e + scLambda sc ix_nm ix_tp e') +asGenVecTerm _ _ = Nothing + -- | 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 @@ -116,14 +137,49 @@ 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... +-- | 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 -> (Term -> TmPrim) -> TmPrim +primGenVec sc = + PrimFilterFun "primGenVec" $ + \case + VExtra (VExtraTerm _ (asGenVecTerm sc -> Just (_, _, f_m))) -> lift f_m + _ -> mzero + +-- | Convert a Boolean value to a 'Term' boolValToTerm :: SharedContext -> Value TermModel -> IO Term boolValToTerm _ (VBool (Left tm)) = return tm boolValToTerm sc (VBool (Right b)) = scBool sc b boolValToTerm _ (VExtra (VExtraTerm _tp tm)) = return tm boolValToTerm _ v = error ("boolValToTerm: unexpected value: " ++ show v) +-- | Convert a bitvector value to a 'Term' +bvValToTerm :: SharedContext -> Value TermModel -> IO Term +bvValToTerm _ (VWord (Left (_,tm))) = return tm +bvValToTerm sc (VWord (Right bv)) = + scBvConst sc (fromIntegral (Prim.width bv)) (Prim.unsigned bv) +bvValToTerm sc (VVector vs) = + do vs' <- traverse (boolValToTerm sc <=< force) (V.toList vs) + bool_tp <- scBoolType sc + scVectorReduced sc bool_tp vs' +bvValToTerm _ (VExtra (VExtraTerm _tp tm)) = return tm +bvValToTerm _ v = error ("bvValToTerm: unexpected value: " ++ show v) + +-- | Convert a natural number value to a 'Term' +natValToTerm :: SharedContext -> Value TermModel -> IO Term +natValToTerm sc (VNat n) = scNat sc n +natValToTerm sc (VBVToNat w bv_val) = + do bv_tm <- bvValToTerm sc bv_val + scBvToNat sc (fromIntegral w) bv_tm +natValToTerm _ (VExtra (VExtraTerm _ n)) = return n +natValToTerm _ v = error ("natValToTerm: unexpected value: " ++ show v) + +-- | A primitive function that expects a 'Term' of type @Nat@ +primNatTermFun :: SharedContext -> (Term -> TmPrim) -> TmPrim +primNatTermFun sc = + PrimFilterFun "primNatTermFun" $ \v -> lift (natValToTerm sc v) + + -- | 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 @@ -275,7 +331,44 @@ primGlobal sc glob = -- 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 + [ + -- Override the usual behavior of gen so it is not evaluated or unfolded + ("Prelude.gen", + Prim (do tp <- scTypeOfGlobal sc "Prelude.gen" + VExtra <$> VExtraTerm (VTyTerm (mkSort 1) tp) <$> + scGlobalDef sc "Prelude.gen") + ), + + -- Also have genWithProof not be evaluated + ("Prelude.genWithProof", + Prim (do tp <- scTypeOfGlobal sc "Prelude.genWithProof" + VExtra <$> VExtraTerm (VTyTerm (mkSort 1) tp) <$> + scGlobalDef sc "Prelude.genWithProof") + ), + + -- 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 $ \f -> primNatTermFun sc $ \ix -> + Prim (do tm <- scApplyBeta sc f ix + tm' <- smtNorm sc tm + return $ VExtra $ VExtraTerm a tm') + ), + + -- Normalize an application of @atWithProof@ to a @gen@ term by applying the + -- function of the @gen@ to the index + ("Prelude.atWithProof", + PrimFun $ \_len -> tvalFun $ \a -> primGenVec sc $ \f -> + primNatTermFun sc $ \ix -> PrimFun $ \_pf -> + Prim (do tm <- scApplyBeta sc f ix + tm' <- smtNorm sc tm + return $ VExtra $ VExtraTerm a tm')), + + {- + -- Don't unfold @genBVVec@ or @genCryM when normalizing ("Prelude.genBVVec", Prim (do tp <- scTypeOfGlobal sc "Prelude.genBVVec" VExtra <$> VExtraTerm (VTyTerm (mkSort 1) tp) <$> @@ -337,7 +430,8 @@ smtNormPrims sc = Map.fromList tm <- scApplyBeta sc f ix'' tm' <- smtNorm sc tm return $ VExtra $ VExtraTerm a tm') - ), + ), -} + -- Don't normalize applications of @SpecM@ and its arguments ("SpecM.SpecM", PrimStrict $ \ev -> PrimStrict $ \tp -> @@ -352,7 +446,8 @@ smtNormPrims sc = Map.fromList ] -- | 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 -> From b1e48534dc26aa7f558893597175eed9c97ddd3b Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 13 Dec 2023 21:30:45 -0800 Subject: [PATCH 235/305] fixed a lifting bug in generalizeCoIndHyp --- src/SAWScript/Prover/MRSolver/Solver.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index dda22ba0b3..acec03348a 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -770,9 +770,10 @@ generalizeCoIndHyp hyp all_specs@(arg_spec_0:arg_specs) = -- 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 arg_reprs hyp'' <- foldlM (\hyp_i (arg_spec_i, repr_i) -> coIndHypSetArg hyp_i arg_spec_i <$> mrApplyRepr repr_i var) - hyp' ((arg_spec_0,repr) : zip eq_args arg_reprs) + hyp' ((arg_spec_0,repr) : zip eq_args arg_reprs') -- We finish by recursing on any remaining arg_specs generalizeCoIndHyp hyp'' uneq_args From 00f242a556e07fed6dae061c931d364bbc17c3f3 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 13 Dec 2023 21:53:19 -0800 Subject: [PATCH 236/305] commented out the no-longer used cases of instUVar --- src/SAWScript/Prover/MRSolver/SMT.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/SAWScript/Prover/MRSolver/SMT.hs b/src/SAWScript/Prover/MRSolver/SMT.hs index 29dd7ace04..c5df397411 100644 --- a/src/SAWScript/Prover/MRSolver/SMT.hs +++ b/src/SAWScript/Prover/MRSolver/SMT.hs @@ -532,6 +532,10 @@ mrProvable bool_tm = instUVar :: LocalName -> Term -> MRM t Term instUVar nm tp = mrDebugPPPrefix 3 "instUVar" (nm, tp) >> liftSC1 scWhnf tp >>= \case + -- NOTE: we should no longer see uvars that are vectors or pairs, + -- since pairs should be curried when they are introduced and vectors + -- should be represented as functions from indices to elements + {- (asNonBVVecVectorType -> Just (m, a)) -> liftSC1 smtNorm m >>= \m' -> case asBvToNat m' of -- For variables of type Vec of length which normalizes to @@ -561,7 +565,7 @@ mrProvable bool_tm = (asPairType -> Just (tp1, tp2)) -> do e1 <- instUVar nm tp1 e2 <- instUVar nm tp2 - liftSC2 scPairValue e1 e2 + liftSC2 scPairValue e1 e2 -} -- Otherwise, create a global variable with the given name and type tp' -> liftSC2 scFreshEC nm tp' >>= liftSC1 scExtCns From 6be5284db370b42c61de23e8905c19975007babf Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 14 Dec 2023 07:09:27 -0800 Subject: [PATCH 237/305] added evar lowering as part of mrProvable, to ensure evars over function variables do not become higher-order variables in SMT --- src/SAWScript/Prover/MRSolver/Monad.hs | 86 +++++++++++++++++++++----- src/SAWScript/Prover/MRSolver/SMT.hs | 12 ++-- src/SAWScript/Prover/MRSolver/Term.hs | 8 +++ 3 files changed, 85 insertions(+), 21 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/Monad.hs b/src/SAWScript/Prover/MRSolver/Monad.hs index 22a7b29660..5eb3326a4c 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.Reader @@ -201,13 +203,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] @@ -222,11 +227,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: @@ -617,6 +622,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 @@ -822,7 +834,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 @@ -859,7 +872,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) -> @@ -950,7 +963,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'. @@ -989,8 +1003,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) } @@ -1048,11 +1062,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) @@ -1061,10 +1117,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 diff --git a/src/SAWScript/Prover/MRSolver/SMT.hs b/src/SAWScript/Prover/MRSolver/SMT.hs index c5df397411..09cb2824fc 100644 --- a/src/SAWScript/Prover/MRSolver/SMT.hs +++ b/src/SAWScript/Prover/MRSolver/SMT.hs @@ -510,7 +510,7 @@ mrProvableRaw prop_term = 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)))) ++ + "\n - " ++ show (ppName $ ecName x) ++ " = " ++ renderSawDoc defaultPPOpts (ppFirstOrderValue defaultPPOpts v)) cex) >> recordUsedSolver stats prop_term >> return False Right (stats, SolveSuccess _) -> @@ -525,7 +525,7 @@ 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 @@ -1089,12 +1089,12 @@ mrProveRelH' :: Map MRVar MRVarInfo -> Bool -> Term -> Term -> Term -> Term -> MRM t TermInCtx -- If t1 is an instantiated evar, substitute and recurse -mrProveRelH' var_map het tp1 tp2 (asEVarApp var_map -> Just (_, args, Just f)) t2 = +mrProveRelH' var_map het tp1 tp2 (asEVarApp var_map -> Just (_, _, args, Just f)) t2 = mrApplyAll f args >>= \t1' -> mrProveRelH het tp1 tp2 t1' 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 = +mrProveRelH' var_map _ tp1 tp2 (asEVarApp var_map -> Just (evar, _, args, Nothing)) t2 = do tps_are_eq <- mrConvertible tp1 tp2 if tps_are_eq then return () else throwMRFailure (TypesNotEq (Type tp1) (Type tp2)) @@ -1105,12 +1105,12 @@ mrProveRelH' var_map _ tp1 tp2 (asEVarApp var_map -> Just (evar, args, Nothing)) 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)) = +mrProveRelH' var_map het tp1 tp2 t1 (asEVarApp var_map -> Just (_, _, args, Just f)) = mrApplyAll f args >>= \t2' -> mrProveRelH het tp1 tp2 t1 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)) = +mrProveRelH' var_map _ tp1 tp2 t1 (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)) diff --git a/src/SAWScript/Prover/MRSolver/Term.hs b/src/SAWScript/Prover/MRSolver/Term.hs index 416f3389d5..3f0354451e 100644 --- a/src/SAWScript/Prover/MRSolver/Term.hs +++ b/src/SAWScript/Prover/MRSolver/Term.hs @@ -55,6 +55,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) From 6e4d2e4ddede4522ce7c114b5b81dc8949cccfac Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 14 Dec 2023 11:57:18 -0800 Subject: [PATCH 238/305] whoops, forgot to lift the arg0 repr in generalizeCoIndHyp --- src/SAWScript/Prover/MRSolver/Solver.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index acec03348a..a8628a0bc3 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -770,10 +770,10 @@ generalizeCoIndHyp hyp all_specs@(arg_spec_0:arg_specs) = -- 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 arg_reprs + 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' ((arg_spec_0,repr) : zip eq_args arg_reprs') + hyp' (zip (arg_spec_0:eq_args) arg_reprs') -- We finish by recursing on any remaining arg_specs generalizeCoIndHyp hyp'' uneq_args From 7897e70d674793cf118a08503be5943b46888b5c Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 14 Dec 2023 13:26:22 -0800 Subject: [PATCH 239/305] added loop detection to proveCoIndHyp --- src/SAWScript/Prover/MRSolver/Solver.hs | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index a8628a0bc3..bff217c49b 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -673,12 +673,12 @@ 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 @@ -691,12 +691,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 From c1e15ae6f7b64f11cc1ac2be5b6c8e6fe240b41e Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 14 Dec 2023 15:45:53 -0800 Subject: [PATCH 240/305] added calls to mrIndexBVVec in the mrProveRelH for vectors, though mrIndexBVVec is not yet defined... --- src/SAWScript/Prover/MRSolver/SMT.hs | 22 ++++++++-------------- 1 file changed, 8 insertions(+), 14 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/SMT.hs b/src/SAWScript/Prover/MRSolver/SMT.hs index 09cb2824fc..11ad5b45bd 100644 --- a/src/SAWScript/Prover/MRSolver/SMT.hs +++ b/src/SAWScript/Prover/MRSolver/SMT.hs @@ -1153,24 +1153,18 @@ mrProveRelH' _ het tp1 _ t1 (asBvToNat -> Just (n, 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 -> +mrProveRelH' _ het tp1@(asBVVecType -> Just (asNat -> Just n1, len1, tpA1)) + tp2@(asBVVecType -> + Just (asNat -> Just n2, len2, tpA2)) t1 t2 = mrConvertible len1 len2 >>= \lens_are_eq -> - (if ns_are_eq && lens_are_eq then return () else + (if n1 == n2 && 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] + withUVarLift "ix" (Type ix_tp) (len1,len2,tpA1,tpA2,t1,t2) $ + \ix (len1',len2',tpA1',tpA2',t1',t2') -> + do t1_prj <- mrIndexBVVec n1 len1' tpA1' t1' ix + t2_prj <- mrIndexBVVec n2 len2' tpA2' t2' ix cond <- mrProveRelH het tpA1' tpA2' t1_prj t2_prj extTermInCtx [("ix",ix_tp)] <$> liftTermInCtx2 scImplies (TermInCtx [] ix_bound) cond From 71b8125cc84cc9e1dbd2f409edd91c06c2d2629e Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Thu, 14 Dec 2023 20:00:07 -0500 Subject: [PATCH 241/305] resolve all but one unused import and variable warnings --- .../src/Verifier/SAW/Heapster/Permissions.hs | 5 +---- .../src/Verifier/SAW/Heapster/SAWTranslation.hs | 12 ++++-------- src/SAWScript/Prover/MRSolver/Solver.hs | 1 - 3 files changed, 5 insertions(+), 13 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs index 36060c9d77..7c43c160f3 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs @@ -30,7 +30,6 @@ module Verifier.SAW.Heapster.Permissions where import Prelude hiding (pred) import Data.Char -import qualified Data.Text as Text import Data.Word import Data.Maybe import Data.Either @@ -86,8 +85,6 @@ 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 @@ -971,8 +968,8 @@ $(mkNuMatching [t| forall ctx. PermVarSubst ctx |]) $(mkNuMatching [t| PermEnvFunEntry |]) $(mkNuMatching [t| SomeNamedPerm |]) $(mkNuMatching [t| SomeNamedShape |]) -$(mkNuMatching [t| PermEnvGlobalEntry |]) $(mkNuMatching [t| GlobalTrans |]) +$(mkNuMatching [t| PermEnvGlobalEntry |]) $(mkNuMatching [t| forall args. BlockHintSort args |]) $(mkNuMatching [t| forall blocks init ret args. BlockHint blocks init ret args |]) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 9d13f9874f..888200a9c1 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -37,11 +37,9 @@ import Data.Maybe import Numeric.Natural import Data.List hiding (inits) import Data.Text (pack) -import Data.Kind import GHC.TypeLits import Data.BitVector.Sized (BV) import qualified Data.BitVector.Sized as BV -import Data.Functor.Compose import Data.Functor.Constant import Control.Applicative import Control.Lens hiding ((:>), Index, ix, op, getting) @@ -49,7 +47,6 @@ import qualified Control.Monad as Monad import Control.Monad.Reader hiding (ap) import Control.Monad.Writer hiding (ap) import Control.Monad.State hiding (ap) -import Control.Monad.Cont hiding (ap) import Control.Monad.Trans.Maybe import qualified Control.Monad.Fail as Fail @@ -81,7 +78,6 @@ 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 @@ -3744,7 +3740,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of tp2 <- translate p2 tptrans <- translateSimplImplOutHead mb_simpl withPermStackTopTermsM id - (\ts (ps :>: p_top) -> + (\ts (ps :>: _p_top) -> ps :>: typeTransF tptrans [leftTrans tp1 tp2 (tupleOpenTerm' ts)]) m @@ -3753,7 +3749,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of tp2 <- translate p2 tptrans <- translateSimplImplOutHead mb_simpl withPermStackTopTermsM id - (\ts (ps :>: p_top) -> + (\ts (ps :>: _p_top) -> ps :>: typeTransF tptrans [rightTrans tp1 tp2 (tupleOpenTerm' ts)]) m @@ -4151,7 +4147,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of ++ "unexpected form of output permission") (w_tm, len_tm, elem_tp, ap_tp_trans) <- translateLLVMArrayPerm mb_ap withPermStackTopTermsM id - (\ts (pctx :>: ptrans_cell) -> + (\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 @@ -4291,7 +4287,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of (\ (_ :>: ptrans_x :>: _ :>: _) -> ptrans_x) (\(ns :>: x :>: _ :>: l2) -> ns :>: x :>: l2) (\ts pctx_all -> case pctx_all of - (pctx :>: ptrans_x :>: _ :>: + (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 :>: diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index bff217c49b..1136f08a59 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -123,7 +123,6 @@ we are trying to prove @m1@ refines @m2@ in context @C@. This proceeds by cases: module SAWScript.Prover.MRSolver.Solver where import Data.Maybe -import Data.Either import Data.List (find, findIndices) import Data.Foldable (foldlM) import Data.Bits (shiftL) From 97d6695b49c72950b69e0ae162c38586985edcc9 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Thu, 14 Dec 2023 20:01:35 -0500 Subject: [PATCH 242/305] add mrAtBVVec, potentially finish BVVec case of mrProveRelH' --- src/SAWScript/Prover/MRSolver/Monad.hs | 37 +++++++++++++++++ src/SAWScript/Prover/MRSolver/SMT.hs | 55 ++++++-------------------- src/SAWScript/Prover/MRSolver/Term.hs | 4 +- 3 files changed, 51 insertions(+), 45 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/Monad.hs b/src/SAWScript/Prover/MRSolver/Monad.hs index 5eb3326a4c..846d1b8e8e 100644 --- a/src/SAWScript/Prover/MRSolver/Monad.hs +++ b/src/SAWScript/Prover/MRSolver/Monad.hs @@ -578,6 +578,43 @@ 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 @genBVVec n len a (\i _ -> f i)@ +asGenBVVecTerm :: Recognizer Term (Term, Term, Term, SharedContext -> IO Term) +asGenBVVecTerm (asApplyAll -> (isGlobalDef "Prelude.genBVVec" -> Just _, + [n, len, a, asIndexWithProofFnTerm -> Just m_f])) + = Just (n, len, a, m_f) +asGenBVVecTerm _ = Nothing + +-- | ... +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 diff --git a/src/SAWScript/Prover/MRSolver/SMT.hs b/src/SAWScript/Prover/MRSolver/SMT.hs index 11ad5b45bd..479568d648 100644 --- a/src/SAWScript/Prover/MRSolver/SMT.hs +++ b/src/SAWScript/Prover/MRSolver/SMT.hs @@ -56,8 +56,6 @@ import qualified Verifier.SAW.Prim as Prim 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(..)) @@ -74,27 +72,6 @@ asSymBVType :: Recognizer Term Term asSymBVType (asVectorType -> Just (n, asBoolType -> Just ())) = Just n asSymBVType _ = Nothing --- | Match a term of the form @gen n a f@ or @genWithProof n a (\i _ -> e)@, --- where the latter case means that the function ignores its proof argument. In --- this latter case, return just the function @\i -> e@. -asGenVecTerm :: SharedContext -> Recognizer Term (Term, Term, IO Term) -asGenVecTerm _ (asApplyAll -> - (isGlobalDef "Prelude.gen" -> Just _, [n, a, f])) - = Just (n, a, return f) -asGenVecTerm sc (asApplyAll -> - (isGlobalDef "Prelude.genWithProof" -> Just _, - [n, a, (asLambda -> Just (ix_nm, ix_tp, - asLambda -> Just (_, _, e)))])) - | not $ inBitSet 0 $ looseVars e - = Just (n, a, - 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 "asGenVecTerm: unexpected var occurrence", ix_var] - e' <- instantiateVarList sc 0 s e - scLambda sc ix_nm ix_tp e') -asGenVecTerm _ _ = Nothing - -- | 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 @@ -110,16 +87,6 @@ genBVVecTerm sc n_tm len_tm a_tm f_tm = 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 _, @@ -143,7 +110,7 @@ primGenVec :: SharedContext -> (Term -> TmPrim) -> TmPrim primGenVec sc = PrimFilterFun "primGenVec" $ \case - VExtra (VExtraTerm _ (asGenVecTerm sc -> Just (_, _, f_m))) -> lift f_m + VExtra (VExtraTerm _ (asGenVecTerm -> Just (_, _, f_m))) -> lift $ f_m sc _ -> mzero -- | Convert a Boolean value to a 'Term' @@ -179,7 +146,7 @@ primNatTermFun :: SharedContext -> (Term -> TmPrim) -> TmPrim primNatTermFun sc = PrimFilterFun "primNatTermFun" $ \v -> lift (natValToTerm sc 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 @@ -298,6 +265,7 @@ bvVecBVVecFromVecArg sc n n' len a (BVVecLit vs) = 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? @@ -1153,18 +1121,19 @@ mrProveRelH' _ het tp1 _ t1 (asBvToNat -> Just (n, 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 (asNat -> Just n1, len1, tpA1)) - tp2@(asBVVecType -> - Just (asNat -> Just n2, len2, tpA2)) t1 t2 = +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 n1 == n2 && lens_are_eq then return () else + (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) (len1,len2,tpA1,tpA2,t1,t2) $ - \ix (len1',len2',tpA1',tpA2',t1',t2') -> - do t1_prj <- mrIndexBVVec n1 len1' tpA1' t1' ix - t2_prj <- mrIndexBVVec n2 len2' tpA2' t2' ix + withUVarLift "ix" (Type ix_tp) (n1,n2,len1,len2,tpA1,tpA2,t1,t2) $ + \ix (n1',n2',len1',len2',tpA1',tpA2',t1',t2') -> + do ix_bound <- liftSC2 scGlobalApply "Prelude.bvult" [n1', ix, len1'] + t1_prj <- mrAtBVVec n1' len1' tpA1' t1' ix + t2_prj <- mrAtBVVec n2' len2' tpA2' t2' ix cond <- mrProveRelH het tpA1' tpA2' t1_prj t2_prj extTermInCtx [("ix",ix_tp)] <$> liftTermInCtx2 scImplies (TermInCtx [] ix_bound) cond diff --git a/src/SAWScript/Prover/MRSolver/Term.hs b/src/SAWScript/Prover/MRSolver/Term.hs index 3f0354451e..0fa34679d0 100644 --- a/src/SAWScript/Prover/MRSolver/Term.hs +++ b/src/SAWScript/Prover/MRSolver/Term.hs @@ -47,7 +47,6 @@ import Verifier.SAW.Term.CtxTerm (MonadTerm(..)) import Verifier.SAW.Term.Pretty import Verifier.SAW.SharedTerm import Verifier.SAW.Recognizer hiding ((:*:)) -import Verifier.SAW.OpenTerm import Verifier.SAW.Cryptol.Monadify @@ -421,6 +420,7 @@ 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) +deriving instance _ => TermLike (a,b,c,d,e,f,g,i) deriving instance _ => TermLike [a] deriving instance TermLike () @@ -439,7 +439,7 @@ instance TermLike Natural where substTermLike _ _ = return deriving anyclass instance TermLike Type -deriving instance TermLike EvTerm +deriving anyclass instance TermLike EvTerm deriving instance TermLike NormComp deriving instance TermLike CompFun deriving instance TermLike Comp From c859c55fbb143d4e6222b20c8dc5b08295e1bc64 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Thu, 14 Dec 2023 20:17:19 -0500 Subject: [PATCH 243/305] add `genBVVecNoPf` case to `asGenBVVecTerm` --- src/SAWScript/Prover/MRSolver/Monad.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/SAWScript/Prover/MRSolver/Monad.hs b/src/SAWScript/Prover/MRSolver/Monad.hs index 846d1b8e8e..8bb53442b1 100644 --- a/src/SAWScript/Prover/MRSolver/Monad.hs +++ b/src/SAWScript/Prover/MRSolver/Monad.hs @@ -601,8 +601,12 @@ asGenVecTerm (asApplyAll -> (isGlobalDef "Prelude.genWithProof" -> Just _, = Just (n, a, m_f) asGenVecTerm _ = Nothing --- | Match a term of the form @genBVVec n len a (\i _ -> f i)@ +-- | 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) From 6c8797a04fa4ac38df6adc95b388f1c2e503f764 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Thu, 14 Dec 2023 20:31:23 -0500 Subject: [PATCH 244/305] add `mkInjReprType` to forall/exists cases of `mrRefines` --- src/SAWScript/Prover/MRSolver/Solver.hs | 24 ++++++++++++++++-------- src/SAWScript/Prover/MRSolver/Term.hs | 2 +- 2 files changed, 17 insertions(+), 9 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index 1136f08a59..fe341dae8f 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -982,13 +982,17 @@ mrRefines' (AssertBoolBind cond1 k1) 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' -> + mkInjReprType (typeTm tp) >>= \(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' -> + mkInjReprType (typeTm tp) >>= \(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') = @@ -1177,13 +1181,17 @@ 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', r) <- mkInjReprType (typeTm tp) + evar <- mrFreshEVar nm (Type tp') + evar' <- mrApplyRepr r evar + m2' <- applyNormCompFun f2 evar' 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', r) <- mkInjReprType (typeTm tp) + evar <- mrFreshEVar nm (Type tp') + evar' <- mrApplyRepr r evar + m1' <- applyNormCompFun f1 evar' mrRefines m1' m2 -- If none of the above cases match, then fail diff --git a/src/SAWScript/Prover/MRSolver/Term.hs b/src/SAWScript/Prover/MRSolver/Term.hs index 0fa34679d0..f4b5ba9794 100644 --- a/src/SAWScript/Prover/MRSolver/Term.hs +++ b/src/SAWScript/Prover/MRSolver/Term.hs @@ -118,7 +118,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. From 076d21d52a481568516a0aff10ee0491f09c8637 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 15 Dec 2023 06:50:18 -0800 Subject: [PATCH 245/305] removed TermLike instance for tuples of length longer than 7 because those do not work with GHC 8.10 --- src/SAWScript/Prover/MRSolver/SMT.hs | 4 ++-- src/SAWScript/Prover/MRSolver/Term.hs | 3 ++- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/SMT.hs b/src/SAWScript/Prover/MRSolver/SMT.hs index 479568d648..d9ff7f61df 100644 --- a/src/SAWScript/Prover/MRSolver/SMT.hs +++ b/src/SAWScript/Prover/MRSolver/SMT.hs @@ -1129,8 +1129,8 @@ mrProveRelH' _ het tp1@(asBVVecType -> Just (n1, len1, tpA1)) throwMRFailure (TypesNotEq (Type tp1) (Type tp2))) >> liftSC0 scBoolType >>= \bool_tp -> liftSC2 scVecType n1 bool_tp >>= \ix_tp -> - withUVarLift "ix" (Type ix_tp) (n1,n2,len1,len2,tpA1,tpA2,t1,t2) $ - \ix (n1',n2',len1',len2',tpA1',tpA2',t1',t2') -> + withUVarLift "ix" (Type ix_tp) ((n1,n2,len1,len2),(tpA1,tpA2,t1,t2)) $ + \ix ((n1',n2',len1',len2'),(tpA1',tpA2',t1',t2')) -> do ix_bound <- liftSC2 scGlobalApply "Prelude.bvult" [n1', ix, len1'] t1_prj <- mrAtBVVec n1' len1' tpA1' t1' ix t2_prj <- mrAtBVVec n2' len2' tpA2' t2' ix diff --git a/src/SAWScript/Prover/MRSolver/Term.hs b/src/SAWScript/Prover/MRSolver/Term.hs index f4b5ba9794..d16c84ad53 100644 --- a/src/SAWScript/Prover/MRSolver/Term.hs +++ b/src/SAWScript/Prover/MRSolver/Term.hs @@ -420,7 +420,8 @@ 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) -deriving instance _ => TermLike (a,b,c,d,e,f,g,i) +-- 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 () From 11a3f0594ae96ed5edc027b03c4aefa9fe393499 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 15 Dec 2023 07:31:20 -0800 Subject: [PATCH 246/305] Fixed vecLenIx to use mrAtVec and mrAtBVVec instead of directly applying the at and atBVVec accessors --- src/SAWScript/Prover/MRSolver/Monad.hs | 13 ++++++++++++- src/SAWScript/Prover/MRSolver/SMT.hs | 4 ++-- 2 files changed, 14 insertions(+), 3 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/Monad.hs b/src/SAWScript/Prover/MRSolver/Monad.hs index 8bb53442b1..ccb01c943f 100644 --- a/src/SAWScript/Prover/MRSolver/Monad.hs +++ b/src/SAWScript/Prover/MRSolver/Monad.hs @@ -612,7 +612,18 @@ asGenBVVecTerm (asApplyAll -> (isGlobalDef "Prelude.genBVVec" -> Just _, = 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 diff --git a/src/SAWScript/Prover/MRSolver/SMT.hs b/src/SAWScript/Prover/MRSolver/SMT.hs index d9ff7f61df..e08f4a7707 100644 --- a/src/SAWScript/Prover/MRSolver/SMT.hs +++ b/src/SAWScript/Prover/MRSolver/SMT.hs @@ -629,8 +629,8 @@ vecLenUnify len1 len2 = vecLenIx :: VecLength -> Term -> Term -> Term -> MRM t Term vecLenIx (BVVecLen n len) tp v ix = do n_tm <- liftSC1 scNat n - mrApplyGlobal "Prelude.atBVVecNoPf" [n_tm, len, tp, v, ix] -vecLenIx (NatVecLen n) tp v ix = mrApplyGlobal "Prelude.at" [n, tp, v, ix] + mrAtBVVec n_tm len tp v ix +vecLenIx (NatVecLen n) tp v ix = mrAtVec n tp v ix -- | Smart constructor for pair representations, that combines a pair of -- identity representations into an identity representation on the pair type From 4d11bffad43c559e20e41f760fe38f01635077fd Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 18 Dec 2023 07:01:13 -0800 Subject: [PATCH 247/305] changed heapster_init_env to add an import of the SpecM SAW core module instead of Prelude when it creates a SAW core module --- src/SAWScript/HeapsterBuiltins.hs | 24 +++++++----------------- 1 file changed, 7 insertions(+), 17 deletions(-) diff --git a/src/SAWScript/HeapsterBuiltins.hs b/src/SAWScript/HeapsterBuiltins.hs index d4b41b7869..e404543fb3 100644 --- a/src/SAWScript/HeapsterBuiltins.hs +++ b/src/SAWScript/HeapsterBuiltins.hs @@ -88,7 +88,6 @@ 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 @@ -347,8 +346,9 @@ heapster_init_env_gen _bic _opts dlevel mod_str llvm_filename = 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] @@ -363,24 +363,14 @@ load_sawcore_from_file _ _ mod_filename = 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 - liftIO $ ensureCryptolMLoaded sc - (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] -> From cfc8544a89fedc461a1bb6a8307766b6cbab8bc5 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 18 Dec 2023 07:20:51 -0800 Subject: [PATCH 248/305] updated the docs for heapster_define_reachability_perm --- src/SAWScript/Interpreter.hs | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/src/SAWScript/Interpreter.hs b/src/SAWScript/Interpreter.hs index 9c6010ccc1..035ab53bca 100644 --- a/src/SAWScript/Interpreter.hs +++ b/src/SAWScript/Interpreter.hs @@ -4361,12 +4361,13 @@ primitives = Map.fromList "HeapsterEnv -> 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." + [ "heapster_define_recursive_perm env nm arg_ctx value_type p trans_fun" + , " defines a recursive named Heapster permission named nm with arguments" + , " parsed from args_ctx and type parsed from value_type that unfolds to p," + , " which should form a reachability permission, meaning that it should" + , " have the form eq(x) or q for some permission q, where x is the last" + , " argument argument in arg_ctx and q can contain nm with no arguments to" + , " refer to the entire permission recursively." ] , prim "heapster_define_recursive_shape" From aac9638657edfa00114fcc4544a4565ad5066570 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 18 Dec 2023 07:23:15 -0800 Subject: [PATCH 249/305] started updating mbox example to work with the new SpecM monad... --- heapster-saw/examples/mbox.saw | 10 +++++----- heapster-saw/examples/mbox.sawcore | 22 +++++++++++----------- 2 files changed, 16 insertions(+), 16 deletions(-) diff --git a/heapster-saw/examples/mbox.saw b/heapster-saw/examples/mbox.saw index 62b3b6ce9e..63f4eb3e4d 100644 --- a/heapster-saw/examples/mbox.saw +++ b/heapster-saw/examples/mbox.saw @@ -30,9 +30,9 @@ heapster_define_perm env "aes_sw_ctx" 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 +68,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)"; 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); From c6a47ed9ba11bd70a75d47b72b91620e77266fc2 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Wed, 20 Dec 2023 13:00:16 -0500 Subject: [PATCH 250/305] add case for `Vec const_n` back to Monadification --- cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs b/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs index 366baa94f7..c361c0975b 100644 --- a/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs +++ b/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs @@ -557,11 +557,9 @@ monadifyTpExpr ctx (asDataType -> Just (pn, args)) = monadifyTpExpr ctx) args) monadifyTpExpr _ (asBitvectorType -> Just w) = SomeTpExpr MKTypeRepr $ MTyBV w -{- FIXME: if we need general finite Vecs, then we need Nat tp exprs -monadifyType ctx (asVectorType -> Just (len, tp)) = - let lenOT = monadifyTypeNat ctx len in - MTySeq (ctorOpenTerm "Cryptol.TCNum" [lenOT]) $ monadifyType ctx tp --} +monadifyTpExpr ctx (asVectorType -> Just (asNat -> Just n, a)) = + let nM = NExpr_Const $ ctorOpenTerm "Cryptol.TCNum" [natOpenTerm n] + in SomeTpExpr MKTypeRepr $ MTySeq nM (monadifyType ctx a) monadifyTpExpr ctx (asApplyAll -> ((asGlobalDef -> Just seq_id), [n, a])) | seq_id == "Cryptol.seq" = SomeTpExpr MKTypeRepr $ MTySeq (monadifyNum ctx n) (monadifyType ctx a) From 9e0693901ae85473549f538a05c1ce0bc1551627 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Wed, 20 Dec 2023 13:03:33 -0500 Subject: [PATCH 251/305] clean up MRSolver/SMT.hs --- src/SAWScript/Prover/MRSolver/SMT.hs | 424 ++++++-------------------- src/SAWScript/Prover/MRSolver/Term.hs | 8 + 2 files changed, 93 insertions(+), 339 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/SMT.hs b/src/SAWScript/Prover/MRSolver/SMT.hs index 93469c59b3..ea5508bd97 100644 --- a/src/SAWScript/Prover/MRSolver/SMT.hs +++ b/src/SAWScript/Prover/MRSolver/SMT.hs @@ -41,6 +41,7 @@ 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 @@ -49,7 +50,6 @@ 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 qualified Verifier.SAW.Prim as Prim @@ -64,44 +64,9 @@ import SAWScript.Prover.MRSolver.Monad ---------------------------------------------------------------------- --- * Various SMT-specific Functions on Terms +-- * Normalizing terms for SMT ---------------------------------------------------------------------- --- | Recognize a bitvector type with a potentially symbolic length -asSymBVType :: Recognizer Term Term -asSymBVType (asVectorType -> Just (n, asBoolType -> Just ())) = Just n -asSymBVType _ = Nothing - --- | 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 @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 -- | A primitive function that expects a term of the form @gen n a f@ and the @@ -146,139 +111,6 @@ primNatTermFun :: SharedContext -> (Term -> TmPrim) -> TmPrim primNatTermFun sc = PrimFilterFun "primNatTermFun" $ \v -> lift (natValToTerm sc 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 - VWord (Left (_, 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 (asBvToNatKnownW -> - 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 defaultPPOpts 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) - VWord (Left (_, asGenCryMTerm -> Just (_, _, f))) -> - return (Nothing, f) - VExtra (VExtraTerm _ (asGenFromBVVecTerm -> Just (asNat -> Just n, _, _, - v, _, _))) -> - (Just n,) <$> primGenBVVecFilter sc n v - VWord (Left (_, 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 - VWord (Left (_, asGenFromBVVecTerm -> Just (asNat -> Just n, len, _, - v, _, _))) -> - return $ FromBVVec n len v - VExtra (VExtraTerm _ (asGenCryMTerm -> Just (_, _, body))) -> - return $ GenCryM body - VWord (Left (_, 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 -> @@ -312,19 +144,11 @@ primGlobal sc glob = smtNormPrims :: SharedContext -> Map Ident TmPrim smtNormPrims sc = Map.fromList [ - -- Override the usual behavior of gen so it is not evaluated or unfolded - ("Prelude.gen", - Prim (do tp <- scTypeOfGlobal sc "Prelude.gen" - VExtra <$> VExtraTerm (VTyTerm (mkSort 1) tp) <$> - scGlobalDef sc "Prelude.gen") - ), - - -- Also have genWithProof not be evaluated - ("Prelude.genWithProof", - Prim (do tp <- scTypeOfGlobal sc "Prelude.genWithProof" - VExtra <$> VExtraTerm (VTyTerm (mkSort 1) tp) <$> - scGlobalDef sc "Prelude.genWithProof") - ), + -- 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"), -- 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 @@ -347,71 +171,6 @@ smtNormPrims sc = Map.fromList tm' <- smtNorm sc tm return $ VExtra $ VExtraTerm a tm')), - {- - -- 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 -> - 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'' - tm' <- smtNorm sc tm - return $ VExtra $ VExtraTerm a tm') - ), -} - -- Don't normalize applications of @SpecM@ and its arguments ("SpecM.SpecM", PrimStrict $ \ev -> PrimStrict $ \tp -> @@ -421,8 +180,7 @@ smtNormPrims sc = Map.fromList tp_tm <- readBackValueNoConfig "smtNormPrims (SpecM)" sc (VSort $ mkSort 0) tp ret_tm <- scGlobalApply sc "SpecM.SpecM" [ev_tm,tp_tm] - return $ TValue $ VTyTerm (mkSort 0) ret_tm), - ("SpecM.VoidEv", primGlobal sc "SpecM.VoidEv") + return $ TValue $ VTyTerm (mkSort 0) ret_tm) ] -- | A version of 'mrNormTerm' in the 'IO' monad, and which does not add any @@ -508,103 +266,26 @@ mrProvable bool_tm = prop <- liftSC2 scImplies assumps bool_tm >>= liftSC1 scEqTrue 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 - -- NOTE: we should no longer see uvars that are vectors or pairs, - -- since pairs should be curried when they are introduced and vectors - -- should be represented as functions from indices to elements - {- - (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 ---------------------------------------------------------------------- --- * SMT-Friendly Representations +-- * Unifying BVVec and Vec Lengths ---------------------------------------------------------------------- --- | 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) - - -- | The length of a vector, given either as a bitvector 'Term' of a -- statically-known bitwidth or as a natural number 'Term' data VecLength = BVVecLen Natural Term | NatVecLen Term - deriving (Generic, Show) - --- | 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) + deriving (Generic, Show, TermLike) -deriving instance TermLike InjectiveRepr -deriving instance TermLike InjNumRepr -deriving instance TermLike VecLength +instance PrettyInCtx VecLength where + prettyInCtx (BVVecLen n len) = + prettyAppList [return "BVVecLen", prettyInCtx n, parens <$> prettyInCtx len] + prettyInCtx (NatVecLen n) = + prettyAppList [return "NatVecLen", prettyInCtx n] -- | Convert a natural number expression to a 'VecLength' asVecLen :: Term -> VecLength @@ -645,6 +326,70 @@ vecLenIx (BVVecLen n len) tp v ix = mrAtBVVec n_tm len tp v ix vecLenIx (NatVecLen n) tp v ix = mrAtVec n tp v ix + + +---------------------------------------------------------------------- +-- * SMT-Friendly Representations +---------------------------------------------------------------------- + +-- | A representation of some subset of the elements of a type @tp@ as elements +-- of some other type @tp_r@. The idea is that the type @tp_r@ is easier to +-- represent in SMT solvers. +-- +-- This is captured formally with a function @r@ from elements of the +-- representation type @tp_r@ to the elements of type @tp@ that they represent +-- along with an equivalence relation @eq_r@ on @tp_r@ such that @r@ is +-- injective when viewed as a morphism from @eq_r@ to the natural equivalence +-- relation @equiv@ of @tp@. In more detail, this means that @eq_r@ holds +-- between two inputs to @r@ iff @equiv@ holds between their outputs. Note that +-- an injective representation need not be surjective, meaning there could be +-- elements of @tp@ that it cannot represent. +data InjectiveRepr + -- | The identity representation of @(tp,equiv)@ by itself. Only applies to + -- non-vector types, as vectors should be represented by one of the vector + -- representations. + = InjReprId + -- | A representation of a numeric type (@Num@, @Nat@, or @Vec n Bool@) by + -- another numeric type defined as the composition of one or more injective + -- numeric representations. NOTE: we do not expect numeric representations + -- to occur inside other representations like those for pairs and vectors + | InjReprNum [InjNumRepr] + -- | A representation of the pair type @tp1 * tp2@ by @tp_r1 * tp_r2@ using + -- representations of @tp1@ and @tp2@ + | InjReprPair InjectiveRepr InjectiveRepr + -- | A representation of the vector type @Vec len tp@ by the functional type + -- @tp_len -> tp_r@ from indices to elements of the representation type + -- @tp_r@ of @tp@, given a representation of @tp@ by @tp_r@, where the index + -- type @tp_len@ is determined by the 'VecLength' + | InjReprVec VecLength Term InjectiveRepr + deriving (Generic, Show, TermLike) + +-- | A representation of a numeric type (@Num@, @Nat@, or @Vec n Bool@) by +-- another numeric type defined as an injective function +data InjNumRepr + -- | The @TCNum@ constructor as a representation of @Num@ by @Nat@ + = InjNatToNum + -- | The @bvToNat@ function as a representation of @Nat@ by @Vec n Bool@ + | InjBVToNat Natural + deriving (Generic, Show, TermLike) + +instance PrettyInCtx InjectiveRepr where + prettyInCtx InjReprId = return "InjReprId" + prettyInCtx (InjReprNum steps) = + prettyAppList [return "InjReprNum", list <$> mapM prettyInCtx steps] + prettyInCtx (InjReprPair r1 r2) = + prettyAppList [return "InjReprPair", parens <$> prettyInCtx r1, + parens <$> prettyInCtx r2] + prettyInCtx (InjReprVec n tp repr) = + prettyAppList [return "InjReprVec", parens <$> prettyInCtx n, + parens <$> prettyInCtx tp, + parens <$> prettyInCtx repr] + +instance PrettyInCtx InjNumRepr where + prettyInCtx InjNatToNum = return "InjNatToNum" + prettyInCtx (InjBVToNat n) = + prettyAppList [return "InjBVToNat", prettyInCtx n] + -- | Smart constructor for pair representations, that combines a pair of -- identity representations into an identity representation on the pair type injReprPair :: InjectiveRepr -> InjectiveRepr -> InjectiveRepr @@ -963,7 +708,7 @@ mrEq' :: Term -> Term -> Term -> MRM t Term 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' (asSymBVType -> Just n) t1 t2 = liftSC3 scBvEq n t1 t2 +mrEq' (asSymBitvectorType -> Just n) t1 t2 = liftSC3 scBvEq n t1 t2 mrEq' (asNumType -> Just ()) t1 t2 = (,) <$> liftSC1 scWhnf t1 <*> liftSC1 scWhnf t2 >>= \case (asNum -> Just (Left t1'), asNum -> Just (Left t2')) -> @@ -1109,7 +854,8 @@ mrProveRelH' _ _ (asTupleType -> Just []) (asTupleType -> Just []) _ _ = -- For nat, bitvector, Boolean, and integer types, call mrProveEqSimple mrProveRelH' _ _ (asNatType -> Just _) (asNatType -> Just _) t1 t2 = mrProveEqSimple (liftSC2 scEqualNat) t1 t2 -mrProveRelH' _ _ tp1@(asSymBVType -> Just n1) tp2@(asSymBVType -> Just n2) t1 t2 = +mrProveRelH' _ _ tp1@(asSymBitvectorType -> Just n1) + tp2@(asSymBitvectorType -> Just n2) t1 t2 = do ns_are_eq <- mrConvertible n1 n2 if ns_are_eq then return () else throwMRFailure (TypesNotEq (Type tp1) (Type tp2)) diff --git a/src/SAWScript/Prover/MRSolver/Term.hs b/src/SAWScript/Prover/MRSolver/Term.hs index e6c2337689..6f0ec6ee83 100644 --- a/src/SAWScript/Prover/MRSolver/Term.hs +++ b/src/SAWScript/Prover/MRSolver/Term.hs @@ -300,6 +300,11 @@ 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 + -- | Test if a 'Term' is a 'BVVec' type, excluding bitvectors asBVVecType :: Recognizer Term (Term, Term, Term) asBVVecType (asApplyAll -> @@ -536,6 +541,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" From 30c863a5121364d8570ba4dda41e101ef298a87b Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Wed, 20 Dec 2023 16:08:12 -0500 Subject: [PATCH 252/305] add special handling of constant-length vecs in VecLength, etc. --- src/SAWScript/Prover/MRSolver/SMT.hs | 213 ++++++++++++++++-------- src/SAWScript/Prover/MRSolver/Solver.hs | 17 +- src/SAWScript/Prover/MRSolver/Term.hs | 19 --- 3 files changed, 155 insertions(+), 94 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/SMT.hs b/src/SAWScript/Prover/MRSolver/SMT.hs index ea5508bd97..4a9e8e502c 100644 --- a/src/SAWScript/Prover/MRSolver/SMT.hs +++ b/src/SAWScript/Prover/MRSolver/SMT.hs @@ -51,7 +51,7 @@ import Verifier.SAW.Term.Pretty import Verifier.SAW.SharedTerm import Verifier.SAW.Recognizer -import Verifier.SAW.Prim (EvalError(..)) +import Verifier.SAW.Prim (widthNat, EvalError(..)) import qualified Verifier.SAW.Prim as Prim import Verifier.SAW.Simulator.Value import Verifier.SAW.Simulator.TermModel @@ -276,56 +276,130 @@ mrProvable bool_tm = -- * Unifying BVVec and Vec Lengths ---------------------------------------------------------------------- --- | The length of a vector, given either as a bitvector 'Term' of a --- statically-known bitwidth or as a natural number 'Term' -data VecLength = BVVecLen Natural Term | NatVecLen Term +-- | 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 (BVVecLen n len) = - prettyAppList [return "BVVecLen", prettyInCtx n, parens <$> prettyInCtx len] - prettyInCtx (NatVecLen n) = - prettyAppList [return "NatVecLen", prettyInCtx n] + 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)) = BVVecLen n len -asVecLen n = NatVecLen n - --- | Convert a 'VecLength' to a natural number expression -vecLenToNat :: VecLength -> MRM t Term -vecLenToNat (BVVecLen n len) = liftSC2 scBvToNat n len -vecLenToNat (NatVecLen n) = return n +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' -vecLenIxType :: VecLength -> MRM t Term -vecLenIxType (BVVecLen n _) = liftSC1 scBitvector n -vecLenIxType (NatVecLen _) = liftSC0 scNatType +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 'vecLenIxType' -vecLenUnify :: VecLength -> VecLength -> MRM t (Maybe (VecLength, VecLength)) -vecLenUnify vlen1@(BVVecLen n1 len1) vlen2@(BVVecLen n2 len2) - | n1 == n2 = - do lens_eq <- mrProveEq len1 len2 - if lens_eq then return (Just (vlen1,vlen2)) - else return Nothing -vecLenUnify (BVVecLen _ _) (BVVecLen _ _) = return Nothing -vecLenUnify len1 len2 = - do n1 <- vecLenToNat len1 - n2 <- vecLenToNat len2 - mrProveEq n1 n2 >>= \case - True -> return $ Just (NatVecLen n1, NatVecLen n2) - False -> return Nothing +-- 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 _ len) tp f = + do len_tm <- liftSC1 scNat len + 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 'vecLenIxType', index into the vector -vecLenIx :: VecLength -> Term -> Term -> Term -> MRM t Term -vecLenIx (BVVecLen n len) tp v ix = +-- 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 -vecLenIx (NatVecLen n) tp v ix = mrAtVec n tp v ix - +mrVecLenAt (SymNatVecLen len) tp v ix = + do mrAtVec len tp v ix ---------------------------------------------------------------------- @@ -431,18 +505,11 @@ mrApplyRepr (InjReprPair repr1 repr2) t = do t1 <- mrApplyRepr repr1 =<< doTermProj t TermProjLeft t2 <- mrApplyRepr repr2 =<< doTermProj t TermProjRight liftSC2 scPairValueReduced t1 t2 -mrApplyRepr (InjReprVec (NatVecLen n) tp repr) t = - do nat_tp <- liftSC0 scNatType - f <- mrLambdaLift1 ("ix", nat_tp) (repr, t) $ \x (repr', t') -> - mrApplyRepr repr' =<< mrApply t' x - mrApplyGlobal "Prelude.gen" [n, tp, f] -mrApplyRepr (InjReprVec (BVVecLen n len) tp repr) t = - do bv_tp <- liftSC1 scBitvector n - f <- mrLambdaLift1 ("ix", bv_tp) (repr, t) $ \x (repr', t') -> +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 - n_tm <- liftSC1 scNat n - mrApplyGlobal "Prelude.genBVVecNoPf" [n_tm, len, tp, f] - + mrVecLenGen vlen tp f newtype MaybeTerm b = MaybeTerm { unMaybeTerm :: If b Term () } @@ -483,15 +550,14 @@ mkInjRepr b (asPairType -> Just (tp1, tp2)) t = tm_r <- map2MaybeTermM b (liftSC2 scPairValueReduced) tm_r1 tm_r2 return (tp_r, tm_r, InjReprPair r1 r2) -mkInjRepr b (asVectorType -> Just (len, tp@(asBoolType -> Nothing))) tm = - do let vlen = asVecLen len - ix_tp <- vecLenIxType vlen +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'' -> vecLenIx vlen' tp' tm'' ix) tm' + 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... @@ -571,8 +637,8 @@ injUnifyReprTypes tp1 r1 tp2 InjReprId -- 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 $ vecLenUnify len1 len2 - ix_tp <- lift $ vecLenIxType len1' + 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') @@ -877,28 +943,31 @@ mrProveRelH' _ het _ tp2 (asBvToNat -> Just (n, t1)) t2 = mrProveRelH' _ het tp1 _ t1 (asBvToNat -> Just (n, t2)) = mrBvType n >>= \bv_tp -> mrProveRelH het tp1 bv_tp t1 t2 --- FIXME HERE NOWNOW: generalize Vec = Vec relation - -- 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,n2,len1,len2),(tpA1,tpA2,t1,t2)) $ - \ix ((n1',n2',len1',len2'),(tpA1',tpA2',t1',t2')) -> - do ix_bound <- liftSC2 scGlobalApply "Prelude.bvult" [n1', ix, len1'] - t1_prj <- mrAtBVVec n1' len1' tpA1' t1' ix - t2_prj <- mrAtBVVec n2' len2' tpA2' t2' ix - cond <- mrProveRelH het tpA1' tpA2' t1_prj t2_prj - extTermInCtx [("ix",ix_tp)] <$> - liftTermInCtx2 scImplies (TermInCtx [] ix_bound) cond +mrProveRelH' _ het tp1@(asVecTypeWithLen -> Just (vlen1, tpA1)) + tp2@(asVecTypeWithLen -> Just (vlen2, tpA2)) t1 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 + cond <- mrProveRelH het tpA1' tpA2' t1_prj t2_prj + 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 +-- FIXME: Don't re-associate tuples +mrProveRelH' _ het (asPairType -> Just (asPairType -> Just (tp1a, tp1b), tp1c)) tp2 t1 t2 = + do tp1' <- liftSC2 scPairType tp1a =<< liftSC2 scPairType tp1b tp1c + mrProveRelH het tp1' tp2 t1 t2 +mrProveRelH' _ het tp1 (asPairType -> Just (asPairType -> Just (tp2a, tp2b), tp2c)) t1 t2 = + do tp2' <- liftSC2 scPairType tp2a =<< liftSC2 scPairType tp2b tp2c + mrProveRelH het tp1 tp2' t1 t2 mrProveRelH' _ het (asPairType -> Just (tpL1, tpR1)) (asPairType -> Just (tpL2, tpR2)) t1 t2 = do t1L <- liftSC1 scPairLeft t1 diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index d80c894f57..4fc540f6d2 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -1293,6 +1293,7 @@ mrRefinesFunH k vars piTp1 t1 (asPi -> Just (nm2, tp2@(asBoolEq -> -- 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' -> @@ -1302,6 +1303,16 @@ 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 = @@ -1386,9 +1397,9 @@ refinementTermH :: Term -> Term -> MRM t Term refinementTermH t1 t2 = do (EvTerm ev, tp1) <- fromJust . asSpecM <$> mrTypeOf t1 (EvTerm _, tp2) <- fromJust . asSpecM <$> mrTypeOf t2 - tps_eq <- mrConvertible tp1 tp2 - unless tps_eq $ - throwMRFailure (ReturnTypesNotEq (Type tp1) (Type tp2)) + -- tps_eq <- mrConvertible tp1 tp2 + -- unless tps_eq $ + -- throwMRFailure (ReturnTypesNotEq (Type tp1) (Type tp2)) rr <- liftSC2 scGlobalApply "SpecM.eqRR" [tp1] ref_tm <- liftSC2 scGlobalApply "SpecM.refinesS" [ev, tp1, tp1, rr, t1, t2] uvars <- mrUVarsOuterToInner diff --git a/src/SAWScript/Prover/MRSolver/Term.hs b/src/SAWScript/Prover/MRSolver/Term.hs index 6f0ec6ee83..be3e316433 100644 --- a/src/SAWScript/Prover/MRSolver/Term.hs +++ b/src/SAWScript/Prover/MRSolver/Term.hs @@ -305,25 +305,6 @@ asSymBitvectorType :: Recognizer Term Term asSymBitvectorType (asVectorType -> Just (n, asBoolType -> Just ())) = Just n asSymBitvectorType _ = 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 - -- | Like 'asLambda', but only return's the lambda-bound variable's 'LocalName' asLambdaName :: Recognizer Term LocalName asLambdaName (asLambda -> Just (nm, _, _)) = Just nm From 040891e27354225e5bbe8823157c35f4a06b7d22 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Mon, 25 Dec 2023 13:10:23 -0500 Subject: [PATCH 253/305] add scWhnf to mrFunOutType and do some minor cleanup --- src/SAWScript/Prover/MRSolver/Evidence.hs | 2 +- src/SAWScript/Prover/MRSolver/Monad.hs | 19 +++++++++---------- src/SAWScript/Prover/MRSolver/Solver.hs | 8 ++++---- 3 files changed, 14 insertions(+), 15 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/Evidence.hs b/src/SAWScript/Prover/MRSolver/Evidence.hs index 2977020a9c..c265d32e1e 100644 --- a/src/SAWScript/Prover/MRSolver/Evidence.hs +++ b/src/SAWScript/Prover/MRSolver/Evidence.hs @@ -116,7 +116,7 @@ data FunAssump t = FunAssump { -- or @RewriteFunAssump t2@ otherwise asFunAssump :: Maybe t -> Recognizer Term (FunAssump t) asFunAssump ann (asRefinesS -> Just (RefinesS args - (asGlobalDef -> Just "Prelude.VoidEv") + (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 diff --git a/src/SAWScript/Prover/MRSolver/Monad.hs b/src/SAWScript/Prover/MRSolver/Monad.hs index 8bbdc7b9ab..dd6539d1ef 100644 --- a/src/SAWScript/Prover/MRSolver/Monad.hs +++ b/src/SAWScript/Prover/MRSolver/Monad.hs @@ -90,7 +90,7 @@ data MRFailure | MalformedTpDescList Term | MalformedDefs Term | MalformedComp Term - | NotCompFunType Term + | NotCompFunType Term Term | AssertionNotProvable Term | AssumptionNotProvable Term | InvariantNotProvable FunName FunName Term @@ -186,8 +186,9 @@ instance PrettyInCtx MRFailure where prettyPrefix "Cannot handle multiFixS recursive definitions term:" t prettyInCtx (MalformedComp t) = prettyPrefix "Could not handle computation:" t - prettyInCtx (NotCompFunType tp) = - prettyPrefix "Not a computation or computational function type:" tp + prettyInCtx (NotCompFunType tp t) = + prettyPrefixSep "Not a computation or computational function type:" tp + "for term:" t prettyInCtx (AssertionNotProvable cond) = prettyPrefix "Failed to prove assertion:" cond prettyInCtx (AssumptionNotProvable cond) = @@ -825,13 +826,11 @@ mrConvertible = liftSC4 scConvertibleEval scTypeCheckWHNF True -- 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 (ev, tp)) -> (ev,) <$> liftSC1 scWhnf tp - _ -> do pp_ftype <- funNameType fname >>= mrPPInCtx - pp_fname <- mrPPInCtx fname - mrDebugPrint 0 "mrFunOutType: function does not have SpecM return type" - mrDebugPretty 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 diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index 4fc540f6d2..542a56f635 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -1347,10 +1347,10 @@ 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 From 3858031589247e2a31ff9b5eabfaeb007aa17889 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Mon, 25 Dec 2023 13:41:44 -0500 Subject: [PATCH 254/305] fix ConstNatVecLen case of mrVecLenGen --- src/SAWScript/Prover/MRSolver/SMT.hs | 10 +++++++--- src/SAWScript/Prover/MRSolver/Solver.hs | 12 ++++++------ 2 files changed, 13 insertions(+), 9 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/SMT.hs b/src/SAWScript/Prover/MRSolver/SMT.hs index 4a9e8e502c..3c78e4ff3e 100644 --- a/src/SAWScript/Prover/MRSolver/SMT.hs +++ b/src/SAWScript/Prover/MRSolver/SMT.hs @@ -375,9 +375,13 @@ 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 _ len) tp f = - do len_tm <- liftSC1 scNat len - mrApplyGlobal "Prelude.gen" [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] diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index 542a56f635..a9f697c0a4 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -1070,12 +1070,12 @@ mrRefines' m1@(FunBind f1 args1 k1) zipWithM_ mrAssertProveEq args2'' args2 recordUsedFunAssump fa >> mrRefinesFun tp1 k1 tp2 k2 - -- -- If we have an opaque FunAssump that f1 refines some f /= f2, and f2 - -- -- unfolds and is not recursive in itself, unfold f2 and recurse - -- (_, Just fa@(FunAssump _ _ _ (OpaqueFunAssump _ _) _)) - -- | Just (f2_body, False) <- maybe_f2_body -> - -- normBindTerm f2_body k2 >>= \m2' -> - -- recordUsedFunAssump fa >> mrRefines m1 m2' + -- If we have an opaque FunAssump that f1 refines some f /= f2, and f2 + -- unfolds and is not recursive in itself, unfold f2 and recurse + (_, Just fa@(FunAssump _ _ _ (OpaqueFunAssump _ _) _)) + | Just (f2_body, False) <- maybe_f2_body -> + normBindTerm f2_body k2 >>= \m2' -> + recordUsedFunAssump fa >> mrRefines m1 m2' -- If we have a rewrite FunAssump, or we have an opaque FunAssump that -- f1 args1' refines some f args where f /= f2 and f2 does not match the From c8d3fa00ce24d1ac1aeb812ccbdd332c6618e895 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Mon, 25 Dec 2023 13:52:25 -0500 Subject: [PATCH 255/305] remove top-level type conversion check from mrProveRel --- src/SAWScript/Prover/MRSolver/SMT.hs | 17 ++++++----------- 1 file changed, 6 insertions(+), 11 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/SMT.hs b/src/SAWScript/Prover/MRSolver/SMT.hs index 3c78e4ff3e..b0e131b28b 100644 --- a/src/SAWScript/Prover/MRSolver/SMT.hs +++ b/src/SAWScript/Prover/MRSolver/SMT.hs @@ -848,17 +848,12 @@ mrProveRel het t1 t2 = mrDebugPPPrefixSep 2 nm t1 (if het then "~=" else "==") 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 ts_eq <- mrConvertible t1 t2 - res <- if ts_eq then return True - else do cond_in_ctx <- mrProveRelH het tp1 tp2 t1 t2 - withTermInCtx cond_in_ctx mrProvable - mrDebugPrint 2 $ nm ++ ": " ++ if res then "Success" else "Failure" - return res + ts_eq <- mrConvertible t1 t2 + res <- if ts_eq then return True + else do cond_in_ctx <- mrProveRelH het tp1 tp2 t1 t2 + withTermInCtx cond_in_ctx mrProvable + mrDebugPrint 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 From 62c99772d072420528e98af7e605a6b43bfacffb Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Mon, 25 Dec 2023 14:04:35 -0500 Subject: [PATCH 256/305] add a (albeit hacky) check for type equality back to refinementTermH --- src/SAWScript/Prover/MRSolver/Solver.hs | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index a9f697c0a4..9143f2ba28 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -1397,9 +1397,13 @@ refinementTermH :: Term -> Term -> MRM t Term refinementTermH t1 t2 = do (EvTerm ev, tp1) <- fromJust . asSpecM <$> mrTypeOf t1 (EvTerm _, tp2) <- fromJust . asSpecM <$> mrTypeOf t2 - -- tps_eq <- mrConvertible tp1 tp2 - -- unless tps_eq $ - -- throwMRFailure (ReturnTypesNotEq (Type tp1) (Type tp2)) + -- FIXME: Add a direct way to check that the types are related, instead of + -- calling 'mrProveRelH' on dummy variables and ignoring the result + withUVarLift "x" (Type tp1) (tp1,tp2) $ \x1 (tp1',tp2') -> + withUVarLift "x" (Type tp2') (tp1',tp2',x1) $ \x2 (tp1'',tp2'',x1') -> + do tp1''' <- mrSubstEVars tp1'' + tp2''' <- mrSubstEVars tp2'' + void $ mrProveRelH False tp1''' tp2''' x1' x2 rr <- liftSC2 scGlobalApply "SpecM.eqRR" [tp1] ref_tm <- liftSC2 scGlobalApply "SpecM.refinesS" [ev, tp1, tp1, rr, t1, t2] uvars <- mrUVarsOuterToInner From 9660e9d69aeea842eacda175acd567165dfd1abe Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Mon, 25 Dec 2023 17:37:44 -0500 Subject: [PATCH 257/305] add mrNormOpenTerm before any calls to mrRefinesFunH or mkInjReprType --- src/SAWScript/Prover/MRSolver/Solver.hs | 28 ++++++++++++------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index 9143f2ba28..d9d144b40d 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -740,7 +740,7 @@ generalizeCoIndHyp hyp all_specs@(arg_spec_0:arg_specs) = -- 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 + 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 @@ -752,7 +752,7 @@ generalizeCoIndHyp hyp all_specs@(arg_spec_0:arg_specs) = 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 + 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) -> @@ -995,14 +995,14 @@ mrRefines' (AssertBoolBind cond1 k1) m2 = mrRefines' m1 (ForallBind tp f2) = let nm = maybe "x" id (compFunVarName f2) in - mkInjReprType (typeTm tp) >>= \(tp', r) -> + 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 - mkInjReprType (typeTm tp) >>= \(tp', r) -> + mrNormOpenTerm (typeTm tp) >>= mkInjReprType >>= \(tp', r) -> withUVarLift nm (Type tp') (f1,m2) $ \x (f1',m2') -> mrApplyRepr r x >>= \x' -> applyNormCompFun f1' x' >>= \m1' -> @@ -1036,8 +1036,8 @@ mrRefines' (FunBind f args1 k1) (FunBind f' args2 k2) mrRefines' m1@(FunBind f1 args1 k1) m2@(FunBind f2 args2 k2) = - mrFunOutType f1 args1 >>= \(_, tp1) -> - mrFunOutType f2 args2 >>= \(_, tp2) -> + 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 -> @@ -1203,14 +1203,14 @@ mrRefines'' (AssumeBoolBind cond1 k1) m2 = mrRefines'' m1 (ExistsBind tp f2) = do let nm = maybe "x" id (compFunVarName f2) - (tp', r) <- mkInjReprType (typeTm tp) + (tp', r) <- mkInjReprType =<< mrNormOpenTerm (typeTm tp) evar <- mrFreshEVar nm (Type tp') evar' <- mrApplyRepr r evar m2' <- applyNormCompFun f2 evar' mrRefines m1 m2' mrRefines'' (ForallBind tp f1) m2 = do let nm = maybe "x" id (compFunVarName f1) - (tp', r) <- mkInjReprType (typeTm tp) + (tp', r) <- mkInjReprType =<< mrNormOpenTerm (typeTm tp) evar <- mrFreshEVar nm (Type tp') evar' <- mrApplyRepr r evar m1' <- applyNormCompFun f1 evar' @@ -1230,8 +1230,8 @@ 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'' @@ -1384,8 +1384,8 @@ 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 @@ -1426,6 +1426,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 From cf23d1ef7c1a317461a718761af55b289e7fa628 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Tue, 26 Dec 2023 12:49:59 -0500 Subject: [PATCH 258/305] change "Prelude." to "SpecM.", remove unused OpenTerm code --- .../src/Verifier/SAW/Heapster/CruUtil.hs | 3 - saw-core/src/Verifier/SAW/OpenTerm.hs | 467 +----------------- src/SAWScript/HeapsterBuiltins.hs | 4 +- src/SAWScript/Interpreter.hs | 2 +- src/SAWScript/Prover/MRSolver/Solver.hs | 8 +- 5 files changed, 8 insertions(+), 476 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/CruUtil.hs b/heapster-saw/src/Verifier/SAW/Heapster/CruUtil.hs index 6e0477016c..a5941f520e 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/CruUtil.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/CruUtil.hs @@ -186,9 +186,6 @@ instance Liftable Ident where instance NuMatching OpenTerm where nuMatchingProof = unsafeMbTypeRepr -instance NuMatching SpecTerm where - nuMatchingProof = unsafeMbTypeRepr - instance NuMatching GlobalSymbol where nuMatchingProof = unsafeMbTypeRepr diff --git a/saw-core/src/Verifier/SAW/OpenTerm.hs b/saw-core/src/Verifier/SAW/OpenTerm.hs index e08e6df3ab..571a31f725 100644 --- a/saw-core/src/Verifier/SAW/OpenTerm.hs +++ b/saw-core/src/Verifier/SAW/OpenTerm.hs @@ -99,13 +99,7 @@ module Verifier.SAW.OpenTerm ( arrayValueTermLike, bvLitTermLike, vectorTypeTermLike, bvTypeTermLike, pairTermLike, pairTypeTermLike, pairLeftTermLike, pairRightTermLike, tupleTermLike, tupleTypeTermLike, projTupleTermLike, - letTermLike, sawLetTermLike, - -- * Old approach to building SpecM computations - SpecTerm(), defineSpecOpenTerm, lambdaPureSpecTerm, lambdaPureSpecTermMulti, - lrtClosTypeSpecTerm, sawLetPureSpecTerm, lrtToTypeSpecTerm, - mkBaseClosSpecTerm, mkFreshClosSpecTerm, callClosSpecTerm, applyClosSpecTerm, - applyCallClosSpecTerm, importDefSpecTerm, monadicSpecOp, - specMTypeSpecTerm, returnSpecTerm, bindSpecTerm, errorSpecTerm, + letTermLike, sawLetTermLike ) where import qualified Data.Vector as V @@ -1100,465 +1094,6 @@ sawLetTermLike x tp tp_ret rhs body_f = [tp, tp_ret, rhs, lambdaTermLike x tp body_f] --------------------------------------------------------------------------------- --- Building SpecM computations (old stuff; remove) - --- | When creating a SAW core term of type @PolySpecFun@ or @PolyStackTuple@, --- the body or bodies are relative to: the current event type (or @EvType@); the --- @FunStack@ of @LetRecType@s of the locally-defined corecursive functions; the --- list of imported spec definitions; an extended stack that specifies the --- @FunStack@ of any future @SpecDef@ that this object will be used in; and a --- stack inclusion between the @FunStack@ defined by the local stack plus --- imports and the extended stack. These are captured by the 'SpecInfo' type. -data SpecInfo = - SpecInfo { specInfoEvType :: OpenTerm, - specInfoLocalsStack :: OpenTerm, - specInfoImps :: OpenTerm, - specInfoExtStack :: OpenTerm, - specInfoIncl :: OpenTerm } - --- | An 'OpenTerm' that depends on a 'SpecInfo'. These are used for the bodies --- of terms of type @PolySpecFun@ or @PolyStackTuple@. -type SpecInfoTerm = Reader SpecInfo OpenTerm - --- | Apply a 'SpecInfoTerm' to another -applySpecInfoTerm :: SpecInfoTerm -> SpecInfoTerm -> SpecInfoTerm -applySpecInfoTerm f arg = applyOpenTerm <$> f <*> arg - --- | Apply an operator to the event type, locals stack, imports, extended --- function stack, and tsack inclusion in the current 'SpecInfo' -applyStackInclOp :: Ident -> SpecInfoTerm -applyStackInclOp f = - do info <- ask - return $ applyGlobalOpenTerm f - [specInfoEvType info, specInfoLocalsStack info, specInfoImps info, - specInfoExtStack info, specInfoIncl info] - --- | Apply an operator to the current event type and extended function stack -applyExtStackOp :: Ident -> SpecInfoTerm -applyExtStackOp f = - do info <- ask - return $ applyGlobalOpenTerm f - [specInfoEvType info, specInfoExtStack info] - --- | Build the 'SpecInfoTerm' for the extended function stack -extStackSpecInfoTerm :: SpecInfoTerm -extStackSpecInfoTerm = ask >>= (return . specInfoExtStack) - --- | FIXME: docs -bindSpecInfoTerm :: (LocalName -> TypedTerm -> TypedTerm -> TermF TypedTerm) -> - LocalName -> SpecInfoTerm -> SpecInfoTerm -> SpecInfoTerm -bindSpecInfoTerm f x tpM bodyM = - do tpOT <- tpM - bodyOT <- bodyM - return $ OpenTerm $ do - -- First we compute the type of the variable by running its underlying TCM - -- computation and normalizing it; normalization is required here because - -- the typeInferComplete instance for TermF TypedTerm, which we use below, - -- assumes that the variable type is normalized - TypedTerm tp tp_tp <- unOpenTerm tpOT - tp_whnf <- typeCheckWHNF tp - let tp' = TypedTerm tp_whnf tp_tp - - -- Next, we run the body TCM computation to get its TypedTerm, making - -- sure to run that computation in an extended typing context with x - body <- withVar x tp_whnf $ unOpenTerm bodyOT - - -- Finally, build and return the required lambda-abstraction - typeInferComplete $ f x tp' body - - --- | In order to create a recursive function in a @SpecDef@, we need its --- @LetRecType@ and its definition as a @PolySpecFun E stk lrt@. The difficulty --- is that the function stack @stk@ is only known after we have fully processed --- all the recursive function definitions in the entire @SpecDef@, so we make --- the body depend on the @stk@ value; that is, 'specRecFunBody' should take in --- @stk@ and return a SAW core term of type @PolySpecFun E stk lrt@, where @lrt@ --- is the value of 'specRecFunLRT'. -data SpecRecFun = SpecRecFun { specRecFunLRT :: OpenTerm, - specRecFunBody :: Maybe SpecInfoTerm } - -tempSpecRecFun :: OpenTerm -> SpecRecFun -tempSpecRecFun lrt = SpecRecFun { specRecFunLRT = lrt, - specRecFunBody = Nothing } - --- | The state that is built up when building a 'SpecTerm' that is needed to --- make the top-level @defineSpec@ call; all the lists are accumulated in --- reverse order, so that the final index of elements already in the lists don't --- change as we add new elements -data SpecTermState = - SpecTermState { specStEvType :: OpenTerm, - specStNumBaseRecs :: Natural, - specStCtxLen :: Int, - specStExtraRecsRev :: [SpecRecFun], - specStImportsRev :: [OpenTerm] } - --- | Return the local corecursive functions in a 'SpecTermState' in the correct --- order, by reversing the reversed 'specStExtraRecsRev' list -specStExtraRecs :: SpecTermState -> [SpecRecFun] -specStExtraRecs st = reverse $ specStExtraRecsRev st - --- | Return the spec imports in a 'SpecTermState' in the correct order, by --- reversing the reversed 'specStImportsRev' list -specStImports :: SpecTermState -> [OpenTerm] -specStImports st = reverse (specStImportsRev st) - --- | Increment the context length of a 'SpecTermState' by the specified amount -specStIncCtx :: Int -> SpecTermState -> SpecTermState -specStIncCtx inc st = st { specStCtxLen = specStCtxLen st + inc } - --- | Decrement the context length of a 'SpecTermState' by the specified amount -specStDecCtx :: Int -> SpecTermState -> SpecTermState -specStDecCtx dec st = st { specStCtxLen = specStCtxLen st - dec } - -specStInsTempClos :: OpenTerm -> SpecTermState -> (Natural, SpecTermState) -specStInsTempClos lrt st = - (specStNumBaseRecs st + fromIntegral (length $ specStExtraRecsRev st), - st { specStExtraRecsRev = tempSpecRecFun lrt : specStExtraRecsRev st }) - -setNthClosBody :: Int -> SpecInfoTerm -> [SpecRecFun] -> [SpecRecFun] -setNthClosBody i _ recFuns - | i >= length recFuns || i < 0 = - panic "setNthClosBody" ["Index out of range"] -setNthClosBody i body recFuns = - let new_recFun = case recFuns!!i of - SpecRecFun lrt Nothing -> SpecRecFun lrt (Just body) - SpecRecFun _ (Just _) -> - panic "setNthClosBody" ["Closure body already set"] in - take i recFuns ++ new_recFun : drop (i+1) recFuns - -setNthClosBodyRev :: Int -> SpecInfoTerm -> [SpecRecFun] -> [SpecRecFun] -setNthClosBodyRev i body recFuns = - setNthClosBody (length recFuns - i) body recFuns - -specStSetClosBody :: Natural -> SpecInfoTerm -> SpecTermState -> SpecTermState -specStSetClosBody clos_ix body st = - st { specStExtraRecsRev = - setNthClosBodyRev (fromIntegral clos_ix) body (specStExtraRecsRev st) } - --- | Add a spec import with the given @LetRecType@ and body to the list of --- imported spec definitions in a 'SpecTermState' -specStInsImport :: OpenTerm -> OpenTerm -> SpecTermState -> - (Natural, SpecTermState) -specStInsImport lrt def st = - let imp = ctorOpenTerm "Prelude.Build_SpecImp" [specStEvType st, lrt, def] in - (fromIntegral (length $ specStImportsRev st), - st { specStImportsRev = imp : specStImportsRev st }) - -initSpecTermState :: OpenTerm -> Natural -> Int -> SpecTermState -initSpecTermState ev n ctx_len = - SpecTermState { specStEvType = ev, specStNumBaseRecs = n, - specStCtxLen = ctx_len, - specStExtraRecsRev = [], specStImportsRev = [] } - --- | High-level idea: while building a @SpecM@ computation, you have to keep --- track of the imported SpecDefs and the co-recursive functions that are --- created by defunctionalization, and this is tracked in this monad -type SpecTermM = State SpecTermState - -runSpecTermM :: OpenTerm -> Natural -> SpecTermM OpenTerm -> OpenTerm -runSpecTermM ev n m = OpenTerm $ - do ctx_len <- length <$> askCtx - unOpenTerm $ evalState m $ initSpecTermState ev n ctx_len - --- | A 'SpecTerm' is a term representation used to build @SpecM@ computations to --- be used in spec definitions, i.e., terms of type @SpecDef E@ for some given --- @E@. Any monadic functions or calls to functions that have been previously --- defined are lifted to the top level using the 'SpecTermM' monad. The --- resulting terms will always be inside a @PolySpecFun@ or @PolyStackTuple@, --- and so are in the context of the information provided by a 'SpecInfoTerm', --- thus the use of the 'SpecInfoTerm' type. -newtype SpecTerm = SpecTerm { unSpecTerm :: SpecTermM SpecInfoTerm } - -instance OpenTermLike SpecTerm where - openTermLike = openTermSpecTerm - typeOfTermLike = specTermType - flatTermLike = flatSpecTerm - applyTermLike = applySpecTerm - lambdaTermLike = lambdaSpecTerm - piTermLike = piSpecTerm - ctorTermLike = ctorSpecTerm - dataTypeTermLike = dataTypeSpecTerm - -applySpecTerm :: SpecTerm -> SpecTerm -> SpecTerm -applySpecTerm (SpecTerm f) (SpecTerm arg) = - SpecTerm (applySpecInfoTerm <$> f <*> arg) - -applySpecTermMulti :: SpecTerm -> [SpecTerm] -> SpecTerm -applySpecTermMulti = foldl applySpecTerm - -specInfoTermTerm :: SpecInfoTerm -> SpecTerm -specInfoTermTerm t = SpecTerm $ return t - --- | Convert an 'OpenTerm' to a 'SpecTerm' -openTermSpecTerm :: OpenTerm -> SpecTerm -openTermSpecTerm t = - SpecTerm $ - do ctx_len <- specStCtxLen <$> get - return $ return $ - OpenTerm $ - do ctx <- askCtx - if length ctx == ctx_len then unOpenTerm t else - panic "openTermSpecTerm" ["Typing context not of expected length\n" ++ - "Found: " ++ show (length ctx) ++ - ", Expected: " ++ show ctx_len] - --- | Return the type of a 'SpecTerm' as a 'SpecTerm' -specTermType :: SpecTerm -> SpecTerm -specTermType (SpecTerm m) = - SpecTerm $ flip fmap m $ \info_tm -> fmap openTermType info_tm - --- | Build the 'SpecTerm' for the extended function stack -extStackSpecTerm :: SpecTerm -extStackSpecTerm = specInfoTermTerm extStackSpecInfoTerm - --- | Build an 'OpenTerm' for the top variable in a 'SpecTermM' computation -topVarSpecTerm :: SpecTermM OpenTerm -topVarSpecTerm = - do outer_ctx_len <- specStCtxLen <$> get - return $ OpenTerm $ - do inner_ctx_len <- length <$> askCtx - typeInferComplete (LocalVar (inner_ctx_len - - outer_ctx_len) :: TermF Term) - --- | Run a 'SpecTermM' computation with a 'specStCtxLen' value that has been --- incremented by the specified amount. This means that the computation is --- intuitively inside a binding for that many variables. -withIncCtxLen :: Int -> SpecTermM a -> SpecTermM a -withIncCtxLen inc m = - do modify (specStIncCtx inc) - ret <- m - modify (specStDecCtx inc) - return ret - --- | Run a 'SpecTermM' computation in a context with an extra bound variable -withVarSpecTermM :: SpecTermM SpecInfoTerm -> SpecTermM SpecInfoTerm -withVarSpecTermM m = withIncCtxLen 1 m - --- | Build a lambda abstraction as a 'SpecTerm' from a function that takes in a --- pure 'OpenTerm' -lambdaPureSpecTerm :: LocalName -> SpecTerm -> (OpenTerm -> SpecTerm) -> SpecTerm -lambdaPureSpecTerm x (SpecTerm tpM) body_f = SpecTerm $ - do tp <- tpM - body <- withVarSpecTermM (topVarSpecTerm >>= (unSpecTerm . body_f)) - return $ bindSpecInfoTerm Lambda x tp body - --- | Build a nested sequence of pure lambda abstractions as a 'SpecTerm' -lambdaPureSpecTermMulti :: [(LocalName, SpecTerm)] -> - ([OpenTerm] -> SpecTerm) -> SpecTerm -lambdaPureSpecTermMulti xs_tps body_f = - foldr (\(x,tp) rest_f xs -> - lambdaPureSpecTerm x tp (rest_f . (:xs))) (body_f . reverse) xs_tps [] - --- | Build a lambda abstraction as a 'SpecTerm' -lambdaSpecTerm :: LocalName -> SpecTerm -> (SpecTerm -> SpecTerm) -> SpecTerm -lambdaSpecTerm x tp body_f = - lambdaPureSpecTerm x tp (body_f . openTermSpecTerm) - --- | Build a pi abstraction as a 'SpecTerm' -piSpecTerm :: LocalName -> SpecTerm -> (SpecTerm -> SpecTerm) -> SpecTerm -piSpecTerm x (SpecTerm tpM) body_f = SpecTerm $ - do tp <- tpM - body <- withVarSpecTermM (fmap openTermSpecTerm topVarSpecTerm >>= - (unSpecTerm . body_f)) - return $ bindSpecInfoTerm Pi x tp body - --- | Convert a term @lrt@ of type @LetRecType@ to the type it represents by --- forming the term @LRTArg stk lrt@ -lrtToTypeSpecTerm :: OpenTerm -> SpecTerm -lrtToTypeSpecTerm lrt = - applyGlobalTermLike "Prelude.LRTArg" - [specInfoTermTerm (specInfoExtStack <$> ask), openTermSpecTerm lrt] - -funStackTypeOpenTerm :: OpenTerm -funStackTypeOpenTerm = globalOpenTerm "Prelude.FunStack" - -letRecTypeOpenTerm :: OpenTerm -letRecTypeOpenTerm = dataTypeOpenTerm "Prelude.LetRecType" [] - -specImpOpenTerm :: OpenTerm -> OpenTerm -specImpOpenTerm ev = dataTypeOpenTerm "Prelude.SpecImp" [ev] - -defineSpecStackOpenTerm :: OpenTerm -> OpenTerm -> OpenTerm -> OpenTerm -defineSpecStackOpenTerm ev local_stk imps = - applyGlobalOpenTerm "Prelude.defineSpecStack" [ev, local_stk, imps] - -mkPolySpecLambda :: OpenTerm -> OpenTerm -> OpenTerm -> SpecInfoTerm -> OpenTerm -mkPolySpecLambda ev local_stk imps t = - let stk = defineSpecStackOpenTerm ev local_stk imps in - lambdaOpenTerm "stk'" funStackTypeOpenTerm $ \stk' -> - lambdaOpenTerm "incl" (applyGlobalOpenTerm - "Prelude.stackIncl" [stk, stk']) $ \incl -> - runReader t $ SpecInfo { specInfoEvType = ev, - specInfoLocalsStack = local_stk, - specInfoImps = imps, - specInfoExtStack = stk', - specInfoIncl = incl } - -mkSpecRecFunM :: OpenTerm -> SpecTerm -> SpecTermM SpecRecFun -mkSpecRecFunM lrt (SpecTerm m) = SpecRecFun lrt <$> Just <$> m - -specRecFunsStack :: [SpecRecFun] -> OpenTerm -specRecFunsStack recFuns = - list1OpenTerm letRecTypeOpenTerm $ map specRecFunLRT recFuns - -specRecFunsTuple :: [SpecRecFun] -> SpecInfoTerm -specRecFunsTuple recFuns = - tupleOpenTerm <$> forM recFuns - (\rf -> case specRecFunBody rf of - Just body -> body - Nothing -> panic "specRecFunsTuple" ["Recursive function body not defined"]) - --- | Build a spec definition, i.e., a term of type @SpecDef E@, given: an event --- type @E@; a list of corecursive functions that can be called in that spec --- definition, given as pairs of a @LetRecType@ and a 'SpecTerm' of that type; --- and a @LetRecType@ plus a body for the entire definition. -defineSpecOpenTerm :: OpenTerm -> [(OpenTerm,SpecTerm)] -> - OpenTerm -> SpecTerm -> OpenTerm -defineSpecOpenTerm ev base_recs_in lrt body_in = - runSpecTermM ev (fromIntegral $ length base_recs_in) $ - do base_recs <- - -- NOTE: the closures and the final body are going to be stuck inside a - -- lambda binding for the stack and stackIncl by mkPolySpecLambda, below, - -- so we increment their context lenghts for their SpecTermM computations - withIncCtxLen 2 $ - forM base_recs_in $ \(fun_lrt,fun_tm) -> mkSpecRecFunM fun_lrt fun_tm - body <- withIncCtxLen 2 $ unSpecTerm body_in - final_st <- get - let all_recs = base_recs ++ specStExtraRecs final_st - let local_stk = specRecFunsStack all_recs - let imps = list1OpenTerm (specImpOpenTerm ev) (specStImports final_st) - return $ applyGlobalOpenTerm "Prelude.defineSpec" - [ev, local_stk, lrt, imps, - mkPolySpecLambda ev local_stk imps (specRecFunsTuple all_recs), - mkPolySpecLambda ev local_stk imps body] - --- | Build the type @LRTClos stk lrt@ from @lrt@ in the current stack -lrtClosTypeSpecTerm :: OpenTerm -> SpecTerm -lrtClosTypeSpecTerm lrt = - applyGlobalTermLike "Prelude.LRTClos" [extStackSpecTerm, - openTermSpecTerm lrt] - --- | Internal-only helper function -mkClosSpecInfoTerm :: Natural -> SpecInfoTerm -mkClosSpecInfoTerm n = - applySpecInfoTerm (applyStackInclOp "Prelude.mkLocalLRTClos") - (return $ natOpenTerm n) - --- | Build a closure that calls one of the "base" recursive functions in the --- current spec definition -mkBaseClosSpecTerm :: Natural -> SpecTerm -mkBaseClosSpecTerm clos_ix = SpecTerm $ - do st <- get - if clos_ix < specStNumBaseRecs st then return () else - panic "mkBaseClosSpec" ["Closure index out of bounds"] - return $ mkClosSpecInfoTerm clos_ix - --- | Build a closure that calls a new corecursive function with the given --- @LetRecType@ and body, that can call itself using the term passed to it -mkFreshClosSpecTerm :: OpenTerm -> (SpecTerm -> SpecTerm) -> SpecTerm -mkFreshClosSpecTerm lrt body_f = SpecTerm $ - do (clos_ix, st) <- specStInsTempClos lrt <$> get - put st - body <- unSpecTerm $ body_f (SpecTerm $ return $ - mkClosSpecInfoTerm clos_ix) - modify $ specStSetClosBody clos_ix body - return $ mkClosSpecInfoTerm clos_ix - --- | Apply a closure of a given @LetRecType@ to a list of arguments -applyClosSpecTerm :: OpenTerm -> SpecTerm -> [SpecTerm] -> SpecTerm -applyClosSpecTerm lrt clos args = - applyGlobalTermLike "Prelude.applyLRTClosN" - (extStackSpecTerm : natTermLike (fromIntegral $ length args) - : openTermSpecTerm lrt : clos : args) - --- | Build a @SpecM@ computation that calls a closure with the given return --- type specified as a @LetRecType@ -callClosSpecTerm :: OpenTerm -> SpecTerm -> SpecTerm -callClosSpecTerm tp clos = - applySpecTermMulti (monadicSpecOp "Prelude.CallS") - [openTermSpecTerm tp, clos] - --- | Convert a closure of a given @LetRecType@ to a spec function and apply it --- to some number of arguments -applyCallClosSpecTerm :: OpenTerm -> SpecTerm -> [SpecTerm] -> SpecTerm -applyCallClosSpecTerm lrt clos args = - applySpecTermMulti (monadicSpecOp "Prelude.applyCallClos") - (openTermSpecTerm lrt : clos : args) - --- | Import another spec definition inside a spec definition, and return the --- @SpecFun@ that calls its body -importDefSpecTerm :: OpenTerm -> OpenTerm -> SpecTerm -importDefSpecTerm lrt def = SpecTerm $ - do (imp_ix, st) <- specStInsImport lrt def <$> get - put st - return $ - applySpecInfoTerm (applyStackInclOp "Prelude.callNthImportS") - (return $ natOpenTerm imp_ix) - --- | Build a 'SpecTerm' for a monadic operation that takes the current event --- type and extended function stack -monadicSpecOp :: Ident -> SpecTerm -monadicSpecOp f = specInfoTermTerm $ applyExtStackOp f - --- | Build the type @SpecM ev stk tp@ from the type @tp@ -specMTypeSpecTerm :: SpecTerm -> SpecTerm -specMTypeSpecTerm = applySpecTerm (monadicSpecOp "Prelude.SpecM") - --- | Build a @SpecM@ computation that returns a value of a given type -returnSpecTerm :: SpecTerm -> SpecTerm -> SpecTerm -returnSpecTerm tp val = - applySpecTermMulti (monadicSpecOp "Prelude.retS") [tp, val] - --- | Build a @SpecM@ computation that does a monadic bind -bindSpecTerm :: SpecTerm -> SpecTerm -> SpecTerm -> - SpecTerm -> SpecTerm -bindSpecTerm tp1 tp2 m f = - applySpecTermMulti (monadicSpecOp "Prelude.bindS") [tp1, tp2, m, f] - --- | Build a @SpecM@ error computation at the given type with the given message -errorSpecTerm :: SpecTerm -> Text -> SpecTerm -errorSpecTerm tp msg = - applySpecTermMulti (monadicSpecOp "Prelude.errorS") - [tp, openTermSpecTerm (stringLitOpenTerm msg)] - --- | Build a 'SpecInfoTerm' from a 'FlatTermF' -flatSpecInfoTerm :: FlatTermF SpecInfoTerm -> SpecInfoTerm -flatSpecInfoTerm ftf = fmap flatOpenTerm $ sequence ftf - --- | Build a 'SpecTerm' from a 'FlatTermF' -flatSpecTerm :: FlatTermF SpecTerm -> SpecTerm -flatSpecTerm ftf = - SpecTerm $ fmap flatSpecInfoTerm $ sequence (fmap unSpecTerm ftf) - --- | Build a 'SpecInfoTerm' for a constructor applied to its arguments -ctorSpecInfoTerm :: Ident -> [SpecInfoTerm] -> SpecInfoTerm -ctorSpecInfoTerm c args = fmap (ctorOpenTerm c) (sequence args) - --- | Build a 'SpecTerm' for a constructor applied to its arguments -ctorSpecTerm :: Ident -> [SpecTerm] -> SpecTerm -ctorSpecTerm c args = - SpecTerm $ fmap (ctorSpecInfoTerm c) $ sequence $ map unSpecTerm args - --- | Build a 'SpecInfoTerm' for a datatype applied to its arguments -dataTypeSpecInfoTerm :: Ident -> [SpecInfoTerm] -> SpecInfoTerm -dataTypeSpecInfoTerm d args = fmap (dataTypeOpenTerm d) (sequence args) - --- | Build a 'SpecTerm' for a datatype applied to its arguments -dataTypeSpecTerm :: Ident -> [SpecTerm] -> SpecTerm -dataTypeSpecTerm d args = - SpecTerm $ fmap (dataTypeSpecInfoTerm d) $ sequence $ map unSpecTerm args - --- | Build a let expression as an 'SpecTerm'. This is equivalent to --- > 'applySpecTerm' ('lambdaSpecTerm' x tp body) rhs -sawLetPureSpecTerm :: LocalName -> SpecTerm -> SpecTerm -> SpecTerm -> - (OpenTerm -> SpecTerm) -> SpecTerm -sawLetPureSpecTerm x tp tp_ret rhs body_f = - applySpecTermMulti (globalTermLike "Prelude.sawLet") - [tp, tp_ret, rhs, lambdaPureSpecTerm x tp body_f] - - - -------------------------------------------------------------------------------- -- sawLet-minimization diff --git a/src/SAWScript/HeapsterBuiltins.hs b/src/SAWScript/HeapsterBuiltins.hs index e404543fb3..851833be73 100644 --- a/src/SAWScript/HeapsterBuiltins.hs +++ b/src/SAWScript/HeapsterBuiltins.hs @@ -1086,8 +1086,8 @@ heapster_typecheck_mut_funs_rename _bic opts henv fn_names_and_perms = warnErrs nm_to =<< fmap (fromJust . defBody) (scRequireDef sc $ mkSafeIdent saw_modname nm_to) where warnErrs :: String -> Term -> IO () - warnErrs nm (asApplyAll -> (asGlobalDef -> Just "Prelude.errorS", - [_ev, _stk, _a, asStringLit -> Just msg])) + 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 printOutLn opts Warn (pref ++ nm ++ ":\n" ++ msg_body ++ "\n") diff --git a/src/SAWScript/Interpreter.hs b/src/SAWScript/Interpreter.hs index 035ab53bca..bb67b98981 100644 --- a/src/SAWScript/Interpreter.hs +++ b/src/SAWScript/Interpreter.hs @@ -4254,7 +4254,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." ] --------------------------------------------------------------------- diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index d9d144b40d..b6b2f27a37 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -309,7 +309,7 @@ normComp (CompTerm t) = {- FIXME HERE NOW: match a tuple projection of a MultiFixS - (isGlobalDef "Prelude.MultiFixS" -> Just (), ev:tp_ds:defs:args) -> + (isGlobalDef "SpecM.MultiFixS" -> Just (), ev:tp_ds:defs:args) -> do -- Bind fresh function vars for the new recursive functions fun_vars <- mrFreshCallVars ev tp_ds defs @@ -538,7 +538,7 @@ compFunToTerm (CompFunComp f g) = case (f_tp, g_tp) of (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'') -> @@ -556,14 +556,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" -} From 4db5da6615dca07d2410cf76196d6838f40f41e9 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Tue, 26 Dec 2023 13:50:51 -0500 Subject: [PATCH 259/305] only unfold main fun in warnErrs, unfold __bodies in print_fun_trans --- src/SAWScript/HeapsterBuiltins.hs | 31 +++++++++++++++++++------------ 1 file changed, 19 insertions(+), 12 deletions(-) diff --git a/src/SAWScript/HeapsterBuiltins.hs b/src/SAWScript/HeapsterBuiltins.hs index 851833be73..16aaec3427 100644 --- a/src/SAWScript/HeapsterBuiltins.hs +++ b/src/SAWScript/HeapsterBuiltins.hs @@ -1082,16 +1082,14 @@ 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, _) -> liftIO $ - warnErrs nm_to =<< fmap (fromJust . defBody) - (scRequireDef sc $ mkSafeIdent saw_modname nm_to) - where warnErrs :: String -> Term -> IO () + 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])) + [_ev, _a, asStringLit -> Just msg])) | Just msg_body <- stripPrefix implicationFailurePrefix (T.unpack msg) = let pref = "WARNING: Heapster implication failure while typechecking " - in printOutLn opts Warn (pref ++ nm ++ ":\n" ++ msg_body ++ "\n") - warnErrs nm (asConstant -> Just (_, Just body)) = warnErrs nm body + 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 @@ -1142,16 +1140,25 @@ heapster_set_event_type _bic _opts henv term_string = liftIO $ modifyIORef' (heapsterEnvPermEnvRef henv) $ \env -> env { permEnvEventType = EventType (globalOpenTerm ev_id) } +-- | 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 + -- | 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 - sc <- getSharedContext - let saw_modname = heapsterEnvSAWModule henv - fun_term <- - fmap (fromJust . defBody) $ - liftIO $ scRequireDef sc $ mkSafeIdent saw_modname fn_name + 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 From 0cf71be1c228a66a6b40f417522bbaecb6f5bf60 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 28 Dec 2023 07:25:57 -0800 Subject: [PATCH 260/305] added tuple shapes; changed the translation of memblock permissions to always be 0 or 1 terms, tupling what used to be multiple terms together; still need to update the translations of the implication rules for memblock permissions to work with this new translation --- .../src/Verifier/SAW/Heapster/Implication.hs | 62 ++++++++ .../src/Verifier/SAW/Heapster/Permissions.hs | 27 ++++ .../Verifier/SAW/Heapster/SAWTranslation.hs | 149 +++++++++++------- 3 files changed, 182 insertions(+), 56 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs b/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs index dfe8a227bb..9fc20b80dd 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs @@ -61,6 +61,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 @@ -1117,6 +1118,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) @@ -2161,6 +2176,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) = @@ -2538,6 +2558,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 = @@ -3163,6 +3188,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 |] -> @@ -5520,6 +5549,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 @@ -7988,6 +8021,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 diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs index 7c43c160f3..2705f4fc02 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs @@ -259,6 +259,9 @@ data PermExpr (a :: CrucibleType) where 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) @@ -1683,6 +1686,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 @@ -1764,6 +1770,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 @@ -4298,6 +4307,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 @@ -4364,6 +4374,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) = @@ -4396,6 +4407,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) = @@ -4547,6 +4559,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) = @@ -4844,6 +4857,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) @@ -4985,11 +5000,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 @@ -6130,6 +6147,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) = @@ -6390,6 +6408,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) = @@ -6552,6 +6571,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) = @@ -6663,6 +6683,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) = @@ -6880,6 +6901,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 |] -> @@ -7651,6 +7673,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 @@ -8008,6 +8033,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) = @@ -8597,6 +8623,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 diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 83740c0e98..85008170b0 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -240,9 +240,10 @@ 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 a list of 0 or more type descriptions along - -- with the translations to the types they represent, in that order - ETrans_Shape :: [OpenTerm] -> [OpenTerm] -> ExprTrans (LLVMShapeType w) + -- | 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 @@ -256,13 +257,19 @@ data ExprTrans (a :: CrucibleType) where type ExprTransCtx = RAssign ExprTrans --- | Destruct an 'ExprTrans' of shape type to a list of type descriptions and --- the types they represent, in that order -unETransShape :: ExprTrans (LLVMShapeType w) -> ([OpenTerm], [OpenTerm]) -unETransShape (ETrans_Shape ds tps) = (ds, tps) +-- | 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]) @@ -315,7 +322,8 @@ instance IsTermTrans (ExprTrans tp) where transTerms ETrans_Fun = [] transTerms ETrans_Unit = [] transTerms ETrans_AnyVector = [] - transTerms (ETrans_Shape ds _) = [tupleTpDesc ds] + transTerms (ETrans_Shape (Just (d, _))) = [d] + transTerms (ETrans_Shape Nothing) = [] transTerms (ETrans_Perm ds _) = [tupleTpDesc ds] transTerms (ETrans_Term _ t) = [t] @@ -338,11 +346,12 @@ 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 [d] [tpElemTypeOpenTerm ?ev d]) +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]) + mkTypeTrans1 tpDescTypeOpenTerm $ \d -> + ETrans_Perm [d] [tpElemTypeOpenTerm ?ev d] exprTransType (ETrans_Term tp t) = mkTypeTrans1 (openTermType t) (ETrans_Term tp) @@ -368,7 +377,8 @@ exprTransDescs (ETrans_Struct etranss) = exprTransDescs ETrans_Fun = [] exprTransDescs ETrans_Unit = [] exprTransDescs ETrans_AnyVector = [] -exprTransDescs (ETrans_Shape ds _) = ds +exprTransDescs (ETrans_Shape (Just (d, _))) = [d] +exprTransDescs (ETrans_Shape Nothing) = [] exprTransDescs (ETrans_Perm ds _) = ds exprTransDescs (ETrans_Term tp t) = case translateKindDescs tp of @@ -985,8 +995,8 @@ translateType (ValuePermRepr _) = ETrans_Perm [d] [tpElemTypeOpenTerm ?ev d]), [tpKindDesc]) translateType (LLVMShapeRepr _) = - (mkTypeTrans1 tpDescTypeOpenTerm (\d -> - ETrans_Shape [d] [tpElemTypeOpenTerm ?ev d]), + (mkTypeTrans1 tpDescTypeOpenTerm (\d -> ETrans_Shape + (Just (d, tpElemTypeOpenTerm ?ev d))), [tpKindDesc]) translateType tp@(FloatRepr _) = @@ -1345,7 +1355,7 @@ instance TransInfo info => -- LLVM shapes are translated to type descriptions by translateDescs [nuMP| PExpr_EmptyShape |] -> - return $ ETrans_Shape [] [] + return $ ETrans_Shape Nothing [nuMP| PExpr_NamedShape _ _ nmsh args |] -> case mbMatch $ fmap namedShapeBody nmsh of [nuMP| DefinedShapeBody _ |] -> @@ -1358,8 +1368,9 @@ instance TransInfo info => args_terms <- transTerms <$> translate args args_ds <- descTransM $ translateDescs args return $ - ETrans_Shape [substIndIdTpDescMulti (mbLift desc_id) k_ds args_ds] - [applyGlobalOpenTerm (mbLift tp_id) args_terms] + 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) = @@ -1368,32 +1379,42 @@ instance TransInfo info => args_terms <- transTerms <$> translate args args_ds <- descTransM $ translateDescs args return $ - ETrans_Shape [substIdTpDescMulti (mbLift desc_id) k_ds args_ds] - [applyGlobalOpenTerm (mbLift tp_id) args_terms] - [nuMP| PExpr_EqShape _ _ |] -> return $ ETrans_Shape [] [] + 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_Shape <$> descTransM (translateDescs fsh) <*> 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_ds, elem_tps) <- unETransShape <$> translate mb_sh + (elem_d, elem_tp) <- unETransShapeTuple <$> translate mb_sh return $ - ETrans_Shape [bvVecTpDesc w_term len_d (tupleTpDesc elem_ds)] - [bvVecTypeOpenTerm w_term len_term (tupleTypeOpenTerm' elem_tps)] + ETrans_Shape + (Just (bvVecTpDesc w_term len_d elem_d, + bvVecTypeOpenTerm w_term len_term elem_tp)) + [nuMP| PExpr_TupShape sh |] -> + ETrans_Shape <$> Just <$> unETransShapeTuple <$> translate sh [nuMP| PExpr_SeqShape sh1 sh2 |] -> - do (ds1, tps1) <- unETransShape <$> translate sh1 - (ds2, tps2) <- unETransShape <$> translate sh2 - return $ ETrans_Shape (ds1 ++ ds2) (tps1 ++ tps2) + do shtr1 <- unETransShape <$> translate sh1 + shtr2 <- unETransShape <$> translate sh2 + return $ ETrans_Shape $ case (shtr1, shtr2) of + (Nothing, _) -> shtr2 + (_, Nothing) -> shtr1 + (Just (d1,tp1), Just (d2,tp2)) -> + Just (pairTpDesc d1 d2, pairTypeOpenTerm tp1 tp2) [nuMP| PExpr_OrShape sh1 sh2 |] -> - do (ds1, tps1) <- unETransShape <$> translate sh1 - (ds2, tps2) <- unETransShape <$> translate sh2 + do (d1, tp1) <- unETransShapeTuple <$> translate sh1 + (d2, tp2) <- unETransShapeTuple <$> translate sh2 return $ - ETrans_Shape [sumTpDesc (tupleTpDesc ds1) (tupleTpDesc ds2)] - [eitherTypeOpenTerm - (tupleTypeOpenTerm' tps1) (tupleTypeOpenTerm' tps2)] + 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 @@ -1410,12 +1431,12 @@ instance TransInfo info => -- whereas the description of the sigma type requires binding deBruijn -- index for that sigma type variable tp <- sigmaTypeTransM "x_exsh" tptrans $ \e -> - inExtTransM e (openTermsTypeTrans <$> snd <$> - unETransShape <$> translate mb_sh) - return $ ETrans_Shape [d] [tp] + inExtTransM e (openTermTypeTrans <$> snd <$> + unETransShapeTuple <$> translate mb_sh) + return $ ETrans_Shape $ Just (d, tp) [nuMP| PExpr_FalseShape |] -> return $ - ETrans_Shape [voidTpDesc] [dataTypeOpenTerm "Prelude.Void" []] + ETrans_Shape $ Just (voidTpDesc, dataTypeOpenTerm "Prelude.Void" []) [nuMP| PExpr_ValPerm p |] -> ETrans_Perm <$> descTransM (translateDescs p) <*> (typeTransTypes <$> @@ -1533,7 +1554,10 @@ instance TranslateDescs (PermExpr a) where -- 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 + -- 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 @@ -1555,17 +1579,25 @@ instance TranslateDescs (PermExpr a) where return [substIndIdTpDescMulti (mbLift desc_id) k_ds args_ds] [nuMP| PExpr_EqShape _ _ |] -> return [] [nuMP| PExpr_PtrShape _ _ sh |] -> translateDescs sh - [nuMP| PExpr_FieldShape fsh |] -> translateDescs fsh + [nuMP| PExpr_FieldShape fsh |] -> + translateDescs fsh >>= \case + [] -> return [] + ds -> return [tupleTpDesc ds] [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 - return (ds1 ++ ds2) + -- 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 [tupleTpDesc (ds1 ++ ds2)] [nuMP| PExpr_OrShape sh1 sh2 |] -> (\d -> [d]) <$> (sumTpDesc <$> translateDesc sh1 <*> translateDesc sh2) [nuMP| PExpr_ExShape mb_sh |] -> @@ -1647,10 +1679,11 @@ data AtomicPermTrans ctx a where LLVMArrayPermTrans ctx w -> AtomicPermTrans ctx (LLVMPointerType w) - -- | The translation of an LLVM block permission is a sequence of elements of - -- the translations of its shapes to types + -- | The translation of an LLVM block permission is an element of the + -- translation of its shape to a type or 'Nothing' if the shape translates to + -- no types APTrans_LLVMBlock :: (1 <= w, KnownNat w) => - Mb ctx (LLVMBlockPerm w) -> [OpenTerm] -> + Mb ctx (LLVMBlockPerm w) -> Maybe OpenTerm -> AtomicPermTrans ctx (LLVMPointerType w) -- | LLVM free permissions have no computational content @@ -1669,10 +1702,12 @@ data AtomicPermTrans ctx a where APTrans_IsLLVMPtr :: (1 <= w, KnownNat w) => AtomicPermTrans ctx (LLVMPointerType w) - -- | The translation of an LLVMBlockShape permission is a sequence of elements - -- of the translations of its shape to types + -- | The translation of an LLVMBlockShape permission is an element of the + -- translation of its shape to a type or 'Nothing' if the shape translates to + -- no types APTrans_LLVMBlockShape :: (1 <= w, KnownNat w) => - Mb ctx (PermExpr (LLVMShapeType w)) -> [OpenTerm] -> + Mb ctx (PermExpr (LLVMShapeType w)) -> + Maybe OpenTerm -> AtomicPermTrans ctx (LLVMBlockType w) -- | Perm_NamedConj permissions are a permission + a term @@ -1886,11 +1921,11 @@ instance IsTermTrans (PermTransCtx ctx ps) where instance IsTermTrans (AtomicPermTrans ctx a) where transTerms (APTrans_LLVMField _ ptrans) = transTerms ptrans transTerms (APTrans_LLVMArray arr_trans) = transTerms arr_trans - transTerms (APTrans_LLVMBlock _ ts) = ts + transTerms (APTrans_LLVMBlock _ ts) = maybeToList ts transTerms (APTrans_LLVMFree _) = [] transTerms (APTrans_LLVMFunPtr _ trans) = transTerms trans transTerms APTrans_IsLLVMPtr = [] - transTerms (APTrans_LLVMBlockShape _ ts) = ts + transTerms (APTrans_LLVMBlockShape _ ts) = maybeToList ts transTerms (APTrans_NamedConj _ _ _ t) = [t] transTerms (APTrans_DefinedNamedConj _ _ _ ptrans) = transTerms ptrans transTerms (APTrans_LLVMFrame _) = [] @@ -2834,9 +2869,10 @@ instance TransInfo info => fmap APTrans_LLVMArray <$> translate ap [nuMP| Perm_LLVMBlock bp |] -> - do (_, tps) <- unETransShape <$> translate (fmap llvmBlockShape bp) - return $ TypeTrans tps (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 |] -> @@ -2845,8 +2881,10 @@ instance TransInfo info => [nuMP| Perm_IsLLVMPtr |] -> return $ mkTypeTrans0 APTrans_IsLLVMPtr [nuMP| Perm_LLVMBlockShape sh |] -> - do (_, tps) <- unETransShape <$> translate sh - return $ TypeTrans tps (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 @@ -4631,6 +4669,8 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of pctx :>: typeTransF ttrans ts) m +-- FIXME HERE NOWNOW + [nuMP| SImpl_IntroLLVMBlockSeq _ _ _ _ |] -> do ttrans <- translateSimplImplOutHead mb_simpl withPermStackTermsM @@ -5658,9 +5698,6 @@ translateCallEntry nm entry_trans mb_tops mb_args mb_ghosts = -- First test that the stack == the required perms for entryID do let entry = typedEntryTransEntry entry_trans ectx_ag <- translate $ mbMap2 RL.append mb_args mb_ghosts - -- FIXME @Eddy: Is `ectx` not getting used here a bug? - ectx <- translate (mbMap2 RL.append - (mbMap2 RL.append mb_tops mb_args) mb_ghosts) pctx <- itiPermStack <$> ask let mb_tops_args = mbMap2 RL.append mb_tops mb_args let mb_s = From 8ab89dd94ad67e104ae57833d18f8f5c23faefaa Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 28 Dec 2023 08:12:44 -0800 Subject: [PATCH 261/305] updated the translations of the memblock implication rules --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 47 ++++++++++++++++--- 1 file changed, 40 insertions(+), 7 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 85008170b0..55bf447c61 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -203,6 +203,12 @@ listTypeTrans :: [TypeTrans tr] -> TypeTrans [tr] listTypeTrans [] = pure [] listTypeTrans (trans:transs) = 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] + ---------------------------------------------------------------------- -- * Expression Translations @@ -4532,6 +4538,22 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of pctx :>: typeTransF ttrans [arr_term]) m + [nuMP| SImpl_IntroLLVMBlockTuple _ _ |] -> + do ttrans <- translateSimplImplOutHead mb_simpl + withPermStackTopTermsM id + (\ts (pctx :>: _) -> + pctx :>: typeTransF ttrans [tupleOpenTerm' ts]) + m + + [nuMP| SImpl_ElimLLVMBlockTuple _ mb_bp |] -> + do ttrans <- translateSimplImplOutHead mb_simpl + shtrans <- unETransShape <$> translate (mbLLVMBlockShape mb_bp) + withPermStackTopTermsM id + (\ts (pctx :>: _) -> + let ts' = case shtrans of { Just _ -> ts ; Nothing -> [] } in + pctx :>: typeTransF ttrans ts') + m + [nuMP| SImpl_IntroLLVMBlockSeqEmpty _ _ |] -> do ttrans <- translateSimplImplOutHead mb_simpl withPermStackTopTermsM id @@ -4645,14 +4667,17 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of do ttrans <- translateSimplImplOutHead mb_simpl withPermStackTopTermsM id (\ts (pctx :>: _) -> - pctx :>: typeTransF ttrans ts) + pctx :>: typeTransF ttrans (tupleOpenTermList ts)) m [nuMP| SImpl_ElimLLVMBlockField _ _ |] -> do ttrans <- translateSimplImplOutHead mb_simpl withPermStackTopTermsM id (\ts (pctx :>: _) -> - pctx :>: typeTransF ttrans ts) + -- 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 _ _ |] -> @@ -4669,21 +4694,29 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of pctx :>: typeTransF ttrans ts) m --- FIXME HERE NOWNOW - [nuMP| SImpl_IntroLLVMBlockSeq _ _ _ _ |] -> do ttrans <- translateSimplImplOutHead mb_simpl withPermStackTermsM (\(_ :>: ptrans1 :>: ptrans2) -> (ptrans1,ptrans2)) RL.tail - (\ts (pctx :>: _ :>: _) -> pctx :>: typeTransF ttrans ts) + (\ts (pctx :>: _ :>: _) -> + pctx :>: typeTransF ttrans (tupleOpenTermList ts)) m - [nuMP| SImpl_ElimLLVMBlockSeq _ _ _ |] -> + [nuMP| SImpl_ElimLLVMBlockSeq _ mb_bp mb_sh2 |] -> do ttrans <- translateSimplImplOutHead mb_simpl + shtrans1 <- unETransShape <$> translate (mbLLVMBlockShape mb_bp) + shtrans2 <- unETransShape <$> translate mb_sh2 withPermStackTopTermsM id (\ts (pctx :>: _) -> - pctx :>: typeTransF ttrans ts) + -- 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 _ _ _ |] -> From 43a23195067e67a707eac7cb82f3526091cd2d7b Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 29 Dec 2023 06:36:52 -0800 Subject: [PATCH 262/305] added more debug info for translating LLVM globals --- heapster-saw/src/Verifier/SAW/Heapster/LLVMGlobalConst.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/LLVMGlobalConst.hs b/heapster-saw/src/Verifier/SAW/Heapster/LLVMGlobalConst.hs index 98d39c0728..6887ea5077 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/LLVMGlobalConst.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/LLVMGlobalConst.hs @@ -273,7 +273,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 From 1f9b98002cd08f5e4f14b799c95e57397910a7a6 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 29 Dec 2023 06:49:17 -0800 Subject: [PATCH 263/305] whoops, fixed the translation of sequence shapes where both sides have no empty translations --- .../src/Verifier/SAW/Heapster/SAWTranslation.hs | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 55bf447c61..6a317b508c 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -209,6 +209,12 @@ 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 @@ -1585,10 +1591,7 @@ instance TranslateDescs (PermExpr a) where return [substIndIdTpDescMulti (mbLift desc_id) k_ds args_ds] [nuMP| PExpr_EqShape _ _ |] -> return [] [nuMP| PExpr_PtrShape _ _ sh |] -> translateDescs sh - [nuMP| PExpr_FieldShape fsh |] -> - translateDescs fsh >>= \case - [] -> return [] - ds -> return [tupleTpDesc ds] + [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 @@ -1603,7 +1606,7 @@ instance TranslateDescs (PermExpr a) where -- 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 [tupleTpDesc (ds1 ++ ds2)] + return $ tupleTpDescList (ds1 ++ ds2) [nuMP| PExpr_OrShape sh1 sh2 |] -> (\d -> [d]) <$> (sumTpDesc <$> translateDesc sh1 <*> translateDesc sh2) [nuMP| PExpr_ExShape mb_sh |] -> From ba071ac9fdeeffedad22b0b5cc38d51efb593b19 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 29 Dec 2023 07:10:12 -0800 Subject: [PATCH 264/305] updated permEnvAddGlobalConst to fit with the new translation of memblock permissions to have 0 or 1 terms --- .../src/Verifier/SAW/Heapster/LLVMGlobalConst.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/LLVMGlobalConst.hs b/heapster-saw/src/Verifier/SAW/Heapster/LLVMGlobalConst.hs index 6887ea5077..9eee6e4867 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/LLVMGlobalConst.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/LLVMGlobalConst.hs @@ -290,6 +290,11 @@ 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, []) -> + 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 <- @@ -300,11 +305,6 @@ permEnvAddGlobalConst sc mod_name dlevel endianness w env global = 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 - let tps_len = fromIntegral $ length tps - let projs = - map (\i -> projTupleOpenTerm' tps_len i t_ident) $ - take (length ts) [0 ..] return $ permEnvAddGlobalSyms env [PermEnvGlobalEntry (GlobalSymbol $ L.globalSym global) p - (GlobalTrans projs)] + (GlobalTrans [globalOpenTerm ident])] From 97b7593283077e48f1b43125c768f8003105f72f Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 29 Dec 2023 07:23:35 -0800 Subject: [PATCH 265/305] added parsing support for tuple shapes --- heapster-saw/src/Verifier/SAW/Heapster/Lexer.x | 1 + heapster-saw/src/Verifier/SAW/Heapster/Parser.y | 2 ++ heapster-saw/src/Verifier/SAW/Heapster/Token.hs | 2 ++ heapster-saw/src/Verifier/SAW/Heapster/TypeChecker.hs | 1 + heapster-saw/src/Verifier/SAW/Heapster/UntypedAST.hs | 2 ++ 5 files changed, 8 insertions(+) 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/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/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 From ca65cb15895fe0bdf3dc43f5b04f967158d4d18f Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 29 Dec 2023 07:23:59 -0800 Subject: [PATCH 266/305] added an explicit tuple shape to the type of memcpy in rust_data.saw --- heapster-saw/examples/rust_data.saw | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/heapster-saw/examples/rust_data.saw b/heapster-saw/examples/rust_data.saw index 5b6e3ab892..90744acb6b 100644 --- a/heapster-saw/examples/rust_data.saw +++ b/heapster-saw/examples/rust_data.saw @@ -253,7 +253,7 @@ heapster_assume_fun env "llvm.expect.i1" heapster_assume_fun env "llvm.memcpy.p0i8.p0i8.i64" "(rw:rwmodality, l1:lifetime, l2:lifetime, sh:llvmshape 64, \ \ b:llvmblock 64, len:bv 64). \ - \ arg0:[l1]memblock(W,0,len,sh), arg1:[l2]memblock(rw,0,len,eqsh(len,b)), \ + \ arg0:[l1]memblock(W,0,len,tuplesh(sh)), 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:TpDesc) (len:Vec 64 Bool) (x:tpElem VoidEv X) -> \ From e566d3e46beaed48a16bd4b950ec67ae571e8d74 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Mon, 1 Jan 2024 10:59:05 -0500 Subject: [PATCH 267/305] fix type error in unsafeAssertMacro --- cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs b/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs index c361c0975b..5585e254cf 100644 --- a/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs +++ b/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs @@ -1274,11 +1274,11 @@ unsafeAssertMacro :: MonMacro unsafeAssertMacro = MonMacro 1 $ \_ ts -> usingEvType $ let numFunType = - MTyForall "n" MKTypeRepr $ \n -> MTyForall "m" MKTypeRepr $ \m -> + 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" -> From 61f4cfe02a03df669c7619beba254f849649b377 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Mon, 1 Jan 2024 11:05:49 -0500 Subject: [PATCH 268/305] attempting to get `take` to work property with MRSolver smtNorm --- cryptol-saw-core/saw/CryptolM.sawcore | 70 ++++-------------- .../src/Verifier/SAW/Simulator/TermModel.hs | 18 ++++- src/SAWScript/Prover/MRSolver/SMT.hs | 74 +++++++++---------- 3 files changed, 62 insertions(+), 100 deletions(-) diff --git a/cryptol-saw-core/saw/CryptolM.sawcore b/cryptol-saw-core/saw/CryptolM.sawcore index c9fdfa9d63..19140b6b61 100644 --- a/cryptol-saw-core/saw/CryptolM.sawcore +++ b/cryptol-saw-core/saw/CryptolM.sawcore @@ -7,48 +7,6 @@ module CryptolM where -- import Cryptol; import SpecM; --- 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 - -takeCryM : (a : isort 0) -> (m n : Nat) -> Vec (addNat m n) a -> Vec m a; -takeCryM a m n v = genCryM m a (\ (i : Nat) -> at (addNat m n) a v i); - -dropCryM : (a : isort 0) -> (m n : Nat) -> Vec (addNat m n) a -> Vec n a; -dropCryM a m n v = genCryM n a (\ (i : Nat) -> at (addNat m n) a v (addNat m i)); - -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)); - - -------------------------------------------------------------------------------- -- Monadic assertions @@ -297,7 +255,7 @@ fromM E a b m n = (map b (a * b) (\ (y : b) -> (x, y)) n) (k x)) xs (\ (kxs:Vec m (Vec n (a * b))) -> retS E (Vec (mulNat m n) (a * b)) - (joinCryM m n (a * b) kxs))) + (join m n (a * b) kxs))) -- Case 2: n = (TCNum m, TCInf) (natCase (\ (m':Nat) -> Vec m' a -> @@ -390,7 +348,7 @@ seqZipM E a b m n = -> SpecM E (mseq E (tcMin (TCNum m) n) (a * b))) (\ (n:Nat) -> \ (xs:Vec m a) -> \ (ys:Vec n b) -> - retS E (Vec (minNat m n) (a * b)) (zipCryM a b m n xs ys)) + 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) -> @@ -422,7 +380,7 @@ seqZipSameM : (E:EvType) -> (a b : isort 0) -> (n : Num) -> seqZipSameM E a b n = Num_rec (\ (n : Num) -> mseq E n a -> mseq E n b -> mseq E n (a * b)) - (\ (n : Nat) -> zipSameCryM a b n) + (\ (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; @@ -621,7 +579,7 @@ ecTakeM E = SpecM E (Vec m a)) -- The case (TCNum m, TCNum n) (\ (n:Nat) -> \ (a:qisort 0) -> \ (xs: Vec (addNat m n) a) -> - retS E (Vec m a) (takeCryM 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 a)) -> vecSequenceM E a m (streamTake (SpecM E a) m xs))) @@ -644,7 +602,7 @@ ecDropM E = Num_rec (\ (n:Num) -> (a:isort 0) -> mseq E (tcAdd (TCNum m) n) a -> mseq E n a) -- The case (TCNum m, TCNum n) - (\ (n:Nat) -> \ (a:isort 0) -> dropCryM a m n) + (\ (n:Nat) -> \ (a:isort 0) -> drop a m n) -- The case (TCNum m, infinity) (\ (a:isort 0) -> streamDrop (SpecM E a) m)); @@ -659,7 +617,7 @@ ecJoinM E = (\ (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 (mseq E n a)) -> @@ -686,7 +644,7 @@ ecSplitM E = (\ (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 (tcMul TCInf n) a -> @@ -711,7 +669,7 @@ 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) -> reverseCryM n); + (\ (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); @@ -723,7 +681,7 @@ ecTransposeM E m n a = Num_rec (\ (n : Num) -> Vec m (mseq E n a) -> mseq E n (Vec m a)) - (\ (n : Nat) -> transposeCryM m n 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 @@ -736,10 +694,10 @@ ecTransposeM E m n a = (\ (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))) -> - genCryM n (Stream (SpecM E a)) (\ (i : Nat) -> + gen n (Stream (SpecM E a)) (\ (i : Nat) -> MkStream (SpecM E a) (\ (j : Nat) -> fmapS E (Vec n a) a - (\ (xs:Vec n a) -> atCryM n a xs i) + (\ (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) -> @@ -807,7 +765,7 @@ ecFromToM E = (\ (last:Num) -> (a : sort 0) -> PLiteral a -> mseq E (tcAdd (TCNum 1) (tcSub last (TCNum first))) a) (\ (last:Nat) -> \ (a : sort 0) -> \ (pa : PLiteral a) -> - genCryM (addNat 1 (subNat last first)) a + gen (addNat 1 (subNat last first)) a (\ (i : Nat) -> pa (addNat i first)))); ecFromToLessThanM : (E:EvType) -> (first : Num) -> isFinite first -> @@ -822,7 +780,7 @@ ecFromToLessThanM E first pf bound a = (\ (bound:Num) -> PLiteralLessThan 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 a) @@ -837,7 +795,7 @@ ecFromThenToM E first next _ a = Num_rec_fin (\ (len:Num) -> PLiteral a -> PLiteral a -> PLiteral a -> mseq E len a) (\ (len:Nat) -> \ (pa : PLiteral a) -> \ (_ : PLiteral a) -> \ (_ : PLiteral a) -> - genCryM len a + gen len a (\ (i : Nat) -> pa (subNat (addNat (getFinNat first) (mulNat i (getFinNat next))) diff --git a/saw-core/src/Verifier/SAW/Simulator/TermModel.hs b/saw-core/src/Verifier/SAW/Simulator/TermModel.hs index 270c907b1b..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 @@ -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 addlPrims (constMap sc cfg)) + 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 diff --git a/src/SAWScript/Prover/MRSolver/SMT.hs b/src/SAWScript/Prover/MRSolver/SMT.hs index b0e131b28b..8c8fa45ee7 100644 --- a/src/SAWScript/Prover/MRSolver/SMT.hs +++ b/src/SAWScript/Prover/MRSolver/SMT.hs @@ -30,6 +30,7 @@ namely 'mrProvable' and 'mrProveEq'. module SAWScript.Prover.MRSolver.SMT where import Data.Maybe +import Data.List (foldl') import qualified Data.Vector as V import Numeric.Natural (Natural) import Control.Monad.Except @@ -51,8 +52,10 @@ import Verifier.SAW.Term.Pretty import Verifier.SAW.SharedTerm import Verifier.SAW.Recognizer +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 @@ -111,24 +114,6 @@ primNatTermFun :: SharedContext -> (Term -> TmPrim) -> TmPrim primNatTermFun sc = PrimFilterFun "primNatTermFun" $ \v -> lift (natValToTerm sc v) --- | 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 - -- | A primitive that returns a global as a term primGlobal :: SharedContext -> Ident -> TmPrim primGlobal sc glob = @@ -139,49 +124,56 @@ 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) + -- | 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 +smtNormPrims :: SharedContext -> SimulatorConfig TermModel -> + Map Ident TmPrim -> Map Ident TmPrim +smtNormPrims sc cfg prims = 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"), + + -- FIXME: remove these + ("Prelude.at", primUnfold sc cfg "Prelude.at"), + ("Prelude.take", primUnfold sc cfg "Prelude.take"), + ("Prelude.sliceBVVec", primGlobal sc "Prelude.sliceBVVec"), + ("Prelude.unsafeAssertBVULt", primGlobal sc "Prelude.unsafeAssertBVULt"), + ("Prelude.unsafeAssertBVULe", primGlobal sc "Prelude.unsafeAssertBVULe"), -- 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 -> + PrimFun $ \_len -> PrimFun $ \_a -> PrimFun $ \_errVal -> primGenVec sc $ \f -> primNatTermFun sc $ \ix -> - Prim (do tm <- scApplyBeta sc f ix - tm' <- smtNorm sc tm - return $ VExtra $ VExtraTerm a tm') + Prim (evalSharedTerm cfg =<< 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 $ \f -> + PrimFun $ \_len -> PrimFun $ \_a -> primGenVec sc $ \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 - ("SpecM.SpecM", - PrimStrict $ \ev -> PrimStrict $ \tp -> - Prim $ - do ev_tp <- VTyTerm (mkSort 1) <$> scDataTypeApp sc "SpecM.EvType" [] - ev_tm <- readBackValueNoConfig "smtNormPrims (SpecM)" sc ev_tp ev - tp_tm <- readBackValueNoConfig "smtNormPrims (SpecM)" sc (VSort $ - mkSort 0) tp - ret_tm <- scGlobalApply sc "SpecM.SpecM" [ev_tm,tp_tm] - return $ TValue $ VTyTerm (mkSort 0) ret_tm) - ] + Prim (evalSharedTerm cfg =<< scApplyBeta sc f ix) + ) + + ]) (foldl' (flip Map.delete) prims [ + "Prelude.gen", "Prelude.atWithDefault", "Prelude.upd", "Prelude.take", + "Prelude.drop", "Prelude.append", "Prelude.join", "Prelude.split", + "Prelude.zip", "Prelude.foldr", "Prelude.foldl", "Prelude.scanl", + "Prelude.rotateL", "Prelude.rotateR", "Prelude.shiftL", "Prelude.shiftR", + "Prelude.EmptyVec" + ]) -- | A version of 'mrNormTerm' in the 'IO' monad, and which does not add any -- debug output. This is used to re-enter the normalizer from inside the @@ -189,7 +181,7 @@ smtNormPrims sc = Map.fromList 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 From b538fb97e21493fc31f56f582959e1b77c75a494 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Thu, 4 Jan 2024 13:52:03 -0500 Subject: [PATCH 269/305] add VVec case to primGenVec, use iteWithProof instead of maybe --- cryptol-saw-core/saw/CryptolM.sawcore | 53 ++++++++-------- cryptol-saw-core/saw/SpecM.sawcore | 12 ++-- .../Verifier/SAW/Heapster/SAWTranslation.hs | 51 +++++++-------- saw-core/prelude/Prelude.sawcore | 63 +++++++++++-------- saw-core/src/Verifier/SAW/Simulator/Prims.hs | 2 +- src/SAWScript/Prover/MRSolver/SMT.hs | 53 ++++++++-------- 6 files changed, 116 insertions(+), 118 deletions(-) diff --git a/cryptol-saw-core/saw/CryptolM.sawcore b/cryptol-saw-core/saw/CryptolM.sawcore index 19140b6b61..8a1c8ea252 100644 --- a/cryptol-saw-core/saw/CryptolM.sawcore +++ b/cryptol-saw-core/saw/CryptolM.sawcore @@ -55,10 +55,9 @@ Num_rec_fin p f = 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 = - maybe (is_bvult n i len) (SpecM E a) - (errorS E a "bvVecAtM: invalid sequence index") - (\ (pf:is_bvult n i len) -> retS E a (atBVVec n len a xs i pf)) - (bvultWithProof n i len); + 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 = @@ -70,22 +69,20 @@ 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 = - maybe (is_bvult n i len) (SpecM E (BVVec n len a)) - (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)) - (bvultWithProof n i len); + 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 = - maybe (is_bvult n i len) (SpecM E (Vec m a)) - (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)) - (bvultWithProof n i len); + 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); @@ -139,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) -> diff --git a/cryptol-saw-core/saw/SpecM.sawcore b/cryptol-saw-core/saw/SpecM.sawcore index 47b9daeb7a..f2b91e90e4 100644 --- a/cryptol-saw-core/saw/SpecM.sawcore +++ b/cryptol-saw-core/saw/SpecM.sawcore @@ -862,16 +862,14 @@ mapBVVecS E a b f n len = mapS E a b f (bvToNat n len); castVecS : (E:EvType) -> (a : sort 0) -> (n1 : Nat) -> (n2 : Nat) -> Vec n1 a -> SpecM E (Vec n2 a); castVecS E a n1 n2 v = - maybe - (Eq Nat n1 n2) (SpecM E (Vec n2 a)) + 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)) - (proveEqNat n1 n2); + v)); -- Append two BVVecs and cast the resulting size, if possible appendCastBVVecS : (E:EvType) -> (n : Nat) -> @@ -879,8 +877,7 @@ appendCastBVVecS : (E:EvType) -> (n : Nat) -> BVVec n len1 a -> BVVec n len2 a -> SpecM E (BVVec n len3 a); appendCastBVVecS E n len1 len2 len3 a v1 v2 = - maybe - (Eq (Vec n Bool) (bvAdd n len1 len2) len3) (SpecM E (BVVec n len3 a)) + 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 @@ -888,8 +885,7 @@ appendCastBVVecS E n len1 len2 len3 a v1 v2 = (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); + (appendBVVec n len1 len2 a v1 v2))); -- diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 83740c0e98..33401c0ad4 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -5103,15 +5103,14 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o do prop_tp_trans <- translate prop ret_tp_m <- compReturnTypeM ret_tp <- returnTypeM - applyGlobalTransM "Prelude.maybe" - [ return (typeTransType1 prop_tp_trans), return ret_tp_m + applyGlobalTransM "Prelude.ifBvEqWithProof" + [ return ret_tp_m + , return (natOpenTerm $ natVal2 prop), translate1 e1, translate1 e2 , return (implFailAltContTerm ret_tp (mbLift prop_str) k) , lambdaTransM "eq_pf" prop_tp_trans (\prop_trans -> withPermStackM (:>: translateVar x) (:>: bvPropPerm prop_trans) $ - popPImplTerm trans k) - , applyGlobalTransM "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) _ |], _) @@ -5152,7 +5151,7 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o (:>: bvPropPerm (BVPropTrans prop pf_tm)) (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 (mbCombine RL.typeCtxProxies mb_impl') >>= \trans -> @@ -5160,16 +5159,15 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o do prop_tp_trans <- translate prop ret_tp_m <- compReturnTypeM ret_tp <- returnTypeM - applyGlobalTransM "Prelude.maybe" - [ return (typeTransType1 prop_tp_trans), return ret_tp_m + applyGlobalTransM "Prelude.ifWithProof" + [ return ret_tp_m + , applyGlobalTransM "Prelude.bvult" + [ return (natOpenTerm $ natVal2 prop), translate1 e1, translate1 e2 ] , return (implFailAltContTerm ret_tp (mbLift prop_str) k) , lambdaTransM "ult_pf" prop_tp_trans (\prop_trans -> withPermStackM (:>: translateVar x) (:>: bvPropPerm prop_trans) $ - popPImplTerm trans k) - , applyGlobalTransM "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) _ |], @@ -5187,7 +5185,7 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o (:>: bvPropPerm (BVPropTrans prop pf_tm)) (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 (mbCombine RL.typeCtxProxies mb_impl') >>= \trans -> @@ -5195,16 +5193,15 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o do prop_tp_trans <- translate prop ret_tp_m <- compReturnTypeM ret_tp <- returnTypeM - applyGlobalTransM "Prelude.maybe" - [ return (typeTransType1 prop_tp_trans), return ret_tp_m + applyGlobalTransM "Prelude.ifWithProof" + [ return ret_tp_m + , applyGlobalTransM "Prelude.bvule" + [ return (natOpenTerm $ natVal2 prop), translate1 e1, translate1 e2 ] , return (implFailAltContTerm ret_tp (mbLift prop_str) k) , lambdaTransM "ule_pf" prop_tp_trans (\prop_trans -> withPermStackM (:>: translateVar x) (:>: bvPropPerm prop_trans) $ - popPImplTerm trans k) - , applyGlobalTransM "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) _ |], @@ -5224,7 +5221,7 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o (:>: bvPropPerm (BVPropTrans prop pf_tm)) (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 (mbCombine RL.typeCtxProxies mb_impl') >>= \trans -> @@ -5232,18 +5229,16 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o do prop_tp_trans <- translate prop ret_tp_m <- compReturnTypeM ret_tp <- returnTypeM - applyGlobalTransM "Prelude.maybe" - [ return (typeTransType1 prop_tp_trans), return ret_tp_m + applyGlobalTransM "Prelude.ifBvuleWithProof" + [ return (natOpenTerm $ natVal2 prop), translate1 e1 + , applyGlobalTransM "Prelude.bvSub" + [return (natOpenTerm $ natVal2 prop), translate1 e2, translate1 e3] + , return ret_tp_m , return (implFailAltContTerm ret_tp (mbLift prop_str) k) , lambdaTransM "ule_diff_pf" prop_tp_trans (\prop_trans -> withPermStackM (:>: translateVar x) (:>: bvPropPerm prop_trans) $ - popPImplTerm trans k) - , applyGlobalTransM "Prelude.bvuleWithProof" - [ return (natOpenTerm $ natVal2 prop), translate1 e1, - applyGlobalTransM "Prelude.bvSub" - [return (natOpenTerm $ natVal2 prop), translate1 e2, translate1 e3]] - ] + popPImplTerm trans k)] ([nuMP| Impl1_TryProveBVProp _ _ _ |], _) -> pimplFailM ("translatePermImpl1: Unhandled BVProp case") diff --git a/saw-core/prelude/Prelude.sawcore b/saw-core/prelude/Prelude.sawcore index 2c04957ef7..b1a82dc023 100644 --- a/saw-core/prelude/Prelude.sawcore +++ b/saw-core/prelude/Prelude.sawcore @@ -355,6 +355,17 @@ 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); + 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?) -- @@ -964,6 +975,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) @@ -1929,25 +1951,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) -> @@ -2155,11 +2168,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 @@ -2168,14 +2180,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 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/src/SAWScript/Prover/MRSolver/SMT.hs b/src/SAWScript/Prover/MRSolver/SMT.hs index 8c8fa45ee7..d8ebbbf51d 100644 --- a/src/SAWScript/Prover/MRSolver/SMT.hs +++ b/src/SAWScript/Prover/MRSolver/SMT.hs @@ -72,13 +72,24 @@ import SAWScript.Prover.MRSolver.Monad type TmPrim = Prim TermModel +-- | Convert a vec value to a 'Term' +vecValToTerm :: SharedContext -> SimulatorConfig TermModel -> + TValue TermModel -> Value TermModel -> IO (Maybe Term) +vecValToTerm sc cfg tp (VVector vs) = + do let ?recordEC = \_ec -> return () + tp' <- readBackTValue sc cfg tp + vs' <- traverse (readBackValue sc cfg tp <=< force) (V.toList vs) + Just <$> scVectorReduced sc tp' vs' +vecValToTerm _ _ _ (VExtra (VExtraTerm _tp tm)) = return $ Just tm +vecValToTerm _ _ _ v = 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 -> (Term -> TmPrim) -> TmPrim -primGenVec sc = - PrimFilterFun "primGenVec" $ - \case - VExtra (VExtraTerm _ (asGenVecTerm -> Just (_, _, f_m))) -> lift $ f_m sc +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' @@ -133,7 +144,7 @@ primUnfold sc cfg glob = -- FIXME: eventually we need to add the current event type to this list smtNormPrims :: SharedContext -> SimulatorConfig TermModel -> Map Ident TmPrim -> Map Ident TmPrim -smtNormPrims sc cfg prims = Map.union (Map.fromList +smtNormPrims sc cfg = Map.union $ Map.fromList [ -- Override the usual behavior of @gen@, @genWithProof@, and @VoidEv@ so -- they are not evaluated or unfolded @@ -142,38 +153,28 @@ smtNormPrims sc cfg prims = Map.union (Map.fromList ("SpecM.VoidEv", primGlobal sc "SpecM.VoidEv"), ("SpecM.SpecM", primGlobal sc "SpecM.SpecM"), - -- FIXME: remove these - ("Prelude.at", primUnfold sc cfg "Prelude.at"), - ("Prelude.take", primUnfold sc cfg "Prelude.take"), - ("Prelude.sliceBVVec", primGlobal sc "Prelude.sliceBVVec"), - ("Prelude.unsafeAssertBVULt", primGlobal sc "Prelude.unsafeAssertBVULt"), - ("Prelude.unsafeAssertBVULe", primGlobal sc "Prelude.unsafeAssertBVULe"), - -- 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 -> PrimFun $ \_a -> PrimFun $ \_errVal -> - primGenVec sc $ \f -> primNatTermFun sc $ \ix -> - Prim (evalSharedTerm cfg =<< scApplyBeta sc f ix) + PrimFun $ \_len -> tvalFun $ \a -> PrimFun $ \_errVal -> + primGenVec sc cfg a $ \f -> primNatTermFun sc $ \ix -> + Prim (do tm <- scApplyBeta sc f ix + tm' <- smtNorm sc tm + return $ VExtra $ VExtraTerm a tm') ), -- Normalize an application of @atWithProof@ to a @gen@ term by applying the -- function of the @gen@ to the index ("Prelude.atWithProof", - PrimFun $ \_len -> PrimFun $ \_a -> primGenVec sc $ \f -> + PrimFun $ \_len -> tvalFun $ \a -> primGenVec sc cfg a $ \f -> primNatTermFun sc $ \ix -> PrimFun $ \_pf -> - Prim (evalSharedTerm cfg =<< scApplyBeta sc f ix) + Prim (do tm <- scApplyBeta sc f ix + tm' <- smtNorm sc tm + return $ VExtra $ VExtraTerm a tm') ) - - ]) (foldl' (flip Map.delete) prims [ - "Prelude.gen", "Prelude.atWithDefault", "Prelude.upd", "Prelude.take", - "Prelude.drop", "Prelude.append", "Prelude.join", "Prelude.split", - "Prelude.zip", "Prelude.foldr", "Prelude.foldl", "Prelude.scanl", - "Prelude.rotateL", "Prelude.rotateR", "Prelude.shiftL", "Prelude.shiftR", - "Prelude.EmptyVec" - ]) + ] -- | A version of 'mrNormTerm' in the 'IO' monad, and which does not add any -- debug output. This is used to re-enter the normalizer from inside the From d7b0ccc30575cb9ea39d512d91e14a913cba0700 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Thu, 4 Jan 2024 16:43:13 -0500 Subject: [PATCH 270/305] make the translation of `ETrans_Shape Nothing` be `unitTpDesc` --- heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 63fc34a17d..fc7663e820 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -335,7 +335,7 @@ instance IsTermTrans (ExprTrans tp) where transTerms ETrans_Unit = [] transTerms ETrans_AnyVector = [] transTerms (ETrans_Shape (Just (d, _))) = [d] - transTerms (ETrans_Shape Nothing) = [] + transTerms (ETrans_Shape Nothing) = [unitTpDesc] transTerms (ETrans_Perm ds _) = [tupleTpDesc ds] transTerms (ETrans_Term _ t) = [t] From 4395e58ec9b21d92e83f43f9774b187ec4bbcea9 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Thu, 4 Jan 2024 18:00:59 -0500 Subject: [PATCH 271/305] simplify types of assumingS/assertingS, add non-S versions, fix typo --- cryptol-saw-core/saw/SpecM.sawcore | 20 +++++++++++----- .../Verifier/SAW/Heapster/SAWTranslation.hs | 24 ++++++++++++------- 2 files changed, 29 insertions(+), 15 deletions(-) diff --git a/cryptol-saw-core/saw/SpecM.sawcore b/cryptol-saw-core/saw/SpecM.sawcore index f2b91e90e4..ad7424a790 100644 --- a/cryptol-saw-core/saw/SpecM.sawcore +++ b/cryptol-saw-core/saw/SpecM.sawcore @@ -572,9 +572,13 @@ 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; +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 #(); @@ -585,9 +589,13 @@ 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; +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. diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index fc7663e820..4792c28cec 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -5186,7 +5186,8 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o , lambdaTransM "eq_pf" prop_tp_trans (\prop_trans -> withPermStackM (:>: translateVar x) (:>: bvPropPerm prop_trans) $ - popPImplTerm trans k)] + popPImplTerm trans k) + ] -- If e1 and e2 are already unequal, short-circuit and do nothing ([nuMP| Impl1_TryProveBVProp x prop@(BVProp_Neq e1 e2) _ |], _) @@ -5243,7 +5244,8 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o , lambdaTransM "ult_pf" prop_tp_trans (\prop_trans -> withPermStackM (:>: translateVar x) (:>: bvPropPerm prop_trans) $ - popPImplTerm trans k)] + popPImplTerm trans k) + ] -- If we know e1 <= e2 statically, translate to unsafeAssert ([nuMP| Impl1_TryProveBVProp x prop@(BVProp_ULeq e1 e2) _ |], @@ -5277,7 +5279,8 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o , lambdaTransM "ule_pf" prop_tp_trans (\prop_trans -> withPermStackM (:>: translateVar x) (:>: bvPropPerm prop_trans) $ - popPImplTerm trans k)] + popPImplTerm trans k) + ] -- If we know e1 <= e2-e3 statically, translate to unsafeAssert ([nuMP| Impl1_TryProveBVProp x prop@(BVProp_ULeq_Diff e1 e2 e3) _ |], @@ -5305,16 +5308,19 @@ translatePermImpl1 mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) o do prop_tp_trans <- translate prop ret_tp_m <- compReturnTypeM ret_tp <- returnTypeM - applyGlobalTransM "Prelude.ifBvuleWithProof" - [ return (natOpenTerm $ natVal2 prop), translate1 e1 - , applyGlobalTransM "Prelude.bvSub" - [return (natOpenTerm $ natVal2 prop), translate1 e2, translate1 e3] - , return ret_tp_m + applyGlobalTransM "Prelude.ifWithProof" + [ return ret_tp_m + , applyGlobalTransM "Prelude.bvule" + [ return (natOpenTerm $ natVal2 prop), translate1 e1 + , applyGlobalTransM "Prelude.bvSub" + [return (natOpenTerm $ natVal2 prop), translate1 e2, translate1 e3] + ] , return (implFailAltContTerm ret_tp (mbLift prop_str) k) , lambdaTransM "ule_diff_pf" prop_tp_trans (\prop_trans -> withPermStackM (:>: translateVar x) (:>: bvPropPerm prop_trans) $ - popPImplTerm trans k)] + popPImplTerm trans k) + ] ([nuMP| Impl1_TryProveBVProp _ _ _ |], _) -> pimplFailM ("translatePermImpl1: Unhandled BVProp case") From 91f311de93a723425a9feb427b4c4d8abbbaa8c1 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Tue, 16 Jan 2024 12:23:18 -0500 Subject: [PATCH 272/305] resolve some unused import warnings --- cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs | 2 +- heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs b/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs index 6b3d98aff8..e9e6fbfa8a 100644 --- a/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs +++ b/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs @@ -106,7 +106,7 @@ 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(..)) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs index 1308f4e5e9..747ebb9ed4 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs @@ -51,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) From 9398ba8dc70f34fd3a435bb22edeedb1f57f8ccd Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Tue, 16 Jan 2024 13:30:25 -0500 Subject: [PATCH 273/305] expand tuples for exists/forall evars, get arrays_mr_solver working again --- heapster-saw/examples/Makefile | 3 ++- heapster-saw/examples/SpecPrims.cry | 8 ++++---- heapster-saw/examples/arrays.cry | 2 +- heapster-saw/examples/c_data.saw | 2 +- heapster-saw/examples/specPrims.saw | 4 ++-- src/SAWScript/Prover/MRSolver/Solver.hs | 25 +++++++++++++++---------- 6 files changed, 25 insertions(+), 19 deletions(-) diff --git a/heapster-saw/examples/Makefile b/heapster-saw/examples/Makefile index 7f9b6e2ebf..fb855b6521 100644 --- a/heapster-saw/examples/Makefile +++ b/heapster-saw/examples/Makefile @@ -41,7 +41,8 @@ endif $(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 +# FIXME: Get linked_list and sha512 working with type descriptions +MR_SOLVER_TESTS = 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) diff --git a/heapster-saw/examples/SpecPrims.cry b/heapster-saw/examples/SpecPrims.cry index ffe5aa6cc3..5a64cf7754 100644 --- a/heapster-saw/examples/SpecPrims.cry +++ b/heapster-saw/examples/SpecPrims.cry @@ -16,13 +16,13 @@ noErrors = exists // The specification which asserts that the first argument is True and then // returns the second argument -asserting : {a} Bit -> (() -> a) -> a -asserting b x = if b then x () else error "Assertion failed" +asserting : {a} Bit -> a -> a +asserting b x = if b then x else error "Assertion failed" // The specification which assumes that the first argument is True and then // returns the second argument -assuming : {a} Bit -> (() -> a) -> a -assuming _ x = x () +assuming : {a} Bit -> a -> a +assuming _ x = x // A hint to Mr Solver that a recursive function has the given loop invariant invariantHint : {a} Bit -> a -> a diff --git a/heapster-saw/examples/arrays.cry b/heapster-saw/examples/arrays.cry index bc7d5140f0..4b7ce92922 100644 --- a/heapster-saw/examples/arrays.cry +++ b/heapster-saw/examples/arrays.cry @@ -12,4 +12,4 @@ zero_array_loop_spec ys = loop 0 ys zero_array_spec : {n} Literal n [64] => [n][64] -> [n][64] zero_array_spec xs = assuming (`n <= 0x0fffffffffffffff) - (\ _ -> [ 0 | _ <- xs ]) + [ 0 | _ <- xs ] 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/specPrims.saw b/heapster-saw/examples/specPrims.saw index 847d2c760f..ea8a818159 100644 --- a/heapster-saw/examples/specPrims.saw +++ b/heapster-saw/examples/specPrims.saw @@ -4,6 +4,6 @@ import "SpecPrims.cry"; set_monadification "exists" "SpecM.existsS" true; set_monadification "forall" "SpecM.forallS" true; -set_monadification "asserting" "SpecM.assertingS" true; -set_monadification "assuming" "SpecM.assumingS" true; +set_monadification "asserting" "SpecM.asserting" true; +set_monadification "assuming" "SpecM.assuming" true; set_monadification "invariantHint" "SpecM.invariantHint" true; diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index ad859d33b9..0693b72a8a 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -127,7 +127,7 @@ import qualified Data.Text as T import Data.List (find, findIndices) import Data.Foldable (foldlM) import Data.Bits (shiftL) -import Control.Monad (void, foldM, zipWithM, zipWithM_) +import Control.Monad (void, foldM, forM, zipWithM, zipWithM_) import Control.Monad.Except (MonadError(..)) import qualified Data.Map as Map import qualified Data.Text as Text @@ -433,7 +433,8 @@ FIXME HERE NOW: match a tuple projection of a MultiFixS -- forNatLtThenSBody, vecMapM, vecMapBindM, seqMapM (f@(asGlobalDef -> Just ident), args) | ident `elem` - ["Prelude.sawLet", "Cryptol.Num_rec", "SpecM.invariantHint", + ["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 -> @@ -1203,17 +1204,21 @@ mrRefines'' (AssumeBoolBind cond1 k1) m2 = mrRefines'' m1 (ExistsBind tp f2) = do let nm = maybe "x" id (compFunVarName f2) - (tp', r) <- mkInjReprType =<< mrNormOpenTerm (typeTm tp) - evar <- mrFreshEVar nm (Type tp') - evar' <- mrApplyRepr r evar - 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) - (tp', r) <- mkInjReprType =<< mrNormOpenTerm (typeTm tp) - evar <- mrFreshEVar nm (Type tp') - evar' <- mrApplyRepr r evar - 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 From 98b3446adeec5a01ceca1e41f6d74b5835929982 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Tue, 23 Jan 2024 18:28:20 -0500 Subject: [PATCH 274/305] handle SpecM fns in mrProveEq, clean up unused heterogeneity --- heapster-saw/examples/Makefile | 3 +- heapster-saw/examples/higher_order.cry | 14 + .../examples/higher_order_mr_solver.saw | 5 + src/SAWScript/Prover/MRSolver/Monad.hs | 31 +-- src/SAWScript/Prover/MRSolver/SMT.hs | 255 ++++++++---------- src/SAWScript/Prover/MRSolver/Solver.hs | 76 ++++-- 6 files changed, 200 insertions(+), 184 deletions(-) create mode 100644 heapster-saw/examples/higher_order.cry create mode 100644 heapster-saw/examples/higher_order_mr_solver.saw diff --git a/heapster-saw/examples/Makefile b/heapster-saw/examples/Makefile index fb855b6521..e2729f900a 100644 --- a/heapster-saw/examples/Makefile +++ b/heapster-saw/examples/Makefile @@ -42,7 +42,8 @@ endif # Lists all the Mr Solver tests, without their ".saw" suffix # FIXME: Get linked_list and sha512 working with type descriptions -MR_SOLVER_TESTS = exp_explosion_mr_solver arrays_mr_solver # linked_list_mr_solver sha512_mr_solver +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) 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/src/SAWScript/Prover/MRSolver/Monad.hs b/src/SAWScript/Prover/MRSolver/Monad.hs index d556334aaa..fca1cb15a7 100644 --- a/src/SAWScript/Prover/MRSolver/Monad.hs +++ b/src/SAWScript/Prover/MRSolver/Monad.hs @@ -76,13 +76,15 @@ 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 - | BindTypesNotEq 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 @@ -105,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 @@ -148,18 +144,19 @@ instance PrettyInCtx FailCtx where 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) = + prettyInCtx (TermsNotEq t1 t2) = prettyPrefixSep "Could not prove terms equal:" t1 "and" t2 - prettyInCtx (TermsNotRel True t1 t2) = - prettyPrefixSep "Could not prove terms heterogeneously related:" t1 "and" t2 - prettyInCtx (TypesNotRel False tp1 tp2) = + prettyInCtx (TypesNotEq tp1 tp2) = prettyPrefixSep "Types not equal:" tp1 "and" tp2 - prettyInCtx (TypesNotRel True tp1 tp2) = - prettyPrefixSep "Types not heterogeneously related:" tp1 "and" tp2 - prettyInCtx (BindTypesNotEq tp1 tp2) = - prettyPrefixSep "Could not start co-induction because bind types are 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) = diff --git a/src/SAWScript/Prover/MRSolver/SMT.hs b/src/SAWScript/Prover/MRSolver/SMT.hs index 079d062503..4a508a2123 100644 --- a/src/SAWScript/Prover/MRSolver/SMT.hs +++ b/src/SAWScript/Prover/MRSolver/SMT.hs @@ -32,7 +32,7 @@ module SAWScript.Prover.MRSolver.SMT where import Data.Maybe import qualified Data.Vector as V import Numeric.Natural (Natural) -import Control.Monad (MonadPlus(..), (>=>), (<=<), when, foldM) +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(..)) @@ -748,7 +748,7 @@ injUnifyRepr tp_r1 tm1 r1 tp2 tm2 = tps_eq <- mrConvertible tp_r1 tp_r2 if not tps_eq then return Nothing else do r1_tm1 <- mrApplyRepr r1 tm1 - rel <- mrProveRel True r1_tm1 tm2 + rel <- mrProveEq r1_tm1 tm2 if rel then return (Just (tp_r1, tm1, r1, r2)) else return Nothing @@ -760,25 +760,20 @@ injUnifyRepr tp_r1 tm1 r1 tp2 tm2 = -- | 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' (asSymBitvectorType -> Just n) t1 t2 = liftSC3 scBvEq n t1 t2 -mrEq' (asNumType -> Just ()) 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 @@ -810,136 +805,110 @@ 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 ts_eq <- mrConvertible t1 t2 - res <- if ts_eq then return True - else do cond_in_ctx <- mrProveRelH het tp1 tp2 t1 t2 - withTermInCtx cond_in_ctx mrProvable - mrDebugPrint 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 --- over zero or more universally quantified variables 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 = + 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 nat, bitvector, Boolean, and integer types, call mrProveEqSimple -mrProveRelH' _ _ (asNatType -> Just _) (asNatType -> Just _) t1 t2 = - mrProveEqSimple (liftSC2 scEqualNat) t1 t2 -mrProveRelH' _ _ tp1@(asSymBitvectorType -> Just n1) - tp2@(asSymBitvectorType -> Just n2) 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 - --- If one side is a finite Num, treat it as a natural number -mrProveRelH' _ het _ tp2 (asNum -> Just (Left t1)) t2 = - liftSC0 scNatType >>= \nat_tp -> mrProveRelH het nat_tp tp2 t1 t2 -mrProveRelH' _ het tp1 _ t1 (asNum -> Just (Left t2)) = - liftSC0 scNatType >>= \nat_tp -> mrProveRelH het tp1 nat_tp t1 t2 - --- If one side is a bvToNat term, treat it as a bitvector -mrProveRelH' _ het _ tp2 (asBvToNat -> Just (n, t1)) t2 = - mrBvType n >>= \bv_tp -> mrProveRelH het bv_tp tp2 t1 t2 -mrProveRelH' _ het tp1 _ t1 (asBvToNat -> Just (n, t2)) = - mrBvType n >>= \bv_tp -> mrProveRelH het tp1 bv_tp 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@(asVecTypeWithLen -> Just (vlen1, tpA1)) - tp2@(asVecTypeWithLen -> Just (vlen2, tpA2)) t1 t2 = +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 -> @@ -948,35 +917,45 @@ mrProveRelH' _ het tp1@(asVecTypeWithLen -> Just (vlen1, tpA1)) do ix_bound <- mrVecLenIxBound vlen1'' ix t1_prj <- mrVecLenAt vlen1'' tpA1' t1' ix t2_prj <- mrVecLenAt vlen2'' tpA2' t2' ix - cond <- mrProveRelH het tpA1' tpA2' t1_prj t2_prj - extTermInCtx [("ix",ix_tp)] <$> - liftTermInCtx2 scImplies (TermInCtx [] ix_bound) cond + 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 -- FIXME: Don't re-associate tuples -mrProveRelH' _ het (asPairType -> Just (asPairType -> Just (tp1a, tp1b), tp1c)) tp2 t1 t2 = +mrRelTerm' _ piRel (asPairType -> Just (asPairType -> Just (tp1a, tp1b), tp1c)) t1 + tp2 t2 = do tp1' <- liftSC2 scPairType tp1a =<< liftSC2 scPairType tp1b tp1c - mrProveRelH het tp1' tp2 t1 t2 -mrProveRelH' _ het tp1 (asPairType -> Just (asPairType -> Just (tp2a, tp2b), tp2c)) t1 t2 = + 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 - mrProveRelH het tp1 tp2' t1 t2 -mrProveRelH' _ het (asPairType -> Just (tpL1, tpR1)) - (asPairType -> Just (tpL2, tpR2)) t1 t2 = + 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' _ _ tp1 tp2 t1 t2 = - do success <- mrConvertible t1 t2 - if success then return () else - do tps_eq <- mrConvertible tp1 tp2 - if 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 0693b72a8a..bacf453301 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -710,8 +710,8 @@ 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)) @@ -795,7 +795,8 @@ newtype AssumpFun t = AssumpFun { appAssumpFun :: -- 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 (tp,e1,e2)) = Just $ mrEq' tp e1 e2 +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 @@ -881,7 +882,7 @@ 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 err) = throwMRFailure (ReturnNotError (Right err) e) mrRefines' (ErrorS err) (RetS e) = throwMRFailure (ReturnNotError (Left err) e) @@ -1031,7 +1032,7 @@ mrRefines' (FunBind (EVarFunName evar) args (CompFunReturn _)) m2 = mrRefines' (FunBind f args1 k1) (FunBind f' args2 k2) | f == f' && length args1 == length args2 = - zipWithM_ mrAssertProveEq args1 args2 >> + zipWithM_ mrAssertProveEqBiRef args1 args2 >> mrFunOutType f args1 >>= \(_, tp) -> mrRefinesFun tp k1 tp k2 @@ -1067,8 +1068,8 @@ mrRefines' m1@(FunBind f1 args1 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 @@ -1100,7 +1101,7 @@ mrRefines' m1@(FunBind f1 args1 k1) rhs' <- mrFunAssumpRHSAsNormComp rhs evars <- mrFreshEVars ctx (args1'', rhs'') <- substTermLike 0 evars (args1', rhs') - zipWithM_ mrAssertProveEq args1'' args1 + 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'' @@ -1116,16 +1117,15 @@ mrRefines' m1@(FunBind f1 args1 k1) 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 + -- 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 (BindTypesNotEq (Type tp1) (Type tp2)) + _ -> 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 @@ -1143,7 +1143,7 @@ mrRefines' m1@(FunBind f1 args1 k1) m2 = do rhs' <- mrFunAssumpRHSAsNormComp rhs evars <- mrFreshEVars ctx (args1'', rhs'') <- substTermLike 0 evars (args1', rhs') - zipWithM_ mrAssertProveEq args1'' args1 + 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'' @@ -1239,8 +1239,29 @@ mrRefinesFun tp1 f1 tp2 f2 = piTp2 <- mrTypeOf f2'' >>= mrNormOpenTerm mrRefinesFunH mrRefines [] piTp1 f1'' piTp2 f2'' - --- | The main loop of 'mrRefinesFun' and 'askMRSolver': given a function that +-- | 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 @@ -1257,9 +1278,8 @@ mrRefinesFun tp1 f1 tp2 f2 = -- 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 --- heterogeneously related as in 'HetRelated'. -mrRefinesFunH :: (Term -> Term -> MRM t a) -> [Term] -> - Term -> Term -> Term -> Term -> MRM t a +-- 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 = @@ -1278,7 +1298,7 @@ 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] @@ -1288,7 +1308,7 @@ 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] @@ -1328,7 +1348,7 @@ mrRefinesFunH k vars (asPi -> Just (nm1, tp1, _)) t1 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,r1,r2,t1,t2) $ \var (vars',r1',r2',t1',t2') -> @@ -1340,7 +1360,7 @@ mrRefinesFunH k vars (asPi -> Just (nm1, tp1, _)) t1 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 @@ -1403,12 +1423,12 @@ refinementTermH t1 t2 = do (EvTerm ev, tp1) <- fromJust . asSpecM <$> mrTypeOf t1 (EvTerm _, tp2) <- fromJust . asSpecM <$> mrTypeOf t2 -- FIXME: Add a direct way to check that the types are related, instead of - -- calling 'mrProveRelH' on dummy variables and ignoring the result - withUVarLift "x" (Type tp1) (tp1,tp2) $ \x1 (tp1',tp2') -> - withUVarLift "x" (Type tp2') (tp1',tp2',x1) $ \x2 (tp1'',tp2'',x1') -> + -- 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 $ mrProveRelH False tp1''' tp2''' x1' x2 + 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 From 2e7cef4a532a8a804ea5cbf4cfdd991a84ac0ff8 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Tue, 23 Jan 2024 18:36:18 -0500 Subject: [PATCH 275/305] minimize `sawLet`s and beta normalize in `heapster_print_fun_trans` --- saw-core/src/Verifier/SAW/OpenTerm.hs | 4 +++- src/SAWScript/HeapsterBuiltins.hs | 3 ++- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/saw-core/src/Verifier/SAW/OpenTerm.hs b/saw-core/src/Verifier/SAW/OpenTerm.hs index 571a31f725..00a539e7d5 100644 --- a/saw-core/src/Verifier/SAW/OpenTerm.hs +++ b/saw-core/src/Verifier/SAW/OpenTerm.hs @@ -99,7 +99,9 @@ module Verifier.SAW.OpenTerm ( arrayValueTermLike, bvLitTermLike, vectorTypeTermLike, bvTypeTermLike, pairTermLike, pairTypeTermLike, pairLeftTermLike, pairRightTermLike, tupleTermLike, tupleTypeTermLike, projTupleTermLike, - letTermLike, sawLetTermLike + letTermLike, sawLetTermLike, + -- * Other exported helper functions + sawLetMinimize ) where import qualified Data.Vector as V diff --git a/src/SAWScript/HeapsterBuiltins.hs b/src/SAWScript/HeapsterBuiltins.hs index 045c6cce4c..2731ee8779 100644 --- a/src/SAWScript/HeapsterBuiltins.hs +++ b/src/SAWScript/HeapsterBuiltins.hs @@ -1149,7 +1149,8 @@ heapsterFunTrans henv fn_name = bodies <- fmap (fmap fst) $ liftIO $ scResolveName sc $ T.pack $ fn_name ++ "__bodies" - liftIO $ scUnfoldConstants sc bodies fun_term + 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 -> From cd15f29b6dffd7f54d885cc58fa84c4b437bbc8a Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Tue, 23 Jan 2024 20:03:39 -0500 Subject: [PATCH 276/305] add Dilithium example --- heapster-saw/examples/.gitignore | 1 + heapster-saw/examples/Dilithium2.cry | 333 ++++++++++++++++++++ heapster-saw/examples/Dilithium2.saw | 426 ++++++++++++++++++++++++++ heapster-saw/examples/Makefile | 22 +- heapster-saw/examples/dilithium.patch | 216 +++++++++++++ heapster-saw/examples/dilithium2.bc | Bin 0 -> 107320 bytes 6 files changed, 995 insertions(+), 3 deletions(-) create mode 100644 heapster-saw/examples/Dilithium2.cry create mode 100644 heapster-saw/examples/Dilithium2.saw create mode 100644 heapster-saw/examples/dilithium.patch create mode 100644 heapster-saw/examples/dilithium2.bc 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..34d539f21f --- /dev/null +++ b/heapster-saw/examples/Dilithium2.saw @@ -0,0 +1,426 @@ +enable_experimental; + +import "Dilithium2.cry"; + +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, sh:llvmshape 64, \ + \ b:llvmblock 64, len:bv 64). \ + \ arg0:[l1]memblock(W,0,len,tuplesh(sh)), 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))" + "\\ (T:TpDesc) (len:Vec 64 Bool) (x:tpElem VoidEv T) -> 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 e2729f900a..8a189bdf8a 100644 --- a/heapster-saw/examples/Makefile +++ b/heapster-saw/examples/Makefile @@ -35,18 +35,34 @@ 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 + cd dilithium && git checkout standard + 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 +# 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/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;nO0;9SsfBbcTyzA`TaCsPWDWIDlAV zYKtwagHe&WyO>sN>(&gQp;1d^MP}`wRMeV_W?o92-#O1aGhC|u?*Bg_yqD)a&w0-C zoacPb<(-mKEMLv^CqzI9$(6{XGFQC4_TgVnF7{Z$WO3kHgoKa_xrBIdBM2AH$G|_4 zZv0+l7e7NNoi_VfPL*VWKpYgt-<`|I(zwabdL;9Gruip|10QmqrmsoYc1Da(^)=Q@ zmCthXyTr%+Who15WM?_k^i_eeF|nrj9j&YO%DTFMZmo=vGWa_!QtU3vujczjHCMr} z%T-M#f8Q)qy+;-QVQFJ$2q!Sg3>Dif@fi58uz$?Dx){y%@F%P)sfj<~RyvZh zCweURY1ec8<~-2J;c(nv^uNTAYG%26sRBNXUY|TgFk2>*DU`|x^BezWZ#6xe9MW$#n?4BPWWyD1*!K^#bKLI%V-rNx`g4TgDpINm z&}lj{EktVWS>oeW8uN-&G<){!li6aXu`%SySf0X*%nP_AGcv{_VzWPagz!n~vR#G{ z?rX6f9Ho~gpifoc^;8)ocfggpL(Nso}KlMcYiq(m+v#+PI^Tw{5GjLMtkb5tSD5O4CK# z)8W{d&|utZ5>*uP${1rpp;2oVm6Ps>kX}vLIgYF=BJ`VxkWO9bxhBtnh>(wTp%>I4 z?YdC7OUlHe%?-v+zb+>7p%#yv;F2Bv{DX9%C#q8@HH@32nx5nW#b`B3`6D^s6S%kF25H zKn*E)UWf=8;Dow}h_`GtCa8=Rg`%y6yb7_XL~Sf>5Lu8_=#+i@VnoQr|Mqx;u{=?< zg$idU3}LHr+i%O{VqfS5Cagaq#Ks8&mOl6uGd0`HMs1*R69~j)++wEkhlwcUm9&V; zXf zXZk|>m0{;JAp^S5>rI~heWBl5L%W(nx|%#;&0LAV;|uDrOUkf;-|kmtEN?Jsr6QR3 z1Q=;LOueB5765SN>Rr~Y3~O(~wP))K1yK*cxH#BG#Nhnm1c8K01CbOgKUlz<#iG)o z$8n})p%<+o-~2WYS|cnx81I$_V}cx3jsYHr^)_0~kqEs{M;auNdT2wu+-DkKU1SyF!I zt|LBrrdO4ylq!PjqQ!c33dc<;g`F`2_A(Fn>!(*I%d*6~-1tiZ->uRqo_6E!jd_$9R!#0Gp0lRBje+R){v3yx=#U_6WaWM6fxQ z$V6LvgjX3+1*~26L3;OuR8-1{GQGt<&nkA+`v-AmBsVlpEPCS~U*^92<-bFHRs4>r z5(EH*C{!fnXr#oQP-9OoG2FnV2RZu*M@CQam%qhy&TEWN%pgLbA2ZpN-DDDaNeRz+ zNx_l4az0`=LuAe?#9f^}(>G7SAt+7ugQO;3l<~M~=M@seLk@Dk>$}$= z8P(%vUs33&9zUr5nISQ*2cgH;r!ER49GUA9^cY((&7Cl=E69BA3uy`h^XvEsYFa=7;NgQJ+wtZbKg5(1Xa@xdNb@>+!i46gG7)ULlEFC0zn-baC_K!PqI zqQp`&C6~x3-tyCg0E-k(Y6PWmzQQnv3==H~?US89SwqQ4+17n9Kqp%Kk9;SK-a(}`$5Spnvrf;FlxvFjl#k~Xf;CA?VnhF&E)-Y4Zjvn zkzvNKn0&ohEvy{P>$t+`@!|I_XWA=)lp0y{iFYR^=Kvop68A` zHk!$g9#I&Uk79CJz55ftVzT`at7P?PCf|;2P);U9>*NQwth)T_xdY5FB}Y|#vpv~^ z$ep8>63~Tdk1IWMfglK-{owvEIO(EN#J4yvp$;CMKE~@Y!bCW(!M4Lh90>NiUxhymD=$yUu*K@5j-jZt5q(w?~aS_GHL8lw2$T z8EkMPMt$^Sj(6ASx&C2Jn{t%(Ir^tin|hRy`s91BQWJ+GcdZFnV@E4RNixuN=!g9< zTvM-1b$h9V$ULy;Sm1M7SVKsV4>+`L6CXUoPjL_QNM(NMPTgPqOJ(4PzW43A{r}`W zxa5XiG$ZXjdwAFF@=tHSZJ7DV;-)DbKiiF!la==H??1m=?SJc^_rsTdeye)=`+1x{ zytjgR@W%Kr25;FpUw^Tg`TWOwcFwV%zOswTe_EsY*LUyOMPEE_zaRd=7uk0z+x~g- zrkxXQ|C8M~r}^Is$rpCJQM&f0rt-Z0#)1{(^6J9(-yWO!%W9*~!z=CKy`}?qD$VzD zuG;(l{IBgXpD+E|t~>nhal7b`W4?&kzviS}B$a&LbYRmjcG01~EN*)A@-4e@{=^mb z@S>F)?^O==tqCpN`S_j6+a21_;-%qQoCkJ=%P0R zs{e6#4Txgr2lpyXw@SVH_lDl7Z2jk~yLL|Vy2EzSn=e(~54Y^Azf-BYx6`!PH#GBS zZ+oTXa-#oJ6@REczVW^L;mhN9-l;5nV#|Gdgka@ccG2ElpV`CL`hR+_viI^0yS?wJ zw2OA*SC4*Y4=;Q(%TTiCnj+-U3wGm;TV?mdZ7WlYXXJG+PE%?A*DSqh3WaYh^c3tR?T*21|?V=Bh zt=9Yh`q*wfxZ?-lcIBt`%9s*g&-}L^G)$ZSPm=WAXLixjng6thr>dIoRZ9Q8^NL;f z?dAP;$`{AYU95WvL)UNoFYf-!9-g1D&|WEh zJo_7a#DkAlrGfoy(y}1?R_&U=g1!UIOacJj46F?zhK_YzWd>q zHYM=FPT$hyr%kU(dnzF7^Ig0U&y^s$*JcwWL7#OjL<((iBo-0DB@ zFMoSw;=i8rTGhHK^QS-9E1CBXdR@H!;Jr%4x7ps>iXs@o<@2}f$}K5(?Zz+d%kGDF z&71j4<<^xu{$p>tb@q=4x(~j46$&ii|P%!ij&3nJbB@;^xO3JW>>s zuG24%sfmQW>Nw!xeeid>mo6RMt=;`G$D^AoaSzcukii zgC`FWhmf^$0c~ao?&i(wN|{&Bo7cUy9)d61!Ea1AY9R`vXXsZD;)w`t*MzN=*Umjlg--A4=bq=yZS9b}yUwW1F_vl#Nj~^R(SWxysp3~WHI2|hqWuiK7z=OF6^QWA}OKYbHdgJ zE=g=nnbT;P+pUUn3Rd%DZ#5B z3x4ufz(9J?+*ZT9lZN1`j>P(u+1(vUZPwXc9WchE?(~y1%pocP0p=KkzBuD`MeY5A z4O~<2ujSrf%e-%@yo#k>m*rk?`lC(woz1IX<#k)0(szMI&;~h_bIro@pLZm}WVLoo z?M<1}oie8;We$wGCuKg_CL<&t%yns4x-6we6697oEnPNVSHE}fhpA?1Ony@QwB)Bv z5ii7ewW`*`+FSVTgj$ZsI4&wZM3z|x$Nu7p~j1VamD<+M=nY1#9z)G{sNIHW!qZt=m{Ei;aJ6R8~55U2$H~ru>4bTN4x3B+Qsnw61v5)+tXEZK0AuTG?_|vZ)2Ro1Tzm6tCUrys{;)P*b|5Y+XfxDkDXf zRj|3B2>D5LvI7S$Zm_9#ecAf*($d0>@S`nVx1nHt!L|*W^0=wasVQ_E6yZG4t8w&F z-o}EpYs<>w%ceORtS^r*ms5Ebt;?NSRJ3`+lz916Jf@3bD!T|=(+gtFFIXE_h^($D z2kF62Q9<#B4ftzQ@y6o30%SZs!O1xuxmYg)hRZ9q#24mi%gQz71#wf?uG5xHlTV8) zTwjovr&+&-UM|yaEGyekhBVjZZd#l7TQ-#y6y%p`a#6;c<2TE5HSrpGUU?}r zfOc_HT_TSwg!3|(6wQWdGZP#X%Qet3OdsgMOY>PAEZ4W*Z5MNi*Lblav0g?l$@QeZ zL(Emch2693Ws|>!7Um9d`?Gjq4qUhb7uw*$b+43%Ic2_}%L>L9D8i>*^@ydp6Aq+i zmO3Lp?=O#yhb#OT7NE-{GX>q5kW?a^OdH#%y(mlL?QilEuHZu(AiB?wB|3+516$xD zSu5B_8rU!ucGP%!bVr3FI;!{g^cx&2B8-enn03&Wj8E&}52SI4ObpSPdiY1=OJ`&; zt6RYVkb$i;je|>;^bh5n*ZUw30x*8i*~qd6{0==h9$(`ykhFPh5wJ!nK|=?nC}^Yx z8WnJbc6awQhsbI`L=YfhNmuLz2SyK6uK$|SfRmD|yEt&FXm_e$FT#`qji;TY&+p<9 z8N_>3(MVb$kcx?%Cs%Q#Tq4OP)r9Z@z&C{(-~_{EV6D51XF7ch+oY@6Hfd9ugo=lq zZItm%oCMltxe>b?O$ibPl&|AC!GLcv$+$`p_LSS;k z@fKo_lIfEE)&m_9!))!h@(#x9@!8#Sli>+3_Hq2{ccR6da)RvXB zyHw9X_-hfw;MvELEbIe3#ZPc@0B85ffzK*LUjrzUl*>h;N&k4Kgl0QUPInc zW~W8*dpRfQ8FcvoJMI@%!9G3gxZjtZ1bJ(NS$Qk`%%GV}u!HS}ZUEQ}=hbBhB(#39k7 zTU??sg-@3<+xrC@x>LoLr_ia`4o8YgrwC3B6M?1Dv7kuryIEDFN(|I-BT($bu3&wl zX4Z?TJb~&?leiXX)e=1E72%1c772eMtlUeYhOusnG$V;_8Ht?+YjhIVp$^HuE_LXM zbWBP!sEl(`EW25bc$^k-y`>A7>J-c2q^6FZbkmdc)jen6&UrB?_-#F%+-2^s`*0>W z7*OQ7zkY3hYB5vlApHIV=Y`q6GdV&M1EcSj_18QN{NOszVY^FN;+M44Z`%^T=|0?^ z@s=3|8|;AAXB>-h6_X218;}^VEby9jge2mcBhw{JUH@rdrQS{6K{^HXD4m12#mt3G z;fZMmGKfQHc9R>(7&R*EdTzIz5j?}-Lnqx(%TeXj?DAo!b|aTgt%Ogaw<&{xA!#)3 z6sU3&_l{J#gQ-I*SC$<8v4ooh{cfJ-+&no%8x3q)J{QV_xxfCg`NsA6&S>(Qqx6G= zIHlhl_}%0;1257meL_=kn+|^(xJfMr_V)u8!<-&nuy#zS_9f!|z1geK^0%sBGdBBL zSZos(tKDy!y}oCJA(>{5(H9z&6YoOHhx||r?_o3lTi;0Q=Z1&0vSKhPddWxkEjCag_Ie>kBQL%Nwiu7x+LjRU=Kypd0vu+UPgL(XA1FsK1ta19@L z9;cn=+hAVR+k550s;prs5UAKR)o+!yW1_wm=Fo zN86Ax4_x8al-WHU`fozcK$Qigysc1l5jsG9(=jtHtG&KedH2b@`_b|B{#NC614xh$ zVYA0QRn(o-Y?#{!jx=wc*^mTIwW$L&K_esNc{uRnD<`8}z_uslTt(7&Qmyb1h*PEG z$w`&PpD*WJ^C3&UW04Eoft#Ns9)7F6Zwg#L4t!7;* z0%btOjz4QkHO2X5@r4?IP{gn5#gOG0?`HJ7X?+7*)P&2V!`78aEW51Hmm=d5e7J+r zmbTPEzxYJA$$-ED{~&&9nlM^-8bH;0Vbfy9)7p|%SB0#^DS$sF8;+QgT3d8Qsqczc zU@wgGxtqUuQSu8Ogq)e6KWwsQ6m8)Uq`7ZeqFdZlLTTm-qpe>9I=Jj>UHpM9s_hgZ z>Q#}q-NrShehUVs{vrN?ZH9e=HvzvQ@g1eUUqL(_iSxY{U7G9367RBR?0DHhe0E~( ze`dgrAZtjOpC#>9hEEg^w0isTH`$DC+_^V8_|}lS8ok=fE?3G$rUqGCN_v*GM-eqq zTqyVTkz(l3X{pCG1=nC{d@j>78&xgUG8mD9J1FVEE? zkj}{Hy#tAR?f392H|XnSSy$MmO~lHf|{SfPDc{CM&hD+6;obicDeoNKy*AG_ zjD8zFY8g&H?cL$S+klT=8BV`1ei(f|rC%|e{#Mhl;T``5IX{F_eb#hq%rWL-?mhduWcydUVF zXMv&IIN9{KzXTa_B^NB%m~fzR$Uf;gnaqG!g$p>$Qwd3d33)1$5+z@xn8D$|H0Nva z;S-#5uLT*7NJ605d>MZ&%-??9*R)w8ZB{`0IHA1oMv$Rh;>$KGgk}xO{%F!8sv@3i zCGOJ)?()elPjQTl!De32?5l*NL$mT!&B|}0iNcR_Fh1rZ%a48}FkViie8ZexQA7h= zQiE$^u4RCqq8?T-Vpw+J{VD#8wO(lz8V*C%8$bVyxzO+d4$r25;r*-t$R=4UsY?ii zZl^`|1{t_sW1!DQ@#c2uLE#HM#7wM`Ni1qSkHH=nSd8n=m}{u~-t-IzG6DSvQPI$1 z*)r(8Q~^>gmD2^{59{9=-eZ`Nr|P!SRw`7iN}Jb5^-84(7;`N0i@K!rkD%4X;jQG} z(5h*8E9;!}z0m3kwo-(lJZ`J6`4QP39Q=;Kp+z~)TqRY3wuVb!CG6Z_`@n`nU7&`c z#z@3n^~!6agV;HT3mTj_E22lK5Kb4Krp^6@C@WHZdNE;=xYP1fOgk*cp3j8x94HKm zk5TBZLzmBBmu7~_dorqda4SDvto(EX^csV`ZU=(Z^oSFW5NIXeycjoV{Ags5cLUh$ z$Iqnp26koAIi0KU7*A$^*#T?Q`3U!FgFb4{1VP90cH33F3 z&R@~OoXe=`1QVH@s~_}=j91EydmCg~QF!odgRIk#ktIFf2e$GA1GaKgI@rp&EuDO2 z=<-~>*=usVQf+*$LDp(`C`;PkH({dqD)9r8T7xFF3r*_UTs4#CflO z#JwK8H%PGx^gF=yANE`~-m^LHT^aFQ7vAd`x;JLna}-%vT=%%+U@R_KP*`!yDT`CB z!|!cGIkmX%nX89ASB&?XUH2H2p#uu_r&6rY;+TW9sd6e`ex8sk*9`Ssg!dbr6yCNB z?|D7mYjE9D4Db0#ytm(Vj~RZCq6m}gUhD9Ch4@^(^WHln`g;QJQEZ1R;vF*lxwUw& z%Jtj`UJCFY%%u&u6=0JwE~p3geV)L>7p$5*p?DBX zKA0>Z3ngBJZ&iQnmMX?ef%K9)T#~)#2DVpajL0VDzj_7)w}P@B_sRxEWWjd%Y@b0T zuz8I3{_(C?Jug7-CTtI|Z3*=LcBA-$#k+S1vmA@w58y0pmx{w2O2`LS7R>UzBG;O0 z{i)OUF7%@DPH7>E#lf%5+6tKOQrH{N-p9ZrN_p=Ny_-UF#@y!MDk#JP?RDNOU0f9{ z_>gY~soIb$c`n5`2N%znE=-$`V%xc)>ype15Z+F+YwYG9Yi0h8L5AdTWbCU1b*W4Q z?HA-j`*|CPVRi#>aU}c{a=}9`S_}uJdc1_~eGFWGJ{+WecX%Bx0=24bAzj}39@ruy!nhdv37hmks8`)Bih!(?K zSC=;LT>T&8V^q1o+`xv8KZv%0$eQ`Vt`%$zwN;HN2PtF@Ew(|?lqSHFvGKGOizgea z0Ei#!9FldV#rHzJvd4gWO)hTS%(5I0uB;f5zo68Z%~Urw$arh z0kyD<`AX-3mxfUdxUU2DwJiIzZ&iz1ysZoLp_k5frx~^JzGWi%JT~?cRnV&>x>F%J z16K!zH2mBaE>0ofJIohLTHQg}`o2rKbYbUnyvg&v+EyOUko zpWHNI{$c>z?yn8;YV%%o33xp>jMup}ZgOJSc*ZQ>O?8*$m6>P(a*6CE2MZG{$b$Px z`9jLVe3k`W46p#W)5${m?%W|3`X;m!$vL2;9!{K0Y==vQ!!KFrCGGJ3tP|SRIOI3w zP(BJnUcmNeO~fG&^~dbiyZXConb^fpd74;CRLYr66V5P{i-z5x8K6LBgPH*4zs113 z)_9RK-~x?Z_zJOTQ*5GKSQ9;hrLZR6W1?W$!5vu4la+A!eA<#&h%+l-_jEs{hG#1- zFrrsX?x3ryQ|Ue?hFw`IS|7pRz`*V%SdHq_FY<$(w96xsb}dfUVb`Z};PE&7fzUs2 zcDT9VH-I|xaNShfh)asn+xJA)f*QQ-{p$87CL6;v;yz5f!kgeP&Jyx&Y?r ztyCsW z;k;kimI0fCrda@II#s-Fl=_XbxTg4$jWT$!F}i@~;VCQ29$ zyb2=*gWU_^nw~w%#Y83pXNX;wvJpPB2`>8a7g3)XlQVP;s(2Wxg=Ls_)egbhEF}?O z`U!nxOwQ0X=~adKIHH!xet%uAfdZR#Yq#Z1D+kvYi#J^B)a|F31Gk3O>DmC!;l|FV z!1rYqFS@h`pmx!oD+6LU(cOM ze;~Wj%!P$K|F~hF>X}nwT*!lGLmN9Qj_pD(P`7x{7S%g`st|qI9nXrQKMZ?SiSDuu z1HiYscB8w@J>1fsVR`Uj>S*514_FjApLLfl(FI!H>q<6WJO4w&zJ_Q14nv17+$J^h zclJD*sxAEJ()d3dwa6+3p& zz;nMV@EoV4LD8c~=O+BZ{pCuDkT&C=A8Hm)_m>gPez=L+q*%7t~l}~-x9n>T`M&6^}3t{G~wc595hi54g(u5 ziQcjf9|Cm~sr%(5P!jGxjDU`EFoMAC5d^5eIEX%)lYlOK%rF8P$^qT$oie!H1e4`( zyD#}t$8lgJfv{l&l$3)J1nzKvfaxTfiF@*&A;=uejl+28y+Sxy8^pyZ^34t#1eOzI zlZy!$gZnXf$L)DH9zfO)-T-iV|3eUiDHZpAdm9wSI9xc-)MN!9qxJ>D`RHFIJ`UmP zyAMKCTM>xi+4}|>u2vv4o=x0zN<>i$BoJoq+hy~hU{WJvufg*gp5D*E0cI4<5Yld# zPzc6>^?m}Yw`<=9Q<7RwAC*bk!Co{J#MA?#6Z;q-stx{07s4xdp9k(cS^ul&CxP_< zrj|rX0KKfkux^ac9t?pK8sTr0elL@vpOuQ-vrbjllShE>tbCBh!1|75!UC|fja_G4 z`G}PdC+b2$(W0lJJRU@O_X0D{8Rz^_d|d|qTQ==|o#8p*I_Ujm*JkV6c6WbT#NOH+7!#keFWL;Q~?OrMt?EeBi1cx%$V3o?Zr04|RbW z9u)vOnr*!2+PE7a%D-2KjG57iSZWPzgG9)}Au-)HJY|8Qj|-wp0X<5a_iYY<{3nrj zhcl$=G1hlLt6;Vj`usMpyM1p#wuJlOa9XA|U?OBVt($!yhjNw{n|dI%;KvTIOi^iF zHHZD>J!rLqN=us(cv2Y*6SE+hYD*vnFdjIc!ob>HfOAzJh~A^}8^2E>{x=Z>qF57b zv3Ont0S4})i-J;3INYXR088);OSL2LlohGwzvj|G>rKBL8+ytIht2FAK6sn^&*HRv zER-|6L?F>!b;%`)52CqC&{?03gM=i{bcQbU5282$u+S4>_|s=A1f)xXZb8Y!MF9T6 zEfD78>T|zjim~(Ay97 zTQhFBt%p*xIG>w*@Pig#&qY6|HTo5;Z{=&__?SeP=VRDM4xEZ1>OvLSek3|NViI5| zNUXQJ66^AN=maScOOL`te!qi>Ahqq|f)4f`H0i8G#v?=+JFfpgp#wkF2_5e8sJ%Oa z@Bl#sx+XVj-=qmpiMP|Wy6(Ll8_;klhK>|>p=LBwOl`EY*|q2|sR!mW z!-mi<=nF5J+&kOiPkXp1PsaEL5m7o0p7f$=kacKtkzTI7N$ zIG~3NUyT65iH+x8izZsDANWqMq;BVusx0)KvTLBJh8HOn1Chi7`OsR5F;a8pr(oaQ z(7ve(Ji$DAIuKaPCDBf&JGCsc2{%<4nx8Y~@cP}z z6D$MReZe5Q4;e(b=HxT|z!B&<3VUwLgiNHu2YX&6fGp$yFS!-=x4%q-G^BK<5_W<| zBX|oq#2p>JzF0PkPaVD`8U862Y`PSZq~KWQ%mRfz{i;7CDo^mwfI_oTOO4jI6=w<9 ze$Dp^7&uDwv51?vY1J^}Av3LC{w%n2?dbWHOgaYwUx5N|3n;{a5e*FN?E})cY+wqC z3wkM}NI*zYw<-vTtaYn*<1q;g>_h{ZF!in0DvngjV|_jFG#wv}3~CY`CJ-PASp^97S-o&#>?$!_yF z*$F+-%tysP^P%{~xE*R_cu*rV5CJtZC(PbBCTHxz;l~sbTG~ReiUr~klbza-F`p)C zOcZ}R;t{9w*a(8b6+!6dQG~yhY9Xi$s;Q!pDpo|)5UEqBPTJw5()xjvGwtI|(>H9A z%Av*aN*dBgWh55BS`$EjPVm8cED41pe>4t9O3~;AbE^<^x`R<{D3I2GPPOd9-~_HD z%}jtJso1u?4%$x3f$($tlW_DiBj@`GiGZg8YgLW8gymLLJ~V)ns~}WhsD`6spve%V zNC6{)K@%TX+tsgwRq6JXz|k@|lJexx_tDFKq)jcsiF5`%3tJnmaUXx4?L8+7mJg6a&SN87r0b|tuFp1N^Z3$a%TCnqFAU*Pj| z8}J!`s(Nw&^mihz`NB^DhY1eC-3vcO6O%O=j>f@JkBA=$_EMY@0qlM%1S0qH#cxA& zwC9oyo}EUY-8ATYLHD|2xz4{##!dTbygRlwhBIZ@bC9^aZ@o?9-uZlbkS|P^uP>^uk<@=3v`DdFCal1 zxm52tTpisK1J?%V4ma~dB$I@yjDTgID@chZY}@f#DWl?G0CB%Evq9+yAf|dPy(H;& z1Q2sgzJ(@70C7q6ewE>QLKNTX_|vMoOnX&Da&t8EBoCC*KSXlF&3sArGL2ERL7Cb- z8yeB;5K{E`c}OR9kZc~RF#Df$vN}jjHKlVX_;-h(rtuEJFYiA1g*)#PW>$5Rhg7$N z=0)MHU@)N23RTyvd)eibWXx})4&iXEtsbWsrj}OWSQfX5Fm<5xWEdqUnF zt5;>zt_WN%dEvE5r>4Csz7aK{SOYe<`B~pL<;McEUVL;%0kzIo+99C2Xu^cenwDTNESX2@6OgD_3WFT?zXhc1B0vjL*2^E{p}lREz*sC&!z4DA9b*nU2F1v zc`#T+Ek5ic>D43lkymja$rZppa()u-BWmT5#bl-j&&-W^tcCWrRtDJIOnHIn%&KozKP3V=E??*Zu;4GDQ?e&%Gii_rC9`JKRq2#89SiEY9AFA z!H>cQBMM_3K*0=^txzrN+^MkK70hEzniII2_y=*{p@^W>v8`0;U!;gUB*2NtlYME; z0j;pKI81(oI}02%DkpGo%cyZ}LA+m(Ea1x+ExQH9yF7|09~z$e6E?U4zi_{6wy^tM zmCK_r@f)xKt($c+wqK9?U6DfKGsM^e+z@GTi<2>p`ym$5D25ojjgUx2_gN=n4{Qa- z97QLl)Mv0W8r^hu*350Do$>#Pd)2EZfWqCr5Y0Iq8{z~txd9<8YLCDg(Eu5otPtv8 zuc})X2uL>u_bS1p8BScI4~T>ok}=?TsH?#raljRoTng%6fzZS1E`U8}0`56#feYH? zG+`u)*N%=o_+~0TU@WUUMolMM!3wk{BOH?8?!3GS(T&BEMJ~h8O-?mLa+p}Und_Sn zZB$u2DXh8Vj(HcrLb8nr(H~8R`pC6zb>RC1xB$*I_Ya^m2uAD$fOE~g2YWW?P!^N0 z%rV~w(?nyQ2R!sV-NZaTgzb*T8Z5~_(#|3P+QbBkVb9!#dnQwT3D}V%rm=9ZJ26eG z3Us-$K|hS~ zM6a41-MLp$L1DAwZ(YC1B&+A7dcyLcywj%s6`0^)ZDgg+4kXTmnL;Or3Ykt2%&+?}!(d3oJmKX_k$~nTjJKFwRs6l3AGuiR~^L7b@{s zMAOf54~#QiKLdcgKgs)m*s@n)YVUOFr7;Z6a$ zoRW)LxTM@2mE2Z6SK)eaD-Rebo+degdOlt#gp5Ap5u*V$6HN7oM^5lRuHq<;V&8R- zV=r-P5j(@n#Vksy!8?I)r*I4|ybnEg0kjX7a#zx3HILC0E2#P^-B|QxZda$`Ak7d! zeX36tKxB_nAx}+w72O$Y61p?jJbI3zwpR;4$WtXpfpZTOGBFk|BTOy_wb7>jvpZR3 z_5k@X9k0haoEn<~uHNA2U|LDLz#ng>1RsM-`yyoUbrA6}mI$xq0x~d$ZW&&iT3rwJ z2!Vkw^8?S|uCY*p)h}dhVLR-r?%Ei5WUbp@V3n2AzTZ({-xhCnhEGW)=;u77g1LQ1 z4xJ4Ej`Lz29I%)8su=6zJSn?&_PGfE<^`Wmv+1K^R|>b9G7H{ge0`4=1zD0GgD(Ta zItYwOKpjLPq)X{XBO@gHx3Lw*Bmh=%pkkYaS0l02{|BE4(3R6C+NwRUeH6B;n$Kb@ zC>k4vt=uYEY*n>j1h$Hdr`XDE?+9#_mCItQiSfg+RZAy}t+I26V=HYfi>=x^TZgb! ziO<+?tYP2m9Sb247F%TmHS?34*s4o5;Zj5#i>*q94@7vE&^qs)eY4YRx5>R(Y;{VR z*~8n;Vk^Ga(j#Hr4s4ZY^1W$-H{`L%1F)6FI09S!jM(ae2(Z=u1&FQgBet603)re< zFJh~Moq(;rkJ=2_DmEUl)nm1xk8t)sgxG3zWc07GmBM=jw(9;ru$2==jbm${9T>~; zp3(n=tt`Bk{s(O3Jd|B1d2=_evMGY7ci| zt3K~x*s9Na2wPPzKx{PwvDKyUMkltq=Iz2(cMYSlRSE9Qw~a1rbvMO@t?a*nt!|6H zabm0cL)hy6?_sOk9f+;yD>sVv9vXS>5m7&tBjj+Xt?m3wh!(ac6)V;sGJ$P~ECG}S zKn?cpy;`<{Fah7FN{*5Nrdc7ZcEdYZiIz@Z%8B>g17N9^f~AFAUx#t5+gs=YOKc!e z27nb7K)OGqqsoP7O9S0fq4<=>0v8^ULVf8-z#Q+p8>{K8V2A2cBfyA1Nsaj4ULYK& z7O;ji!C^?#DN}H##gig9U)GT7m$8O)meY`4WW3Rk%H66ECz`?7XI+wkA)SSWv^ql$ zm;?;zWHh82Uj$l{4LmTU)fp1_{>vGn7?`fa+M`eudRSr&#}ecc`l{wxI{ZaPCOL<{ zuO(AJ-a0G4s{}h|3Z-RTQSD}^*uFyZXVDtOT4Ss9Ao1uDJPw-NiPZ8{km_S2i>x8F zjJawBLt3{l1}Ls|I|PRG1|=~u9kEI%&*kICbZmkBVMfM0?1DREv zqwp>impVZ05(Gvy2+EdU!ea`}b0>6>W$16E0^jw4m>AYgX{_>r(M?)nMmHb};Myyc zM0Rd+0BK`FS+6K3A`nZTpQAbXTmWn4<=CmhwePR*>?@P*j5(hN4y<$wB|14dB{Gltf$S$yoSKkp=7w4<IAT6 z1}S9m!H4F=|Nq2QknCnZh^uZvPSub9sH?7zjafAyt`ejt69{GU5MeQV!8n@x$%jYT zcykqvTjj#}@5h^Iv>7t8uH28?p~8UHQP`?8#}T)hjM(aY-JjXG)d@%3Y6W7ezXhyf z<5oouZ1o0Wt7j*@#m22{4s4~xyGt|N+Ik>X{YrD{D*qF8w(O;madj)wnAis*#-6KF zF56uF=yJ)cA5D7uwI*^Ya_UEyXTe+EmRKnA>+zeL?slk#CW7^cT9Y$xq^_ok;2Ztk zOWUJA%46eDO(x$3*Mcz-OtF%9H((_-WTY}CHK*pBhX~vOdMW;mm`7X zQ&(j2VzOxrZznhAWXpGcisPqA3pqL^L?KX>ECJ;7yodWE9RF34dUx}cTy-`^rJz_( zKl^qEUl(>?qgQy#;*|~6@V<7p9->lfHBrBcM~w_Yao9Jm9p!d-0(EgpS5zpHt$LzS zAuM{ss8CV~8x=a^iVD@F(s0#g4EkV=7tJ%LvQZ&_UuRS((wDwI!&cBa!c~2Khbg2| zraGfSwdwU3u2NuB$bfI*V7O}Wj-jYfO%)A6l@0H#N`T0PeNn46y$T7?u#%HNT29t5 z0&EP6hLxP$R#mgXHAxQ!A@X#tuu={}pBdB@og7HRN+c4)N|O->Il@ZE5&DQ}SZM`9 zpL`lIpN!y$hLvOG=x50xT~Hyf?*}b z5mqt}CCvhNBlL+u=(GPc3w;1THi z>d3e#3JGce64bTD03;ajL`V=ZHWQ51f*|gE8?;J}dmbQxo_61rw%-W}N}HM~B(PyM z)4+rj;*RfObqNkYUu6`2{H=GX0|z9>?T3!Six)2pK34jT{y z*^284bn#7cCYo3ijPh^kz|&f{mvC6^GU)6+?X08(@Xacl1BEp?7TO?)xCC*EGzJy^ zNZjN{K;bdwBg;lKlJ>a&OHl1kLrN{XyI`J|N5D)Ti3`Ja7;kRb-3};|#Xk@+)nR%( z?Qs=6b%Os1fYY%Ci1ocl@sI5Y#QNH7AwV5MMav!d2eGX!Hzt7ezzT`u!U|ymi5u8l zHl9*|@suWSjHjH!c*?E{)6#IyjrQBIy#TBs+=z>qzS+k!KtXdmjg}cQv zdbb_#f{pJBK7A}Q{lNagJu@KQa`ahWThpJXE-!x)vL^GUbtH7sydnZB$vese>VBPy2KCPJm=3VsotNnXGC1(&+!mf zDcvK6f|MeRtK?sPX)&n|7QDc1xi}CQpt!Tp`U=TRa$h7+y%|qpnb>DIDvp1JaLy*IY@7l0=btmL#X<{Kq>Ja4Ud>XL?lUlCMp2WnvBe_(QN(s<6mYoESof!@zY)GJWB!L{tZ71=BJ@mtI zuFU<(Gnl#Op;dmYgU#H_FmwMHZzywLxJLs9Pl8st4PH5cR17v>g)P`x(a+SQGWRkg z16#~rmOwtf2Q&BXpCvjo_w6%(BXj?kCTHfpdOc?D`{}kcb3Wh@k6uFa4_tRw=DzMz z%-qLB!cKL1eF%&TificGxe2nD9GUy%pV5!5+2hLG=U&Fly&D?e<9%Ra!D%W(rzx#y zSmyqCJY?>BFmvzzc>|lduh9j2N+8dk$2_Bja>_4*v!V$b(5#Cs}1Xl4jEeF2X z3ymqlpwvhyn7(k$JQXUUJ4}mtZ+)ujdRnW@}--9E3+5Ssz-c);s2)HiY@cNTG+}!T?SK2MQ-F4;{U7v zj~yupObQxWfxW>!Tp+xh&FnNm;GicK33HPgAu7=)jKH@gxJeCgvO;(cV>p8hw|&XCUt3KrbV?*Utd%Eh#IJ`<7$CJ@HP1oK`O*741afa+5w#V~$HEfw0EU zGz(SrZWAoR#kKNe;1=aU%3fszfh4!DycjTCgc>;x25jf^U<>0>8czpnQYrGaFe{rQe6lMJ8Dk z$eaxlaGfte0?u4cV7>g52#>CHqi+RGxDD!jqYy5%gri33!afK71WBw!ufgzP z^F6`;0`GLdomS2g-zo6~B)J{mSv>)-L1>67gIcwD2zJq_WdeudTx${US}ESWqR$4r z`uvH6RAqe@x6sTubxus{zpq@G3RnJ_TnT7Steg_%=Wm=+Rl>sN} z%!{-2vCAcurLirqIqI2tw&B&2W?iP@st=1Sr>Wdxrm~s5Bkr+2p8#&hkkVty2}ef2 z$864Fa`b4QpWx@}_zI@AguISNORA4tVuus7}w zvC{xQnMH`74vYhov`YRZlw%*)L0CnJ<7gSMz`NH~pg47zUP#8K1BWpa-WB37Sz z(RnmwzEUJ3zgWEQqK|f%YQ}2i1o!KXgN~r>QM2y~cw^iA zqkd#U~JTr^ux{MW{OhTn)X$b;rQ!P9!MF8`NFF3K4Cg1HCnq>98iHV zj&EFb^DU`tjYxK6IJ@od^}bMNUA#!JYz+OP?!hoKGEgLA7Fg-p1tH_Eo~xX2sc$hC zzi^-;(jzv)`!*Y2@XJxvZnHSz3oZK0^C|2X4&3Mu$Zik&3WV_|k#CnYGG$@%*B#6u zQWq|~0k5;P8Y^HO8(c&RZf+uRh%3cNJdn1YwW!Ui3kLzkHW1P9GJ z*ihs2?>7e>>o6W?4tkiz%9{W8`>c1r?+a-M@1u z`%V@8lPT$1B3wNd;Qs{rx3YLY_oFz{4R40ze&%46Nk za{+vksb?teXYhbGZ=Qr-D4YKo7l(jjm=04)Y2><*Ew&{%PDN9Dp&G96b2#AHLw2L= z=JXo)4o3n~ar%nutf)|~vW@l0L!j|;JhWrf%qUFzdK6~YOqago=}H{i$V?AN064m% zwE!*GpQY5wz99;rG|uTt$6pCn;!l>tV%d+s-RG3gXf_!dZYrBB20v40wNPv_=E&d1 zS$%xfBTFA!^XNlznTh*+Mz_8g-Q|21_7eb;p#N?nNLOlMaRL7~&l?@>m zin`a7vH?a|tk-zl4Dz9eZ;nq{=+KHYnb01OdyU;-(+=Ai9=5AIYzySD zb+x&MSS~u;9U50U15Ia4gt>IJ(NBff67BGq&X~mBq6DGG8S|c=Z)6;&lhLNT>rMzF#pEi)F-QfaMbk?gAgx)aD6Dk!k9A z=IAp$F9bc$E_5R(wje(XR*{{@ZD|T>!xsj6f!6`A|40j!LoDp7s~s+(^8PARZqgm7 zvjSi7PnN@CIgG#EJlWO88He9#HqIb?w5-N|{{TNeob~9VS*&4p+co1`1IBmZ$plqv zHGiMfS{Xcp#aX*ktcJ>leJU;x8O;g+13OY z%;vV>E4-FzJZZ9N3}!PPds5@c&2FAtqlyWnZ-(*MQG+K>O_4eRsiAaRJ&o=Xs!a0a zS%W8!89e!^#*;DR$xlr@xy<0nnmqK6a9cKax4C(;Xh0$D89~R?BR|@d6k{p&^{_NL0%5J!cRvRk#}z`$r6zU|X;wVn<5^?I##A$>fPCw05;`BmyE#5;}sqCIC z2l!q7WH~IBALG-_c$Y@G#=8UX(eeoXyA9q|7kA-Vw;Y|&{vtZub+U6j2Prw4--B}0 zmF$+I#crP6GP1I8AoCz51`I0=P1v-xa9@EHA&x;Sm9_mpQL(%18%+GDxuT)y@~_0y zsmUUylp*{V%@i2uf`ZmG)v*7G5+hk`?|1P4z0frl6-0ok2z@?i7y|oJ4jb#O+rs4@ zh}0wYSjlYja*txF@K`E$ECv;^VGMt!dIy6y5Xb%__Wx2j;QMkLh0WuoAilz>1|?yC zkt)3n4q}LE&^P{=1Dm&dSNr_t!V|TF=xj`=)`Yq#hRNz@ zn5@33CX;n*TqlofZb)-a=gYROdn|YObflpD)P`yXuRbGI(GIUumrpmaPa)oa*yk#a z(~6W#^6C3NSEygECZD|B=Ia_|<%;?0mQSI6`_1x6;$Bjit;?qfO=pUHO7+v-t{wGy ziDz=13KWTaO12t-qKG2h^V(I9K#^NM%`4UA(};Ap&dl-)=;C=5jaZ3a!nhsy@X7Kh z`->1py(o-!<%d8R34^Lfz@X(|P=_~7;@5I1lknDSkMOPWkTD9Uc&%0U^0NFMh74=| z(WVMNKnJP^YkJWG=>#OAigeCSvN7y3LO6T37Ix{aDgXlUO$Vct+qT+|2DP)BN%!V- zl3!2!0B=)AYqsD&!rQo&Q0MI}>FqD3cj0Z%F`De^(?xdKH5-t!YjkJXRYch}Ci9$zmX#Qy7AnUr({Ea`ErmkX?_gdIDSg z(7MM69J%ePh3x?gyXay>J6V$%P4K(R4OOOdFToxO?(XG4Y`j5Qg?+6pn zop8%TCf(&C+@hm}5v!@Yp7(e`*IiHDM0Z`hVdd`+>#pnd196g|;yeskQ3(m@dhbU1 zuIERn$LeFw4f9DvNyJ9|$V`v|D^HaHtZZ)qZc~ zhCmiY_t35CQh`ubi&Y(>tZE;VRo$S06!`-+tJ=)VnVs~~KH=r08{*#d=QO<}cJ=bx zVd$ovmYqAh^6pHJiLPP5^gF=6Ut)()4 z%(%856N+}Y4e>3?Hxom=K#K`AChww8fT^h`GPt063ih5)Qt`D!jDwBXS?5iHqLFF>A;UrIMUM#;o8wBoa$## zs3*J%|Hy34Gs%>W|Ys8?Cf8(?S>a}*%LcFrxtZPfzrrO};4(j6D30;nHs7(ppkrP5v>`*Y`Nnj%`JDb*Xb`r2LPjT> zFXK7dd=LCnxP(39R=C6?nw%3{qA^34b4U8??Hasjh!l?8&~u zggs?;*RiMSO*;0Z9_fTVRY_}f4SUM$ZeUMU=M8tY|IM+d%;$CKCD>Er@|$5#Z$>NZ z>1=<^W2KBz*tx=t#c~vX{~z=B+Q+jEef9sMg8p9@{!VyI@%O&F zDZdQMdxXO&Jo*kgu zQXK|=Z!q)s1`~g`8T@_C%-{c^^LNo>I)9%Z(3QW79y9TGyTRYr4E|P+bmH${nfbfj z#NWR%`1|~T8}PSXVXN(3_&f2joALKAHU7Rb;3oVHHWq&VKaUNqcxdgiN0zQziSgY! zxg)TwqYF=aKBag%e@bVaoD|@e*}zvfbkfP$FA`sU>YuW~5;xq+2D@ao!R$}zHdx(Y z-3H4HFxg<40fr5R#kg^|vx7}G*r)q-8|=@z4VL)S4Q#Lpj14V&QI}#WHuTg@Y_RIz zXomMwH@3mtdyEj;O=Z^q3O`@*kQqPsy&f2Jz03YKY}9n}w9flmYuew0jh*)QQ|@oC zXa6bu+`jP^`1wU|7WTMpu5Wakt8t@lb7fC6*<9Jv44bRuTixceKWoCzTLX0bynVBd zpI^Un6Z|}XS{Iw^o155NM}}xN*S9yZxpW;>66<4`#NAeBns@5lOh^5%@bncA-4IXj z6@<2EonyWYCEC6xcHVbqka4aPN;>U(Mj7}0xql8%FS!+-KEh^-`8Jm5=lV#Pey-Dl zOy@d1$T-*8iTb&&3p3&A>4iF;KH6p&DDudS@bvTpUGVg21a! z6`ro|{U%EdZ5RH@a-jGCf8T8H|5x}rx&Z50xHrMq`+l{(Zx=o&+^YB>ZaVouOU1PW z1^-@8#Ra~;s6oSmh_8p4@b$i-WjYpAo74#l>emlg&<8&M8hrh|rrW~T-z&Z?eEq$o zTjA?N&G>p#l8&#(tkLoHeyfQJYWRA;Jp4n$*K=}oe0`iSpN6mRDl_o)acgw0j2`-Z ze0`{auP?o5#@B}$`1;ZY17Dy11Ni#TF8F%CLzrsh4e<3G-r9lO^8D#H#n*M-rd*p0 zhQ^;PhsE+5{_g4de~7mOJLrnHM_YGBcje`m6))G%Qh597I}E%%Hmoz=zSVb&fw#{x z;q5tdJK^oKh_^4h@PCW9@47v_eb=q<_8d)C<_X^ZvMwvL?$BjrR8JG$9@W!?x6h)i z6uf=)9VWc}!(lq!{_saS-v09U@b-s;zmK=Sd;`4wWrqoG&%2`w-u|+Iw?}Qi3Eu9$ z=SAV|Kl18~x337kIo_`G=O%Qq0#EW!mg9$I@Bb=im9qE8OV-4!dF*kN5$X2yl-RN< zU3qk`#-np6Z#5tBZTrr1JvF`S8(G<~=iFu;1NpMhz(DGTck&Uh=fFq&>+p&H8Vuy} z3|>*#IffZ8;U2ks#0`~PKBb9bQw;M46%?0GjlgJnMUjEXyHS$5;bs|oZH6vmHySc_ znpwt9Gs)QNhKzl74Ini1#!Nz6*9&v*LRR!hhQzN7AA*>Y^btSI@V&NW=!kJoTKYTO3KBneFkMQ-QSu2)2 zv<#JNZoXdqRnN6u_&VVo#n)jElCO7^pj2&n{nVtw1hg1y9j@Ajq-Wb6r$}rC;a3Ui|NXYKgGbnnER8#Q>>`+sUVQe z=;;PTPwPi((bFHwrPSm6sS)ltzwcB@xUDwV1vJ)Ffy#*U$Lb}bzEcH`?p!|bw%8rj zRwHY`cdA54OUf8J$*^mZ4&bo|nE(N;S~|dg(mc^b{*8)-R!6ET(IBK9NWOnP z?U=-ObUUUjl6H*Lizf9|c1$z#29o+3J|8v)cFaVI@rua)k~d&WMBYHlLHK+Q4~FC~ z1?$$edgShYQn0Wr78!O$@9bjcII@HPlW!%`yk5pk-=cSF^px_-=XiT30yD+z%RQK2 zd*%BB@gpdj@=9a@JopzE!Z{A6=2gBw7{5?io9~?A5cs-LlCs5H`^tM~W* zoMGwnUJ>byECjo1ew3gkUb0r_(p-!r?Keu+iJ6|RrNNkLbv|0c)9KH3Ufu`6wi3yQ z)$fxge-bRBVaEX}7bwvYXOv3=Tp z(nUx7`er)fx~3z}kG++S*k#fY(A&nuRG4C6`D6TYQi z^(^he+YL>Mx3hD|+gtq(tqgJ1ILdxhXu0Og3)l<$%(vxS2vf?Sygb+uAErv0Q|&u_ zUhbp}hK_?W2dF_;`>wPb#je!t`)#WL zv#RP!M?a>?u#c-JQoV}vSp3+UKZqHHu`xR0Aw`)bWg<#_v^t&PMxD;|r5FQ<$G)8J z)#>c+RKrnnBR=yq_zYb_H9kv_TzBTV{ICo)=ff;U4~lf(7ZN8}tj@y0?mP8PCA;d- zS^mqM@Y>Au=nmh?!qe4Y3$azti82a0rxHh_n; znqha1PKa(YOpz83O3Az1MQk=yc$}*H61J(;*ygNuUtJ2Tx~xW3m&>T?s@1Bx{Kyow zrm8NBRCN^(1XC2o{swYl<|a!l{I4hrWsrDnL0*Oo%4()?b4i}N%jQDL-d4GWHg9Zo zEOcI>6_U+4lXb)O<>ZBM)#f3D_=DVt71nLAn_YZZ)l=@>&4UT3?!bGH7eYZS=;D0p zFjxTdR%=-=RO8Sty4$C9ae)zHDae~+aX#G5FUF@sYrbIU+n@d~`Q>){^9i`C<(&EfDU5AQx=6dw@mEN{nMpiWp=!EZYBfGQ=+|`L){y}~z z8nDo)i)dETNbW>x*QC*VRxPg6$hwF%dR;`(Ks~M#*F%fzu-i>s4UE zk0dO+#fvFn`Jz?^Sl`19sNRfUYHlH4OnU5gdNwoJUdzo9e%X?OTl%{2i&i6+rfS4A zTq>(*r;lCZmlPhphCj@YMhPgTJ1_6a}2PHDtO)qcFH-%-34%QZ~O%viFf?7Y{=#*neK zT3@-X?7}lEmWn()1gdx*4@#w}TC7S{i#6P!TCB`nEoP31J>1C;`4{lHmZPKO;sd2Y z4|L)4LRCkU7AJK?2A@}(_`Gn8iO*M>_FS^l@+ z^TsjeeCG;(-Mniv>L1r>^^d~m>rC~J%~Jm;e16%)=Oqv7eBKzT^Z60~8}s=&GoLp` z8hn1v;B(x{^nE_hC!arI@OfjTiOJG(3D?7d(mk*h_ra|O^p1G+qM}^`8$f=*JTE+>%#Azlaw8hKZt&b zR@)6b!0Bz+0SOa3*#X&`nZGkBUD*NXq_oS91$@tL9O$+iXH1bRj74n5yY0q_nT8$E z5-(C*ypj&h4mjYxx#lG8fXliaV4tMh0r`WJ9Z*X}`d(FNu%e*Pm zq(1W430TfNNNA2@7nL*DO`%K)ir9Qc>pac<3 zvl`pL%-Uc>P?oTL10F zA-d+ZC_83nW|`DnDZ5vrLsj8FOoyrlxX6kQ3&TFr=}JP%X1wKoqa-q>3jwAbJb^xNK3RjBUc zNQ;yEI1HWF?rYd~g>y_g?`fN1+g<6|N#`|WL+6d}ll-r-?XDGSF~@kr1S}BYA?ev} z6YyGshP&B}$CQkb(4_vDrztj*Z|Yj&HWIJ&)NnUxQ&^m+<8Ilj^}LQFTHRy;>n4ww z>n5|=Br0q(#Mk00#KPc>^jd=Zll&!KB6X9C%XBO(x{t(5JXBi}Kg&t>G|lJBS$z4} zMRsu-ecc7W^e5e7d*R}}#X)}fg}AQSqf_8)Dp%xWJsYrXsEtZulR_kiN1>{+6x~e9 zoSyJyj0KX6qJ#i81+;o@c6c{vdQ3HQ8 zRz+j3<};@$iP4zEMVI*t)&4qBLNBf?m!{I)cTrgJD- zw#JtA^@Z=0NY}oJ6~mYeuJ&BM?Eb)9Q(7O^(LK48+nhTp4BzIGe_{gM7!Ip`1j_ec6a{=@ukUt#9= zD@N_jdq!=-BCR$-_x z&hPe>7j=HGJ;@^jnf!fzZxDX3*7@DG;rhxXm2mY$R(ONQbgfgf|ESQxQ8B8S z#C_>ou2kX})5zRapS<~W z{C>3VRGH%U@$Q=B^;@<0y&mSDVT#`yk2R^sqV+KU3{(8xc&wQ1YPIN zei|Loy#G(gM(D;UeOv5bHT`Gb5P`vfP`}4627*u@Yhd1_`XZf&Ptp0~2a487DKF|CJh zeNIg|0qUGyFIDv?CcWhOtcFiW{fTCWohsT{8=&bW;Le^K-M&d&R(QKfFO?1HWQSd& zUix^*-TxZB)Vle0^itlCM{dUs%Nru?bhC5OHNxvgxO3u0vtFtjqT6BZztQcmYi7N4 z&7_xFU)1fej(b&PO?r5KXGGS{4lyEY-=0;GwRGK_DwVLvcjN0 zAi}gj92B{}?(7g2?TKaAaWCR-INer%>ADdX#m2mCEZb3S;J>EsD)-|tx-JKxTI&>g zztM=V{WrC$Q)sc)<-pAIopHHuL^mZ1Mq|fkT#MQMEbqxwHwzHL5o~S}{uUkOr+9y9 z;4O8OmaiU%oB?H%^$FeChdBdo-mimSzBL3lUCl|e-3uMnJbYB%P;^Ca-@dap=+U&G z>!*@Cd~g}2b4mCH&y48ek%f={XviXHmS|@*IM{Tl(acQ7P5$X*-pC%qLwk z&%R9PomQW?+{R>s>ft}D4jyakW9lK}cdyqq&y=i~TJ(_Vq@x%hW=RrsmFgv9j>~8| zYL=%Kr16Y*w=8NiwJa)zW?=iXW5xfbjJWsR3S?h^(YMHak5uC^bqcmjt>rC{ znbKCqt?{07qUWR5X07dn(Jk8jJ?}NaXLrgqPB{(WjgVD7ea3<7ay*fVuxp7=A^4{> zXfgQboNK}{Ml+VG+MXm~u>5o~SZ&z>H-qI~q=XgUeZmE_`$y+ze_qTt!G_xc&cp;J zVQsBVR4z$G&DIV3O3xMNv5?db(9kt1SXS<3UGo zosxnU`TPrL(!W8vHxE6fw8k5_%;bqe46ibZC&l0SP-u3htEaeptVN#ydGsoiVf$5?}TNuM7a0t;7u!=HNtMv-OT5KXSFokKPQx-CdjF zg`at*ly(OapW-LULY~J`Y@R92NEl+iPzHW4=e~#M5Wc@OYVxgYQ>_QjV@sE=UAJaQ z)}zre6CPT-E^FPAo`p*WrOo(F@^*fIs1X>^J+4)U@C_-5_7LT^xFzkDb_Se(c?PSa6zM92_i{qg;np!#^-f>pX{AQa5D9Z00U2C_`#$V% z)x_>UWALyvgDY7(1BUpf0k-FO&Dh#U@QK=H` zlQ+9LnNL<0+30>erLP|z7X-C(rZ;X`i$nCJ=$)12xJQE`Iqt!e7Tf_<$ZM4z_w`88 zbV3ThrTjm-r}qPO)kR*)sK0a+GE>VO9*9A{UDf)LLwNx%A2u6%a3IE5kdLrT%1=D- z)%6ydLVwzphs#c@HD6$HpaNo}_?x*Hu;bnHi#@~(IM@y%MKiU4Iv`8CU`y)@+jcrM z(<2(+Rw-B8osC@5iYVDiw!%Iexfq|3OtC9AinMz-Y9oMYFJ>p?_C2Ez>wyiR&H2cm zLcaur*d~@EW>^1U6f{zX+(K95-w)JRYkRji4^Mdq@-`mF-IU!$?;gXCYJVR~`n_Al zU;lc*r_O*5Xy@F%_h8!P+H;@rxnipg`F+i{$-N5b@%*J8LpKkk=Bzf{-fKnmraCCh>ApRPJ0%H|B@t?7aG zxi~o9;Xc=%<+IcgMz6L84}bh@&64HrMr^w6H}Oi@WNV0F`ynRNu=hY6u9VuoGop7+ zWApHX*&}&%2yo_0h4-p-zN`MDvWAb>`mRB$PdfFSsWuw6Jel+#Ds< z%ZI;S9lXI^WAJ3r&U4#;YBALqJR4Iw+%<7$-ejbeUX2}sn?$N9n_F39&_UUJowE7w z4EL5|9pi$2uI?6*Ji%F>)>02hTkRjT0XzKz$Le1FrqAmqL|7f5v|%?(8iXxd`m0oF zuRGoL-1P!^Y`^)jb6W@_M{Hw$J?7XTDl-PT@FxG!J>K!u(jPjHZdds{wK` zgNrI57f%tvsF0#FO@1oVQ;B*Sq0|T)<{A*lRdpAGhg>*|telCz$2pQ~7RrPF3>legzGlJc=Z`>;s|5CRvo{)pMp+_4d?+X^5ER(n6rOy0 zr2{rr0ApFSKaRkU z`xe$gMO0kHOmN==)|YY*E@h7ld;%WiU5;Zk{47^_8Di+j7F2<(rhE?E`6#SI+hk=O zw&zC-eTk?!u@yTTyI4h>}dPR!b<-kWIFYPW{x7KmBfi#JL~?JR%*_3%jm(Lm-rDdjyR z_sn>rZZT^lYePme!&Pl%u7%xP?@I+QP^Qmcq9Hp*jIFv;yx}XH<({4i;^Rv0NlK}W z_O4CYyCTC_x~(wS+m5q!={2c*+_#Sey=(SyA?Fg>l16z=4c$4nA8tdM>pv>`?vcTQ zsBT}7?)%OueX>tdHAn`_@Hi z6W{5v$36I%=J&7x zUhmFCfUP0QLM*Mf&_cX&_ZA%6YU^3C5U+nw0SZW)q#$}F&8TKPuGa-YPi#3zC1fpsGT8O3&S7_5w z$c1&3c2cbsJuwrYh02%Q|3^Hs&XVPWg&w6$kDf?GBliIazs9!Rby)Q822}kwyzuG2 z=??KTy;~qkz+8Q@^8#^CEq=NgBH7WMM%@1GNI6*OQ1=1m8qL{*CKl|G=IjT1Vv(K= zI8T9 zWZxud&n+&f`?18PN)?sKavGz_xwV)_D{87%kEKpFMw3%3$J;$xqZ&=KTpY1H(FJ?) zzkoLUkCscghhe$cf~DTRgR;S;nLep8J8_uY1B7w_kG=SxKENF(hw96{C`8q9@SwIWS9^K7k+7^ck@h?~3VDbeg75f}mncX!=Nl`idBn=~EG7m_9|P zY5L@-$6@+dl6k5sVs>M$nx#|`^9ufP19K-C)2KY7n>%UKb#rIbA91!6cy^km$1~0l zvqb{4#r`tju2JJ~nB1mL<7wU0$zK91LYX>sF=z4RH!yYV@2i13nK~T!iBgzN@6X4# z0#`tq^w!wA7@7-Nv}e}$LkbSM#D;ht)2MTJvLS5ieSLl<}g|P8bHezJirs zk_j4zejl~p(%DKplLFtp&}$w>EPi=EzVft%(kS`_eC~x7KV_6WEG}hfeH?$Y7Qb0% z$%Dv)g`^Pr;(nC`P&vb#*XW3kld#OaF91WQhWi)WlIPsffVj1mv z`4qnO5Av8 zm&Si)#XjD-9kAuXTyKQ&n$G~`%uU2f?H^2r!;e~@fucQ{w*r!MuI7j(uMmrk?30h_ zFW>Yvray(|TjB=;@xnT}uDr6}7qmMUD7&)>6vgVre5-uuYp8acZ?)8@OrbQ%^j|wLefg8+uvm8DlR1x4uuA-lzUMgntz>zE)V)87 zf8Qc@?zY?XyUcnP9@KHkpD!Nz3lANa+&Z&x3NnRv4eBiwLzhpDuJZiz#UcjEv*vu6 z8NPfoZqrL2=d;1K(&xLJxx;8(=33uCAO+9`O}0XsY&EaKuST5xGE6qlzZ7F-h>p9j zG>#pND~+22V6D|&1r78Zix@Osc0udX4bg+&zEefaiq+$8 z?`{8cxq2+xVbiQA->D*Io6Vyo{&_1O)1>4zCw~{ehf=Z?|D%}wx1U3_XdY(1sjkwZ ziP^kKzr|q>BEZ)CDx-2fW`OPKfKSRDo!jkz+xM;3VzWg$? zdQnJwpif%%zh8~hx++u$Kb-~(LBAituZ8`Z-o6VJw1{n8KjB$7(3uTbBh=cJx3n-; zfsR_Z8uoHy1+^&0CtBH;7pR!8Pmud^DO>PHn&Dfi{N0-H$ipk3b=+)}Bx<&^iLh5I zleEaC1IzVbuIp1hnCtui!XM!)2Q`7SJM%4<1QtURSdI(Zuy(dE;}Zxishy2Gj5bXZ zM$i#&siE{AiPz#jzz?M$s3hfmi2JWyDLTT~WO2YqT~2E}XgM<%V2wWt!!)itG84+Z zDD*4(0IuCVz?0w99~Tzn=6Taup8*Xa84v2cfRK_%_}92G)Y1=_WLV2v2;{yZj{5S& zjEwc99!U5z(>Ef!*KQh^G4D`W zFXnw0?Q|rK@Ik6T`zb*H8brN0mpGw7OHv0Eu=-R$%dMaCD%Z~jk|JAQ;pc^!eqf8O z{fS>IgQD{JSP*kaUT@7Wk3J;W^zKyimR?wA$oNCTW@tdzxD^^kK^>P?A zXbYn7l88VsUwsQq4~xyteb|+O)STS6IC9qVgG=8Xa^kj&F+iv(Z3wh7cO9Z93GzGWYn{ejKcDZhCI*8iKFyuvQ2;yy}s+ZFOQ+ufK%TvasF%ZX^r!AHW$#GKc#@O9^I(q=`0H4-OQH zFFxQ;V{gK7SV^s4hRQ?bJhNA=V7PhP-3LOwIykD=C29raCvmhYKDg~wIdGv&1#&gy zx$yOscd`H4upS)Qd3+p}G+{mMLg#pXu5k?m^Ek)fiO-5I^U2ph$a-}~$ZQ{r?bv!A z1f9Q_te?G^r>$H&ZO$Pbh`l=Hw4Jk3N>oxxES$+RQ7%%VE*VB`-txI_f~i+MHsue| z@=5UED<6Y3Vvm~mCuIt$751@4t)bDukTq|RTJr@aHPH`B-(+d?b1yaFyv6H&Td80(EheBb6id3?x=1atMld9Qi} zqDnyr>Qz@o%@zm_0G_rS3n%d|CQ%tqX+k48#Aey?eS+B3J@{E82TFpZJ!q!}$`}KgFyUjKiDlz?@@yYN zUG4iA33`fP>Q(Pf0L>w$HYI5w@IxcH?^D|cY<2?$74-NkzCVxq1Fe} zL9HT1tutPr)>}HY)T^LY!ccc6%}uA?P8!RRtt%eHK2&gId(~>L zzLX5mxt&=HQ z$2A#(!)0h4^{O>Kb^rti8!|UpIEg1PiPGg%0b!p=V0XR;g~O32xHX#xknfKy<>$V~ zy!m+(KPxL@1+9c;@4`+ohQ%ojG;VUOPk#mjWyMN7;yhLcT~Ly)>4M_T>t!IExWGp# z8^b=KE_m}rkgX(LbU}Fl_B~tI1=_2%DW&()!m!ZSOaD368=0hn44Wj#fNOan%bG;Y z2R_D;<39NiXS}s#D3%xZ$r*mm?_m7(lV*HYWdk|F*Ig_uY~TWJVB~}sVOr%pPg|#H zG8J;@3T1QIzAk@}15qKz1W;`@i9#M8EDwqKa)%8pQl%?o^(qwdH@ZR&UGaVM<-dhm z3p8qV-1{u3^>b>@=BK!(Y@t>`8L72EsI@)_)LLp#OTAi~a^0ZT0-;uWfLZ;t52fTg z-iI3s@iD6*0V8G%rRu1c1+`>Q8!mi-8lpus?zhmDo7$hM(2Zes@7cJ?f??Q&sT=X9`brNOr9Rcn0EP&3;e zUkbJjETQJ9|D+y!iCU|?=g)!kSu1kLauFQe?|~JRsx!CqKt4dF=<@#%wN-u(tktD$ z_3m6*XN-kyrki9aKY@8c}pu6S5mG-pltXHX^3;aA&QckUcenV&kv~ z*;-$a^%sWNkXIo#>UrIx+uE-G1RBm#Uq%)ES%w%U+d`vyjsqQ5Jx@XFb1z3VzI;f@*Hm1lec=;bzN%LtUw1>k!fp&gnmA@nQ^2{538sDv z{Yg*QN>5}Dhs1iTj1sFtM$bLWvlDqAcQ{whQKYjszBTs)-G8wCPIl0{n|+Ta!0Row z6MW;q2(`z51|5AtyyqHCM_=1Mjbn+9p1>%o{VnQfq+NpUHC|whg@L0m!B#^@t5;nW zK08f1+HWBb#Zuo*kU+oNgxxsWlgHTgDH=TFS`RA#zjcO@km~xhRwbmqYX`Pz)%3jPNL%WHE#LCDl~oPjt;f6b)AFA!U67bEa@5&rr>nxE zcJ6E&5|tiZUUK-e(c|QIWHUM~As_82#1`tNX4x26JhweHean}1NL5=mILQ%T z+^wJQebYRivPFCo`um>F&;Q-E*OL5f#C6Y<>+_;Uy84H1Nwv0o*R9a6JY|_LuMei zmbwSHYy!ou24rynb>lWZG40~))MgG4%Pw6xUo(a0zsCVaYZeRW+V3S$#$Jh;zx57n zg`Bw7Pktmf-oEb*f24RXFp={A>h9qQbMWeZW4e9)taoC#s~iqUeqw?J=lok1q#)3L zmFRowG!#WCM7HJMk!|kup)kAj8=xRSUj`F>x#SJWrlBvDd-EVkBx~(l0Q_4eJHITz zv0e8|>mkEPWxhkvw-X>yI;d{zH#X61sGI;W~w^8^e|KqT!%MSS@765OrL{=5MqPZ-gE?)1>zLDaF+g(KG93Wt%ch-x$!RD-4k^Sh zDyI2V;uo}yoA-Lp*KD7T*Dbx7^PlOZDc2=T4k`LB3Bd2qJ%7X3?0D@-zSguCIdZKw zEuoje2;e;0#H{m~mu>NgVM1^Av%#s7&ARHu z_=;}Hz4)7P#mF!Y9*rITd#?lT1mda*=?X{9iYW(}1uX9Nsz#5PH%^{2Bc}em} zNE+GOQiG&t@!U>3=$1Q*itv32%SM1Q8$9|o#M0z+gIe-j3!a1NSGa91mT7w!*iOYh zEVD(HIkctJ&k{I5EVaTgJaOJDG!Qv-*@c7o_@>W&vBg0nlkFCt9<(P@<9Zz;hG&~p zji>e%M$Sb7xd1#nO79)1v1xch8Pfky%UwWlN(zi}yt&B{75TEs)**}|qeN9a&#g^u2D=y5yYP87!HxRD7)*I+ zkpryX^C-rMv0&Zxg%Oydt%#P(u9Vo3gz{>8&B9@h3M~W~z7sOs(E&1uiCE;@8()Mp z_q0%D|44mRec><}#g0*SH^(96(mJYD{F350C!EgO(N@%|ls7v^TAT+hJU!o@nr^p5 zw%OGn^R$e>B>tu!euIp_q>4<*2((xj4}ZXuIpeDwe?9fm`G8?5zmK_?zi#9MUQd^% zAh3ZySq_UO6&QL?4L9dI#Lb;{!sg*AUY;p_$5Q+}Q@R~X>GrwO*LUHWe+)B6L|)oX z>U!F@e@xH*Hj|zPW?tAsVdin06=q%$Ps|+m3u~BpbIL*;Gtb|YnV@6lXkPSBj%++><@1KS~>4Ju9V+Uo^9{v7H%%fY#3sae@x+o|I*# z9$se>u6a0nR6yeenlzrYa1h|!tw>_y8P~;WGif}DF$;R`)_C^rhx1JOrkq+vWy`qr z&3I2E)_pZVU9l~SQ`0wD@wk!}-xG?M`r?$fl%wv%k%{Y|CrZgDeuLJawj1|%Y)0aU z-=KW_L%Y9Y-7>w;!=zyl`+$2&58z;KeuFL?t?eW6s9UU^K|69%3+>1h9I7Mn@ME-6 zi&CIIsA|ghQ}A=4)%8fA6jj8--*b9#QkMe}kzCjDk_-hnU5 z=b^8QC&&iio+X9rE1{*z<<8;B7x}GyQLZx5jB z(NCh%@v|`Y-v(4iQ|#n#CN78gZlDd4vo-V}RLC!QbUS1%=+xM~nIg4<1(Oq~TRKXK z{w^c>dp2Gs@e~ATqA`iHGI_Xs<25%HWO!D{aMmD0hen3zT#tzmryDAjhO>oQK$gLC zL6)X&q{MkQCGOe9L}S^Di6Z{4$voC_9_Q6O4q_ff#yr%kAjU*v9&gAz&KvW%rsm;w zcT>S6%;RbEJp6`m9uXpjuW0kIO>4(IF33E#$vm#hJR~Y{Ma|yw8}iJ({=WA1qpk4&0Sw~ALdbOo`+u)>Cx7U`x2zh!{0#F*H0GgR1w9@x=J8)Lk04_ng=!v~?r*kdU>^16d6dXJlKOBS zp>BFSbPe-}lX<)%^C*^i{F?I!RrBb;Jc^8Ys8>OcTw@+z$~;1ic@%5(cre2IAs#`8;v5+_4|9b@?~lFShsiD+ESq8PODzg;7&J2oSGh|2;S|HDTv)hPQqq zXcep8nj$DHo*)!%??+6cK>`Pk{fMHq&LtF{zZH;_%l}J+B>ZBy0EyA%Z>1biP&mQA zdkOyKbl{uU{n|SC%g|vsmNDD#v?*D5VPMaDP{45(etz?}UK_4$-iQgD_TfUzPet`a zW!wTVUKmc9M88V+N`#B*4--?%s|JF?jy3pkU61*kyL zI1)qQnoyZR1Fc}TU1xFpm1FYoofs=HonysqMvHNm|23PW0>zD%_~TMvHn-pG1p$PV zgbNYh&u`ff3hKz8EQiJNx+w>N86<`+1rzFE*PMgf?TJGBNo5_lagHfr+oyD~pFAV9 zoP!<8ezGQa$vG%9C{&;*;bYoYis;{MT)JE$5(= z+TEIL^ zNaq|?)g(CwF8|jc?&2Qd`Hzh908_+`Acof_wPO()Ksp*dNqxc@(;rN0qHr!_`e{6c z5j0Wy(qk>$rbo{z$k83Hids0}JcXqca&f09T#i0TMS03_pxx*(D31-cpm<17|kyAcMsq3(W?7qsJv?4Y2Rx2k&k)RwKc@?;;yR=KvDB^Yy*p2aEC}OLSe5r-*i_HGR z0M358%-+%ihdbmTU<4J1m_7q*>KgTfk|{0#)u#*9+qyHJ7@aIZ6)o8ypMqji5v5=1 z27dOR4ar}UTB1W0A>j-b-eBb1A}FTmhk9VivwfkMLWC|g&OV?~NVv%0Dbl0aO{0X^ zUL2Y7@X zIZcSzWQo{(Zh>AMp+{`gt1uxlU_#J}c2Xic!Xf`%ITF1;Nd7DxO)0u>$9o|EJf<|1 z%)P{wq%fr+`A_<}ntPLTbusi|ywYEGuPv6JlkwSdNqp=bb5**GYhV+6>Ia%nSF)V0)ifcBMm&Nud8e2VQQ<_iB&(rb zNd++>=6#KohzU`@;~3U=gJ}9TMAPecNbvBS5aqQ7+Ca)Oi3*8)l}_EYisFtYjPrjV?;Y!33d^g`3bQe-CJML1@%!s|L<;VaG>Um20kKAG|I?a9gO$cNZ9Dwl5R8c1ZTY2u3!% zd(tC)-4iQW*d7e|x!aJR>Qz@oX{YRic}KBnZIXSEmz)7a@RyQnmU4<>^XHOXa*(+b z`N!aw+IH$9)OiyT>KG0Y>Qo}s5ef0&R3h|MNkAB>iT?U9CLqkGcu0~ofjkipMUsFp zQl$Sm+F+Hsc(BW>5TPd-Lw3i;Y&$7J{hp(nTDc8g4=)rL(+tZnD!;|^QN$mV*u7(Ww6hin)(fS-V_)s zxsU7^bFA# zktxhO$aqALOscn$n)HsAnuPA0|1s1D;n96Nk#J=B=y~$!F-`h7Cf5TeUnbILosj4- zrO(3kls?Bq`qVv*wVySlk9yT(Q}$%D^vMtj-7faYC}!OuJm2gw1q8X@k3!E+!t*uT zn7lY}14pl!%g+mIhhTeaKGKsKi{x#buNEz31=&2`-AllzXcQAs4h$xb<{nh3H?dDQ z0P;Vd%+T;5Z<1)?2on7o1x9W-Q*ZKvvG)3%dT3a^>fNpJX+&=6Wk_haW*b~a=M~9g zxSu+m8Gzm!!5cs8Mc(K&gaL*1;p4II6Rvag^~&_9or>*Ue~>>{mZ*9gNq|}^18}#e z%N(9KCHG&zxJlE;9*tsV#?iChOs^z30^WZO%U zJC}*I`=xKg+C?X;SHYm;f{{Ciq6n8b2{VyZVri7ri)_k#94^<;3E-24x#FvCrF08> zsfCI)m!pThM0M1fe;2kl>?H*^FbtyJw#HW&$r0^8lH`c&Eg07^NNoSnZUr!G7Ir3G z6o8~J1kI!kUBu*w#L-FtFgfDLFsxnWkI1W30OsU~u$P$rw;&(7y!2oN1kOfJ3Y_wF zXm7PJbGQ<(6 zAN7q_>7)LS@=@=hk2+ZQQPrJNWhVR{8tI39)C0f09Urx9_VOS0QHv&;eblqFbszQE zZ*?E_Q?rlysmVuO_Bwr3xjv|79?mPYy(RQ&IUPac?V5k<0G^DGs1i%h; z4W}z#K1poP$ztpwk}~ZY&;Z+>&uE{tTPQBt*Lh9zUztYY?h39+a5@5ORzYSwZcc0g3Zr? z`mD9T2SV5sdHha8M3aJq|d`<_Y+oh(B)%p=49 zQQ-DDl8paH44pVxXMXi6n16w8W93>WA`w4mjwIqAVIqFXdNC@YW8NPrMG*3ZS4iarY?Q8iCchpDezq(we~ z=3Lw!TI5*9rE(zhMUzu8v~pidUndiN&7tG=NHX{}4DI(M%?}w`y$V(NXDuloxNCkX z+_JbmOaylnaNZYX-U6=|sdX*P$*VGxXT7PFU+clOAIUcytOoJdudl)Hbc{82b3;Lo!eQL749(b*02L6yfy4TGv4~f z0qU}m;}za|k$7td@z!s?S3juXtse1Ot$%5oD&CV4u3`;uE!?5$GJiMTx-USkEK_w{ z8r~W-ccr1rwoH}6!&>641@2abNt!Mzr`|}NtLw5IExImCKCST9Uc_6I{S3S{;t+M2 z4}q;+J9NBt)@jJP33q@s>kkOtIvB6bx`ZDpFLL`wVA3ub$j~_cl|Z#-EvLm<8H$rs zG~@R?wc}|SMva()b5}D`#=J_~%{C75v;M%B!ppSXW}W6)?lLU6cDtZ0{>PvVW?j;? zLDV5?gPP3Wa*$aSSjADv@R+aACr7t>aA?#B0=qF(oxA4Kv|dNKlr>jO>m10Xq8Ykr zoi&#t4{|9=)1HEzMU5bKHkAb0Ed&}u5j2|wsu@RRFyRo-F*?IQ&m7Q!i3uZajP15k zAxtGC zX64!L9Uz}FGSsWCidH7~=mjL(k7Bw>0R(*W<`TmBlPoDkSSgj1atfvLGpIHX>XdTc zgi@J(3E>E(%2P=xd$MrT^P&S%gi@<|lTs;)QpmKyXM<9Q&Gw_5R`Hnl(HRE z9z{ARWjiR8S`i%F-YJ^bANm%fJK`HerV8P8MN|gwuB;h&kAQPT9c=IIhXko&0-3*oR+z@XhJnv|! zm4xTSnOefLp^rj4>7x!)?2owTFG&q9O6`Sb znFnp;Ro%AF71hP(^4%TNb9YxgHAmA^uWLTnyv})5t@90^%l5j-=emb_O666x-rpPVBtqB@53~ z3%7Q=(Aon^yW0Kj4vPCKetZ7{uD$SMwf5Q`m$7!AQCxeI_&-^Xle`amQ%Ynl;pe{P z^nbDpvIoiBfzM9XeFxW*Dpe_Fm#pN$HmLKh2ewwlT!?OHnZTZ(* z)wrFOe^Qp8BL3$BZTZXcIL)J6eo`;)eym!)!sU@?%ZQ&(W4&Z7hGizbrpT z+x^~aWcf$k%jfRr%knc+aL~Q`eV=AJLWpV;G6u98_I6lIJA{A|l^{Z=2W}6)-FmwbVr!baGKd&OD*rwP63ltn>!0 z5f2;1w9O6)x-REpQl?7W>M#KseTb5(vl*e(L4Amt!sPaC7Z`REl zbA4aJ)1Q>kg_m6OzPmhurmY}P=14ZZOerClXj(dX!!_MT#AU@nOyRR+O53XYK;_)J z1>pE2X()|Qz*p6M^d?lrC`4(iq{SYlOW$L{ZqM1*kQ`Mfn`yV89e7PS^Qbc4L>CEH zhU7o3P!FS7#HK5D6za>%*7M4N7E?$ zbR?);W4ROCv+PYUzRK?Slzge>U;w7i^#ozgrV;e<9{BWyG3OBM%azTPAmzf${=lGW z?xP2pBgHiT#>FffP04aT4fm1M9+tT01L5F}z6Tg~TXh_?QHd!JkS~pLVvN+A-iFnQ z7=e^_V;3b{lj>;&n7*zyYs|H_aPh|4XQWV}wAyji#;KMfwD&_wc+hcp{B_0iiPF>{7F36;PVIn3w zDEFHGxi&;I!`|X%`dLo1b;Xk`SH2%g&$3fmBwi3f@{yR^3%SPMNT74ItkJ?SYJ;)H z)y5hveqQw)2`;f}xw^3QGCEC2A3$t;kSEOSW~=unZQcJ0cD<+$Svfc6j5iM18vT$J zEfjET01sKI9I_k_9m>Vh)`NTl5Iu6;VC#GG+GAd1nEM@2f6f^UXVS7N?$9e7ppJ6Th zJ}$=ciYkNNNm2F{u$ za>x!zG2LHy$R_lY%3yWK`m!?EIAk?9IAo0vsza7rHlz;WSliFkA#1|MSf6hNn!!V+ zQg>TrO5@|4SonJsaK%zmop(P4+?6DP6pO+^<-YBVn65t#rVs&VUt|b4J$1KzB=i-8 z_zMSS?84JeDj|*w)Ls5xUj(PVMPOaPf3CdBLka8u&2;M;mk*sD0JpocY(^$C=;l6fZ5p#Tq@k)<+#o4U~xK=YPN7Z%Jym@Kkmcb9RZH-ZtJG z)dg?%Z3*ky(#4PWT%r8<{Nu`xugmC+H&{HgNxw)rUU51V~SAU}8&FSx(dWxm{8+dc(VI6NimPTtq z^1L$Mhx(MBV*8E@-prn28UH0ZH53f|36DY-U>K1|=_z(LgThSfDVE_60Z{HmwR4zE zwwtA{XEOxu9n2qw(wu$G{vPSZT8)Pe2 zSs3j-N0;&i$s5jo6FXQ_-WwwqABLZ=EX(Xs_~{L@d)t{eoV|k41Jz0_=mE8}s+CyS zFGwWSN~|G`SpGqYF+L!h`)?L#xRpAVuU-X~KhKQi7at~;f8FH*MURdrz;IETY?jLY zPDtbama6@2Wg>5>X@7rz zc05HLD>UkF<>^C@6`7~L-*3I|o*D0)|MPtG*q&Ll-~H~r_S$Q$z4qE`IeX?nk*^%g zV+fmxbomnLa@Jr`hk9}tb)%>b&2%}z>W|{Ey{B=+3%%)4Z0gR9Vig)ov7hmZc(JBS z%e!T#tnZ+A%WgW%$sP3W%`UUm(3uwxfpd@(SWq_vI_1!rjNoB?O-^AyrI3R&RJAv+ z3hl0dK&y=7ZYJXu>Ss5I@9?J-FL8}DD$kn)645=O^hcexo#Ua`=pk@EeTfy%34zl~ z++mvxY+3po1GcIKTW`yl_7GcxB-pCE@wi;i4H8Xu zPcT)sn&-JS`&e3j+)nXadLjNAUk4p@RCvU$KsbHp~UK6 zp^U>BuY?k-$faY39!jj{dAdVQ;4P>6SHvAE#|wn=&qsgYPlzrxO z?i<8DkS7Zw>uNHGMKfuLE4YT5-J+RdtV_HVonADP&RqK8%wC~u_g>1b&D9Vfpdpuv zYuL^M2wSlCAEbwAUFo(_`#g6YTY~B)AB1AKXeM3hHVaSA8-%G$c#LbJb})zGwHq6j zW3RYe>GVf&#D0r$#LkLXVCO}#+9GDBJaSuD-HJ;G0s%*ofPlvS98<|mGQ59Hpzf3> z3~wJ@Zfji(&n%CEQ7?DL{K^xC*Iw=!#cHH%J3kktNur5upUKOy8)Vy=w}hjYXkxGZ zs6;?T9&vIWs<@N9A5p9-@`V4FBuln6gO9fK%){>QxbV?*QGY)tAN}iKs=r0TM`a(~ z=l53)ObU0=cnh>q9YOZdf0Ea4Nf zgi97+3BRZ>;R5kz{M=Z=?G0TbO=~AFr==waF4$}C7 z6Brk>9+s=(XX)3PqPz7fS-EzJ>E}zgzwJk~ldJRoo_=?h9Mb zmlRCecjDN4*5IS*V?KsL-7b7|xolA1Bp=->uD54(sq+9B$4NII)gQ%G@iCr`z4w0) zCQyA+j$eyqL97=)TW27rCT=Y0-uboP%7h$X@$M*B2gCYcDX!s#g!}DZTbF zEw1A;iR;xOCW%L)njiiT8xlqCCozi_bAR@it7)-mF=H6B+8ET!v4tk0x+Fs7Q5;A= zOmnWrh18PCinL^4Yp;udX;)JO_`e{|SZBmeQp{kR&h^~5B^OITPIF)Q8YdUiJ72c| zmVY9#uEgd_Q;7<~d6W}4D>NErukz{ib!&Qn{yx$B3|TPvBkZD+izy3Ei}$eq3uL0H z;=H;~WI;W)N^9F(vOs?nvLKGGu@ZzcdLR8t&ke$96EELm2DWOtL|_UI5L=e+j4f3m z*qYv#*g7WIsvZDrt#)Hee-ww(hKnyN3bq`5M|%WOtn;VktdYu^C0wFbEu#z9|C5$m z|H09>^hL{+pFnu(^UzA1oENW@hN7mMU?^%8!L+k4rHc66J^1BhAeOlEM}u& z)TtMEQS&{u7Hi^%DO?lp1#%eGQ=mk~3~}ky`lF`t8wMIqj;Q!PE1nZaH){%a2=>{= zw#L?JGqi_&WO$Fun5w2zYpkXhw|%xKzxRV?E0(z!p8hBf$)*}1?pRS6-jh27XL=mn zrfn2IUT@H@^O>|n9w%pi%5-ppTyKd~45GUuOiUzD_;J#NfTY@nESpuw` zHu&g4#PC7_Jn~W7)8uwuZ&2!N+>DtDI4yj%fYH^OCIJt+sb7E8X=}O}d{kXgF)zOx z#JA^KF5wh?3Ex4YOkOTa`0JawgqQ0}_(gO&dAWND@4Unk{#IYYL$HK*Zjn3f&&v{i z!&t&!4U1z#qRtJXg(5|k@PYnZ=WoaoUSY<(pLQ={c@#^y)xCt@xNr$Cub>F{P8P&r zY1uYJc9=^@_qG>ghuJa<#AAEGy~F(R5<3u1pd+y9YasN;Ldt^CTX@d8Yr4Jzsh<5^ zCK?*T9mt1f^2YCaV3|g~!8NffjI?Ch2U)OvwrdBXKkB`*ezr@e-nHez9mqanD??%H zw_`(~W(u}^h7en+f~_;eR)&tPQ^eMfE^O(K0$abku$7@>%R13B4(bY8os#dRvQ{oF zXAQw-vSl*;({{We_JRq%X!)lzSbw5c?+~1vw;8APYumeggaNV~69&+^=U)aNbzD`2 zW&4@%(G5aa_fqQoJdAwwU&2RiBf&WKxcR95sAK!;$2=_vKhc8VpGm9TQGG$gc+*b$ za}u4McRxnD|9Lb&2hK*P1Adl^RB{4PAas5H&Uk3d5%S<#Z9dMH3Wo4PqUA9O@p!MH zQ#*Zg!lG`#YL~P^Zh{g&2hDa#D{^goPKvsW zF@0l<2~OCr+`_9v$tyOKeZPDQM{~>=P0jW9Vl)S2G`TXGc8+FBK1XxRJ(|_-(ddtw z#@Ai%smha!$;0ic% zEs^ov6C~CqgS)2R_c7wBRSS1r?nmx=n%s5k8DgnPxNG9?7=B`!i@WNNLesv_Q`0`q zbzwOr*OTrOEW$(QmkoaczuM1hPmV@u{m1L%UcflAr62pt=PHIV{4v>eM__6iEd#hC zka54kzU^B2uX2g>@N}v`wqHrCJN6r5?$_Pputx5qm^(a{jC+?b?$gB5j{PF$X8U74 z&bS!2{wNstS>_g3R*R`=yu@|rR<5!WIu_pzU0vx9i^ETUro~~xIJRE%g2agl4ZvL0 z43W<*4}fjd3>gj9rmFzI3WLN8`gYe}$%XDaMCz9tGe>l0=Gb1v7wBFI%}L@a^Ya}< z#^EF}zZi;eUGTq}_)aRqFNe~@_=iEDhlJk5QmrV$UJ(dya%{g#5w4X-VSWiQdnm$3 zD5tF>HerE|t-5BGkD1dHq;BB(1kClxq{~$n4rC$>&;TGj4m3pGAgxy(!EL zS0%&o0{uRVvrho;@;YB&q?qbH??tg$LkfMIwVv-x!t=XUiDf5EOxaU`CG-6vg&bWm zAMGwFq(2Id-5jGI07|R{uQy$H=^9_4TlWEpH1^yQ-lfwFop5e<_g%W@uG8<*)uo+( zmu?TQ?a80rqG=Dox3QaXHbk&~2SHAT%>Mp~ff7Nlt9h!$$UMWybm!*T^^v?Ya{<3n z-Wg_{G43OD>OQ<%_w#bjls~AS57js5=R-#`&h_)GPWABfZ1C{&yoNbvTz;NjnqxmY zqvGf7s`B*nj0uZ?pJ&OZx}T>;KTm)9d9FU-WA8Wdl7616m7iyK<>wi#`(IYk|FT;7 zd1f#b8sg`~ zr~w<7_<1KYc)eYZ9d|M#ou5q%_W2<1wHa66Qn8@GOubxJ-yAa}RP}?mU=`n8kp4<8 zRGt^HpA~OIFD#mbL72+;%PZYe{UqDglP_MKO=iFNVu_QN zq26ACx387AXGxsAs5y54g*cXzIC)7j_GpO<*O*F+%GPTrAsfT_d6tbg3>vHWS=Udc z@8Aq4j6*IkpfAM7wPKx)c3atv3_qImHiZ~HZ0TKAITY?o)q%katNoUv!KPGn)oQZB zfk0f<9LF5oca30J?odhEUHbMTc>JHdnHbQEA=2YQd5Iv46R1m~UW{sgp5IwhGegpu z{YHmZOhxSlvEbCznz+O`ykP0LjIm08%25jj4u{iO zqa+TqKXne=2z07DoXXAHxqfFm-rk1J#wD~T4%!2c9s3-xSHmU7(gUaUHAA7s=`Jxj z(xuyIwyRiA{yZT-MDL4qJep0PzxubKHsV~;gpo&(X7u9-L8rcNa=FBe{0W^csx$S- z+YXn}wGj+}FK)+9^Y=_Lw4S(6zR)0iVA1+JEX5NIVFn}`m)lmvCu_dYa=g0U#&WQ zttxU#0J|ccz8tiq?cw>&Xwp~H4IE>VjImIzMI4tg{=zYC*T*;%hVTma7`JB|}~5&QaZjK}5Z>X3}_ zTaGdLVHsl!$2i6{#^i_HV`LU`wglF3X}`w0qXQ0R#9|m%KZv&&i)?ubX7OPzGI1V0 zD(n6iA6jQua4^-|Xv?m6xIb#>d4I+-`Npi!UU*@96$oD!C}T;N=lM0Zy@Y_~l903~#IN!GSYSEfRUQ+z4<&o?dX>k7 z@3?MUx05HF=hxWq@ECMWEo4$G`l6)B>&E+P!34EZk>f)_LEwsUmx; z-`bsPo_Q|t{XOfy-xm^8Zw*>$J-*89WAQmt)8g%Aw*-7;?V4FPEcdI?Pc7;b^T>c_ zUW!{m^$LG>i>5u}afcN*Y&`YH27EowpQxkvg6=s#7DJ~M!@I3GPhXtyrg1OmOXFTp z{<;1{Ei*mz#Vkm?nltuB0aT*8kvt&=QmP z8~#KEyuW%V-{ntq`kyaSesec;#>i0^%=@cnJaQBs-%EcYiN(-9lbXq-mDZ_PKo2~L z1++^R#+yq(Yo9O{Lwf}6+ljP^yt$0)iJbpvKIAA(7A~`q?uuDCo?5{JT<*JMPx&Sn z*!2=5;Wt@e47PkU-zBr#XI?0?>%WA|)*k1E@}#^63Q;VMHh){s-F^Udf!{v{lZ%wx zhi9dKCB1-#lliXT3uk3quot*A(1OH!z(C)mx~46m+-=`W-9n-vpPflbCz|ESe35j# z=GyS4OVXXpcS|~53jF@f<)pw|iHo4U3Yp8WP!TnZi%>{++$Usetbe6-avT|eHcH|m zj0FSmYIVg$&>zJo5Jb*r;A5H zT8Jtnfr4RP|dTA!kUx zKazg0lYXCK(?j)spCpaC`>j8UelIeP?5TK+p>vY-+xnHL8ymPbQzE&c8d^woiZX$x*_xA_Vqxl%dM9a#p0c6ewW^<`hA(>dmp55tJJT&WUcb>PTi|} zr>@-`XhcEq%&Gjl1=y8bxK}|&1ir0ZLK;~@eRuTfdBPOx?>#jyI*9M#3|#;#1X)3h~#4>?i-J6Z^?8wvcY+GisQB;0P1+v{7vSf&@M0`>HGl>&Fsz!@KO( zD!s2cFCCAjjapYf*@pok&iMt>)z2e3#N(8OODQ~6bch2bJ7Mg|D9|kazH7!-Q*7GK z3HuOfMN+4}zJ6M1dgbxA9%BPVo((i6{@J5}DmD;*ZUY4#4UCrt3eRbv?k^qndmc@O3ZP`2gB^|oJ50;bAfW^h-9xJk! zBVS7pbGYAAjV}j>h29K3+#(&q4D{*&7%O@s<3gtS=so=A*|=z1A@u z3HVt>pA}Ey;PVz-O-Ks)A{{kirAA^TYS?_a=^3-D3<+$y(e`vYJs7z~WK4SPYHvNu zF%L3u%!FHN&VHdVq$h=ZhPKiVR5R&!@%HYFogMNxnz4JA1`^3lWtn)_f%LV&=Dq1i zg%cVsCo~~7s3hlA&E5-<%f;K@aPVYkC^7JyNWA`9#9S0BS)Uwqev|L*kh0BXbJ5_3 zVgR|f2A!|$r8l@ub^fR7t5gb@F)0|vXvrcivA`u$h3PurGe15VLmunE@4MvQZk^vp zy9~2Qn`s2nyO_!uyH|Ek+N&b#+gp0|KmtFFXFVa$Ohx9jvTL9Zwj~ZjgGCx~I5t(` ztu*8jbST&oWSsIfka$M3PMB+D=4aZ#8I(q0kmQxme$5PFSZNV>9 z{Zr8NxEQNhi;?)li~Q!dffiTrm1}QEEkmj#nYJG+oqvh6FyW9f_d&hqG1; zewo(^8Q717Fb2XY!EtllJ5*(3^%OKX-O#Xyk4*%%H`nPg5X>$ z>)(6S9@g)+Plq|mrd>;>g+IGR)563yKGl`~&Bu27VY4{}*=4+$3Jza%d69wodj2;( z9{T*y%gKxEyrmEsX+`c^31;J<{#Xcsx7p-8E_9^LoHh<-m}vK`ZY#wE1pGm3tvo4h85^rFmmP zW2fo5RH@%~Hfc(2k}g$#+S#M9zK1SVYA99ys!NsfG0Q5p7Mpdca$-$F>w!U(Dv}|t z-@x>!SWRnMW+@4Z8aB7zrooX&^tSYi1>nnuR5`8l^u^@qoA5g~eYIYDTteZdajW^5#j}BmL9;v>7%xI$(YX!m^=QDs z2DEbfjE zq-Q(Cjb~I~gB)qtbI5BB*4LxXBp$8qF2MOxC9O+qXE>m7u8idIn&% z&$Gim0lQ(>`7o6P+*K?~7I_*=dm|SLIjkMrsC+0mXyJ>>kGeC~wc9{o)i#I#cMN};) zK{Y)y&ns=nQ3g?Eqo}GFJYt6-s_cOeLR2M+v^9f&I|fjiG?$J9C+tR1m6I3*PAH

2$!g;sbHS88Zyx%N#pToPd=J=G)nRBnOQ01-|?=k6OdEG`>|_hrs5ZW z9z>YqtVp!gO3CIG#vEP8a6tzRHQxSx!8qi)vN{dzN(K;O_BSXeTRp zrqjFzT{Vq`0W zxODX!!x;u=fv&6Z!tH@e@oRjBjSA?#>R?dqcA1*Z^$aXq#6DI})tiqc4&{iUsbZCy zvb#wFx+cQG8&k%0_YNiMYgQmfBx*xkB%X(6Mel%$;UKx%mM~qSPLss*>5o#P<{ZT@ zxOlZ5nk%EZ|NLiF&XehjQrmzS6;*iIahyp26BpgmcN+`VzeR1)0gT zg4^)E2(MWdoJ$=GtDc5{u)cl)p!l?Kn^{}k^C{Xka5jY}UXtDxWO?6VkfyfkIvc0F z-WBT4Qf9`vRY91SxK&4Wo@Ul21~Ct%BP=Nz*l?Cig;qMdDjGDL(ES+%;FZu7+N$w) z7?y75c6XDYA{+Z|3SP^;*P-v_Z?PwD=zZUXzQ& z*i$|+53ahkk7lyA_R+NdT6&q*GycUjp^h;o?iCLw&A2hXi@t}P9uw#f5smz+|K>h! zIreXXOqSZsq_xHeyyaVN3w5rpW1`T0|1J;#wT+_ab^MPf*MAGgZpO%UI!xcWwNRGT z7-mn?U}#_cV!1@$JB>pNW+F@~<)>7_M&na_0&h&{IK8!X5eXiouH-dj_6MhgIf-yzqrc^z9U~7-}l7gJr&O-@m;N#ghS`ANxOiA8EoGDBY~Lahwy~Nhl)E~a1)u<%=mo=4IUQC`M~wGGG_p!U zeh*6l7=pZ?MB>0c&7>ufXW4z%Le+qyLB&-;x{iJ^{3l|p3jh4w$2L|L3+*;N@!eP} zVz=SixisGA*yqk&q;MWMD!tpN3vk{jI7hT}?9yYOSD2Z(JX6t|Eq$Zyg0Yu-k=`)&Vvn)c ztFe3OIgn&=JB+b+38+$IM}lmShrW$o5f#L3ba#CnXUIAZtw;hIe2Ip2Nl#L76@j|n z;)~TcG+>qJoKt}k{th%*X6@lZFd8RTTCNK}0HVtC2Z@gh7`rxAzs&p;w+#Dd>+ z8tK?s)IFJn!wU14#an!#W-9hTvhT=oraRmEyjdxf|RIm z?|9w(b<>zuvR0>XVRdS>(-%v}*r*)VvsuaMlxii#wXUnXV&Me^g@Vj>fkSF#*K&p5 z3>I12f^fQ}XJnPG#&ILQ48xa3YBkB5vAl&!*S?3zsI}t4(vG$GwZNY~aJzb<(Yq+q zr*=U{AYd&Nuv2^E%T6-u`r8cBe$JS|i_PC5kNNY*XCK>drp!(eHgH;h^X+$jeY>M6 z(CmM997Lrs-E-&lfYAROJa=jOpPM-+Ker%%G3BE^r^5?24(A$ZbMf30^)t4b9@cs8 z&YmA03-XxOEUq`~N$po-PwM2J^fIT2eYgdz#Ud;_zZ!Fz-bVHIq%Sd23WjF{DibCHw2 z>3lg7rq@wN%_oZw^`dH-;J|c-%AU*N{RgtU7&s&(R0EpD<3V#|5qdSyXEdS%)!|&! z+L=3|7AM|aYi$vGW3kv9{l$eeG6uDMOc+B(a3sgjYz0xS9mTiA*NR*x|J2rqAQ_bo zaO309^%^2W@t~r%p?<3|h`VWBtEQNuQw;o`N?`bP%%uIz+}nogVa2$y+{9iLnEpcG zYPjWTi{vqHvM2qqI&$f{P@PNbcZ6&bz}>~Azf)Y=la{IPVX13@sV4vOl9+Ypp0U5} z2zt*M^r6=IBWvf69i2aOcK$*OK4uO6#u5CTGx!HBlK8V*xMie__=8Ko^s!;_ z^zeTp9-Za7iNf!O%d4j+8 zCzyT`Z(VvccA_cPOAE)D#g4%FLj%&IG$&M-6Ff2a8C_5^M%Ob9Wd@6)Q7wuL4=ts| z5IAT?r%UXe45c$ej}e?s4sKF9 ztTB6J&)$Px9-U#Zc0jxFq&4EtZqYO+%5FZB-EuG9%XTMVoM$NY`aB1ei@$D$^>X}i z$zpw)WvbO&2j11*?Jm!`uESi%h4XCd!|2F$oxM{X$+zT0`#5jKNmI?hmkWCC(RxxU zmXA5Kad&ma#MC;NX^H|0|aMD&`OY2t$D66-f+>C^GJcZu3VcA8ye1L z0>bf*+8TU0ILwDG`7NdN@erM-u!J#VMp`z>R%KQU9eF!FiZockWNPJQ@U8%PjhKh0 z%E#kuI{y9mNRVom;J4AEDE26H)l+zVZB&61eF^o0$3ps}B{5XVBCBxlKEn%Wz*YAAPAy@>5B{ML(h&mab6rWO`B`=ZxA!U1Q7$rYycnZ8VkdY#4@)S@2Tc{ zEc$y)H{m^{#(Og1@-GKQt@0kLFEe;mj;DX?!LBjjz@y@EuGdAPYjP-S3g;3D{>=w9S;G^0jkQM6Q?C@pBXRd`9lseC& z4yS3w_;(pyAv-6#C@XtOZrb83u)m?h64DkI6=vFV)3Woji=N%-J@}N5HE{ftVCaPX z+&W=Qb%kl5t`k0H-V=Yy&; zc~c>e#izJBEO`7QpqzIN_MAi(*9n_ztNCH@-R{sgE#3~;RpL^qm{_>ir#;FB#lR1!mpJ~SK>Jv|y#x|DfoiSdmeSp_@J5xtvOx4{jsN@jUEDYVo)#)Na=IDqnu#g^SP7t zFGGKCm4jm0ms}OWi!8%|h~uyp8Bw$^&V&C?X>ZtdBQHjKH%%FE0qyy?X|K|Q_PV-h zueAREg7%_5=n(CdcZl|Gy8`VciaCk2w}bnNb7=1$p0wA)MSHR5(q4^=_G&z6FV&Ow zQeCv?^q{@=D9~Pwi}vQaXs^+O_Rb{w@58!?aM9jKH|-_;-A#MH`U&mjx@d2voAy2( zN7@^y(_Y;rX>XB5({2VI8x|ZIU2b}!YgXmVlFna8w5K&g4yz7ec z=&w@}x;|ar@1aSl8I9!w_TN$*{XgX~-``qQ7+i7fH&bgr8dVY7Fs->hts?HF>Fu{w zRm8u3SNQF3R17;hE8*{7RE+pbT57l8l_S5f7k_ol%7m7Ts>L_29Nn5(>%DyCjcc=; z7eBXh?13Er!)I3}Itml^j9WFKZE0%J>QxiJf1r5Um~cnRuGOZh?*9pQ++4QNR9m#* zD#zp}wwanIyw=MxWlxQ%-Dhls!}k3vrtsw22*+)0ubUFgA4E8&ZG6L&y7}`6$DQx) zHx)N@igcuIsWVk=9vtboyZtTL0{E8+!^tfWAYHvTW%1mXvgEp8?0-;B#y?iW{$2i9 z&c?r(PWty7P!H=z1KWq4j3yubPyNnstj|CGMm<}V;HL&tr4gRT8!D&OL@~%qNP8nc*@lTb6^Sw_27KeYTRP7uF4B}B!rGona5in0; zXQr15J`&%t&Cyh;;PV0R4!9}>j&a=!IMC%P6`VdZ?-0ael*LXsT53 zM!<&vu1W>}8SpWHt5U&7cx&1XfU8o$^8x2Ps#3w90G#upN(KKAaMF(|75rzwNrS3X z@ZLT;T$Ktw9&pl$DiwS&;5P!UN(FxbaIP;^D)^^>v;V48a6c>*_EVJ#9uGKmH&rTl zD&XwDDi!>G1FlL1-)Xe3N(KMGsIN)||2NlN(B#rt!WVIt5U&71J3uVQo-i}-XCyPD)<_}`vI;>1%DoJ(z7ZR z{BH(al?r~+XkV2I-V?? zu;G(-RH@n-7@(ggs#3KR2RQRus#3Kx6L9ull?q-0IPs%O1%KM8uSx~~n^9kt3jQ65EU1^>}#UzG|T z8KkclRVw%&04IH_Qo*wU=f+T#3cea}3*f3$@Lhm&ysA|24*>5AxGELA&48;?!Mk{*^8DqQMfSy)-b63VTvlMuF3ibUnj1GaV}2YA@HzIv%tCwK-2B{( zWks16eKu`gcERFd@xySKJx||#V+SN{8h zgdk8onw!5gv!jSxnpv1VZ`mcAOv^9G%)9ijyzie@u<+6q^c;nkts-qKzH%FvtD?7& zJ^zXw0i9gBPCb0??5fM#CD+8Ili+UsP9G} zXYaqm-<+(4dBEQl-?9*)&pVFkg@$8J2bvWJg$~r~2!a=;Enad_{-pC(gSJsCD|=qi zrFjVGQ5M0%w2sWzLU2(JU*`@C<^O-a7N&K4z6$bPr}`b}lk2Rw19e^JV;!ig&R9B7 zRT$VkS6G!DBCNCy5LMb03F^wk)FDE;G70q3YUVd8B zIyUZn`SR~9(oH_7#BGJ literal 0 HcmV?d00001 From 416f64ccd45dc950b04fed0d9dcb6f6fd7ee506f Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Wed, 24 Jan 2024 11:19:10 -0500 Subject: [PATCH 277/305] update pinned commit of entree-specs --- .github/workflows/ci.yml | 2 +- saw-core-coq/README.md | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index d71ca56ed2..d5a39ef35d 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#d1b669cc68e9826fe287e80992346e2849736be4 # 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/saw-core-coq/README.md b/saw-core-coq/README.md index ad8ca7c9e5..92e0e14dc1 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#d1b669cc68e9826fe287e80992346e2849736be4 ``` We have pinned the `entree-specs` dependency's commit to ensure that it points @@ -48,7 +48,7 @@ and the `ocaml` base system installed on your machine and it can be fixed as exp Currently, the Coq support libraries for `saw-core-coq` requires Coq 8.15. Note that the `entree-specs` dependency does not currently build with Coq 8.16 -(see [this issue](https://github.com/GaloisInc/entree-specs/issues/1)). +(see [this issue](https://github.com/GaloisInc//issues/1)). ## Building the and Using the Coq Support Libraries From b100897835691cb220d4f01645a2ee2af17a2f10 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Wed, 24 Jan 2024 11:52:51 -0500 Subject: [PATCH 278/305] fix Haddock in Heapster + MRSolver, fix typos found by @RyanGlScott --- cryptol-saw-core/saw/SpecM.sawcore | 4 +- cryptol-saw-core/src/Verifier/SAW/Cryptol.hs | 2 +- .../src/Verifier/SAW/Heapster/CruUtil.hs | 4 +- .../src/Verifier/SAW/Heapster/GenMonad.hs | 2 +- .../src/Verifier/SAW/Heapster/HintExtract.hs | 21 +++-- .../src/Verifier/SAW/Heapster/Implication.hs | 34 +++---- .../src/Verifier/SAW/Heapster/Permissions.hs | 90 +++++++++---------- .../src/Verifier/SAW/Heapster/RustTypes.hs | 18 ++-- .../Verifier/SAW/Heapster/SAWTranslation.hs | 32 +++---- .../Verifier/SAW/Heapster/TypedCrucible.hs | 36 ++++---- .../src/Verifier/SAW/Heapster/Widening.hs | 2 +- saw-core-coq/README.md | 2 +- .../src/Verifier/SAW/Translation/Coq/Term.hs | 6 +- saw-core/src/Verifier/SAW.hs | 7 -- saw-core/src/Verifier/SAW/Name.hs | 2 +- saw-core/src/Verifier/SAW/OpenTerm.hs | 15 ++-- src/SAWScript/Builtins.hs | 2 +- src/SAWScript/HeapsterBuiltins.hs | 2 +- src/SAWScript/Prover/MRSolver/Monad.hs | 6 +- src/SAWScript/Prover/MRSolver/SMT.hs | 8 +- src/SAWScript/Prover/MRSolver/Term.hs | 2 +- 21 files changed, 145 insertions(+), 152 deletions(-) diff --git a/cryptol-saw-core/saw/SpecM.sawcore b/cryptol-saw-core/saw/SpecM.sawcore index ad7424a790..11f8d708c0 100644 --- a/cryptol-saw-core/saw/SpecM.sawcore +++ b/cryptol-saw-core/saw/SpecM.sawcore @@ -386,8 +386,8 @@ substVar n_top env_top K var_top = (n:Nat) (env:TpEnv) -> Nat__rec (\ (_:Nat) -> Either (kindElem K) Nat) - -- If the lifting level = 0, recursively substitue the tail of env into - -- var'; this intuitively decrements var' and the size of env + -- 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 diff --git a/cryptol-saw-core/src/Verifier/SAW/Cryptol.hs b/cryptol-saw-core/src/Verifier/SAW/Cryptol.hs index 9f214919d7..3a1b86f895 100644 --- a/cryptol-saw-core/src/Verifier/SAW/Cryptol.hs +++ b/cryptol-saw-core/src/Verifier/SAW/Cryptol.hs @@ -93,7 +93,7 @@ import Verifier.SAW.TypedAST (mkSort, FieldName, LocalName) import GHC.Stack --- Type-check the Prelude, Cryptol, and CryptolM modules at compile time +-- 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 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 589f7f6f34..cde8a27634 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/GenMonad.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/GenMonad.hs @@ -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/Implication.hs b/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs index 0c6dc22c74..e86cb7649d 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs @@ -1656,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 @@ -1686,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') @@ -1866,8 +1866,8 @@ 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. @@ -4053,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 = @@ -4491,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 = @@ -4781,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) -> @@ -5489,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 @@ -5672,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@ @@ -6633,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 @@ -7041,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 @@ -8881,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) -> @@ -9225,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/Permissions.hs b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs index 747ebb9ed4..acf3677232 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs @@ -108,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) @@ -163,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 @@ -251,10 +251,10 @@ 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) -> @@ -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 = @@ -721,7 +721,7 @@ data ReachMethods reach args a where NoReachMethods :: ReachMethods args a 'False -- | A recursive permission is a permission that can recursively refer to --- itself. This is represented as a "body" of the recursive permission that has +-- 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 @@ -755,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 @@ -896,7 +896,7 @@ 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 @@ -1154,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. @@ -1829,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 @@ -1938,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 @@ -1949,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 @@ -1961,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) = @@ -1981,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'. @@ -1999,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) @@ -2199,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 @@ -2213,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 @@ -3265,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' @@ -3381,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 = @@ -4909,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 @@ -5109,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 -> @@ -5137,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) @@ -5214,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 @@ -5393,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 -> @@ -7955,7 +7955,7 @@ instance AbstractVars (NamedPermName ns args a) where ---------------------------------------------------------------------- -- | An existentially quantified LLVM shape with a name, but that is considered --- "partial" because it has not been added to the environment yet +-- \"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 @@ -8449,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 } 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 04c0cc0a60..c573cee589 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -401,7 +401,7 @@ exprTransDescs (ETrans_Term tp t) = [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 +-- | 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) @@ -472,7 +472,7 @@ extExprTransCtx :: ExprCtxExt ctx1 ctx2 -> ExprTransCtx ctx1 -> ExprTransCtx ctx2 extExprTransCtx (ExprCtxExt ectx2) ectx1 = RL.append ectx1 ectx2 --- | Use an 'ExprCtxExt' to "un-extend" an 'ExprTransCtx' +-- | Use an 'ExprCtxExt' to \"un-extend\" an 'ExprTransCtx' unextExprTransCtx :: ExprCtxExt ctx1 ctx2 -> ExprTransCtx ctx2 -> ExprTransCtx ctx1 unextExprTransCtx ((ExprCtxExt ectx3) :: ExprCtxExt ctx1 ctx2) ectx2 = @@ -500,7 +500,7 @@ class TransInfo info => TransInfoM info where infoEvType :: TransInfo info => info ctx -> EventType infoEvType = permEnvEventType . infoEnv --- | A "translation monad" is a 'Reader' monad with some info type that is +-- | 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 } @@ -740,8 +740,8 @@ sigmaTypeTransM x tptrans tp_f = 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 +-- | 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) -> @@ -896,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 @@ -1179,7 +1179,7 @@ inExtCtxDescTransM ctx m = inExtDescTransMultiM kdesc_ctx $ m kdescs -- | Run a 'DescTransM' computation in an expression context that binds a --- context of deBruij indices.Pass the concatenated list of all the kind +-- 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 @@ -1472,7 +1472,7 @@ instance TranslateDescs (LLVMFieldShape w) where translateDescs (mbMatch -> [nuMP| LLVMFieldShape p |]) = translateDescs p --- A sequence of expressions translates to an ExprTransctx +-- 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 @@ -1649,7 +1649,7 @@ substNamedIndTpDesc d_id tps args = -- * 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@. @@ -2342,8 +2342,8 @@ setLLVMArrayTransSlice arr_trans sub_arr_trans off_tm = -- * Translations of Lifetime Ownership Permissions ---------------------------------------------------------------------- --- | An 'LOwnedInfo' is essentially a set of translations of "proof objects" of --- permission list @ps@, in a variable context @ctx@, along with additional +-- | 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 = @@ -3306,8 +3306,8 @@ emptyBlocksImpTransM = withInfoM (\(ImpTransInfo {..}) -> ImpTransInfo { itiBlockMapTrans = emptyTypedBlockMapTrans, .. }) --- | Run an implication translation computation in an "empty" environment, where --- there are no variables in scope and no permissions held anywhere +-- | 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 = @@ -3564,8 +3564,8 @@ failPImplTermAlt msg = PImplTerm $ \k -> ImplFailContMsg ev _ -> ImplFailContMsg ev msg _ -> k)) --- | "Force" an optional 'PImplTerm' to a 'PImplTerm' by converting a 'Nothing' --- to the 'failPImplTerm' +-- | \"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 @@ -6375,7 +6375,7 @@ someTypedCFGFunEntry some_cfg@(SomeTypedCFG sym _ _) 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 xfunction indexes in this lambda-abstraction +-- lambda-bound function indexes in this lambda-abstraction lambdaCFGPermEnv :: HasPtrWidth w => [SomeTypedCFG LLVM] -> TypeTransM ctx OpenTerm -> TypeTransM ctx OpenTerm lambdaCFGPermEnv some_cfgs m = diff --git a/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs b/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs index 765442f52b..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 @@ -1188,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 { @@ -1822,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 { @@ -1835,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 = @@ -2135,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 @@ -2148,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) @@ -2331,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 -> @@ -2351,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 @@ -2506,13 +2506,13 @@ stmtRecombinePerms = pcmEmbedImplM TypedImplStmt emptyCruCtx (recombinePerms dist_perms) >>> pure () --- | Helper function to pretty print "Could not prove ps" for permissions @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 +-- | 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 () @@ -2771,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 -> @@ -4306,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/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 92e0e14dc1..3a931a0066 100644 --- a/saw-core-coq/README.md +++ b/saw-core-coq/README.md @@ -48,7 +48,7 @@ and the `ocaml` base system installed on your machine and it can be fixed as exp Currently, the Coq support libraries for `saw-core-coq` requires Coq 8.15. Note that the `entree-specs` dependency does not currently build with Coq 8.16 -(see [this issue](https://github.com/GaloisInc//issues/1)). +(see [this issue](https://github.com/GaloisInc/entree-specs/issues/1)). ## Building the and Using the Coq Support Libraries 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/src/Verifier/SAW.hs b/saw-core/src/Verifier/SAW.hs index ddf5db8575..d322a5a468 100644 --- a/saw-core/src/Verifier/SAW.hs +++ b/saw-core/src/Verifier/SAW.hs @@ -20,10 +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 --- NOTE: this is now done in Verifier.SAW.Cryptol, which also type-checks the --- Cryptol-related SAW core modules as well --- --- 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 d930cf4985..9e3d147818 100644 --- a/saw-core/src/Verifier/SAW/Name.hs +++ b/saw-core/src/Verifier/SAW/Name.hs @@ -135,7 +135,7 @@ 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 +-- | 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 diff --git a/saw-core/src/Verifier/SAW/OpenTerm.hs b/saw-core/src/Verifier/SAW/OpenTerm.hs index 00a539e7d5..2e5f755dbc 100644 --- a/saw-core/src/Verifier/SAW/OpenTerm.hs +++ b/saw-core/src/Verifier/SAW/OpenTerm.hs @@ -127,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 =<< @@ -164,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 @@ -848,17 +849,17 @@ newtype OpenTermM a = OpenTermM { unOpenTermM :: TCM a } instance MonadIO OpenTermM where liftIO = OpenTermM . liftIO --- | "Run" an 'OpenTermM' computation to produce an 'OpenTerm' +-- | \"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' +-- | \"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 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) = diff --git a/src/SAWScript/Builtins.hs b/src/SAWScript/Builtins.hs index 8309eefac2..79e5f693eb 100644 --- a/src/SAWScript/Builtins.hs +++ b/src/SAWScript/Builtins.hs @@ -777,7 +777,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. diff --git a/src/SAWScript/HeapsterBuiltins.hs b/src/SAWScript/HeapsterBuiltins.hs index 2731ee8779..3473ec92e2 100644 --- a/src/SAWScript/HeapsterBuiltins.hs +++ b/src/SAWScript/HeapsterBuiltins.hs @@ -873,7 +873,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 = diff --git a/src/SAWScript/Prover/MRSolver/Monad.hs b/src/SAWScript/Prover/MRSolver/Monad.hs index fca1cb15a7..ac91ecd519 100644 --- a/src/SAWScript/Prover/MRSolver/Monad.hs +++ b/src/SAWScript/Prover/MRSolver/Monad.hs @@ -800,13 +800,13 @@ mrBvCastInRange w1_t w2_t bv = -- | 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 @@ -1202,7 +1202,7 @@ mrSubstEVars = memoFixTermFun $ \recurse t -> _ -> 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 +-- 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, diff --git a/src/SAWScript/Prover/MRSolver/SMT.hs b/src/SAWScript/Prover/MRSolver/SMT.hs index 4a508a2123..85fe53e9ad 100644 --- a/src/SAWScript/Prover/MRSolver/SMT.hs +++ b/src/SAWScript/Prover/MRSolver/SMT.hs @@ -211,8 +211,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! @@ -776,7 +776,7 @@ asSimpleEq (asNumType -> Just ()) = Just $ \sc 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 @@ -794,7 +794,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 diff --git a/src/SAWScript/Prover/MRSolver/Term.hs b/src/SAWScript/Prover/MRSolver/Term.hs index 9b7b9c98e3..58ab969352 100644 --- a/src/SAWScript/Prover/MRSolver/Term.hs +++ b/src/SAWScript/Prover/MRSolver/Term.hs @@ -178,7 +178,7 @@ mrVarCtxOuterToInner = reverse . mrVarCtxInnerToOuter mrVarCtxFromOuterToInner :: [(LocalName,Term)] -> MRVarCtx mrVarCtxFromOuterToInner = mrVarCtxFromInnerToOuter . reverse --- | 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@ From 2ac59d64affacb4620f9ea0108cea5aa15371dd8 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Wed, 24 Jan 2024 12:11:12 -0500 Subject: [PATCH 279/305] add more info about generating dilithium2.bc --- heapster-saw/examples/Dilithium2.saw | 12 ++++++++++++ heapster-saw/examples/Makefile | 2 +- 2 files changed, 13 insertions(+), 1 deletion(-) diff --git a/heapster-saw/examples/Dilithium2.saw b/heapster-saw/examples/Dilithium2.saw index 34d539f21f..66231ffb80 100644 --- a/heapster-saw/examples/Dilithium2.saw +++ b/heapster-saw/examples/Dilithium2.saw @@ -2,6 +2,18 @@ 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) +// 2. Applying the `dilithium.patch` file provided in this directory +// 3. Running `LLVM_COMPILER=clang make bitcode` in the `ref` directory of the +// patched repo +// 4. Copying the `libpqcrystals_dilithium2_ref.so.bc` file generated in the +// `ref` directory of the patched repo into this directory as `dilithium2.bc` +// Run `make Dilithium2.bc` to perform these steps automatically, or see the +// `Makefile` in this directory for more detail. Note that these steps have only +// been tested on a Ubuntu machine and with the `standard` branch commit: +// `918af1a6eaedcedf9fdd8aaaca6c1fccd5a7a51f`. env <- heapster_init_env "Dilithium2" "dilithium2.bc"; diff --git a/heapster-saw/examples/Makefile b/heapster-saw/examples/Makefile index 8a189bdf8a..d83bb729cd 100644 --- a/heapster-saw/examples/Makefile +++ b/heapster-saw/examples/Makefile @@ -39,7 +39,7 @@ ifeq ($(CI),) dilithium: dilithium.patch rm -rf dilithium git clone https://github.com/pq-crystals/dilithium.git - cd dilithium && git checkout standard + 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, From 56b964d3c8c4c6d6c676924b62618bddc8ff6367 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Wed, 24 Jan 2024 14:42:43 -0500 Subject: [PATCH 280/305] add comments about dilithium commit sha --- heapster-saw/examples/Dilithium2.saw | 14 ++++++++------ heapster-saw/examples/Makefile | 2 ++ 2 files changed, 10 insertions(+), 6 deletions(-) diff --git a/heapster-saw/examples/Dilithium2.saw b/heapster-saw/examples/Dilithium2.saw index 66231ffb80..9bf6d10820 100644 --- a/heapster-saw/examples/Dilithium2.saw +++ b/heapster-saw/examples/Dilithium2.saw @@ -4,16 +4,18 @@ 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) +// 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 repo +// patched `dilithium` repo // 4. Copying the `libpqcrystals_dilithium2_ref.so.bc` file generated in the -// `ref` directory of the patched repo into this directory as `dilithium2.bc` +// `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. Note that these steps have only -// been tested on a Ubuntu machine and with the `standard` branch commit: -// `918af1a6eaedcedf9fdd8aaaca6c1fccd5a7a51f`. +// `Makefile` in this directory for more detail. env <- heapster_init_env "Dilithium2" "dilithium2.bc"; diff --git a/heapster-saw/examples/Makefile b/heapster-saw/examples/Makefile index d83bb729cd..83d2027534 100644 --- a/heapster-saw/examples/Makefile +++ b/heapster-saw/examples/Makefile @@ -39,6 +39,8 @@ ifeq ($(CI),) 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 From 50dd970cabfeef6161c363f37c95ad6677fdea81 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 2 Feb 2024 09:42:22 -0800 Subject: [PATCH 281/305] updated the commit number for the entree-specs repo --- .github/workflows/ci.yml | 2 +- saw-core-coq/README.md | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index a6e828fee6..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#d1b669cc68e9826fe287e80992346e2849736be4 + - 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/saw-core-coq/README.md b/saw-core-coq/README.md index 3a931a0066..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#d1b669cc68e9826fe287e80992346e2849736be4 +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 From ec47ec156dc755a640ef9d3132154ea587732154 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 2 Feb 2024 17:05:00 -0800 Subject: [PATCH 282/305] removed references to functions that are no longer used from unfold_bv_funs --- saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreBitvectors.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreBitvectors.v b/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreBitvectors.v index 02d77adbc2..3327585a22 100644 --- a/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreBitvectors.v +++ b/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreBitvectors.v @@ -82,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. From 7ec0f6297cf6c50e0bbb7432dc26f39322e15727 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 2 Feb 2024 17:25:02 -0800 Subject: [PATCH 283/305] removing unsafeAsserts from the definition of iteWithProof because the unsafeAssert Coq tactic is currently defined *after* the translation to Coq of the Prelude --- saw-core/prelude/Prelude.sawcore | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/saw-core/prelude/Prelude.sawcore b/saw-core/prelude/Prelude.sawcore index b1a82dc023..5c48fdcc83 100644 --- a/saw-core/prelude/Prelude.sawcore +++ b/saw-core/prelude/Prelude.sawcore @@ -359,8 +359,12 @@ ite_false (a : sort 1) (x y : a) : Eq a (ite a False x y) y = 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); - ite a b (f1 (unsafeAssert Bool b True)) (f2 (unsafeAssert Bool b False)); + 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; From 4189f44b4a5fe9e0464048de3587804315d487e6 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 2 Feb 2024 17:27:16 -0800 Subject: [PATCH 284/305] changed the Coq translations of tcAdd and tcMul to be written by hand in SpecM.v instead of automatically generated --- .../coq/handwritten/CryptolToCoq/SpecM.v | 21 +++++++++++++++++++ .../SAW/Translation/Coq/SpecialTreatment.hs | 5 +++++ 2 files changed, 26 insertions(+) diff --git a/saw-core-coq/coq/handwritten/CryptolToCoq/SpecM.v b/saw-core-coq/coq/handwritten/CryptolToCoq/SpecM.v index 645d006e4c..bb0005a0b0 100644 --- a/saw-core-coq/coq/handwritten/CryptolToCoq/SpecM.v +++ b/saw-core-coq/coq/handwritten/CryptolToCoq/SpecM.v @@ -9,6 +9,23 @@ From EnTree Require Import EnTreeSpecs TpDesc. ** Defining the TpExprOps instance for SAW **) +(* NOTE: We must define any operations used in Cryptol types before evalBinOp, +which in turn is defined before the translation of the Cryptol SAW core module, +so we define these operations by hand here rather than automatically translating +them from the Cryptol SAW core module *) + +Definition tcAdd (n m: Num) : Num := + match n, m with + | TCNum x, TCNum y => TCNum (addNat x y) + | _, _ => TCInf + end. + +Definition tcMul (n m: Num) : Num := + match n, m with + | TCNum x, TCNum y => TCNum (mulNat x y) + | _, _ => TCInf + end. + 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) @@ -20,6 +37,8 @@ Inductive TpExprBinOp : ExprKind -> ExprKind -> ExprKind -> Type@{entree_u} := | 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}. @@ -45,6 +64,8 @@ Definition evalBinOp {EK1 EK2 EK3} (op: TpExprBinOp EK1 EK2 EK3) : | BinOp_MulNat => mulNat | BinOp_AddBV w => bvAdd w | BinOp_MulBV w => bvMul w + | BinOp_AddNum => tcAdd + | BinOp_MulNum => tcMul end. Global Instance SAWTpExprOps : TpExprOps := 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 05f2e056ca..6920ce7efb 100644 --- a/saw-core-coq/src/Verifier/SAW/Translation/Coq/SpecialTreatment.hs +++ b/saw-core-coq/src/Verifier/SAW/Translation/Coq/SpecialTreatment.hs @@ -227,12 +227,17 @@ specialTreatmentMap configuration = Map.fromList $ 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", mapsTo specMModule "Num") , ("TCNum", mapsTo specMModule "TCNum") , ("TCInf", mapsTo specMModule "TCInf") , ("Num_rec", mapsTo specMModule "Num_rect") , ("unsafeAssert_same_Num", skip) -- unsafe and unused + , ("tcAdd", mapsTo specMModule "tcAdd") + , ("tcMul", mapsTo specMModule "tcMul") ] -- NOTE: while I initially did the mapping from SAW core names to the From 67e04100f114acef69e38fe459e3d8436921d5f2 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 2 Feb 2024 18:08:32 -0800 Subject: [PATCH 285/305] changed SpecM.v to rely on CryptolPrimitivesForSAWCore.v rather than the other way around, so that it can use the generated Num operations like tcAdd and tcMul --- .../CryptolToCoq/SAWCorePreludeExtra.v | 10 +++++++ .../coq/handwritten/CryptolToCoq/SpecM.v | 27 ++----------------- .../src/Verifier/SAW/Translation/Coq.hs | 2 -- .../SAW/Translation/Coq/SpecialTreatment.hs | 13 ++++----- src/SAWScript/Prover/Exporter.hs | 11 +++++++- 5 files changed, 29 insertions(+), 34 deletions(-) diff --git a/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCorePreludeExtra.v b/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCorePreludeExtra.v index 22e6165044..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 diff --git a/saw-core-coq/coq/handwritten/CryptolToCoq/SpecM.v b/saw-core-coq/coq/handwritten/CryptolToCoq/SpecM.v index bb0005a0b0..d3be33b3a8 100644 --- a/saw-core-coq/coq/handwritten/CryptolToCoq/SpecM.v +++ b/saw-core-coq/coq/handwritten/CryptolToCoq/SpecM.v @@ -1,6 +1,8 @@ From CryptolToCoq Require Import SAWCoreScaffolding. From CryptolToCoq Require Import SAWCoreVectorsAsCoqVectors. +From CryptolToCoq Require Import CryptolPrimitivesForSAWCore. +Import CryptolPrimitivesForSAWCore. From EnTree Require Import EnTreeSpecs TpDesc. @@ -9,23 +11,6 @@ From EnTree Require Import EnTreeSpecs TpDesc. ** Defining the TpExprOps instance for SAW **) -(* NOTE: We must define any operations used in Cryptol types before evalBinOp, -which in turn is defined before the translation of the Cryptol SAW core module, -so we define these operations by hand here rather than automatically translating -them from the Cryptol SAW core module *) - -Definition tcAdd (n m: Num) : Num := - match n, m with - | TCNum x, TCNum y => TCNum (addNat x y) - | _, _ => TCInf - end. - -Definition tcMul (n m: Num) : Num := - match n, m with - | TCNum x, TCNum y => TCNum (mulNat x y) - | _, _ => TCInf - end. - 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) @@ -83,14 +68,6 @@ Global Instance SAWTpExprOps : TpExprOps := ** Now we re-export all of TpDesc using the above instance **) -(* Num: note that the Num type has to be defined in the TpDesc module, so its -type descriptions can refer to it, so we map the definition in Cryptol.sawcore -to that definition *) -Definition Num := TpDesc.Num. -Definition Num_rect := TpDesc.Num_rect. -Definition TCNum := TpDesc.TCNum. -Definition TCInf := TpDesc.TCInf. - (* EvType *) Definition EvType := FixTree.EvType. Definition Build_EvType := FixTree.Build_EvType. diff --git a/saw-core-coq/src/Verifier/SAW/Translation/Coq.hs b/saw-core-coq/src/Verifier/SAW/Translation/Coq.hs index 4db4fb8fa1..05ad4f231c 100644 --- a/saw-core-coq/src/Verifier/SAW/Translation/Coq.hs +++ b/saw-core-coq/src/Verifier/SAW/Translation/Coq.hs @@ -54,8 +54,6 @@ 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 SpecM. -From CryptolToCoq Require Import SpecMPrimitivesForSAWCore. From CryptolToCoq Require Import #{vectorModule}. Import VectorNotations. 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 6920ce7efb..195ce7c999 100644 --- a/saw-core-coq/src/Verifier/SAW/Translation/Coq/SpecialTreatment.hs +++ b/saw-core-coq/src/Verifier/SAW/Translation/Coq/SpecialTreatment.hs @@ -200,6 +200,9 @@ sawDefinitionsModule = mkModuleName ["SAWCoreScaffolding"] specMModule :: ModuleName specMModule = mkModuleName ["SpecM"] +tpDescModule :: ModuleName +tpDescModule = mkModuleName ["TpDesc"] + {- polyListModule :: ModuleName polyListModule = mkModuleName ["PolyList"] @@ -231,13 +234,11 @@ cryptolPreludeSpecialTreatmentMap = Map.fromList $ [] -- defined *before* type descriptions, so we have to map Num and some of its -- operations to that library ++ - [ ("Num", mapsTo specMModule "Num") - , ("TCNum", mapsTo specMModule "TCNum") - , ("TCInf", mapsTo specMModule "TCInf") - , ("Num_rec", mapsTo specMModule "Num_rect") + [ ("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 - , ("tcAdd", mapsTo specMModule "tcAdd") - , ("tcMul", mapsTo specMModule "tcMul") ] -- NOTE: while I initially did the mapping from SAW core names to the diff --git a/src/SAWScript/Prover/Exporter.hs b/src/SAWScript/Prover/Exporter.hs index ffce568bc3..12c4ed2293 100644 --- a/src/SAWScript/Prover/Exporter.hs +++ b/src/SAWScript/Prover/Exporter.hs @@ -442,6 +442,14 @@ 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 }) = @@ -571,7 +579,8 @@ writeCoqCryptolPrimitivesForSAWCore cryFile specMFile cryMFile notations skips = withImportSAWCorePrelude $ coqTranslationConfiguration notations skips let configuration_spec = - withImportCryptolPrimitivesForSAWCore configuration + withImportCryptolPrimitivesForSAWCore $ + withImportSpecM configuration let configuration_mon = withImportSpecMPrimitivesForSAWCore configuration let doc = Coq.translateSAWModule configuration m From 6546f814853b44ce5bdb954d624e93301c07bbe6 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 2 Feb 2024 18:13:49 -0800 Subject: [PATCH 286/305] fixed up the imports for the heapster_export_coq command --- src/SAWScript/HeapsterBuiltins.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/SAWScript/HeapsterBuiltins.hs b/src/SAWScript/HeapsterBuiltins.hs index 0d7357f310..bbe7e78b7a 100644 --- a/src/SAWScript/HeapsterBuiltins.hs +++ b/src/SAWScript/HeapsterBuiltins.hs @@ -1171,8 +1171,8 @@ 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 " ++ + "SAWCorePrelude SpecMPrimitivesForSAWCore SAWCoreBitvectors.\n" }, translateSAWModule coq_trans_conf saw_mod] liftIO $ writeFile filename (show coq_doc) From ccc537e987906e7abe17cd772b931b5ba5368464 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Sat, 3 Feb 2024 06:40:50 -0800 Subject: [PATCH 287/305] added MR solver support for the iteWithProof combinator --- src/SAWScript/Prover/MRSolver/Monad.hs | 4 ++++ src/SAWScript/Prover/MRSolver/Solver.hs | 11 ++++++++++- 2 files changed, 14 insertions(+), 1 deletion(-) diff --git a/src/SAWScript/Prover/MRSolver/Monad.hs b/src/SAWScript/Prover/MRSolver/Monad.hs index ac91ecd519..303a9fb8d7 100644 --- a/src/SAWScript/Prover/MRSolver/Monad.hs +++ b/src/SAWScript/Prover/MRSolver/Monad.hs @@ -757,6 +757,10 @@ 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 diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index bacf453301..b57c22db86 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -127,7 +127,7 @@ import qualified Data.Text as T import Data.List (find, findIndices) import Data.Foldable (foldlM) import Data.Bits (shiftL) -import Control.Monad (void, foldM, forM, zipWithM, zipWithM_) +import Control.Monad (void, foldM, forM, zipWithM, zipWithM_, (>=>)) import Control.Monad.Except (MonadError(..)) import qualified Data.Map as Map import qualified Data.Text as Text @@ -256,6 +256,15 @@ normComp (CompTerm t) = return (ErrorS str) (isGlobalDef "Prelude.ite" -> Just (), [_, cond, then_tm, else_tm]) -> return $ Ite cond (CompTerm then_tm) (CompTerm else_tm) + (isGlobalDef "Prelude.iteWithProof" -> Just (), [_, cond, then_f, else_f]) -> + do bool_tp <- liftSC0 scBoolType + then_tm <- + (liftSC1 scBool >=> mrEqProp bool_tp cond >=> mrDummyProof >=> + liftSC2 scApply then_f) True + else_tm <- + (liftSC1 scBool >=> mrEqProp bool_tp cond >=> mrDummyProof >=> + liftSC2 scApply else_f) False + return $ Ite cond (CompTerm then_tm) (CompTerm else_tm) (isGlobalDef "Prelude.either" -> Just (), [ltp, rtp, (asSpecM -> Just (ev, _)), f, g, eith]) -> return $ Eithers [(Type ltp, CompFunTerm ev f), From ec6d5baf15052bac15ef1bcdf3c0869475366b82 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Sat, 3 Feb 2024 06:41:17 -0800 Subject: [PATCH 288/305] changed all the examples to import SpecM instead of the SAW core Prelude --- heapster-saw/examples/clearbufs.sawcore | 2 +- heapster-saw/examples/global_var.sawcore | 2 +- heapster-saw/examples/io.sawcore | 2 +- heapster-saw/examples/iso_recursive.sawcore | 2 +- heapster-saw/examples/iter_linked_list.sawcore | 2 +- heapster-saw/examples/loops.sawcore | 2 +- heapster-saw/examples/memcpy.sawcore | 2 +- heapster-saw/examples/rust_lifetimes.sawcore | 2 +- heapster-saw/examples/string_set.sawcore | 2 +- 9 files changed, 9 insertions(+), 9 deletions(-) diff --git a/heapster-saw/examples/clearbufs.sawcore b/heapster-saw/examples/clearbufs.sawcore index 794f9a00bf..e07bb04b35 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; diff --git a/heapster-saw/examples/global_var.sawcore b/heapster-saw/examples/global_var.sawcore index bc7ca9f054..d4bfcb8223 100644 --- a/heapster-saw/examples/global_var.sawcore +++ b/heapster-saw/examples/global_var.sawcore @@ -1,6 +1,6 @@ module GlobalVar where -import Prelude; +import SpecM; acquireLockM : Vec 64 Bool -> SpecM VoidEv emptyFunStack (Vec 64 Bool * Vec 64 Bool); 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.sawcore b/heapster-saw/examples/iso_recursive.sawcore index 574df711f9..bf2f80c6e3 100644 --- a/heapster-saw/examples/iso_recursive.sawcore +++ b/heapster-saw/examples/iso_recursive.sawcore @@ -1,4 +1,4 @@ module iso_recursive where -import Prelude; +import SpecM; 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/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/memcpy.sawcore b/heapster-saw/examples/memcpy.sawcore index 59a036a748..a965bc842e 100644 --- a/heapster-saw/examples/memcpy.sawcore +++ b/heapster-saw/examples/memcpy.sawcore @@ -1,7 +1,7 @@ module memcpy where -import Prelude; +import SpecM; mallocSpec : (sz:Vec 64 Bool) -> SpecM VoidEv emptyFunStack (BVVec 64 sz #()); 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/string_set.sawcore b/heapster-saw/examples/string_set.sawcore index 6c45859568..7e609b198c 100644 --- a/heapster-saw/examples/string_set.sawcore +++ b/heapster-saw/examples/string_set.sawcore @@ -1,7 +1,7 @@ module string_set where -import Prelude; +import SpecM; listInsertM : (a : sort 0) -> List a -> a -> SpecM VoidEv emptyFunStack (List a); From ecd1ce73807013238b06dc86183141244910f7b2 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Sat, 3 Feb 2024 07:43:28 -0800 Subject: [PATCH 289/305] added checks to heapster_define_opaque_perm and heapster_define_opaque_llvmshape to make sure the user-supplied type and type description match --- .../Verifier/SAW/Heapster/SAWTranslation.hs | 17 +++++++++++++++-- src/SAWScript/HeapsterBuiltins.hs | 18 ++++++++++++++++-- 2 files changed, 31 insertions(+), 4 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index c573cee589..b6fbd9ee3f 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -6583,9 +6583,22 @@ translateCompletePureFunType sc env ctx ps_in p_out = -- of a type-level function over those arguments translateExprTypeFunType :: SharedContext -> PermEnv -> CruCtx ctx -> IO Term translateExprTypeFunType sc env ctx = - liftIO $ completeOpenTerm sc $ runNilTypeTransM env noChecks $ + 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 pi type that @d@ describes, which is: +-- +-- > tpElem ev (Tp_Pi k1 (Tp_Pi k2 (... Tp_Pi kn d))) +translateDescTypeFunType :: SharedContext -> PermEnv -> CruCtx ctx -> + OpenTerm -> IO Term +translateDescTypeFunType sc env ctx d = + let ?ev = permEnvEventType env in + completeNormOpenTerm sc $ tpElemTypeOpenTerm ?ev $ + piTpDescMulti (snd $ translateCruCtx ctx) 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 @@ -6598,7 +6611,7 @@ translateIndTypeFun :: SharedContext -> PermEnv -> CruCtx ctx -> OpenTerm -> IO Term translateIndTypeFun sc env ctx d = let ?ev = permEnvEventType env in - liftIO $ completeOpenTerm sc $ runNilTypeTransM env noChecks $ + completeOpenTerm sc $ runNilTypeTransM env noChecks $ lambdaExprCtx ctx $ do args_tms <- transTerms <$> infoCtx <$> ask let ks = snd $ translateCruCtx ctx diff --git a/src/SAWScript/HeapsterBuiltins.hs b/src/SAWScript/HeapsterBuiltins.hs index bbe7e78b7a..797b040770 100644 --- a/src/SAWScript/HeapsterBuiltins.hs +++ b/src/SAWScript/HeapsterBuiltins.hs @@ -119,6 +119,7 @@ import SAWScript.Builtins import SAWScript.Crucible.LLVM.Builtins import SAWScript.Crucible.LLVM.MethodSpecIR +import Verifier.SAW.Utils (panic) import Verifier.SAW.Heapster.CruUtil import Verifier.SAW.Heapster.HintExtract import Verifier.SAW.Heapster.Permissions @@ -137,6 +138,16 @@ import Prettyprinter tpDescTypeM :: MonadIO m => SharedContext -> m Term tpDescTypeM sc = liftIO $ completeOpenTerm sc tpDescTypeOpenTerm +-- | 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 <- translateDescTypeFunType sc env ctx $ identOpenTerm d_ident + tp <- scGlobalDef sc tp_ident + ok <- scConvertibleEval sc scTypeCheckWHNF True tp d_tp + if ok then return () else + fail ("Type description for " ++ nm ++ + " does not match user-supplied type") -- | 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 @@ -405,7 +416,8 @@ heapster_get_cfg _ _ henv 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 -> String -> TopLevel () @@ -418,6 +430,7 @@ heapster_define_opaque_perm _bic _opts henv nm args_str tp_str term_str d_str = 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' @@ -633,6 +646,7 @@ heapster_define_opaque_llvmshape _bic _opts henv nm w_int args_str len_str tp_st 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 + 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' @@ -1050,7 +1064,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) =<< From 2862381b611200f180485776f116cc3f866a22c9 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Sat, 3 Feb 2024 07:52:49 -0800 Subject: [PATCH 290/305] updated global_var example to work --- heapster-saw/examples/global_var.saw | 10 +++++++--- heapster-saw/examples/global_var.sawcore | 12 ++++-------- 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/heapster-saw/examples/global_var.saw b/heapster-saw/examples/global_var.saw index 597f7c5f6d..5aa413ece8 100644 --- a/heapster-saw/examples/global_var.saw +++ b/heapster-saw/examples/global_var.saw @@ -20,12 +20,14 @@ heapster_define_perm env "int64" " " "llvmptr 64" "exists x:bv 64.eq(llvmword(x) heapster_define_opaque_perm env "has_lock_perm" "rw:rwmodality, dat:llvmptr 64" "unit" - "Vec 64 Bool"; + "Vec 64 Bool" + "Tp_bitvector 64"; heapster_define_opaque_perm env "can_lock_perm" "rw:rwmodality" "unit" - "Vec 64 Bool"; + "Vec 64 Bool" + "Tp_bitvector 64"; // Need to axiomatize acquire_lock because it touches the global variables heapster_assume_fun env @@ -63,11 +65,13 @@ heapster_typecheck_fun env \ -o \ \ ret:int64<>, u:can_lock_perm"; +// FIXME: this is meant to fail; figure out how to check that it does in CI... +/* heapster_typecheck_fun env "acquire_release_fail" "(u:unit). u:can_lock_perm \ \ -o \ \ ret:int64<>, u:can_lock_perm"; - +*/ heapster_export_coq env "global_var_gen.v"; diff --git a/heapster-saw/examples/global_var.sawcore b/heapster-saw/examples/global_var.sawcore index d4bfcb8223..9fad6aae80 100644 --- a/heapster-saw/examples/global_var.sawcore +++ b/heapster-saw/examples/global_var.sawcore @@ -2,12 +2,8 @@ module GlobalVar where 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; From 4767825fb41f49e9aad3e486a495db05f96f1718 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Sat, 3 Feb 2024 08:07:17 -0800 Subject: [PATCH 291/305] added more info to the error message when a type does not match a type description --- src/SAWScript/HeapsterBuiltins.hs | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/src/SAWScript/HeapsterBuiltins.hs b/src/SAWScript/HeapsterBuiltins.hs index 797b040770..964ac0d8a2 100644 --- a/src/SAWScript/HeapsterBuiltins.hs +++ b/src/SAWScript/HeapsterBuiltins.hs @@ -120,6 +120,7 @@ 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 @@ -146,8 +147,14 @@ checkTypeAgreesWithDesc sc env nm tp_ident ctx d_ident = tp <- scGlobalDef sc tp_ident ok <- scConvertibleEval sc scTypeCheckWHNF True tp d_tp if ok then return () else - fail ("Type description for " ++ nm ++ - " does not match user-supplied type") + 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 From e440d4d44de22df97e8223c67ef9dc2cff06cfd5 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Tue, 6 Feb 2024 13:36:31 -0800 Subject: [PATCH 292/305] updated checkTypeAgreesWithDesc, since the previous version was incorrect --- cryptol-saw-core/saw/SpecM.sawcore | 29 +++++++++++++++++++ .../Verifier/SAW/Heapster/SAWTranslation.hs | 19 +++++++----- src/SAWScript/HeapsterBuiltins.hs | 2 +- 3 files changed, 42 insertions(+), 8 deletions(-) diff --git a/cryptol-saw-core/saw/SpecM.sawcore b/cryptol-saw-core/saw/SpecM.sawcore index 11f8d708c0..39772495d0 100644 --- a/cryptol-saw-core/saw/SpecM.sawcore +++ b/cryptol-saw-core/saw/SpecM.sawcore @@ -679,6 +679,35 @@ tpElemEnv E env_top isf_top T_top = 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; diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index b6fbd9ee3f..2a267ff182 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -6589,15 +6589,20 @@ translateExprTypeFunType sc env ctx = -- | 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 pi type that @d@ describes, which is: +-- SAW core free variables) into the type function that @d@ describes, which is: -- --- > tpElem ev (Tp_Pi k1 (Tp_Pi k2 (... Tp_Pi kn d))) -translateDescTypeFunType :: SharedContext -> PermEnv -> CruCtx ctx -> - OpenTerm -> IO Term -translateDescTypeFunType sc env ctx d = +-- > \ (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 - completeNormOpenTerm sc $ tpElemTypeOpenTerm ?ev $ - piTpDescMulti (snd $ translateCruCtx ctx) d + 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 diff --git a/src/SAWScript/HeapsterBuiltins.hs b/src/SAWScript/HeapsterBuiltins.hs index 964ac0d8a2..844165bddb 100644 --- a/src/SAWScript/HeapsterBuiltins.hs +++ b/src/SAWScript/HeapsterBuiltins.hs @@ -143,7 +143,7 @@ tpDescTypeM sc = liftIO $ completeOpenTerm sc tpDescTypeOpenTerm checkTypeAgreesWithDesc :: SharedContext -> PermEnv -> String -> Ident -> CruCtx args -> Ident -> IO () checkTypeAgreesWithDesc sc env nm tp_ident ctx d_ident = - do d_tp <- translateDescTypeFunType sc env ctx $ identOpenTerm 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 From a277fa953c862c2efa15952776c98d48adcb5732 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Tue, 6 Feb 2024 13:37:05 -0800 Subject: [PATCH 293/305] updated memcpy example to work with the new SpecM --- heapster-saw/examples/memcpy.saw | 3 +-- heapster-saw/examples/memcpy.sawcore | 5 ++--- 2 files changed, 3 insertions(+), 5 deletions(-) diff --git a/heapster-saw/examples/memcpy.saw b/heapster-saw/examples/memcpy.saw index 46ed9cc2c3..7b6bf1a254 100644 --- a/heapster-saw/examples/memcpy.saw +++ b/heapster-saw/examples/memcpy.saw @@ -10,8 +10,7 @@ heapster_assume_fun env "llvm.memcpy.p0i8.p0i8.i64" \ arg0:[l1]memblock(W,0,len,sh), 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 (#() * #()) ((),())"; + "\\ (d:TpDesc) (len:Vec 64 Bool) (x:tpElem VoidEv d) -> retS VoidEv #() ()"; heapster_typecheck_fun env "copy_int" diff --git a/heapster-saw/examples/memcpy.sawcore b/heapster-saw/examples/memcpy.sawcore index a965bc842e..0e8b8ce9a0 100644 --- a/heapster-saw/examples/memcpy.sawcore +++ b/heapster-saw/examples/memcpy.sawcore @@ -3,8 +3,7 @@ module memcpy where 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) -> ())); From 7e61ad945ffccb136cf5975d0ddc43a484da4a66 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Tue, 6 Feb 2024 13:39:05 -0800 Subject: [PATCH 294/305] updated ListDescType to the correct version to agree with ListDesc, now that Heapster checks that these agree --- heapster-saw/examples/rust_data.sawcore | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/heapster-saw/examples/rust_data.sawcore b/heapster-saw/examples/rust_data.sawcore index 81f3f8e49a..43eca0d96b 100644 --- a/heapster-saw/examples/rust_data.sawcore +++ b/heapster-saw/examples/rust_data.sawcore @@ -11,4 +11,4 @@ ListDesc = Tp_Ind (Tp_Sum Tp_Unit (Tp_Pair (Tp_Var 1) (Tp_Var 0))); -- Convert ListDesc applied to a type argument given by type description to a -- type ListDescType : TpDesc -> sort 0; -ListDescType T = tpElem VoidEv (Tp_TpSubst ListDesc T); +ListDescType T = indElem (Tp_Sum Tp_Unit (Tp_Pair T (Tp_Ind (Tp_Sum Tp_Unit (Tp_Pair T (Tp_Var 0)))))); From a3a25d93dafd4e66c1f5ecf64d2a4e60cc7cd44a Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Tue, 6 Feb 2024 13:49:11 -0800 Subject: [PATCH 295/305] started updating the string_set example, but ended up commenting most of it out --- heapster-saw/examples/string_set.saw | 9 ++++-- heapster-saw/examples/string_set.sawcore | 37 ++++++++++++++++-------- 2 files changed, 31 insertions(+), 15 deletions(-) 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 7e609b198c..3b701208d9 100644 --- a/heapster-saw/examples/string_set.sawcore +++ b/heapster-saw/examples/string_set.sawcore @@ -3,16 +3,31 @@ module string_set where 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) From 5e1ec6b98f759ff6d29f44523dcda1bc05cd4686 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Tue, 6 Feb 2024 14:56:26 -0800 Subject: [PATCH 296/305] commented out stuff that does not work in the Heapster examples for now --- heapster-saw/examples/clearbufs.saw | 7 ++++-- heapster-saw/examples/clearbufs.sawcore | 26 +++++++++++++++++----- heapster-saw/examples/iter_linked_list.saw | 7 ++++-- heapster-saw/examples/mbox.saw | 4 +++- 4 files changed, 33 insertions(+), 11 deletions(-) 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 e07bb04b35..dc26285e33 100644 --- a/heapster-saw/examples/clearbufs.sawcore +++ b/heapster-saw/examples/clearbufs.sawcore @@ -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/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/mbox.saw b/heapster-saw/examples/mbox.saw index 63f4eb3e4d..a80413cf9d 100644 --- a/heapster-saw/examples/mbox.saw +++ b/heapster-saw/examples/mbox.saw @@ -27,6 +27,8 @@ 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" @@ -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 From da7c090a4313d9f18cd6e0e1b26ade35ff9fd185 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 8 Feb 2024 12:45:47 -0800 Subject: [PATCH 297/305] added an override for iteWithProof when calling into SMT --- src/SAWScript/Prover/MRSolver/SMT.hs | 38 +++++++++++++++++++++++++++- 1 file changed, 37 insertions(+), 1 deletion(-) diff --git a/src/SAWScript/Prover/MRSolver/SMT.hs b/src/SAWScript/Prover/MRSolver/SMT.hs index 85fe53e9ad..02d4afd3ed 100644 --- a/src/SAWScript/Prover/MRSolver/SMT.hs +++ b/src/SAWScript/Prover/MRSolver/SMT.hs @@ -141,6 +141,39 @@ 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 -> SimulatorConfig TermModel -> @@ -174,7 +207,10 @@ smtNormPrims sc cfg = Map.union $ Map.fromList Prim (do tm <- scApplyBeta sc f ix tm' <- smtNorm sc tm return $ VExtra $ VExtraTerm a tm') - ) + ), + + -- Override iteWithProof so it unfolds to a normal ite with dummy proof objects + ("Prelude.iteWithProof", iteWithProofOp sc cfg) ] -- | A version of 'mrNormTerm' in the 'IO' monad, and which does not add any From 3874edab3d5d4e82e7b203cfbed0959a5ee05337 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 8 Feb 2024 13:17:15 -0800 Subject: [PATCH 298/305] added tracing for terms being inserted by Heapster commands when the debug level is at least 2 --- src/SAWScript/HeapsterBuiltins.hs | 55 +++++++++++++++++++++---------- 1 file changed, 37 insertions(+), 18 deletions(-) diff --git a/src/SAWScript/HeapsterBuiltins.hs b/src/SAWScript/HeapsterBuiltins.hs index 844165bddb..d3511c5895 100644 --- a/src/SAWScript/HeapsterBuiltins.hs +++ b/src/SAWScript/HeapsterBuiltins.hs @@ -139,6 +139,16 @@ import Prettyprinter 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 () @@ -287,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 @@ -305,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 @@ -464,7 +484,7 @@ heapster_define_recursive_perm _bic _opts henv nm args_str tp_str p_str = d_tp <- tpDescTypeM sc let d_ident = mkSafeIdent mnm (nm ++ "__desc") d_trm <- liftIO $ translateCompleteDescInCtx sc env args_p mb_p - liftIO $ scInsertDef sc mnm d_ident d_tp d_trm + 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 @@ -472,7 +492,7 @@ heapster_define_recursive_perm _bic _opts henv nm args_str tp_str p_str = transf_tp <- liftIO $ translateExprTypeFunType sc env args transf_trm <- liftIO $ translateIndTypeFun sc env args (globalOpenTerm d_ident) - liftIO $ scInsertDef sc mnm transf_ident transf_tp transf_trm + heapsterInsertDef henv transf_ident transf_tp transf_trm -- Add the recursive perm to the environment and update henv env' <- @@ -520,7 +540,7 @@ heapster_define_reachability_perm _bic _opts henv nm args_str tp_str p_str trans d_tp <- tpDescTypeM sc let d_ident = mkSafeIdent mnm (nm ++ "__desc") d_trm <- liftIO $ translateCompleteDescInCtx sc env args_p mb_p - liftIO $ scInsertDef sc mnm d_ident d_tp d_trm + 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 @@ -528,7 +548,7 @@ heapster_define_reachability_perm _bic _opts henv nm args_str tp_str p_str trans transf_tp <- liftIO $ translateExprTypeFunType sc env args transf_trm <- liftIO $ translateIndTypeFun sc env args (globalOpenTerm d_ident) - liftIO $ scInsertDef sc mnm transf_ident transf_tp transf_trm + heapsterInsertDef henv transf_ident transf_tp transf_trm -- Add the recursive perm to the environment and update henv env' <- @@ -554,17 +574,20 @@ heapster_define_reachability_perm _bic _opts henv nm args_str tp_str p_str trans -- | 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 => SharedContext -> PermEnv -> - ModuleName -> String -> CruCtx args -> NatRepr w -> +addRecNamedShape :: 1 <= w => HeapsterEnv -> String -> + CruCtx args -> NatRepr w -> Mb (args :> LLVMShapeType w) (PermExpr (LLVMShapeType w)) -> TopLevel PermEnv -addRecNamedShape sc env mnm nm args w mb_sh = +addRecNamedShape henv nm args w mb_sh = -- Generate the type description for the body of the recursive shape - do d_tp <- tpDescTypeM sc + 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 - liftIO $ scInsertDef sc mnm d_ident d_tp d_trm + 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 @@ -572,7 +595,7 @@ addRecNamedShape sc env mnm nm args w mb_sh = transf_tp <- liftIO $ translateExprTypeFunType sc env args transf_trm <- liftIO $ translateIndTypeFun sc env args (globalOpenTerm d_ident) - liftIO $ scInsertDef sc mnm transf_ident transf_tp transf_trm + 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 @@ -586,8 +609,6 @@ heapster_define_recursive_shape :: BuiltinContext -> Options -> HeapsterEnv -> TopLevel () heapster_define_recursive_shape _bic _opts henv nm w_int args_str body_str = do env <- liftIO $ readIORef $ heapsterEnvPermEnvRef henv - let mnm = heapsterEnvSAWModule henv - sc <- getSharedContext -- Parse the bit width, arguments, and the body SomeKnownNatGeq1 w <- @@ -598,7 +619,7 @@ heapster_define_recursive_shape _bic _opts henv nm w_int args_str body_str = (consParsedCtx nm (LLVMShapeRepr w) args_ctx) body_str -- Add the shape to the current environment - env' <- addRecNamedShape sc env mnm nm args w mb_sh + env' <- addRecNamedShape henv nm args w mb_sh liftIO $ writeIORef (heapsterEnvPermEnvRef henv) env' @@ -687,10 +708,8 @@ heapster_define_rust_type_qual_opt _bic _opts henv maybe_crate str = env' = permEnvAddNamedShape env nsh liftIO $ writeIORef (heapsterEnvPermEnvRef henv) env' RecShape nm ctx mb_sh -> - do sc <- getSharedContext - let mnm = heapsterEnvSAWModule henv - nm' = crated_nm nm - env' <- addRecNamedShape sc env mnm nm' ctx w mb_sh + do let nm' = crated_nm nm + env' <- addRecNamedShape henv nm' ctx w mb_sh liftIO $ writeIORef (heapsterEnvPermEnvRef henv) env' From 1aed8dea272c9a5838caad4813385d76d4131e74 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 8 Feb 2024 14:43:47 -0800 Subject: [PATCH 299/305] removed iso_recursive example, since it is now superseded by the linked_list example --- heapster-saw/examples/iso_recursive.bc | Bin 2512 -> 0 bytes heapster-saw/examples/iso_recursive.c | 18 ----------- heapster-saw/examples/iso_recursive.saw | 21 ------------ heapster-saw/examples/iso_recursive.sawcore | 4 --- heapster-saw/examples/iso_recursive_proofs.v | 32 ------------------- 5 files changed, 75 deletions(-) delete mode 100644 heapster-saw/examples/iso_recursive.bc delete mode 100644 heapster-saw/examples/iso_recursive.c delete mode 100644 heapster-saw/examples/iso_recursive.saw delete mode 100644 heapster-saw/examples/iso_recursive.sawcore delete mode 100644 heapster-saw/examples/iso_recursive_proofs.v diff --git a/heapster-saw/examples/iso_recursive.bc b/heapster-saw/examples/iso_recursive.bc deleted file mode 100644 index 4f7372434031c2dfa9edc56d93095fc2067e527f..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 2512 zcmZ`*Z%kX)6~D%YYrs4|2yIMx@AVmy)r}JNFo|Po&@iSMS()mn)x?KP*h$QsEhG<{ z`d^~-89TjHbv7qrlRxx>tz}gvRg+sqTR!xIu_>d>jc7Jyh$3VQLTN-I)Mi_zMcd9b zX*+4#mCn8A-h0lu=g;rn_f~Ve>k+hOplmHd7$H@^Be!}87Jx@5bkd%m|Kgor{q4`M zkNxq+%m4V@{ZGGhU_fQAhCQPWp?y^d)mIr24CrYf9Bsd1pVu6%Va?rFRdLjnwza!!%KDM{;5HE*4RGKL=vq1YSpQE?R(9ld3H|#U* zOLkt!9={^a&V$`IMTDAQG`DGM#Z#9wyV|bBp<9b*lFdy+Q;GU`e26{h*QEP=KRfv1 zwDkA-w(r02&zA=kle%wFrztincE+IkP@CiI67~I<0ioZ**!uXnNB@GRl2I*)s`HA0 z1d}*yBI9Wsm?xGb30}uRk@!Sn5y?cBOaSkVg{N>hO)L@)d1C=Bj`ZOimyhxr8BU3E zdAsny$ggA?Hlo5EH@E2KmtDf9U09vrZ)F;mV9U*;N$$2=$lJN447aQZc_Y7+X_zx| zOJGDL5!pq;Cag#}tR(>xu_z=sh=Xb3OJb4Aphgi#S(g+o;p^&Fp{f!P1AdMrFh{Bk9Six2_{rv7K@P@Z4SG(e*A zDxm~fDs%tkjDo`#%$OsQ?I7-e#5%dpy?BjF^r495aqd;!)|MDD}>3InBt^>7Me2gwSP z`ie=b4^KVe0d?IVpTj*j)e4{vEJy%0wI4F?B{Hqo*J;03srW{jFGhvs9Jf@aRYQI) z4!|i09R+-=0N=YNfewO$wnx>rbj+f~A%zx@+5@DgXb@I8X1%UHti&4LaWZ3zOk|rG zLwcW#;Y7cPBNFy4)@+M7$X58u;*J17DA0!^E6nWNAsk_`Pr+j)CX~kG zt|y8hJSNqTi#U{S%qR72-LDU5U)^JTs$B2bR|1c<;PFml`cB09ju}))+0W8dvyjrY zG!7*bwcq;goW}8fTe|fpP9gTLrY^%#jrTzNGK^hXg_|vNqs^+`DTg&)Nc2|_<4=w2 zHjw^4%RE$=E?vI>c!i>lO4SvySZh(;JMZXCsC$c{#Dt8`YcW7pmT^Q@2SP*^NlUSj z*-A2HNq<(-uWd8iPNs{U3U|KdPSVjm@90id`kMvow8IKGoGyGD4t+dn`;*$1E$DuKn#jY%C&wndIOHM| z1~QQ*Ew^6LKS25~oXmQXS?kl6MP>`45KVCTDavmfxs|A}QsUOj{5_R0YB*-iI$n4? zW-B`PJPE`_f*~AA9UFR>)YA+IKd#&>BM(p8MU_AuHuBr*$4qJkIy5 zJ8V-hEhIjygGfmb{DDW)gng;#@ims&$}xAH%$HL8%x$}{UfvC8UIhmRTWr}_?~Pb% zykJc@x{HOLn={?>1&FbyICx_mu?qnWGj`FgRKGWN(is$r>ghhlT7=6N^=$O*A)cVYWVtX`k<;o`mY1VYA zr_j2gKQSPb@is|m4TPUA9#HJ)920xPkP@%;}K7u zai9H>7}${#JIx(Zha{RRs|PyG63jZf%pK%V6H7~5%g2{j=kF~o94{{AZ*3fDY4RMsbot}oe7yJayT!|Arxgg~*Kh~u zcf7vNX98^D$grGp^a4b(j_$?6p)&7WIDs13$lnj`x`6sdul+mWUn zoq~QZ>S|OvlldWyOLtA$)o4&ZuWM!d`%$50Kw(j}{f*Wtjc&B1%4o2Nb#XLWTldW5 zL`#(>gS33#8?A8!n>B5)Iem$4eot{WUHb!TeX81iM5jZV8Q0>JYe@-JRi*ZtHdXJd z&^Y)*eK0d@TO1`cz*d?E{#Tv_u1P(;O&91t3yqJ)HUvat83v+_j&v^53A6^FXMmmq z(gRUF+P>PSJe8--0z}^|+Nd1;zd(B`Q}jddVHdFA!$rDs+CSns;~ColNXTj#u^c?$ qrU*JP=017OAL^7kIuCV7r~T(fe4dl90q6prj*}x#)OKwCXa8?ZZA0_` 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 bf2f80c6e3..0000000000 --- a/heapster-saw/examples/iso_recursive.sawcore +++ /dev/null @@ -1,4 +0,0 @@ - -module iso_recursive where - -import SpecM; 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. From 1860d0d06856d0e932fe921c4c5d919ec6d894ea Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 8 Feb 2024 17:21:58 -0800 Subject: [PATCH 300/305] whoops, forgot to remove the iso_recursive example from the _CoqProject --- heapster-saw/examples/_CoqProject | 2 -- 1 file changed, 2 deletions(-) diff --git a/heapster-saw/examples/_CoqProject b/heapster-saw/examples/_CoqProject index 267f4afa42..986d2b7d3c 100644 --- a/heapster-saw/examples/_CoqProject +++ b/heapster-saw/examples/_CoqProject @@ -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 From 9a4df7d828bca1fafd7f464a8d929dd2d759a944 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 9 Feb 2024 09:38:20 -0800 Subject: [PATCH 301/305] simplified memcpy permissions to help with translation --- heapster-saw/examples/Dilithium2.saw | 6 +++--- heapster-saw/examples/memcpy.saw | 6 +++--- heapster-saw/examples/rust_data.saw | 7 +++---- 3 files changed, 9 insertions(+), 10 deletions(-) diff --git a/heapster-saw/examples/Dilithium2.saw b/heapster-saw/examples/Dilithium2.saw index 9bf6d10820..89a45c9d20 100644 --- a/heapster-saw/examples/Dilithium2.saw +++ b/heapster-saw/examples/Dilithium2.saw @@ -31,12 +31,12 @@ 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, sh:llvmshape 64, \ + "(rw:rwmodality, l1:lifetime, l2:lifetime, \ \ b:llvmblock 64, len:bv 64). \ - \ arg0:[l1]memblock(W,0,len,tuplesh(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))" - "\\ (T:TpDesc) (len:Vec 64 Bool) (x:tpElem VoidEv T) -> retS VoidEv #() ()"; + "\\ (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). \ diff --git a/heapster-saw/examples/memcpy.saw b/heapster-saw/examples/memcpy.saw index 7b6bf1a254..dc37382064 100644 --- a/heapster-saw/examples/memcpy.saw +++ b/heapster-saw/examples/memcpy.saw @@ -5,12 +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))" - "\\ (d:TpDesc) (len:Vec 64 Bool) (x:tpElem VoidEv d) -> retS VoidEv #() ()"; + "\\ (len:Vec 64 Bool) -> retS VoidEv #() ()"; heapster_typecheck_fun env "copy_int" diff --git a/heapster-saw/examples/rust_data.saw b/heapster-saw/examples/rust_data.saw index 90744acb6b..f62a51212f 100644 --- a/heapster-saw/examples/rust_data.saw +++ b/heapster-saw/examples/rust_data.saw @@ -251,13 +251,12 @@ heapster_assume_fun env "llvm.expect.i1" // 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,tuplesh(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:TpDesc) (len:Vec 64 Bool) (x:tpElem VoidEv X) -> \ - \ retS VoidEv #() ()"; + "\\ (len:Vec 64 Bool) -> retS VoidEv #() ()"; // Box>::clone box_list20_u64_clone_sym <- heapster_find_symbol_with_type env From 4b9b06ff4fc1e4d3f92e244473d9aa6f2bab7723 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 9 Feb 2024 10:02:10 -0800 Subject: [PATCH 302/305] commented out all the _proofs.v files from the _CoqProject --- heapster-saw/examples/_CoqProject | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/heapster-saw/examples/_CoqProject b/heapster-saw/examples/_CoqProject index 986d2b7d3c..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 @@ -30,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 From 5c1dc8ec32796cc72cfa26a598eda28f6fcd506b Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 9 Feb 2024 10:02:27 -0800 Subject: [PATCH 303/305] updated rust_lifetimes example to work with the new SpecM --- heapster-saw/examples/rust_lifetimes.saw | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) 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"; From 62679e91e0ec6cf9cd53a6841664f9ed1138eb56 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 9 Feb 2024 10:02:57 -0800 Subject: [PATCH 304/305] commented out the processBlocks function from the sha512 example because it currently has a panic --- heapster-saw/examples/sha512.saw | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) 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"; From c7a908529a8e628cd0420c5f27625d06d2240c1f Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 9 Feb 2024 12:15:15 -0800 Subject: [PATCH 305/305] updated io example to work with the new SpecM --- heapster-saw/examples/io.saw | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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)"; ///