From 9620ea8bb54e000a648f4ea71a53a4c6c0165f8d Mon Sep 17 00:00:00 2001 From: Daniel Matichuk Date: Thu, 19 Sep 2024 17:19:09 -0700 Subject: [PATCH 01/36] add FnBindings module representing post-hoc defined functions --- pate.cabal | 1 + src/Pate/SimState.hs | 120 +++++++++++++++++-- src/Pate/Verification/FnBindings.hs | 179 ++++++++++++++++++++++++++++ src/Pate/Verification/PairGraph.hs | 36 ++++-- 4 files changed, 311 insertions(+), 25 deletions(-) create mode 100644 src/Pate/Verification/FnBindings.hs diff --git a/pate.cabal b/pate.cabal index 93efa7bd..2e85c56d 100644 --- a/pate.cabal +++ b/pate.cabal @@ -114,6 +114,7 @@ library Pate.Verification.DemandDiscovery, Pate.Verification.Domain, Pate.Verification.ExternalCall, + Pate.Verification.FnBindings, Pate.Verification.InlineCallee, Pate.Verification.MemoryLog, Pate.Verification.Override, diff --git a/src/Pate/SimState.hs b/src/Pate/SimState.hs index 96ce23ef..bb054fe2 100644 --- a/src/Pate/SimState.hs +++ b/src/Pate/SimState.hs @@ -28,6 +28,8 @@ Functionality for handling the inputs and outputs of crucible. {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ViewPatterns #-} -- must come after TypeFamilies, see also https://gitlab.haskell.org/ghc/ghc/issues/18006 {-# LANGUAGE NoMonoLocalBinds #-} @@ -41,21 +43,31 @@ module Pate.SimState , SimInput(..) , SimOutput(..) , type VarScope + , type GlobalScope , SimScope , scopeAsm , scopeVars , scopeVarsPair , Scoped(..) + , PopScope + , pattern PopScope , ScopedExpr + , mkScopedExpr + , fromGlobalScope , unSE , scopedExprMap , scopedLocWither , WithScope(..) , liftScope0 + , liftScope0Ret , forScopedExpr + , forScopedExprRet , liftScope2 + , liftScope3 , concreteScope , SimSpec + , AbsT(..) + , PopT(..) , mkSimSpec , freshSimSpec , forSpec @@ -84,6 +96,7 @@ module Pate.SimState import GHC.Stack ( HasCallStack ) import qualified Data.Kind as DK import Data.Proxy +import Data.Coerce import qualified Control.Monad.IO.Class as IO import Control.Lens ( (^.) ) @@ -155,6 +168,8 @@ simSP :: MM.RegisterInfo (MM.ArchReg arch) => SimState sym arch v bin -> PSR.MacawRegEntry sym (MT.BVType (MM.ArchAddrWidth arch)) simSP st = (simRegs st) ^. (MM.boundValue MM.sp_reg) +instance Scoped (PopT (SimState sym arch) bin) where + unsafeCoerceScope (PopF s) = PopF (coerce s) data SimInput sym arch v bin = SimInput { @@ -203,11 +218,18 @@ simOutRegs = simRegs . simOutState -- from one type to another via 'unsafeCoerceScope'. -- TODO: A safe variant of 'unsafeCoerceScope' could perform a runtime check to -- ensure that the resulting value is well-scoped. -data VarScope +data VarScope = + GlobalScope {- ^ scope for terms with no bound variables -} + | ArbitraryScope DK.Type {- ^ all other scopes (this constructor is not actually used) -} + +type GlobalScope = 'GlobalScope + + -- | A 'Scoped' type is parameterized by a phantom 'VarScope' type variable, used -- to track the scope of its inner bound variables. -class Scoped f where +-- This class explicitly tells us that the implementation of 'f' doesn't depend on 'v' +class (forall (v :: VarScope) (v' :: VarScope). Coercible (f v) (f v')) => Scoped f where -- | Unsafely change the variable scope parameter for an instance of 'f'. -- This should be a no-op and only used to make types match up where needed. -- It is the responsibility of the user to ensure that this is only applied @@ -215,6 +237,7 @@ class Scoped f where -- in the target scope. -- TODO: We can check this statically to add a safe variant. unsafeCoerceScope :: forall (v :: VarScope) v'. f v -> f v' + unsafeCoerceScope a = coerce a -- | A lambda abstraction over 'f', which is parameterized by a variable scope. -- A 'SimSpec' can be interpreted via 'viewSpec' or modified via 'forSpec'. @@ -230,6 +253,32 @@ data SimSpec sym arch (f :: VarScope -> DK.Type) = forall v. , _specBody :: f v } +-- TODO: probably defined somewhere already +-- can be used for types that abstract over 'bin' and 'v' to expose the +-- 'bin' parameter in a 'SimSpec' +newtype AbsT (f :: k -> DK.Type) (tp1 :: l -> k) (tp2 :: l) = AbsT { unAbsT :: f (tp1 tp2) } + +newtype PopT (f :: l -> k -> DK.Type) (tp1 :: k) (tp2 :: l) = PopF { unPopF :: f tp2 tp1 } + +-- Some trickery to let us use PopT while maintaining that VarScope is phantom +newtype PopScope (f :: l -> VarScope -> DK.Type) (v :: VarScope) (tp :: l) = PopScopeC (f tp GlobalScope) +type role PopScope representational phantom nominal + +unPopScope :: Scoped (f tp) => PopScope f v tp -> f tp v +unPopScope (PopScopeC f) = coerce f + +mkPopScope :: Scoped (f tp) => f tp v -> PopScope f v tp +mkPopScope f = PopScopeC (coerce f) + +pattern PopScope :: Scoped (f tp) => f tp v -> PopScope f v tp +pattern PopScope f <- (unPopScope -> f) where + PopScope f = mkPopScope f +{-# COMPLETE PopScope #-} + + +instance PEM.ExprMappable sym (f tp1 tp2) => PEM.ExprMappable sym (PopT f tp2 tp1) where + mapExpr sym f (PopF a) = PopF <$> PEM.mapExpr sym f a + mkSimSpec :: SimScope sym arch v -> f v -> SimSpec sym arch f mkSimSpec scope body = SimSpec scope body @@ -242,11 +291,8 @@ data SimScope sym arch v = , scopeAsm :: AssumptionSet sym } -instance Scoped (SimScope sym arch) where - unsafeCoerceScope scope = coerce scope - -instance Scoped (Const x) where - unsafeCoerceScope scope = coerce scope +instance Scoped (SimScope sym arch) +instance Scoped (Const x) scopeBoundVars :: SimScope sym arch v -> PPa.PatchPair (SimBoundVars sym arch v) scopeBoundVars scope = PPa.PatchPair (scopeBoundVarsO scope) (scopeBoundVarsP scope) @@ -340,8 +386,7 @@ data SimBundle sym arch v = SimBundle } -instance Scoped (SimBundle sym arch) where - unsafeCoerceScope bundle = coerce bundle +instance Scoped (SimBundle sym arch) instance (W4.IsSymExprBuilder sym, MM.RegisterInfo (MM.ArchReg arch)) => IsTraceNode '(sym,arch) "bundle" where type TraceNodeType '(sym,arch) "bundle" = Some (SimBundle sym arch) @@ -486,9 +531,20 @@ asScopeCoercion rew = ScopeCoercion <$> freshVarBindCache <*> pure rew -- | An expr tagged with a scoped parameter (representing the fact that the -- expression is valid under the scope 'v') -data ScopedExpr sym tp (v :: VarScope) = +newtype ScopedExpr sym tp (v :: VarScope) = ScopedExpr { unSE :: W4.SymExpr sym tp } +-- | Make a ScopedExpr with an unknown scope +mkScopedExpr :: W4.SymExpr sym tp -> Some (ScopedExpr sym tp) +mkScopedExpr e = Some (ScopedExpr e) + +-- | The global scope indicates no bound variables, and so this can +-- be safely converted into any scope +fromGlobalScope :: Scoped f => f GlobalScope -> f v +fromGlobalScope f = coerce f + +instance Scoped (ScopedExpr sym tp) + instance PEM.ExprMappable sym (ScopedExpr sym tp v) where mapExpr _sym f (ScopedExpr e) = ScopedExpr <$> f e @@ -506,6 +562,11 @@ instance TestEquality (W4.SymExpr sym) => Eq (ScopedExpr sym tp v) where Just _ -> True Nothing -> False +instance TestEquality (W4.SymExpr sym) => TestEquality (PopScope (ScopedExpr sym) v) where + testEquality (PopScope (ScopedExpr e1)) (PopScope (ScopedExpr e2)) = case testEquality e1 e2 of + Just Refl -> Just Refl + Nothing -> Nothing + {- newtype ScopedAssertion sym (v :: VarScope) = ScopedAssertion { unSA :: ScopedExpr sym v W4.BaseBoolType } @@ -585,13 +646,27 @@ applyScopeCoercion sym (ScopeCoercion cache (ExprRewrite binds)) (ScopedExpr e) -- incidentally include bound variables from other scopes) liftScope2 :: W4.IsSymExprBuilder sym => + IO.MonadIO m => sym -> - (forall sym'. W4.IsSymExprBuilder sym' => sym' -> W4.SymExpr sym' tp1 -> W4.SymExpr sym' tp2 -> IO (W4.SymExpr sym' tp3)) -> + (forall sym'. W4.IsSymExprBuilder sym' => sym' -> W4.SymExpr sym' tp1 -> W4.SymExpr sym' tp2 -> m (W4.SymExpr sym' tp3)) -> ScopedExpr sym tp1 v -> ScopedExpr sym tp2 v -> - IO (ScopedExpr sym tp3 v) + m (ScopedExpr sym tp3 v) liftScope2 sym f (ScopedExpr e1) (ScopedExpr e2) = ScopedExpr <$> f sym e1 e2 +-- | An operation is scope-preserving if it is valid for all builders (i.e. we can't +-- incidentally include bound variables from other scopes) +liftScope3 :: + W4.IsSymExprBuilder sym => + IO.MonadIO m => + sym -> + (forall sym'. W4.IsSymExprBuilder sym' => sym' -> W4.SymExpr sym' tp1 -> W4.SymExpr sym' tp2 -> W4.SymExpr sym' tp3 -> m (W4.SymExpr sym' tp4)) -> + ScopedExpr sym tp1 v -> + ScopedExpr sym tp2 v -> + ScopedExpr sym tp3 v -> + m (ScopedExpr sym tp4 v) +liftScope3 sym f (ScopedExpr e1) (ScopedExpr e2) (ScopedExpr e3) = ScopedExpr <$> f sym e1 e2 e3 + forScopedExpr :: W4.IsSymExprBuilder sym => sym -> @@ -600,6 +675,17 @@ forScopedExpr :: IO (ScopedExpr sym tp2 v) forScopedExpr sym (ScopedExpr e1) f = ScopedExpr <$> f sym e1 +-- | Similar to 'forScopedExpr' but may return a value as well +forScopedExprRet :: + W4.IsSymExprBuilder sym => + sym -> + ScopedExpr sym tp1 v -> + (forall sym'. W4.IsSymExprBuilder sym' => sym' -> W4.SymExpr sym' tp1 -> IO (f sym', W4.SymExpr sym' tp2)) -> + IO (f sym, ScopedExpr sym tp2 v) +forScopedExprRet sym (ScopedExpr e1) f = do + (a, e2) <- f sym e1 + return (a, ScopedExpr e2) + -- | An operation is scope-preserving if it is valid for all builders (i.e. we can't -- incidentally include bound variables from other scopes) liftScope0 :: @@ -610,6 +696,16 @@ liftScope0 :: IO (ScopedExpr sym tp v) liftScope0 sym f = ScopedExpr <$> f sym +liftScope0Ret :: + forall f v sym tp. + W4.IsSymExprBuilder sym => + sym -> + (forall sym'. W4.IsSymExprBuilder sym' => sym' -> IO (f sym', W4.SymExpr sym' tp)) -> + IO (f sym, ScopedExpr sym tp v) +liftScope0Ret sym f = do + (a, e) <- f sym + return (a, ScopedExpr e) + -- | A concrete value is valid in all scopes concreteScope :: forall v sym tp. diff --git a/src/Pate/Verification/FnBindings.hs b/src/Pate/Verification/FnBindings.hs new file mode 100644 index 00000000..3a545571 --- /dev/null +++ b/src/Pate/Verification/FnBindings.hs @@ -0,0 +1,179 @@ +{-| +Module : Pate.Verification.FnBindings +Copyright : (c) Galois, Inc 2024 +Maintainer : Daniel Matichuk + +Representation of post-hoc definitions for uninterpreted functions. +-} + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE FlexibleInstances #-} + +module Pate.Verification.FnBindings + ( FnBindings + , FnBindingsSpec + , init + , merge + , toScopedPred + , toPred + ) where + +import Prelude hiding (init) +import Control.Monad.Reader +import Control.Monad.Trans.State + +import qualified Data.Parameterized.Context as Ctx +import Data.Parameterized.Classes +import Data.Parameterized.Some +import Data.Parameterized.Map ( MapF ) +import qualified Data.Parameterized.Map as MapF + +import qualified What4.Interface as W4 + +import qualified Pate.Binary as PBi +import qualified Pate.ExprMappable as PEM +import qualified Pate.SimState as PS + + +data BoundFn sym tp = BoundFn (W4.SymFn sym Ctx.EmptyCtx tp) + +-- | By convention we know that a 'BoundFn' is uninterpreted, so it +-- can be lifted to the global scope +evalBoundFn :: + W4.IsSymExprBuilder sym => + sym -> + BoundFn sym tp -> + IO (PS.ScopedExpr sym tp PS.GlobalScope) +evalBoundFn sym (BoundFn f) = do + e <- W4.applySymFn sym f Ctx.empty + Some e_scoped <- return $ PS.mkScopedExpr e + return $ PS.unsafeCoerceScope e_scoped + +instance W4.IsSymFn (W4.SymFn sym) => W4.TestEquality (BoundFn sym) where + testEquality (BoundFn fn1) (BoundFn fn2) = case W4.fnTestEquality fn1 fn2 of + Just Refl -> Just Refl + Nothing -> Nothing + +instance W4.IsSymFn (W4.SymFn sym) => OrdF (BoundFn sym) where + compareF (BoundFn fn1) (BoundFn fn2) = case W4.fnCompare fn1 fn2 of + LTF -> LTF + EQF -> EQF + GTF -> GTF + +-- | Bindings for uninterpreted functions (i.e. functions that +-- are initially uninterpreted but lazily defined). +-- The functions are implicitly scoped to some global scope +-- (i.e. the state at the point of divergence). +-- The bindings are scoped to the given 'v', with the intention that +-- when 'v' is the same scope as the uninterpreted functions, the +-- binding can then be unfolded. +-- i.e. given a global set of variables 'X' we may start with the bindings +-- F(X) == f_0(y), G(X) == g_0(z) +-- And then when propagated through some number of transformation we eventually +-- reach a point such that: +-- F(X) == f_0(f_1(...f_i(X))), G(X) == g_0(g_1(...g_i(X)) +-- At which point we can rewrite these functions in any expression +-- containing F(X) or G(X) +-- i.e. P(X)[F(X)/f_0(f_1(...f_i(X))), G(X)/g_0(g_1(...g_i(X))] +-- +-- Note that X is implicitly understood (since it is globally defined) +-- and so does not need to actually be passed to the uninterpreted functions. +-- +-- The 'bin' parameter specifies which side of the analysis these +-- bindings belong to. Specifically, these functions define the +-- semantics for a single-sided transition that may occur in terms +-- in the other side of the analysis. +newtype FnBindings sym (bin :: PBi.WhichBinary) (v :: PS.VarScope) = + FnBindings (MapF (BoundFn sym) (PS.PopScope (PS.ScopedExpr sym) v)) + +type FnBindingsSpec sym arch = PS.AbsT (PS.SimSpec sym arch) (FnBindings sym) + +instance PS.Scoped (FnBindings sym bin) + +-- | Transform the given value to be globally-scoped by replacing its internal expressions +-- with uninterpreted functions +init :: + W4.IsSymExprBuilder sym => + PS.Scoped f => + PEM.ExprMappable sym (f v) => + sym -> + f v -> + IO (f PS.GlobalScope, FnBindings sym bin v) +init sym e = runStateT (PS.scopedExprMap sym e (mkFreshFns sym)) (FnBindings MapF.empty) + +mkFreshFns :: + W4.IsSymExprBuilder sym => + sym -> + PS.ScopedExpr sym tp v -> + StateT (FnBindings sym bin v) IO (PS.ScopedExpr sym tp PS.GlobalScope) +mkFreshFns sym_ e_scoped = do + (PS.PopF fn, e_global) <- lift $ PS.liftScope0Ret sym_ $ \sym -> do + fn <- W4.freshTotalUninterpFn sym W4.emptySymbol Ctx.empty (W4.exprType (PS.unSE e_scoped)) + e' <- W4.applySymFn sym fn Ctx.empty + return (PS.PopF (BoundFn fn), e') + modify $ \(FnBindings binds) -> FnBindings (MapF.insert fn (PS.PopScope e_scoped) binds) + return e_global + +-- | Merge the two given function bindings, muxing the individual bindings +-- with the given predicate (i.e. path condition) in the case of +-- key (uninterpreted function) clashes +merge :: + forall sym bin v. + W4.IsSymExprBuilder sym => + sym -> + PS.ScopedExpr sym W4.BaseBoolType v -> + FnBindings sym bin v -> + FnBindings sym bin v -> + IO (FnBindings sym bin v) +merge sym p (FnBindings binds1) (FnBindings binds2) = do + FnBindings <$> MapF.mergeWithKeyM go return return binds1 binds2 + where + go :: forall tp. + BoundFn sym tp -> + PS.PopScope (PS.ScopedExpr sym) v tp -> + PS.PopScope (PS.ScopedExpr sym) v tp -> + IO (Maybe (PS.PopScope (PS.ScopedExpr sym) v tp)) + go _fn se1@(PS.PopScope e1) se2@(PS.PopScope e2) = case W4.testEquality se1 se2 of + Just{} -> return $ Just (PS.PopScope e1) + Nothing -> (Just . PS.PopScope) <$> (liftIO $ (PS.liftScope3 sym W4.baseTypeIte p e1 e2 )) + + +toScopedPred :: + forall sym bin v. + W4.IsSymExprBuilder sym => + sym -> + FnBindings sym bin v -> + IO (PS.ScopedExpr sym W4.BaseBoolType v) +toScopedPred sym (FnBindings binds) = do + true_ <- PS.liftScope0 sym $ \sym_ -> return $ W4.truePred sym_ + MapF.foldlMWithKey go true_ binds + where + go :: forall tp. + PS.ScopedExpr sym W4.BaseBoolType v -> + BoundFn sym tp -> + PS.PopScope (PS.ScopedExpr sym) v tp -> + IO (PS.ScopedExpr sym W4.BaseBoolType v) + go p f (PS.PopScope e) = do + f_app <- evalBoundFn sym f + p' <- PS.liftScope2 sym W4.isEq (PS.fromGlobalScope f_app) e + PS.liftScope2 sym W4.andPred p p' + +toPred :: + forall sym bin v. + W4.IsSymExprBuilder sym => + sym -> + FnBindings sym bin v -> + IO (W4.Pred sym) +toPred sym binds = PS.unSE <$> toScopedPred sym binds \ No newline at end of file diff --git a/src/Pate/Verification/PairGraph.hs b/src/Pate/Verification/PairGraph.hs index 05d02a8c..3804bc98 100644 --- a/src/Pate/Verification/PairGraph.hs +++ b/src/Pate/Verification/PairGraph.hs @@ -154,6 +154,8 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (fromMaybe, catMaybes) import Data.Parameterized.Classes +import Data.Parameterized.Map ( MapF ) +import qualified Data.Parameterized.Map as MapF import Data.Set (Set) import qualified Data.Set as Set import Data.Word (Word32) @@ -187,6 +189,7 @@ import qualified Pate.Verification.AbstractDomain as PAD import Pate.Verification.AbstractDomain ( AbstractDomain, AbstractDomainSpec ) import Pate.TraceTree import qualified Pate.Binary as PBi +import qualified Pate.Verification.FnBindings as PFn import Control.Applicative (Const(..), Alternative(..)) @@ -198,6 +201,7 @@ import Data.Parameterized.SetF (SetF) import qualified Data.Parameterized.SetF as SetF import GHC.Stack (HasCallStack) import Control.Monad.Reader +import qualified Data.Parameterized.Context as Ctx -- | Gas is used to ensure that our fixpoint computation terminates @@ -313,7 +317,7 @@ data PairGraph sym arch = -- | Mapping from singleton nodes to their "synchronization" point, representing -- the case where two independent program analysis steps have occurred and now -- their control-flows have re-synchronized - , pairGraphSyncData :: !(Map (GraphNode arch) (SyncData arch)) + , pairGraphSyncData :: !(Map (GraphNode arch) (SyncData sym arch)) , pairGraphPendingActs :: ActionQueue sym arch , pairGraphDomainRefinements :: !(Map (GraphNode arch) [DomainRefinement sym arch]) @@ -424,7 +428,7 @@ data PropagateKind = -- of Original sync point vs. every Patched sync point -- In practice this is still reasonably small, since there are usually -- only 2-3 cut addresses on each side (i.e. 4-9 merge cases to consider) -data SyncData arch = +data SyncData sym arch = SyncData { -- | During single-sided analysis, if we encounter an edge @@ -441,8 +445,14 @@ data SyncData arch = , _syncExceptions :: PPa.PatchPair (SetF (TupleF '(Qu.AsSingle (NodeEntry' arch), PB.BlockTarget arch))) -- Exits from the corresponding desync node that start the single-sided analysis , _syncDesyncExits :: PPa.PatchPair (SetF (PB.BlockTarget arch)) + -- Uninterpreted functions that are used to collect the semantics for + -- variables that the other side of the analysis requires (i.e. in some assertion + -- that was propagated backwards from after a merge point) + , _syncBindings :: MapF (SingleNodeEntry arch) (PFn.FnBindingsSpec sym arch) } + + -- sync exit point should *always* point to a cut address data SyncPoint arch bin = SyncAtExit { syncPointNode :: SingleNodeEntry arch bin , _syncPointExit :: SingleNodeEntry arch bin } @@ -461,16 +471,15 @@ instance OrdF (SyncPoint arch) where compareF sp1 sp2 = lexCompareF (syncPointBin sp1) (syncPointBin sp2) $ fromOrdering (compare sp1 sp2) -instance Semigroup (SyncData arch) where - (SyncData a1 b1 c1 d1) <> (SyncData a2 b2 c2 d2) = (SyncData (a1 <> a2) (b1 <> b2) (c1 <> c2) (d1 <> d2)) - - -instance Monoid (SyncData arch) where - mempty = SyncData +emptySyncData :: SyncData sym arch +emptySyncData = SyncData (PPa.mkPair PBi.OriginalRepr SetF.empty SetF.empty) (PPa.mkPair PBi.OriginalRepr SetF.empty SetF.empty) (PPa.mkPair PBi.OriginalRepr SetF.empty SetF.empty) (PPa.mkPair PBi.OriginalRepr SetF.empty SetF.empty) + MapF.empty + + $(L.makeLenses ''SyncData) $(L.makeLenses ''ActionQueue) @@ -481,7 +490,7 @@ getSyncData :: forall sym arch x bin. HasCallStack => (OrdF x, Ord (x bin)) => - L.Lens' (SyncData arch) (PPa.PatchPair (SetF x)) -> + L.Lens' (SyncData sym arch) (PPa.PatchPair (SetF x)) -> PBi.WhichBinaryRepr bin -> GraphNode arch {- ^ The divergent node -} -> PairGraphM sym arch (Set (x bin)) @@ -497,7 +506,7 @@ getSingleNodeData :: forall sym arch x bin. HasCallStack => (OrdF x, Ord (x bin)) => - L.Lens' (SyncData arch) (PPa.PatchPair (SetF x)) -> + L.Lens' (SyncData sym arch) (PPa.PatchPair (SetF x)) -> SingleNodeEntry arch bin -> PairGraphM sym arch (Set (x bin)) getSingleNodeData lens sne = do @@ -505,11 +514,12 @@ getSingleNodeData lens sne = do let bin = singleEntryBin sne getSyncData lens bin dp + modifySyncData :: forall sym arch x bin. HasCallStack => (OrdF x, Ord (x bin)) => - L.Lens' (SyncData arch) (PPa.PatchPair (SetF x)) -> + L.Lens' (SyncData sym arch) (PPa.PatchPair (SetF x)) -> PBi.WhichBinaryRepr bin -> GraphNode arch -> (Set (x bin) -> Set (x bin)) -> @@ -518,7 +528,7 @@ modifySyncData lens bin dp f = do msp <- tryPG $ lookupPairGraph pairGraphSyncData dp let f' = \x -> SetF.fromSet (f (SetF.toSet x)) let sp' = case msp of - Nothing -> mempty & lens .~ (PPa.mkSingle bin (f' SetF.empty)) + Nothing -> emptySyncData & lens .~ (PPa.mkSingle bin (f' SetF.empty)) Just sp -> sp & lens %~ (\x -> PPa.set bin (f' $ fromMaybe SetF.empty (PPa.get bin x)) x) modify $ \pg -> @@ -528,7 +538,7 @@ addToSyncData :: forall sym arch x bin. (OrdF x, Ord (x bin)) => HasCallStack => - L.Lens' (SyncData arch) (PPa.PatchPair (SetF x)) -> + L.Lens' (SyncData sym arch) (PPa.PatchPair (SetF x)) -> PBi.WhichBinaryRepr bin -> GraphNode arch {- ^ The divergent node -} -> x bin -> From 8016376d18665c49cc475955eb978cfa9b2b9405 Mon Sep 17 00:00:00 2001 From: Daniel Matichuk Date: Wed, 25 Sep 2024 14:38:51 -0700 Subject: [PATCH 02/36] overhaul the control flow sync/merge logic to use uninterpreted functions this gives a much more precise (and sound) treatment to how everything is stitched together when combining two single-sided analysis nodes into a two-sided node. Importantly, the "no-op" bundle for each single sided analysis is modeled as making a no-op for the single-sided node under consideration, but an undefined transition for the other side of the analysis. These undefined transitions are collected as uninterpreted functions, which are eventually to be defined by propagating them backwards through the single-sided analysis. Since this step is not complete, we now expect to generate unprovable assertions which contain these functions. --- src/Data/Parameterized/SetF.hs | 7 ++ src/Pate/AssumptionSet.hs | 10 ++ src/Pate/Equivalence/Condition.hs | 11 +++ src/Pate/ExprMappable.hs | 41 ++++++++- src/Pate/MemCell.hs | 6 ++ src/Pate/Monad/PairGraph.hs | 4 + src/Pate/PatchPair.hs | 32 +++++++ src/Pate/SimState.hs | 19 +++- src/Pate/SimulatorRegisters.hs | 8 +- src/Pate/Verification/FnBindings.hs | 63 ++++++++++--- src/Pate/Verification/PairGraph.hs | 117 +++++++++++++++++++----- src/Pate/Verification/StrongestPosts.hs | 98 ++++++++++++++------ src/Pate/Verification/Widening.hs | 1 + src/What4/ExprHelpers.hs | 45 +++++++++ src/What4/PredMap.hs | 9 ++ 15 files changed, 395 insertions(+), 76 deletions(-) diff --git a/src/Data/Parameterized/SetF.hs b/src/Data/Parameterized/SetF.hs index 950a1a26..437923ca 100644 --- a/src/Data/Parameterized/SetF.hs +++ b/src/Data/Parameterized/SetF.hs @@ -47,12 +47,14 @@ module Data.Parameterized.SetF , fromSet , map , ppSetF + , asSet ) where import Prelude hiding (filter, null, map) import qualified Data.List as List import Data.Parameterized.Classes import qualified Data.Foldable as Foldable +import qualified Control.Lens as L import qualified Prettyprinter as PP import Prettyprinter ( (<+>) ) @@ -150,6 +152,11 @@ toSet (SetF s) = unsafeCoerce s fromSet :: (OrdF f, Ord (f tp)) => Set (f tp) -> SetF f tp fromSet s = SetF (unsafeCoerce s) +asSet :: + (OrdF f, Ord (f tp)) => + L.Lens' (SetF f tp) (Set (f tp)) +asSet f sf = fmap fromSet (f (toSet sf)) + map :: (OrdF g) => (f tp -> g tp) -> SetF f tp -> SetF g tp map f (SetF s) = SetF (S.map (\(AsOrd v) -> AsOrd (f v)) s) diff --git a/src/Pate/AssumptionSet.hs b/src/Pate/AssumptionSet.hs index 76de5275..0b557cd0 100644 --- a/src/Pate/AssumptionSet.hs +++ b/src/Pate/AssumptionSet.hs @@ -138,6 +138,11 @@ instance OrdF (W4.SymExpr sym) => PEM.ExprMappable sym (AssumptionSet sym) where return $ MapF.singleton k' v' return $ mkAssumptionSet sym ps' (foldr (mergeExprSetFMap (Proxy @sym)) MapF.empty bs') +instance PEM.ExprFoldable sym (AssumptionSet sym) where + foldExpr sym f (AssumptionSet ps bs) acc = + PEM.withSymExprFoldable @W4.BaseBoolType sym $ + PEM.foldExpr sym f ps acc >>= PEM.foldExpr sym f bs + instance forall sym. W4S.SerializableExprs sym => W4S.W4Serializable sym (AssumptionSet sym) where w4Serialize (AssumptionSet ps bs) | SetF.null ps, MapF.null bs = W4S.w4Serialize True w4Serialize (AssumptionSet ps bs) | [p] <- SetF.toList ps, MapF.null bs = W4S.w4SerializeF p @@ -166,6 +171,11 @@ data NamedAsms sym (nm :: Symbol) = instance W4S.SerializableExprs sym => W4S.W4Serializable sym (NamedAsms sym nm) where w4Serialize (NamedAsms asm) = W4S.w4Serialize asm +instance PEM.ExprFoldable sym (NamedAsms sym nm) where + foldExpr sym f (NamedAsms asm) acc = PEM.foldExpr sym f asm acc + +instance PEM.ExprFoldableF sym (NamedAsms sym) + instance PEM.ExprMappable sym (NamedAsms sym nm) where mapExpr sym f (NamedAsms asm) = NamedAsms <$> PEM.mapExpr sym f asm diff --git a/src/Pate/Equivalence/Condition.hs b/src/Pate/Equivalence/Condition.hs index 73022613..dbd3b572 100644 --- a/src/Pate/Equivalence/Condition.hs +++ b/src/Pate/Equivalence/Condition.hs @@ -148,6 +148,13 @@ instance PEM.ExprMappable sym (EquivalenceCondition sym arch v) where <*> PEM.mapExpr sym f c <*> PEM.mapExpr sym f d +instance PEM.ExprFoldableF sym (MM.ArchReg arch) => PEM.ExprFoldable sym (EquivalenceCondition sym arch v) where + foldExpr sym f (EquivalenceCondition a b c d) acc = + PEM.foldExpr sym f a acc + >>= PEM.foldExpr sym f b + >>= PEM.foldExpr sym f c + >>= PEM.foldExpr sym f d + instance PS.Scoped (EquivalenceCondition sym arch) where unsafeCoerceScope (EquivalenceCondition a b c d) = EquivalenceCondition a (PS.unsafeCoerceScope b) c d @@ -234,6 +241,10 @@ instance PS.Scoped (RegisterCondition sym arch) where instance PEM.ExprMappable sym (RegisterCondition sym arch v) where mapExpr sym f (RegisterCondition cond) = RegisterCondition <$> MM.traverseRegsWith (\_ -> PEM.mapExpr sym f) cond +instance PEM.ExprFoldableF sym (MM.ArchReg arch) => PEM.ExprFoldable sym (RegisterCondition sym arch v) where + foldExpr sym f (RegisterCondition cond) = PEM.foldExpr sym f (MM.regStateMap cond) + + trueRegCond :: W4.IsSymExprBuilder sym => PA.ValidArch arch => diff --git a/src/Pate/ExprMappable.hs b/src/Pate/ExprMappable.hs index 2f394ac7..e6afb420 100644 --- a/src/Pate/ExprMappable.hs +++ b/src/Pate/ExprMappable.hs @@ -30,6 +30,7 @@ module Pate.ExprMappable ( , withExprFoldable , ExprFoldableFC , ExprFoldableIO(..) + , withSymExprFoldable , SkipTransformation(..) , ToExprMappable(..) , SymExprMappable(..) @@ -70,6 +71,7 @@ import qualified Lang.Crucible.Utils.MuxTree as MT import Data.Parameterized.Map (MapF) import qualified Data.Parameterized.Map as MapF import qualified Data.Parameterized.TraversableF as TF +import qualified Data.Parameterized.TraversableFC as TFC import Data.Text import Control.Monad (forM, foldM) import Data.Kind (Type) @@ -414,6 +416,9 @@ withExprFoldable :: (ExprFoldable sym (f tp) => a) -> a withExprFoldable f = withExprFoldable_ (Proxy @sym) (Proxy @f) (Proxy @tp) f +instance forall sym f. ExprFoldableF sym f => ExprFoldable sym (Some f) where + foldExpr sym f (Some (a :: f tp)) b = withExprFoldable @sym @f @tp $ foldExpr sym f a b + class (forall sym. ExprFoldableF sym f) => ExprFoldableFC f where instance (Ord f, ExprMappable sym f) => ExprMappable sym (MT.MuxTree sym f) where @@ -456,15 +461,37 @@ instance ExprFoldable sym f => ExprFoldable sym (Maybe f) where foldExpr sym f (Just e) b0 = foldExpr sym f e b0 foldExpr _ _ Nothing b0 = return b0 -instance (ExprFoldable sym f) => ExprFoldable sym (MT.MuxTree sym f) where - foldExpr sym f mt b0 | SymExprFoldable aEF <- symExprFoldable sym = aEF @WI.BaseBoolType $ foldExpr sym f (MT.viewMuxTree mt) b0 +instance forall sym f. (ExprFoldable sym f) => ExprFoldable sym (MT.MuxTree sym f) where + foldExpr sym f mt b0 | SymExprFoldable aEF <- symExprFoldable sym = + aEF $ withExprFoldable @sym @(WI.SymExpr sym) @WI.BaseBoolType $ foldExpr sym f (MT.viewMuxTree mt) b0 + +instance forall sym f ctx. ExprFoldableF sym f => ExprFoldable sym (Ctx.Assignment f ctx) where + foldExpr sym f asn b0 = TFC.foldrMFC (\(a :: f x) b -> withExprFoldable @sym @f @x $ foldExpr sym f a b) b0 asn + +instance forall sym f k. (ExprFoldable sym f) => ExprFoldable sym (WPM.PredMap sym f k) where + foldExpr sym f pm b = withSymExprFoldable @WI.BaseBoolType sym $ + WPM.foldMWithKey pm (\k v b_ -> foldExpr sym f k b_ >>= foldExpr sym f v) b + +instance ExprFoldable sym f => ExprFoldable sym ((Const f) tp) where + foldExpr sym f (Const e) b = foldExpr sym f e b + +instance ExprFoldable sym f => ExprFoldableF sym (Const f) + +instance ExprFoldable sym (f tp) => ExprFoldable sym (SetF.SetF f tp) where + foldExpr sym f s b = foldExpr sym f (SetF.toList s) b + +instance forall sym f. ExprFoldableF sym f => ExprFoldableF sym (SetF.SetF f) where + withExprFoldable_ psym _pf ptp f = + withExprFoldable_ psym (Proxy @f) ptp f newtype ToExprFoldable sym tp = ToExprFoldable { unEF :: WI.SymExpr sym tp } instance ExprFoldable sym (ToExprFoldable sym tp) where foldExpr _sym f (ToExprFoldable e) b = f e b -newtype SymExprFoldable sym f = SymExprFoldable (forall tp a. ((ExprFoldable sym (f tp)) => a) -> a) +instance ExprFoldableF sym (ToExprFoldable sym) + +newtype SymExprFoldable sym f = SymExprFoldable (forall a. ((ExprFoldableF sym f) => a) -> a) -- Same approach for 'symExprMappable' to create ExprFoldable instances for SymExpr symExprFoldable :: @@ -474,4 +501,10 @@ symExprFoldable :: symExprFoldable _sym = unsafeCoerce r where r :: SymExprFoldable sym (ToExprFoldable sym) - r = SymExprFoldable (\a -> a) \ No newline at end of file + r = SymExprFoldable (\a -> a) + +withSymExprFoldable :: + forall tp sym a. + sym -> + ((ExprFoldableF sym (WI.SymExpr sym), ExprFoldable sym (WI.SymExpr sym tp)) => a) -> a +withSymExprFoldable sym f | SymExprFoldable aEF <- symExprFoldable sym = aEF $ withExprFoldable @sym @(WI.SymExpr sym) @tp f \ No newline at end of file diff --git a/src/Pate/MemCell.hs b/src/Pate/MemCell.hs index 256dee29..ac2bd0dd 100644 --- a/src/Pate/MemCell.hs +++ b/src/Pate/MemCell.hs @@ -180,6 +180,12 @@ instance PEM.ExprMappable sym (MemCell sym arch w) where ptr' <- WEH.mapExprPtr sym f ptr return $ MemCell ptr' w end +instance PEM.ExprFoldable sym (MemCell sym arch w) where + foldExpr _sym f (MemCell (CLM.LLVMPointer reg off) _w _end) b = + f (WI.natToIntegerPure reg) b >>= f off + +instance PEM.ExprFoldableF sym (MemCell sym arch) + ppCell :: (WI.IsExprBuilder sym) => MemCell sym arch w -> PP.Doc a ppCell cell = let CLM.LLVMPointer reg off = cellPtr cell diff --git a/src/Pate/Monad/PairGraph.hs b/src/Pate/Monad/PairGraph.hs index 938182dc..45933c10 100644 --- a/src/Pate/Monad/PairGraph.hs +++ b/src/Pate/Monad/PairGraph.hs @@ -42,8 +42,10 @@ import Control.Monad (foldM, forM_) import qualified Control.Monad.IO.Unlift as IO import Data.Functor.Const import Data.Maybe (fromMaybe) +import Control.Lens ( (&), (.~), (^.), (%~) ) import qualified Data.Parameterized.TraversableF as TF +import qualified Data.Parameterized.Map as MapF import Data.Parameterized.Some import SemMC.Formula.Env (SomeSome(..)) @@ -65,6 +67,8 @@ import qualified Pate.Equivalence.Error as PEE import GHC.Stack (HasCallStack) import qualified Prettyprinter as PP import qualified What4.Interface as W4 +import qualified Pate.Verification.FnBindings as PFn +import qualified What4.Concrete as W4 instance IsTraceNode (k :: l) "pg_trace" where type TraceNodeType k "pg_trace" = [String] diff --git a/src/Pate/PatchPair.hs b/src/Pate/PatchPair.hs index 1181b76f..ce56769b 100644 --- a/src/Pate/PatchPair.hs +++ b/src/Pate/PatchPair.hs @@ -31,6 +31,7 @@ module Pate.PatchPair ( , PatchPairT , PatchPairC , pattern PatchPairC + , lensC , runPatchPairT , runPatchPairT' , handleSingletonStub @@ -50,6 +51,7 @@ module Pate.PatchPair ( , get , set , view + , lens , asTuple , fromTuple , fromMaybes @@ -57,6 +59,7 @@ module Pate.PatchPair ( , LiftF(..) , PatchPairF , pattern PatchPairF + , lensF , PatchPairMaybeCases(..) , toMaybeCases , forBins2 @@ -106,6 +109,7 @@ import What4.JSON import Control.Monad.State.Strict (StateT (..), put) import qualified Control.Monad.State.Strict as CMS import Control.Applicative ( (<|>) ) +import qualified Control.Lens as L -- | A pair of values indexed based on which binary they are associated with (either the -- original binary or the patched binary). @@ -140,6 +144,20 @@ pattern PatchPairOriginal a = PatchPairSingle PB.OriginalRepr a pattern PatchPairPatched :: tp PB.Patched -> PatchPair tp pattern PatchPairPatched a = PatchPairSingle PB.PatchedRepr a +lens :: + PB.WhichBinaryRepr bin -> + k bin {- ^ default value -} -> + L.Lens' (PatchPair k) (k bin) +lens bin default_ f ppair = case (bin, ppair) of + (PB.OriginalRepr, PatchPair a b) -> fmap (\k -> PatchPair k b) (f a) + (PB.PatchedRepr, PatchPair a b) -> fmap (\k -> PatchPair a k) (f b) + (PB.OriginalRepr, PatchPairOriginal a) -> fmap (\k -> PatchPairOriginal k) (f a) + (PB.PatchedRepr, PatchPairPatched b) -> fmap (\k -> PatchPairPatched k) (f b) + (PB.OriginalRepr, PatchPairPatched b) -> fmap (\k -> PatchPair k b) (f default_) + (PB.PatchedRepr, PatchPairOriginal a) -> fmap (\k -> PatchPair a k) (f default_) + + + {-# COMPLETE PatchPair, PatchPairSingle #-} {-# COMPLETE PatchPair, PatchPairOriginal, PatchPairPatched #-} @@ -400,6 +418,12 @@ type PatchPairC tp = PatchPair (Const tp) pattern PatchPairC :: tp -> tp -> PatchPair (Const tp) pattern PatchPairC a b = PatchPair (Const a) (Const b) +lensC :: + PB.WhichBinaryRepr bin -> + k {- ^ default value -} -> + L.Lens' (PatchPairC k) k +lensC bin default_ = (lens bin (Const default_) . (\f -> fmap Const . f . getConst)) + {-# COMPLETE PatchPairC, PatchPairSingle #-} {-# COMPLETE PatchPairC, PatchPairOriginal, PatchPairPatched #-} @@ -410,6 +434,9 @@ forBinsC f = forBins $ \bin -> Const <$> f bin newtype LiftF (t :: l -> DK.Type) (f :: k -> l) (tp :: k) = LiftF { unLiftF :: (t (f tp)) } +liftFLens :: L.Lens' (LiftF k tp bin) (k (tp bin)) +liftFLens f (LiftF v) = fmap LiftF (f v) + instance Show (t (f tp)) => Show (LiftF t f tp) where show (LiftF x) = show x @@ -424,6 +451,11 @@ pattern PatchPairF a b = PatchPair (LiftF a) (LiftF b) {-# COMPLETE PatchPairF, PatchPairSingle #-} {-# COMPLETE PatchPairF, PatchPairOriginal, PatchPairPatched #-} +lensF :: + PB.WhichBinaryRepr bin -> + k (tp bin) {- ^ default value -} -> + L.Lens' (PatchPairF k tp) (k (tp bin)) +lensF bin default_ = (lens bin (LiftF default_) . liftFLens) forBinsF :: PatchPairM m => (forall bin. PB.KnownBinary bin => PB.WhichBinaryRepr bin -> m (t (f bin))) -> m (PatchPairF t f) forBinsF f = forBins $ \bin -> LiftF <$> f bin diff --git a/src/Pate/SimState.hs b/src/Pate/SimState.hs index bb054fe2..aca34982 100644 --- a/src/Pate/SimState.hs +++ b/src/Pate/SimState.hs @@ -169,7 +169,7 @@ simSP :: MM.RegisterInfo (MM.ArchReg arch) => SimState sym arch v bin -> simSP st = (simRegs st) ^. (MM.boundValue MM.sp_reg) instance Scoped (PopT (SimState sym arch) bin) where - unsafeCoerceScope (PopF s) = PopF (coerce s) + unsafeCoerceScope (PopT s) = PopT (coerce s) data SimInput sym arch v bin = SimInput { @@ -253,12 +253,18 @@ data SimSpec sym arch (f :: VarScope -> DK.Type) = forall v. , _specBody :: f v } +instance (PEM.ExprFoldableF sym (MM.ArchReg arch), PEM.ExprFoldableF sym f) => PEM.ExprFoldable sym (SimSpec sym arch f) where + foldExpr sym f (SimSpec (scope :: SimScope sym arch v) body) b = + PEM.withExprFoldable @sym @f @v $ PEM.foldExpr sym f scope b >>= PEM.foldExpr sym f body + -- TODO: probably defined somewhere already -- can be used for types that abstract over 'bin' and 'v' to expose the -- 'bin' parameter in a 'SimSpec' newtype AbsT (f :: k -> DK.Type) (tp1 :: l -> k) (tp2 :: l) = AbsT { unAbsT :: f (tp1 tp2) } -newtype PopT (f :: l -> k -> DK.Type) (tp1 :: k) (tp2 :: l) = PopF { unPopF :: f tp2 tp1 } +newtype PopT (f :: l -> k -> DK.Type) (tp1 :: k) (tp2 :: l) = PopT { unPopT :: f tp2 tp1 } + +instance (forall (v :: VarScope) (v' :: VarScope). Coercible (f v tp) (f v' tp)) => Scoped (PopT f tp) -- Some trickery to let us use PopT while maintaining that VarScope is phantom newtype PopScope (f :: l -> VarScope -> DK.Type) (v :: VarScope) (tp :: l) = PopScopeC (f tp GlobalScope) @@ -277,7 +283,7 @@ pattern PopScope f <- (unPopScope -> f) where instance PEM.ExprMappable sym (f tp1 tp2) => PEM.ExprMappable sym (PopT f tp2 tp1) where - mapExpr sym f (PopF a) = PopF <$> PEM.mapExpr sym f a + mapExpr sym f (PopT a) = PopT <$> PEM.mapExpr sym f a mkSimSpec :: SimScope sym arch v -> f v -> SimSpec sym arch f mkSimSpec scope body = SimSpec scope body @@ -294,6 +300,10 @@ data SimScope sym arch v = instance Scoped (SimScope sym arch) instance Scoped (Const x) +instance PEM.ExprFoldableF sym (MM.ArchReg arch) => PEM.ExprFoldable sym (SimScope sym arch v) where + foldExpr sym f (SimScope varsO varsP asm) b = + PEM.foldExpr sym f varsO b >>= PEM.foldExpr sym f varsP >>= PEM.foldExpr sym f asm + scopeBoundVars :: SimScope sym arch v -> PPa.PatchPair (SimBoundVars sym arch v) scopeBoundVars scope = PPa.PatchPair (scopeBoundVarsO scope) (scopeBoundVarsP scope) @@ -433,6 +443,9 @@ data SimBoundVars sym arch v bin = SimBoundVars , simBoundVarState :: SimState sym arch v bin } +instance PEM.ExprFoldableF sym (MM.ArchReg arch) => PEM.ExprFoldable sym (SimBoundVars sym arch v bin) where + foldExpr sym f (SimBoundVars regs st) b = PEM.foldExpr sym f (MapF.elems (MM.regStateMap regs)) b >>= PEM.foldExpr sym f st + -- | A value assignment for the bound variables of a 'SimSpec'. These may -- contain arbitrary What4 expressions (e.g. the result of symbolic execution). data SimVars sym arch v bin = SimVars diff --git a/src/Pate/SimulatorRegisters.hs b/src/Pate/SimulatorRegisters.hs index 5cdf2dde..4f2117ed 100644 --- a/src/Pate/SimulatorRegisters.hs +++ b/src/Pate/SimulatorRegisters.hs @@ -151,4 +151,10 @@ instance PEM.ExprFoldable sym (MacawRegEntry sym tp) where CT.StructRepr Ctx.Empty -> return b rep -> error ("foldExpr: unsupported macaw type " ++ show rep) -instance forall sym. PEM.ExprFoldableF sym (MacawRegEntry sym) \ No newline at end of file +instance forall sym. PEM.ExprFoldableF sym (MacawRegVar sym) + +instance PEM.ExprFoldable sym (MacawRegVar sym tp) where + foldExpr sym f (MacawRegVar e vs) b = + PEM.withSymExprFoldable sym $ PEM.foldExpr sym f e b >>= PEM.foldExpr sym f vs + +instance forall sym. PEM.ExprFoldableF sym (MacawRegEntry sym) diff --git a/src/Pate/Verification/FnBindings.hs b/src/Pate/Verification/FnBindings.hs index 3a545571..ab1085bc 100644 --- a/src/Pate/Verification/FnBindings.hs +++ b/src/Pate/Verification/FnBindings.hs @@ -20,6 +20,8 @@ Representation of post-hoc definitions for uninterpreted functions. {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE IncoherentInstances #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeOperators #-} module Pate.Verification.FnBindings ( FnBindings @@ -28,26 +30,32 @@ module Pate.Verification.FnBindings , merge , toScopedPred , toPred + , addUsedFns ) where import Prelude hiding (init) import Control.Monad.Reader import Control.Monad.Trans.State +import Data.Functor.Identity import qualified Data.Parameterized.Context as Ctx import Data.Parameterized.Classes import Data.Parameterized.Some import Data.Parameterized.Map ( MapF ) import qualified Data.Parameterized.Map as MapF +import qualified Data.Set as Set +import Data.Set ( Set ) import qualified What4.Interface as W4 +import qualified What4.Expr.Builder as W4B import qualified Pate.Binary as PBi import qualified Pate.ExprMappable as PEM import qualified Pate.SimState as PS +import qualified Data.Parameterized.TraversableF as TF +import qualified What4.ExprHelpers as WEH - -data BoundFn sym tp = BoundFn (W4.SymFn sym Ctx.EmptyCtx tp) +newtype BoundFn sym tp = BoundFn (W4.SymFn sym Ctx.EmptyCtx tp) -- | By convention we know that a 'BoundFn' is uninterpreted, so it -- can be lifted to the global scope @@ -95,8 +103,13 @@ instance W4.IsSymFn (W4.SymFn sym) => OrdF (BoundFn sym) where -- bindings belong to. Specifically, these functions define the -- semantics for a single-sided transition that may occur in terms -- in the other side of the analysis. -newtype FnBindings sym (bin :: PBi.WhichBinary) (v :: PS.VarScope) = - FnBindings (MapF (BoundFn sym) (PS.PopScope (PS.ScopedExpr sym) v)) +data FnBindings sym (bin :: PBi.WhichBinary) (v :: PS.VarScope) = + FnBindings + { fnBindings :: MapF (BoundFn sym) (PS.PopScope (PS.ScopedExpr sym) v) + , fnBindingsUsed :: Set (Some (BoundFn sym)) + } + + type FnBindingsSpec sym arch = PS.AbsT (PS.SimSpec sym arch) (FnBindings sym) @@ -111,7 +124,7 @@ init :: sym -> f v -> IO (f PS.GlobalScope, FnBindings sym bin v) -init sym e = runStateT (PS.scopedExprMap sym e (mkFreshFns sym)) (FnBindings MapF.empty) +init sym e = runStateT (PS.scopedExprMap sym e (mkFreshFns sym)) (FnBindings MapF.empty Set.empty) mkFreshFns :: W4.IsSymExprBuilder sym => @@ -119,11 +132,11 @@ mkFreshFns :: PS.ScopedExpr sym tp v -> StateT (FnBindings sym bin v) IO (PS.ScopedExpr sym tp PS.GlobalScope) mkFreshFns sym_ e_scoped = do - (PS.PopF fn, e_global) <- lift $ PS.liftScope0Ret sym_ $ \sym -> do + (PS.PopT fn, e_global) <- lift $ PS.liftScope0Ret sym_ $ \sym -> do fn <- W4.freshTotalUninterpFn sym W4.emptySymbol Ctx.empty (W4.exprType (PS.unSE e_scoped)) e' <- W4.applySymFn sym fn Ctx.empty - return (PS.PopF (BoundFn fn), e') - modify $ \(FnBindings binds) -> FnBindings (MapF.insert fn (PS.PopScope e_scoped) binds) + return (PS.PopT (BoundFn fn), e') + modify $ \(FnBindings binds s) -> FnBindings (MapF.insert fn (PS.PopScope e_scoped) binds) s return e_global -- | Merge the two given function bindings, muxing the individual bindings @@ -137,10 +150,10 @@ merge :: FnBindings sym bin v -> FnBindings sym bin v -> IO (FnBindings sym bin v) -merge sym p (FnBindings binds1) (FnBindings binds2) = do - FnBindings <$> MapF.mergeWithKeyM go return return binds1 binds2 - where - go :: forall tp. +merge sym p (FnBindings binds1 s1) (FnBindings binds2 s2) = do + FnBindings <$> MapF.mergeWithKeyM go return return binds1 binds2 <*> (return $ Set.union s1 s2) + where + go :: forall tp. BoundFn sym tp -> PS.PopScope (PS.ScopedExpr sym) v tp -> PS.PopScope (PS.ScopedExpr sym) v tp -> @@ -156,7 +169,7 @@ toScopedPred :: sym -> FnBindings sym bin v -> IO (PS.ScopedExpr sym W4.BaseBoolType v) -toScopedPred sym (FnBindings binds) = do +toScopedPred sym (FnBindings binds _) = do true_ <- PS.liftScope0 sym $ \sym_ -> return $ W4.truePred sym_ MapF.foldlMWithKey go true_ binds where @@ -176,4 +189,26 @@ toPred :: sym -> FnBindings sym bin v -> IO (W4.Pred sym) -toPred sym binds = PS.unSE <$> toScopedPred sym binds \ No newline at end of file +toPred sym binds = PS.unSE <$> toScopedPred sym binds + + + +-- Note we don't require that 'f' has the same scope as +-- the bindings, since we can collect used bindings from any scope +addUsedFns :: + PEM.ExprFoldable sym f => + (W4B.ExprBuilder t st fs ~ sym) => + sym -> + f -> + FnBindings sym bin v -> + FnBindings sym bin v +addUsedFns sym a (FnBindings fns used) = + let + collected = runIdentity $ PEM.foldExpr sym (\e coll -> Identity $ WEH.collectSymFns e coll) a mempty + usedNew = Set.fromList $ filter (\(Some (BoundFn fn)) -> Set.member (Some (W4.SymFnWrapper fn)) (WEH.colSymFns collected)) (MapF.keys fns) + in FnBindings fns (Set.union used usedNew) + + +instance PEM.ExprMappable sym (FnBindings sym bin v) where + mapExpr sym f (FnBindings binds s) = + FnBindings <$> TF.traverseF (\(PS.PopScope se) -> PS.PopScope <$> PEM.mapExpr sym f se) binds <*> return s \ No newline at end of file diff --git a/src/Pate/Verification/PairGraph.hs b/src/Pate/Verification/PairGraph.hs index 3804bc98..e1918be8 100644 --- a/src/Pate/Verification/PairGraph.hs +++ b/src/Pate/Verification/PairGraph.hs @@ -82,11 +82,14 @@ module Pate.Verification.PairGraph , emptyWorkList , SyncData , SyncPoint(..) + , syncData , getSyncData , modifySyncData , syncPoints , syncCutAddresses , syncExceptions + , syncStates + , syncBindings , singleNodeRepr , edgeActions , nodeActions @@ -132,6 +135,7 @@ module Pate.Verification.PairGraph , isSyncNode , queueExitMerges , setPropagationKind + , initFnBindings ) where import Prettyprinter @@ -202,6 +206,8 @@ import qualified Data.Parameterized.SetF as SetF import GHC.Stack (HasCallStack) import Control.Monad.Reader import qualified Data.Parameterized.Context as Ctx +import qualified What4.Expr.Builder as W4B +import qualified What4.Concrete as W4 -- | Gas is used to ensure that our fixpoint computation terminates @@ -445,17 +451,25 @@ data SyncData sym arch = , _syncExceptions :: PPa.PatchPair (SetF (TupleF '(Qu.AsSingle (NodeEntry' arch), PB.BlockTarget arch))) -- Exits from the corresponding desync node that start the single-sided analysis , _syncDesyncExits :: PPa.PatchPair (SetF (PB.BlockTarget arch)) - -- Uninterpreted functions that are used to collect the semantics for - -- variables that the other side of the analysis requires (i.e. in some assertion - -- that was propagated backwards from after a merge point) + -- | A special-purpose assertion that provides bindings for uninterpreted functions + -- representing the semantics of the other side of the analysis at any given sync point. + -- These are created when propagating assertions from sync points back to each single-sided analysis. + -- They are propagated backwards through the single-sided analysis until reaching the divergence point, + -- where they are ultimately discharged by rewriting the uninterpreted functions according to the + -- collected bindings. , _syncBindings :: MapF (SingleNodeEntry arch) (PFn.FnBindingsSpec sym arch) + -- | When a sync point has an assertion that needs to be propagated through the single-sided analysis, + -- it generates a set of uninterpreted functions (implicitly scoped to the program state at the divergence point), + -- that represent the single-sided program state at exactly that sync point. + -- The domain should always be a subset of the sync points. + , _syncStates :: MapF (SingleNodeEntry arch) (PS.SimState sym arch PS.GlobalScope) } -- sync exit point should *always* point to a cut address data SyncPoint arch bin = - SyncAtExit { syncPointNode :: SingleNodeEntry arch bin , _syncPointExit :: SingleNodeEntry arch bin } + SyncAtExit { syncPointNode :: SingleNodeEntry arch bin , _syncPointExit :: SingleNodeEntry arch bin} | SyncAtStart { syncPointNode :: SingleNodeEntry arch bin } deriving (Eq, Ord, Show) @@ -478,6 +492,7 @@ emptySyncData = SyncData (PPa.mkPair PBi.OriginalRepr SetF.empty SetF.empty) (PPa.mkPair PBi.OriginalRepr SetF.empty SetF.empty) MapF.empty + MapF.empty @@ -486,6 +501,18 @@ $(L.makeLenses ''ActionQueue) type ActionQueueLens sym arch k v = L.Lens' (ActionQueue sym arch) (Map k [PendingAction sym arch v]) +-- lifting 'PairGraph' lenses into the monad +getPG :: + L.Lens' (PairGraph sym arch) k -> + PairGraphM sym arch k +getPG lens = (\pg -> pg ^. lens) <$> get + +setPG :: + (k -> k) -> + L.Lens' (PairGraph sym arch) k -> + PairGraphM sym arch () +setPG f lens = modify $ \pg -> pg & lens %~ f + getSyncData :: forall sym arch x bin. HasCallStack => @@ -494,13 +521,7 @@ getSyncData :: PBi.WhichBinaryRepr bin -> GraphNode arch {- ^ The divergent node -} -> PairGraphM sym arch (Set (x bin)) -getSyncData lens bin nd = do - sp <- lookupPairGraph @sym pairGraphSyncData nd - let x = sp ^. lens - -- should be redundant, but no harm in checking - case PPa.get bin x of - Just x' -> return $ SetF.toSet x' - Nothing -> return Set.empty +getSyncData lens bin nd = getPG $ syncDataSet nd bin lens getSingleNodeData :: forall sym arch x bin. @@ -509,10 +530,66 @@ getSingleNodeData :: L.Lens' (SyncData sym arch) (PPa.PatchPair (SetF x)) -> SingleNodeEntry arch bin -> PairGraphM sym arch (Set (x bin)) -getSingleNodeData lens sne = do - let dp = singleNodeDivergePoint sne - let bin = singleEntryBin sne - getSyncData lens bin dp +getSingleNodeData lens sne = + getPG $ syncDataSet (singleNodeDivergePoint sne) (singleEntryBin sne) lens + + +-- | Retrieve the final state that binds the given scope to instead be +-- "globally" scoped (i.e. scoped to the variables at the point of divergence). +-- This is used to represent the uninterpreted transition for the other side of +-- the analysis when going from single-sided to two-sided. +initFnBindings :: + forall sym arch s st fs v bin. + sym ~ W4B.ExprBuilder s st fs => + MM.RegisterInfo (MM.ArchReg arch) => + sym -> + PS.SimScope sym arch v -> + SingleNodeEntry arch bin -> + PairGraph sym arch -> + IO ((PS.SimState sym arch PS.GlobalScope bin, PFn.FnBindings sym bin v), PairGraph sym arch) +initFnBindings sym scope sne pg = do + (PS.PopT st_global, binds) <- PFn.init sym (PS.PopT st) + let pg' = pg & (syncData dp . syncStates) %~ MapF.insert sne st_global + binds' <- case MapF.lookup sne (pg' ^. (syncData dp . syncBindings)) of + Just (PS.AbsT bindsSpec_prev) -> do + (_, binds_prev) <- liftIO $ PS.bindSpec sym (PS.scopeVarsPair scope) bindsSpec_prev + -- bindings cannot clash, since they are fresh, so the mux condition doesn't matter + true_ <- PS.concreteScope sym (W4.ConcreteBool True) + PFn.merge sym true_ binds binds_prev + Nothing -> return binds + let bindsSpec = PS.AbsT $ PS.mkSimSpec scope binds' + return $ ((st_global, binds), pg' & (syncData dp . syncBindings) %~ MapF.insert sne bindsSpec) + where + dp = singleNodeDivergence sne + bin = singleEntryBin sne + + st :: PS.SimState sym arch v bin + st = PS.simVarState $ case bin of + PBi.OriginalRepr -> fst (PS.scopeVarsPair scope) + PBi.PatchedRepr -> snd (PS.scopeVarsPair scope) + +syncData :: + forall sym arch. + GraphNode arch -> + L.Lens' (PairGraph sym arch) (SyncData sym arch) +syncData nd f pg = fmap set_ (f get_) + where + get_ :: SyncData sym arch + get_ = case Map.lookup nd (pairGraphSyncData pg) of + Just sd -> sd + Nothing -> emptySyncData + + set_ :: SyncData sym arch -> PairGraph sym arch + set_ sd = pg { pairGraphSyncData = Map.insert nd sd (pairGraphSyncData pg) } + +syncDataSet :: + forall k sym arch bin. + (OrdF k, Ord (k bin)) => + GraphNode arch -> + PBi.WhichBinaryRepr bin -> + L.Lens' (SyncData sym arch) (PPa.PatchPair (SetF k)) -> + L.Lens' (PairGraph sym arch) (Set (k bin)) +syncDataSet nd bin lens = (syncData nd . lens . PPa.lens bin SetF.empty . SetF.asSet) modifySyncData :: @@ -524,15 +601,7 @@ modifySyncData :: GraphNode arch -> (Set (x bin) -> Set (x bin)) -> PairGraphM sym arch () -modifySyncData lens bin dp f = do - msp <- tryPG $ lookupPairGraph pairGraphSyncData dp - let f' = \x -> SetF.fromSet (f (SetF.toSet x)) - let sp' = case msp of - Nothing -> emptySyncData & lens .~ (PPa.mkSingle bin (f' SetF.empty)) - Just sp -> sp & lens %~ - (\x -> PPa.set bin (f' $ fromMaybe SetF.empty (PPa.get bin x)) x) - modify $ \pg -> - pg { pairGraphSyncData = Map.insert dp sp' (pairGraphSyncData pg)} +modifySyncData lens bin dp f = setPG f $ syncDataSet dp bin lens addToSyncData :: forall sym arch x bin. diff --git a/src/Pate/Verification/StrongestPosts.hs b/src/Pate/Verification/StrongestPosts.hs index d4f7daf4..9ea4bea0 100644 --- a/src/Pate/Verification/StrongestPosts.hs +++ b/src/Pate/Verification/StrongestPosts.hs @@ -29,7 +29,7 @@ import GHC.Stack ( HasCallStack ) import Control.Applicative import qualified Control.Concurrent.MVar as MVar -import Control.Lens ( view, (^.) ) +import Control.Lens ( view, (^.), (&), (%~) ) import Control.Monad (foldM, forM, unless, void, when, guard) import Control.Monad.IO.Class import qualified Control.Monad.IO.Unlift as IO @@ -61,6 +61,7 @@ import qualified Data.Parameterized.TraversableFC as TFC import Data.Parameterized.Nonce import qualified Data.Parameterized.Context as Ctx import qualified Data.Quant as Qu +import qualified Data.Parameterized.Map as MapF import qualified What4.Expr as W4 import qualified What4.Interface as W4 @@ -142,6 +143,7 @@ import qualified What4.Concrete as W4 import Data.Parameterized.PairF (PairF(..)) import qualified What4.Concrete as W4 import Data.Parameterized (Pair(..)) +import qualified Pate.Verification.FnBindings as PFn -- Overall module notes/thoughts -- @@ -653,6 +655,7 @@ handleProcessMerge sneO sneP pg = withPG pg $ do case (getCurrentDomain pg ndO, getCurrentDomain pg ndP) of (Just{}, Just{}) -> do syncNode <- liftEqM $ mergeSingletons sneO sneP + return $ Just $ GraphNode syncNode _ -> do liftPG $ modify $ queueNode (priority PriorityDomainRefresh) divergeNode @@ -701,6 +704,7 @@ workItemDomainSpec wi pg = withPG pg $ case wi of -} mergeSingletons :: + forall sym arch. SingleNodeEntry arch PBi.Original -> SingleNodeEntry arch PBi.Patched -> PairGraph sym arch -> @@ -709,43 +713,53 @@ mergeSingletons sneO sneP pg = fnTrace "mergeSingletons" $ withSym $ \sym -> do let blkO = singleNodeBlock sneO blkP = singleNodeBlock sneP - ndO = GraphNode $ singleToNodeEntry sneO - ndP = GraphNode $ singleToNodeEntry sneP - blkPairO = PPa.PatchPairSingle PBi.OriginalRepr blkO - blkPairP = PPa.PatchPairSingle PBi.PatchedRepr blkP blkPair = PPa.PatchPair blkO blkP syncNodeEntry <- case combineSingleEntries sneO sneP of Just ne -> return ne Nothing -> throwHere $ PEE.IncompatibleSingletonNodes blkO blkP - let syncNode = GraphNode syncNodeEntry + let dp = singleNodeDivergence sneO - specO <- evalPG pg $ getCurrentDomainM ndO - specP <- evalPG pg $ getCurrentDomainM ndP - - pg1 <- fmap (\x -> PS.viewSpecBody x PS.unWS) $ withFreshScope blkPair $ \scope -> fmap PS.WithScope $ - withValidInit scope blkPairO $ withValidInit scope blkPairP $ do - (_, domO) <- liftIO $ PS.bindSpec sym (PS.scopeVarsPair scope) specO - (_, domP) <- liftIO $ PS.bindSpec sym (PS.scopeVarsPair scope) specP - dom <- PAD.zipSingletonDomains sym domO domP - bundle <- noopBundle scope (nodeBlocks syncNodeEntry) - withPredomain scope bundle dom $ do - emitTraceLabel @"domain" PAD.Predomain (Some dom) - let pre_refines = getDomainRefinements syncNode pg - - pg1 <- - withTracing @"node" ndO $ - -- ensure we make any assumptions that have been added to only - -- one side of the analysis - withConditionsAssumed scope bundle dom ndO pg $ - widenAlongEdge scope bundle ndO dom pg syncNode - let pg2 = addDomainRefinements syncNode pre_refines pg1 - withTracing @"node" ndP $ - withConditionsAssumed scope bundle dom ndP pg $ - widenAlongEdge scope bundle ndP dom pg2 syncNode - return (syncNodeEntry, pg1) + let syncNode = GraphNode syncNodeEntry + let snePair = PPa.PatchPair sneO sneP + pg1 <- fmap (\x -> PS.viewSpecBody x PS.unWS) $ withFreshScope blkPair $ \(scope :: PS.SimScope sym arch v) -> fmap PS.WithScope $ do + (bundles, pg') <- mergeBundles scope snePair pg + let pre_refines = getDomainRefinements syncNode pg + + let go :: forall bin. PairGraph sym arch -> SingleNodeEntry arch bin -> EquivM_ sym arch (PairGraph sym arch) + go pg0 sne = do + let bin = singleEntryBin sne + let bin_other = PBi.flipRepr bin + sne_other <- PPa.get bin_other snePair + let nd = GraphNode $ singleToNodeEntry sne + domSpec <- evalPG pg $ getCurrentDomainM nd + (_, dom) <- liftIO $ PS.bindSpec sym (PS.scopeVarsPair scope) domSpec + (SingleBundle bundle binds) <- PPa.get bin bundles + withTracing @"node" nd $ do + emitTraceLabel @"domain" PAD.Predomain (Some dom) + withGraphNode' scope nd bundle dom pg0 $ do + let + collectCondition :: ConditionKind -> PFn.FnBindings sym (PBi.OtherBinary bin) v -> PFn.FnBindings sym (PBi.OtherBinary bin) v + collectCondition condK binds_acc = do + case getCondition pg0 nd condK of + Just condSpec -> PS.viewSpecBody condSpec $ \cond -> PFn.addUsedFns sym cond binds_acc + Nothing -> binds_acc + + pg2 <- propagateCondition scope bundle nd syncNode pg0 >>= \case + Just pg1 -> do + let binds_other = foldr collectCondition binds [minBound .. maxBound] + return $ pg1 & (syncData dp . syncBindings) %~ MapF.insert sne_other (PS.AbsT $ PS.mkSimSpec scope binds_other) + Nothing -> return pg0 + + -- re-apply any refinements that we processed for the other binary + let pg3 = case getDomainRefinements syncNode pg2 of + [] -> addDomainRefinements syncNode pre_refines pg2 + _ -> pg2 + widenAlongEdge scope bundle nd dom pg3 syncNode + TF.foldlMF go pg' snePair + return (syncNodeEntry, pg1) -- | Choose some work item (optionally interactively) withWorkItem :: @@ -1114,6 +1128,30 @@ noopBundle scope pPair = withSym $ \sym -> do return $ SimBundle simIn_ simOut_ +-- | Bundle that transitions from a single-sided analysis to a two-sided analysis. +-- FIXME: do we actually need the bindings here? +data SingleBundle sym arch v bin = SingleBundle + { singleBundle :: SimBundle sym arch v, singleBundleBinds :: PFn.FnBindings sym (PBi.OtherBinary bin) v } + +-- | Similar to 'noopBundle' but produces a pair of bundles, each specialized +-- for the single-sided node to two-sided node +mergeBundles :: + forall sym arch v. + PS.SimScope sym arch v -> + PPa.PatchPair (SingleNodeEntry arch) -> + PairGraph sym arch -> + EquivM sym arch (PPa.PatchPair (SingleBundle sym arch v), PairGraph sym arch) +mergeBundles scope snePair pg = withSym $ \sym -> do + blks <- PPa.forBins $ \bin -> singleNodeBlock <$> PPa.get bin snePair + bundle <- noopBundle scope blks + withPG pg $ do + PPa.forBins $ \bin -> do + let bin_other = PBi.flipRepr bin + sne_other <- PPa.get bin_other snePair + (st_other,binds) <- liftEqM $ \pg_ -> liftIO $ initFnBindings sym scope sne_other pg_ + output <- PPa.get bin_other (simOut bundle) + PS.PopT output' <- return $ PS.fromGlobalScope $ PS.PopT (output { PS.simOutState = st_other }) + return $ SingleBundle (bundle { simOut = PPa.set bin_other output' (simOut bundle) }) binds -- | For a given 'PSR.MacawRegEntry' (representing the initial state of a register) -- and a corresponding 'MAS.AbsValue' (its initial abstract value according to Macaw), diff --git a/src/Pate/Verification/Widening.hs b/src/Pate/Verification/Widening.hs index b434f87b..26b70f5c 100644 --- a/src/Pate/Verification/Widening.hs +++ b/src/Pate/Verification/Widening.hs @@ -34,6 +34,7 @@ module Pate.Verification.Widening , addToEquivCondition , strengthenPredicate , getTraceFootprint + , propagateCondition ) where import GHC.Stack diff --git a/src/What4/ExprHelpers.hs b/src/What4/ExprHelpers.hs index 62921dbb..0b89e4bf 100644 --- a/src/What4/ExprHelpers.hs +++ b/src/What4/ExprHelpers.hs @@ -92,6 +92,8 @@ module What4.ExprHelpers ( , W4SBV.collapseBVOps , bvUMax , bvUMin + , SymFnCollector(..) + , collectSymFns ) where import GHC.TypeNats @@ -618,6 +620,49 @@ boundVars e0 = do newtype ExprFilter sym = ExprFilter (forall tp'. W4.SymExpr sym tp' -> IO Bool) +data SymFnCollector sym = + SymFnCollector + { colSymFns :: Set (Some (W4.SymFnWrapper sym)) + , colVisited :: Set (Some (W4.SymExpr sym)) + } + +instance (OrdF (W4.SymExpr sym), W4.IsSymFn (W4.SymFn sym)) => Semigroup (SymFnCollector sym) where + (SymFnCollector a1 b1) <> (SymFnCollector a2 b2) = SymFnCollector (a1 <> a2) (b1 <> b2) + +instance (OrdF (W4.SymExpr sym), W4.IsSymFn (W4.SymFn sym)) => Monoid (SymFnCollector sym) where + mempty = SymFnCollector mempty mempty + +-- | Collects all functions used anywhere in the given expression. +-- The 'SymFnCollector' caches visited expressions to avoid redundant +-- traversals. +collectSymFns :: + forall sym t st fs tp. + sym ~ W4B.ExprBuilder t st fs => W4B.Expr t tp -> SymFnCollector sym -> SymFnCollector sym +collectSymFns = go + where + goFn :: forall args tp'. W4.SymFn sym args tp' -> SymFnCollector sym -> SymFnCollector sym + goFn fn coll_ = case W4B.symFnInfo fn of + W4B.DefinedFnInfo _ fnBody _ -> go fnBody coll + _ -> coll + where + coll = coll_ { colSymFns = S.insert (Some (W4.SymFnWrapper fn)) (colSymFns coll_) } + + go :: forall tp'. W4.SymExpr sym tp' -> SymFnCollector sym -> SymFnCollector sym + go e coll_ = case e of + W4B.SemiRingLiteral{} -> coll_ + W4B.BoolExpr{} -> coll_ + W4B.FloatExpr{} -> coll_ + W4B.StringExpr{} -> coll_ + W4B.BoundVarExpr{} -> coll_ + _ | S.member (Some e) (colVisited coll_) -> coll_ + W4B.AppExpr a0 -> TFC.foldrFC go coll (W4B.appExprApp a0) + W4B.NonceAppExpr a0 -> case W4B.nonceExprApp a0 of + W4B.FnApp fn args -> TFC.foldrFC go (goFn fn coll) args + W4B.ArrayFromFn fn -> goFn fn coll + napp -> TFC.foldrFC go coll napp + where + coll = coll_ { colVisited = S.insert (Some e) (colVisited coll_) } + -- | Return an 'ExprFilter' that is filters expressions which are bound variables -- that appear somewhere in the given expression. getIsBoundFilter :: diff --git a/src/What4/PredMap.hs b/src/What4/PredMap.hs index fa62b9d9..83129fd3 100644 --- a/src/What4/PredMap.hs +++ b/src/What4/PredMap.hs @@ -41,6 +41,7 @@ module What4.PredMap ( , collapse , predOpUnit , isPredOpUnit + , foldMWithKey ) where import Prelude hiding ( lookup, traverse ) @@ -231,6 +232,14 @@ traverse :: m (PredMap sym f k) traverse pm f = PredMap <$> pure (typeRepr pm) <*> Map.traverseWithKey f (predMap pm) +foldMWithKey :: + Monad m => + PredMap sym f k -> + (f -> W4.Pred sym -> b -> m b) -> + b -> + m b +foldMWithKey (PredMap _ pm) f b = foldM (\b_ (k,v) -> f k v b_) b (Map.toAscList pm) + -- | Alter the key-predicate pairs in a 'PredMap'. -- When any keys are modified, the map is safely rebuilt according -- to the underlying predicate operation in the case of duplicate entries From cd2100cc198e47926c4bbe2c815d3c15e8430d76 Mon Sep 17 00:00:00 2001 From: Daniel Matichuk Date: Wed, 25 Sep 2024 15:40:11 -0700 Subject: [PATCH 03/36] Use BoundVars in FnBindings rather than SymFn to work around grounding issues --- src/Pate/Verification/FnBindings.hs | 26 +++++++-------- src/What4/ExprHelpers.hs | 51 +++++++++++++++++++++++++++++ 2 files changed, 63 insertions(+), 14 deletions(-) diff --git a/src/Pate/Verification/FnBindings.hs b/src/Pate/Verification/FnBindings.hs index ab1085bc..ce4f4e3e 100644 --- a/src/Pate/Verification/FnBindings.hs +++ b/src/Pate/Verification/FnBindings.hs @@ -55,27 +55,26 @@ import qualified Pate.SimState as PS import qualified Data.Parameterized.TraversableF as TF import qualified What4.ExprHelpers as WEH -newtype BoundFn sym tp = BoundFn (W4.SymFn sym Ctx.EmptyCtx tp) +newtype BoundFn sym tp = BoundFn (W4.BoundVar sym tp) -- | By convention we know that a 'BoundFn' is uninterpreted, so it -- can be lifted to the global scope evalBoundFn :: W4.IsSymExprBuilder sym => sym -> - BoundFn sym tp -> + BoundFn sym tp -> IO (PS.ScopedExpr sym tp PS.GlobalScope) -evalBoundFn sym (BoundFn f) = do - e <- W4.applySymFn sym f Ctx.empty - Some e_scoped <- return $ PS.mkScopedExpr e +evalBoundFn sym (BoundFn bv) = do + Some e_scoped <- return $ PS.mkScopedExpr (W4.varExpr sym bv) return $ PS.unsafeCoerceScope e_scoped -instance W4.IsSymFn (W4.SymFn sym) => W4.TestEquality (BoundFn sym) where - testEquality (BoundFn fn1) (BoundFn fn2) = case W4.fnTestEquality fn1 fn2 of +instance W4.IsSymExprBuilder sym => W4.TestEquality (BoundFn sym) where + testEquality (BoundFn fn1) (BoundFn fn2) = case W4.testEquality fn1 fn2 of Just Refl -> Just Refl Nothing -> Nothing -instance W4.IsSymFn (W4.SymFn sym) => OrdF (BoundFn sym) where - compareF (BoundFn fn1) (BoundFn fn2) = case W4.fnCompare fn1 fn2 of +instance W4.IsSymExprBuilder sym => OrdF (BoundFn sym) where + compareF (BoundFn fn1) (BoundFn fn2) = case compareF fn1 fn2 of LTF -> LTF EQF -> EQF GTF -> GTF @@ -133,9 +132,8 @@ mkFreshFns :: StateT (FnBindings sym bin v) IO (PS.ScopedExpr sym tp PS.GlobalScope) mkFreshFns sym_ e_scoped = do (PS.PopT fn, e_global) <- lift $ PS.liftScope0Ret sym_ $ \sym -> do - fn <- W4.freshTotalUninterpFn sym W4.emptySymbol Ctx.empty (W4.exprType (PS.unSE e_scoped)) - e' <- W4.applySymFn sym fn Ctx.empty - return (PS.PopT (BoundFn fn), e') + bv <- W4.freshBoundVar sym W4.emptySymbol (W4.exprType (PS.unSE e_scoped)) + return (PS.PopT (BoundFn bv), W4.varExpr sym bv) modify $ \(FnBindings binds s) -> FnBindings (MapF.insert fn (PS.PopScope e_scoped) binds) s return e_global @@ -204,8 +202,8 @@ addUsedFns :: FnBindings sym bin v addUsedFns sym a (FnBindings fns used) = let - collected = runIdentity $ PEM.foldExpr sym (\e coll -> Identity $ WEH.collectSymFns e coll) a mempty - usedNew = Set.fromList $ filter (\(Some (BoundFn fn)) -> Set.member (Some (W4.SymFnWrapper fn)) (WEH.colSymFns collected)) (MapF.keys fns) + collected = runIdentity $ PEM.foldExpr sym (\e coll -> Identity $ WEH.collectVars e coll) a mempty + usedNew = Set.fromList $ filter (\(Some (BoundFn v)) -> Set.member (Some v) (WEH.colVars collected)) (MapF.keys fns) in FnBindings fns (Set.union used usedNew) diff --git a/src/What4/ExprHelpers.hs b/src/What4/ExprHelpers.hs index 0b89e4bf..a980e883 100644 --- a/src/What4/ExprHelpers.hs +++ b/src/What4/ExprHelpers.hs @@ -94,6 +94,8 @@ module What4.ExprHelpers ( , bvUMin , SymFnCollector(..) , collectSymFns + , VarCollector(..) + , collectVars ) where import GHC.TypeNats @@ -663,6 +665,55 @@ collectSymFns = go where coll = coll_ { colVisited = S.insert (Some e) (colVisited coll_) } + +data VarCollector sym = + VarCollector + { colVars :: Set (Some (W4.BoundVar sym)) + , colVarsVisited :: Set (Some (W4.SymExpr sym)) + } + +instance (OrdF (W4.SymExpr sym), OrdF (W4.BoundVar sym)) => Semigroup (VarCollector sym) where + (VarCollector a1 b1) <> (VarCollector a2 b2) = VarCollector (a1 <> a2) (b1 <> b2) + +instance (OrdF (W4.SymExpr sym), OrdF (W4.BoundVar sym)) => Monoid (VarCollector sym) where + mempty = VarCollector mempty mempty + +-- | Collects all unbound vars used anywhere in the expression. +-- (similar to existing interface function but retains cache). +-- Descends into function definitions, but discards variables scoped to them. +collectVars :: + forall sym t st fs tp. + sym ~ W4B.ExprBuilder t st fs => W4B.Expr t tp -> VarCollector sym -> VarCollector sym +collectVars = go + where + goFn :: forall args tp'. W4.SymFn sym args tp' -> VarCollector sym -> VarCollector sym + goFn fn coll = case W4B.symFnInfo fn of + W4B.DefinedFnInfo args_vars body _ -> + let + coll_body = go body coll + args_vars_set = TFC.foldrFC (\v s -> S.insert (Some v) s) S.empty args_vars + in coll_body { colVars = S.difference (colVars coll_body) args_vars_set } + _ -> coll + + go :: forall tp'. W4.SymExpr sym tp' -> VarCollector sym -> VarCollector sym + go e coll_ = case e of + W4B.SemiRingLiteral{} -> coll_ + W4B.BoolExpr{} -> coll_ + W4B.FloatExpr{} -> coll_ + W4B.StringExpr{} -> coll_ + W4B.BoundVarExpr bv -> coll { colVars = S.insert (Some bv) (colVars coll) } + + _ | S.member (Some e) (colVarsVisited coll_) -> coll_ + W4B.AppExpr a0 -> TFC.foldrFC go coll (W4B.appExprApp a0) + W4B.NonceAppExpr a0 -> case W4B.nonceExprApp a0 of + W4B.FnApp fn args -> TFC.foldrFC go (goFn fn coll) args + W4B.ArrayFromFn fn -> goFn fn coll + napp -> TFC.foldrFC go coll napp + where + coll = coll_ { colVarsVisited = S.insert (Some e) (colVarsVisited coll_) } + + + -- | Return an 'ExprFilter' that is filters expressions which are bound variables -- that appear somewhere in the given expression. getIsBoundFilter :: From 6f3c8bbb37442d1870dbe21e2bd09e58bf04b65a Mon Sep 17 00:00:00 2001 From: Daniel Matichuk Date: Wed, 2 Oct 2024 10:06:49 -0700 Subject: [PATCH 04/36] FnBindings: use bound variables instead of functions this avoids complications with grounding, which doesn't support uninterpreted functions --- src/Pate/SimState.hs | 1 + src/Pate/Verification/FnBindings.hs | 19 +++++++++++++------ 2 files changed, 14 insertions(+), 6 deletions(-) diff --git a/src/Pate/SimState.hs b/src/Pate/SimState.hs index aca34982..da5dd7f5 100644 --- a/src/Pate/SimState.hs +++ b/src/Pate/SimState.hs @@ -102,6 +102,7 @@ import qualified Control.Monad.IO.Class as IO import Control.Lens ( (^.) ) import Control.Monad.Trans.Maybe ( MaybeT(..), runMaybeT ) import Control.Monad.Trans ( lift ) +import Control.Monad ( foldM ) import qualified Prettyprinter as PP diff --git a/src/Pate/Verification/FnBindings.hs b/src/Pate/Verification/FnBindings.hs index ce4f4e3e..d258801e 100644 --- a/src/Pate/Verification/FnBindings.hs +++ b/src/Pate/Verification/FnBindings.hs @@ -55,7 +55,7 @@ import qualified Pate.SimState as PS import qualified Data.Parameterized.TraversableF as TF import qualified What4.ExprHelpers as WEH -newtype BoundFn sym tp = BoundFn (W4.BoundVar sym tp) +newtype BoundFn sym tp = BoundFn (W4.SymExpr sym tp) -- | By convention we know that a 'BoundFn' is uninterpreted, so it -- can be lifted to the global scope @@ -64,8 +64,8 @@ evalBoundFn :: sym -> BoundFn sym tp -> IO (PS.ScopedExpr sym tp PS.GlobalScope) -evalBoundFn sym (BoundFn bv) = do - Some e_scoped <- return $ PS.mkScopedExpr (W4.varExpr sym bv) +evalBoundFn _sym (BoundFn bv) = do + Some e_scoped <- return $ PS.mkScopedExpr bv return $ PS.unsafeCoerceScope e_scoped instance W4.IsSymExprBuilder sym => W4.TestEquality (BoundFn sym) where @@ -132,8 +132,8 @@ mkFreshFns :: StateT (FnBindings sym bin v) IO (PS.ScopedExpr sym tp PS.GlobalScope) mkFreshFns sym_ e_scoped = do (PS.PopT fn, e_global) <- lift $ PS.liftScope0Ret sym_ $ \sym -> do - bv <- W4.freshBoundVar sym W4.emptySymbol (W4.exprType (PS.unSE e_scoped)) - return (PS.PopT (BoundFn bv), W4.varExpr sym bv) + v <- W4.freshConstant sym W4.emptySymbol (W4.exprType (PS.unSE e_scoped)) + return (PS.PopT (BoundFn v), v) modify $ \(FnBindings binds s) -> FnBindings (MapF.insert fn (PS.PopScope e_scoped) binds) s return e_global @@ -194,6 +194,7 @@ toPred sym binds = PS.unSE <$> toScopedPred sym binds -- Note we don't require that 'f' has the same scope as -- the bindings, since we can collect used bindings from any scope addUsedFns :: + forall sym t st fs f bin v. PEM.ExprFoldable sym f => (W4B.ExprBuilder t st fs ~ sym) => sym -> @@ -203,7 +204,13 @@ addUsedFns :: addUsedFns sym a (FnBindings fns used) = let collected = runIdentity $ PEM.foldExpr sym (\e coll -> Identity $ WEH.collectVars e coll) a mempty - usedNew = Set.fromList $ filter (\(Some (BoundFn v)) -> Set.member (Some v) (WEH.colVars collected)) (MapF.keys fns) + + is_boundfn :: Some (BoundFn sym) -> Bool + is_boundfn (Some (BoundFn e)) = case e of + W4B.BoundVarExpr bv -> Set.member (Some bv) (WEH.colVars collected) + _ -> False + + usedNew = Set.fromList $ filter is_boundfn (MapF.keys fns) in FnBindings fns (Set.union used usedNew) From 206e308bc6c7b71ee7fbd26928571ae4dbd83d32 Mon Sep 17 00:00:00 2001 From: Daniel Matichuk Date: Wed, 2 Oct 2024 10:11:34 -0700 Subject: [PATCH 05/36] WIP: handleProcessMerge is over-widening at the moment, see TODO --- src/Pate/Verification/StrongestPosts.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/Pate/Verification/StrongestPosts.hs b/src/Pate/Verification/StrongestPosts.hs index 9ea4bea0..499ff001 100644 --- a/src/Pate/Verification/StrongestPosts.hs +++ b/src/Pate/Verification/StrongestPosts.hs @@ -728,6 +728,13 @@ mergeSingletons sneO sneP pg = fnTrace "mergeSingletons" $ withSym $ \sym -> do (bundles, pg') <- mergeBundles scope snePair pg let pre_refines = getDomainRefinements syncNode pg + --TODO: this isn't quite right, because the transition from single to two sided analysis immediately + -- results in everything getting dumped from the equivalence domain (since the "other" single-sided state + -- has now changed arbitrarily) + -- We need to give an interpretation for this state via the other side of the analysis, which means we + -- need to include both the original and patched pre-domains (and corresponding assumptions about the + -- uninterpreted functions) when widening both sides + let go :: forall bin. PairGraph sym arch -> SingleNodeEntry arch bin -> EquivM_ sym arch (PairGraph sym arch) go pg0 sne = do let bin = singleEntryBin sne From 0af3e981c7f0383ce1db53e88cca2ab6aa1a4639 Mon Sep 17 00:00:00 2001 From: Daniel Matichuk Date: Thu, 31 Oct 2024 14:48:38 -0700 Subject: [PATCH 06/36] FnBindings: don't generate uninterpreted functions for concrete values this avoids edge cases where the globally-scoped value contains fresh variables for values that should always be concrete (e.g. registers that are necessarily bitvectors) --- src/Pate/Verification/FnBindings.hs | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) diff --git a/src/Pate/Verification/FnBindings.hs b/src/Pate/Verification/FnBindings.hs index d258801e..40b30467 100644 --- a/src/Pate/Verification/FnBindings.hs +++ b/src/Pate/Verification/FnBindings.hs @@ -114,8 +114,9 @@ type FnBindingsSpec sym arch = PS.AbsT (PS.SimSpec sym arch) (FnBindings sym) instance PS.Scoped (FnBindings sym bin) --- | Transform the given value to be globally-scoped by replacing its internal expressions --- with uninterpreted functions +-- | Transform the given value to be globally-scoped by replacing its internal symbolic expressions +-- with uninterpreted functions. Concrete expressions are left unmodified as they are +-- valid in any scope. init :: W4.IsSymExprBuilder sym => PS.Scoped f => @@ -130,12 +131,14 @@ mkFreshFns :: sym -> PS.ScopedExpr sym tp v -> StateT (FnBindings sym bin v) IO (PS.ScopedExpr sym tp PS.GlobalScope) -mkFreshFns sym_ e_scoped = do - (PS.PopT fn, e_global) <- lift $ PS.liftScope0Ret sym_ $ \sym -> do - v <- W4.freshConstant sym W4.emptySymbol (W4.exprType (PS.unSE e_scoped)) - return (PS.PopT (BoundFn v), v) - modify $ \(FnBindings binds s) -> FnBindings (MapF.insert fn (PS.PopScope e_scoped) binds) s - return e_global +mkFreshFns sym_ e_scoped = case W4.asConcrete (PS.unSE e_scoped) of + Just c -> lift $ PS.concreteScope sym_ c + Nothing -> do + (PS.PopT fn, e_global) <- lift $ PS.liftScope0Ret sym_ $ \sym -> do + v <- W4.freshConstant sym W4.emptySymbol (W4.exprType (PS.unSE e_scoped)) + return (PS.PopT (BoundFn v), v) + modify $ \(FnBindings binds s) -> FnBindings (MapF.insert fn (PS.PopScope e_scoped) binds) s + return e_global -- | Merge the two given function bindings, muxing the individual bindings -- with the given predicate (i.e. path condition) in the case of From e3df8b8c5313489ff6d87c62cf802ce90fd35b22 Mon Sep 17 00:00:00 2001 From: Daniel Matichuk Date: Thu, 31 Oct 2024 15:01:04 -0700 Subject: [PATCH 07/36] drop implicit SimSpec wrapping from 'withFreshScope' this is just for convenience, since every usage of 'withFreshScope' worked around the wrapping --- src/Pate/Monad.hs | 7 +++---- src/Pate/Verification/StrongestPosts.hs | 6 +++--- src/Pate/Verification/Widening.hs | 4 ++-- 3 files changed, 8 insertions(+), 9 deletions(-) diff --git a/src/Pate/Monad.hs b/src/Pate/Monad.hs index 726569b3..948283a1 100644 --- a/src/Pate/Monad.hs +++ b/src/Pate/Monad.hs @@ -654,14 +654,13 @@ currentAsm = CMR.asks envCurrentFrame withFreshScope :: forall sym arch f. - Scoped f => PB.BlockPair arch -> - (forall v. SimScope sym arch v -> EquivM sym arch (f v)) -> - EquivM sym arch (SimSpec sym arch f) + (forall v. SimScope sym arch v -> EquivM sym arch f) -> + EquivM sym arch f withFreshScope bPair f = do dummy_spec <- withFreshVars @sym @arch @(WithScope ()) bPair $ \_ -> do return (mempty, WithScope ()) - forSpec dummy_spec $ \scope _ -> f scope + fmap (\x -> viewSpecBody x unWS) $ forSpec dummy_spec $ \scope _ -> WithScope <$> f scope -- | Create a new 'SimSpec' by evaluating the given function under a fresh set -- of bound variables. The returned 'AssumptionSet' is set as the assumption diff --git a/src/Pate/Verification/StrongestPosts.hs b/src/Pate/Verification/StrongestPosts.hs index 499ff001..96ee99fe 100644 --- a/src/Pate/Verification/StrongestPosts.hs +++ b/src/Pate/Verification/StrongestPosts.hs @@ -724,7 +724,8 @@ mergeSingletons sneO sneP pg = fnTrace "mergeSingletons" $ withSym $ \sym -> do let syncNode = GraphNode syncNodeEntry let snePair = PPa.PatchPair sneO sneP - pg1 <- fmap (\x -> PS.viewSpecBody x PS.unWS) $ withFreshScope blkPair $ \(scope :: PS.SimScope sym arch v) -> fmap PS.WithScope $ do + + pg1 <- withFreshScope blkPair $ \(scope :: PS.SimScope sym arch v) -> do (bundles, pg') <- mergeBundles scope snePair pg let pre_refines = getDomainRefinements syncNode pg @@ -952,7 +953,7 @@ showFinalResult pg0 = withTracing @"final_result" () $ withSym $ \sym -> do Nothing -> return rs Nothing -> case getCondition pg nd ConditionEquiv of Just cond_spec -> subTrace nd $ withSym $ \sym -> do - spec <- withFreshScope (graphNodeBlocks nd) $ \scope -> fmap PS.WithScope $ do + withFreshScope (graphNodeBlocks nd) $ \scope -> do (_,cond) <- IO.liftIO $ PS.bindSpec sym (PS.scopeVarsPair scope) cond_spec fmap fst $ withGraphNode scope nd pg $ \bundle d -> do cond_simplified <- PSi.applySimpStrategy PSi.deepPredicateSimplifier cond @@ -965,7 +966,6 @@ showFinalResult pg0 = withTracing @"final_result" () $ withSym $ \sym -> do rest scope ieqc >>= \case Just fcond -> return (rs { eqCondFinals = Map.insert nd fcond (eqCondFinals rs), eqCondInterims = interims }, pg) Nothing -> return (rs { eqCondInterims = interims }, pg) - return $ PS.viewSpecBody spec PS.unWS Nothing -> return rs go :: EqCondCollector sym arch -> EquivM sym arch (EqCondCollector sym arch) diff --git a/src/Pate/Verification/Widening.hs b/src/Pate/Verification/Widening.hs index 26b70f5c..c28b7022 100644 --- a/src/Pate/Verification/Widening.hs +++ b/src/Pate/Verification/Widening.hs @@ -799,7 +799,7 @@ isEqCondSingleSided scope blks bin eqCond = withSym $ \sym -> do goalTimeout <- CMR.asks (PC.cfgGoalTimeout . envConfig) -- rewrite the free variables for the other binary into arbitrary (free) terms and -- determine if the resulting predicate is equal to the original - fmap (\x -> PS.viewSpecBody x PS.unWS) $ withFreshScope blks $ \(scope2 :: PS.SimScope sym arch v2) -> do + withFreshScope blks $ \(scope2 :: PS.SimScope sym arch v2) -> do (this_vars :: PS.SimVars sym arch v2 bin) <- PPa.get bin (PS.scopeVars (PS.unsafeCoerceScope scope)) (vars2 :: PS.SimVars sym arch v2 (PBi.OtherBinary bin)) <- PPa.get (PBi.flipRepr bin) (PS.scopeVars scope2) @@ -809,7 +809,7 @@ isEqCondSingleSided scope blks bin eqCond = withSym $ \sym -> do eqCond_pred <- PEC.toPred sym eqCond eqCond2_pred <- PEC.toPred sym eqCond2 conds_eq <- liftIO $ W4.isEq sym eqCond_pred eqCond2_pred - PS.WithScope <$> isPredTrue' goalTimeout conds_eq + isPredTrue' goalTimeout conds_eq From 92813a6cb5fa2971abd1958261ef7664942a1ed9 Mon Sep 17 00:00:00 2001 From: Daniel Matichuk Date: Thu, 31 Oct 2024 15:23:55 -0700 Subject: [PATCH 08/36] remove deprecaded 'scopeAsm' field from 'SimScope' --- src/Pate/Monad.hs | 7 ++- src/Pate/Monad/PairGraph.hs | 11 ++--- src/Pate/SimState.hs | 20 ++++---- src/Pate/Verification/PairGraph.hs | 2 +- src/Pate/Verification/StrongestPosts.hs | 15 +++--- src/Pate/Verification/Widening.hs | 63 ++++++++++++------------- 6 files changed, 53 insertions(+), 65 deletions(-) diff --git a/src/Pate/Monad.hs b/src/Pate/Monad.hs index 948283a1..1b1c5a26 100644 --- a/src/Pate/Monad.hs +++ b/src/Pate/Monad.hs @@ -613,8 +613,7 @@ withSimSpec :: EquivM sym arch (SimSpec sym arch g) withSimSpec blocks spec f = withSym $ \sym -> do spec_fresh <- withFreshVars blocks $ \vars -> liftIO $ bindSpec sym vars spec - forSpec spec_fresh $ \scope body -> - withAssumptionSet (scopeAsm scope) (f scope body) + forSpec spec_fresh $ \scope body -> (f scope body) lookupArgumentNamesSingle :: PBi.WhichBinaryRepr bin @@ -659,7 +658,7 @@ withFreshScope :: EquivM sym arch f withFreshScope bPair f = do dummy_spec <- withFreshVars @sym @arch @(WithScope ()) bPair $ \_ -> do - return (mempty, WithScope ()) + return (WithScope ()) fmap (\x -> viewSpecBody x unWS) $ forSpec dummy_spec $ \scope _ -> WithScope <$> f scope -- | Create a new 'SimSpec' by evaluating the given function under a fresh set @@ -669,7 +668,7 @@ withFreshVars :: forall sym arch f. Scoped f => PB.BlockPair arch -> - (forall v. (SimVars sym arch v PBi.Original, SimVars sym arch v PBi.Patched) -> EquivM sym arch (AssumptionSet sym,(f v))) -> + (forall v. (SimVars sym arch v PBi.Original, SimVars sym arch v PBi.Patched) -> EquivM sym arch (f v)) -> EquivM sym arch (SimSpec sym arch f) withFreshVars blocks f = do argNames <- lookupArgumentNames blocks diff --git a/src/Pate/Monad/PairGraph.hs b/src/Pate/Monad/PairGraph.hs index 45933c10..a83879a3 100644 --- a/src/Pate/Monad/PairGraph.hs +++ b/src/Pate/Monad/PairGraph.hs @@ -205,14 +205,11 @@ initialDomainSpec :: GraphNode arch -> EquivM sym arch (PAD.AbstractDomainSpec sym arch) initialDomainSpec (GraphNodeEntry blocks) = withTracing @"function_name" "initialDomainSpec" $ - withFreshVars blocks $ \_vars -> do - dom <- initialDomain - return (mempty, dom) + withFreshVars blocks $ \_vars -> initialDomain initialDomainSpec (GraphNodeReturn fPair) = withTracing @"function_name" "initialDomainSpec" $ do let blocks = PPa.map PB.functionEntryToConcreteBlock fPair - withFreshVars blocks $ \_vars -> do - dom <- initialDomain - return (mempty, dom) + withFreshVars blocks $ \_vars -> initialDomain + getScopedCondition :: PS.SimScope sym arch v -> @@ -222,7 +219,7 @@ getScopedCondition :: EquivM sym arch (PEC.EquivalenceCondition sym arch v) getScopedCondition scope pg nd condK = withSym $ \sym -> case getCondition pg nd condK of Just condSpec -> do - (_, eqCond) <- liftIO $ PS.bindSpec sym (PS.scopeVarsPair scope) condSpec + eqCond <- liftIO $ PS.bindSpec sym (PS.scopeVarsPair scope) condSpec return eqCond Nothing -> return $ PEC.universal sym diff --git a/src/Pate/SimState.hs b/src/Pate/SimState.hs index da5dd7f5..95b680e1 100644 --- a/src/Pate/SimState.hs +++ b/src/Pate/SimState.hs @@ -45,7 +45,6 @@ module Pate.SimState , type VarScope , type GlobalScope , SimScope - , scopeAsm , scopeVars , scopeVarsPair , Scoped(..) @@ -295,15 +294,14 @@ data SimScope sym arch v = -- variables for both binaries scopeBoundVarsO :: SimBoundVars sym arch v PBi.Original , scopeBoundVarsP :: SimBoundVars sym arch v PBi.Patched - , scopeAsm :: AssumptionSet sym } instance Scoped (SimScope sym arch) instance Scoped (Const x) instance PEM.ExprFoldableF sym (MM.ArchReg arch) => PEM.ExprFoldable sym (SimScope sym arch v) where - foldExpr sym f (SimScope varsO varsP asm) b = - PEM.foldExpr sym f varsO b >>= PEM.foldExpr sym f varsP >>= PEM.foldExpr sym f asm + foldExpr sym f (SimScope varsO varsP) b = + PEM.foldExpr sym f varsO b >>= PEM.foldExpr sym f varsP scopeBoundVars :: SimScope sym arch v -> PPa.PatchPair (SimBoundVars sym arch v) scopeBoundVars scope = PPa.PatchPair (scopeBoundVarsO scope) (scopeBoundVarsP scope) @@ -331,7 +329,7 @@ freshSimSpec :: -- | Fresh base region (forall bin v. PBi.WhichBinaryRepr bin -> m (ScopedExpr sym W4.BaseIntegerType v)) -> -- | Produce the body of the 'SimSpec' given the initial variables - (forall v. (SimVars sym arch v PBi.Original, SimVars sym arch v PBi.Patched) -> m (AssumptionSet sym, (f v))) -> + (forall v. (SimVars sym arch v PBi.Original, SimVars sym arch v PBi.Patched) -> m (f v)) -> m (SimSpec sym arch f) freshSimSpec mkReg mkMem mkStackBase mkMaxregion mkBody = do vars <- PPa.forBins $ \bin -> do @@ -342,8 +340,8 @@ freshSimSpec mkReg mkMem mkStackBase mkMaxregion mkBody = do mr <- mkMaxregion bin return $ SimBoundVars regs (SimState mem (MM.mapRegsWith (\_ -> PSR.macawVarEntry) regs) sb scb mr) (varsO, varsP) <- PPa.asTuple vars - (asm, body) <- mkBody (boundVarsAsFree varsO, boundVarsAsFree varsP) - return $ SimSpec (SimScope varsO varsP asm) body + body <- mkBody (boundVarsAsFree varsO, boundVarsAsFree varsP) + return $ SimSpec (SimScope varsO varsP) body -- | Project out the body with an arbitrary scope. viewSpecBody :: @@ -762,12 +760,10 @@ bindSpec :: (SimVars sym arch v PBi.Original, SimVars sym arch v PBi.Patched) -> SimSpec sym arch f -> - IO (AssumptionSet sym, f v) -bindSpec sym vals (SimSpec scope@(SimScope _ _ asm) (body :: f v')) = do + IO (f v) +bindSpec sym vals (SimSpec scope@(SimScope _ _) (body :: f v')) = do rew <- getScopeCoercion sym scope vals - body' <- scopedExprMap sym body (applyScopeCoercion sym rew) - asm' <- unWS <$> scopedExprMap sym (WithScope @_ @v' asm) (applyScopeCoercion sym rew) - return $ (asm', body') + scopedExprMap sym body (applyScopeCoercion sym rew) ------------------------------------ diff --git a/src/Pate/Verification/PairGraph.hs b/src/Pate/Verification/PairGraph.hs index e1918be8..fdc48dac 100644 --- a/src/Pate/Verification/PairGraph.hs +++ b/src/Pate/Verification/PairGraph.hs @@ -552,7 +552,7 @@ initFnBindings sym scope sne pg = do let pg' = pg & (syncData dp . syncStates) %~ MapF.insert sne st_global binds' <- case MapF.lookup sne (pg' ^. (syncData dp . syncBindings)) of Just (PS.AbsT bindsSpec_prev) -> do - (_, binds_prev) <- liftIO $ PS.bindSpec sym (PS.scopeVarsPair scope) bindsSpec_prev + binds_prev <- liftIO $ PS.bindSpec sym (PS.scopeVarsPair scope) bindsSpec_prev -- bindings cannot clash, since they are fresh, so the mux condition doesn't matter true_ <- PS.concreteScope sym (W4.ConcreteBool True) PFn.merge sym true_ binds binds_prev diff --git a/src/Pate/Verification/StrongestPosts.hs b/src/Pate/Verification/StrongestPosts.hs index 96ee99fe..aaf309c7 100644 --- a/src/Pate/Verification/StrongestPosts.hs +++ b/src/Pate/Verification/StrongestPosts.hs @@ -743,7 +743,7 @@ mergeSingletons sneO sneP pg = fnTrace "mergeSingletons" $ withSym $ \sym -> do sne_other <- PPa.get bin_other snePair let nd = GraphNode $ singleToNodeEntry sne domSpec <- evalPG pg $ getCurrentDomainM nd - (_, dom) <- liftIO $ PS.bindSpec sym (PS.scopeVarsPair scope) domSpec + dom <- liftIO $ PS.bindSpec sym (PS.scopeVarsPair scope) domSpec (SingleBundle bundle binds) <- PPa.get bin bundles withTracing @"node" nd $ do emitTraceLabel @"domain" PAD.Predomain (Some dom) @@ -850,11 +850,10 @@ pairGraphComputeFixpoint entries gr_init = do d' <- asks (PCfg.cfgStackScopeAssume . envConfig) >>= \case True -> strengthenStackDomain scope d False -> return d - withAssumptionSet (PS.scopeAsm scope) $ do - gr2 <- addRefinementChoice nd gr1 - gr3 <- visitNode scope wi d' gr2 - emitEvent $ PE.VisitedNode nd - return gr3 + gr2 <- addRefinementChoice nd gr1 + gr3 <- visitNode scope wi d' gr2 + emitEvent $ PE.VisitedNode nd + return gr3 case mgr4 of Just gr4 -> go gr4 Nothing -> return gr0 @@ -954,7 +953,7 @@ showFinalResult pg0 = withTracing @"final_result" () $ withSym $ \sym -> do Nothing -> case getCondition pg nd ConditionEquiv of Just cond_spec -> subTrace nd $ withSym $ \sym -> do withFreshScope (graphNodeBlocks nd) $ \scope -> do - (_,cond) <- IO.liftIO $ PS.bindSpec sym (PS.scopeVarsPair scope) cond_spec + cond <- IO.liftIO $ PS.bindSpec sym (PS.scopeVarsPair scope) cond_spec fmap fst $ withGraphNode scope nd pg $ \bundle d -> do cond_simplified <- PSi.applySimpStrategy PSi.deepPredicateSimplifier cond eqCond_pred <- PEC.toPred sym cond_simplified @@ -1065,7 +1064,7 @@ withGraphNode scope nd pg f = withSym $ \sym -> do Nothing | GraphNode ne <- nd -> throwHere $ PEE.MissingDomainForBlock (nodeBlocks ne) Nothing | ReturnNode nr <- nd -> throwHere $ PEE.MissingDomainForFun (nodeFuns nr) Just dom_spec -> do - (_, d) <- liftIO $ PS.bindSpec sym (PS.scopeVarsPair scope) dom_spec + d <- liftIO $ PS.bindSpec sym (PS.scopeVarsPair scope) dom_spec case nd of GraphNode ne -> withAbsDomain ne d pg $ withValidInit scope (nodeBlocks ne) $ withSimBundle pg (PS.scopeVars scope) ne $ \bundle -> diff --git a/src/Pate/Verification/Widening.hs b/src/Pate/Verification/Widening.hs index c28b7022..b5ef3b74 100644 --- a/src/Pate/Verification/Widening.hs +++ b/src/Pate/Verification/Widening.hs @@ -177,9 +177,7 @@ getEquivPostCondition scope bundle to condK gr = withSym $ \sym -> do -- this condition is *implied* by the 'from' equivalence condition and equivalence domain let outVars = PS.bundleOutVars scope bundle case getCondition gr to condK of - Just condSpec -> do - (_asm, cond) <- liftIO $ PS.bindSpec sym outVars condSpec - return cond + Just condSpec -> liftIO $ PS.bindSpec sym outVars condSpec Nothing -> return $ PEC.universal sym extractPtrs :: @@ -427,7 +425,7 @@ addRefinementChoice nd gr0 = withTracing @"message" ("Modify Proof Node: " ++ sh env <- CMR.ask let conds = Map.fromList $ mapMaybe (\condK -> case getCondition gr2 nd condK of {Just eqSpec -> Just (condK, eqSpec); Nothing -> Nothing}) [minBound..maxBound] - conds' <- mapM (\spec -> snd <$> (liftIO $ PS.bindSpec sym (PS.scopeVarsPair scope) spec)) conds + conds' <- mapM (\spec -> (liftIO $ PS.bindSpec sym (PS.scopeVarsPair scope) spec)) conds let b = InteractiveBundle scope bundle nd gr2 d conds' env -- TODO: allow updates here emitTrace @"interactiveBundle" b @@ -435,7 +433,7 @@ addRefinementChoice nd gr0 = withTracing @"message" ("Modify Proof Node: " ++ sh choice "Strengthen conditions" $ \(TupleF3 scope bundle d) gr2 -> withSym $ \sym -> do let go condK gr0_ = case getCondition gr0_ nd condK of Just eqCondSpec -> withTracing @"message" (conditionName condK) $ withSym $ \sym -> do - (_, eqCond) <- liftIO $ PS.bindSpec sym (PS.scopeVarsPair scope) eqCondSpec + eqCond <- liftIO $ PS.bindSpec sym (PS.scopeVarsPair scope) eqCondSpec eqCond' <- strengthenCondition eqCond priority <- thisPriority let propK = getPropagationKind gr0_ nd condK @@ -446,7 +444,7 @@ addRefinementChoice nd gr0 = withTracing @"message" ("Modify Proof Node: " ++ sh choice "Simplify conditions" $ \(TupleF3 scope _bundle _) gr2 -> do let go condK gr0_ = case getCondition gr0_ nd condK of Just eqCondSpec -> withTracing @"message" (conditionName condK) $ withSym $ \sym -> do - (_, eqCond) <- liftIO $ PS.bindSpec sym (PS.scopeVarsPair scope) eqCondSpec + eqCond <- liftIO $ PS.bindSpec sym (PS.scopeVarsPair scope) eqCondSpec eqCond_pred <- PEC.toPred sym eqCond emitTraceLabel @"eqcond" (PEE.someExpr sym eqCond_pred) (Some eqCond) meqCond_pred' <- isPredTrue' goalTimeout eqCond_pred >>= \case @@ -990,33 +988,32 @@ widenAlongEdge scope bundle from d gr0 to = withSym $ \sym -> do -- values of the slice again. This is accomplised by 'abstractOverVars', which -- produces the final 'AbstractDomainSpec' that has been fully abstracted away -- from the current scope and can be stored as the updated domain in the 'PairGraph' - (asm, d') <- liftIO $ PS.bindSpec sym (PS.bundleOutVars scope bundle) postSpec - withAssumptionSet asm $ do - md <- widenPostcondition scope bundle d d' - case md of - NoWideningRequired -> - do traceBundle bundle "Did not need to widen" - emitTraceLabel @"domain" PAD.Postdomain (Some d') - finalizeGraphEdge scope bundle d d' from to gr - - WideningError msg _ d'' -> - do let msg' = ("Error during widening: " ++ msg) - err <- emitError' (PEE.WideningError msg') - postSpec' <- abstractOverVars scope bundle from to postSpec d'' - case updateDomain gr from to postSpec' (priority PriorityWidening) of - Left gr' -> - do traceBundle bundle ("Ran out of gas while widening postconditon! " ++ show from ++ " " ++ show to) - return $ recordMiscAnalysisError gr' to err - Right gr' -> return $ recordMiscAnalysisError gr' to err - - Widen _ _ d'' -> do - emitTraceLabel @"domain" PAD.Postdomain (Some d'') - postSpec' <- abstractOverVars scope bundle from to postSpec d'' - case updateDomain gr from to postSpec' (priority PriorityWidening) of - Left gr' -> do - do traceBundle bundle ("Ran out of gas while widening postconditon! " ++ show from ++ " " ++ show to) - finalizeGraphEdge scope bundle d d'' from to gr' - Right gr' -> finalizeGraphEdge scope bundle d d'' from to gr' + d' <- liftIO $ PS.bindSpec sym (PS.bundleOutVars scope bundle) postSpec + md <- widenPostcondition scope bundle d d' + case md of + NoWideningRequired -> do + traceBundle bundle "Did not need to widen" + emitTraceLabel @"domain" PAD.Postdomain (Some d') + finalizeGraphEdge scope bundle d d' from to gr + + WideningError msg _ d'' -> do + let msg' = ("Error during widening: " ++ msg) + err <- emitError' (PEE.WideningError msg') + postSpec' <- abstractOverVars scope bundle from to postSpec d'' + case updateDomain gr from to postSpec' (priority PriorityWidening) of + Left gr' -> do + traceBundle bundle ("Ran out of gas while widening postconditon! " ++ show from ++ " " ++ show to) + return $ recordMiscAnalysisError gr' to err + Right gr' -> return $ recordMiscAnalysisError gr' to err + + Widen _ _ d'' -> do + emitTraceLabel @"domain" PAD.Postdomain (Some d'') + postSpec' <- abstractOverVars scope bundle from to postSpec d'' + case updateDomain gr from to postSpec' (priority PriorityWidening) of + Left gr' -> do + traceBundle bundle ("Ran out of gas while widening postconditon! " ++ show from ++ " " ++ show to) + finalizeGraphEdge scope bundle d d'' from to gr' + Right gr' -> finalizeGraphEdge scope bundle d d'' from to gr' finalizeGraphEdge :: From 45e49baea8eb5986eb232105f1d06a66dc20ce8c Mon Sep 17 00:00:00 2001 From: Daniel Matichuk Date: Wed, 6 Nov 2024 11:14:38 -0800 Subject: [PATCH 09/36] add "composite" scopes to handle mixing variables from scopes --- src/Pate/SimState.hs | 34 ++++++++++++++++++++++++++++++++++ 1 file changed, 34 insertions(+) diff --git a/src/Pate/SimState.hs b/src/Pate/SimState.hs index 95b680e1..29b2b07d 100644 --- a/src/Pate/SimState.hs +++ b/src/Pate/SimState.hs @@ -45,6 +45,8 @@ module Pate.SimState , type VarScope , type GlobalScope , SimScope + , CompositeScope + , compositeScopeCases , scopeVars , scopeVarsPair , Scoped(..) @@ -220,10 +222,42 @@ simOutRegs = simRegs . simOutState -- ensure that the resulting value is well-scoped. data VarScope = GlobalScope {- ^ scope for terms with no bound variables -} + | CompositeScopeC VarScope VarScope {- ^ scope that combines variables from two scopes: one for original variables and one for patched -} | ArbitraryScope DK.Type {- ^ all other scopes (this constructor is not actually used) -} +-- Similar to 'CompositeScopeC' but takes a 'bin' parameter to indicate which variables should be taken from +-- each scope. +type family CompositeScope (bin :: PBi.WhichBinary) (v1 :: VarScope) (v2 :: VarScope) :: VarScope +type instance CompositeScope PBi.Original v1 v2 = + CompositeScopeC v1 v2 +type instance CompositeScope PBi.Patched v1 v2 = + CompositeScopeC v2 v1 + type GlobalScope = 'GlobalScope +compositeScope :: + forall sym arch v1 v2 a. + SimScope sym arch v1 -> + SimScope sym arch v2 -> + ( SimScope sym arch (CompositeScopeC v1 v2) -> + SimScope sym arch (CompositeScopeC v2 v1) -> + a) -> a +compositeScope (SimScope v1O v1P) (SimScope v2O v2P) f = + f (coerce (SimScope (coerce v1O) v2P)) (coerce (SimScope (coerce v2O) v1P)) + +compositeScopeCases :: + forall sym arch v1 v2 m a. + Monad m => + SimScope sym arch v1 -> + SimScope sym arch v2 -> + (forall bin. + PBi.WhichBinaryRepr bin -> + SimScope sym arch (CompositeScope bin v1 v2) -> + m (a bin)) -> m (PPa.PatchPair a) +compositeScopeCases scope1 scope2 f = compositeScope scope1 scope2 $ \scope1' scope2' -> do + aO <- f PBi.OriginalRepr scope1' + aP <- f PBi.PatchedRepr scope2' + return $ PPa.PatchPair aO aP -- | A 'Scoped' type is parameterized by a phantom 'VarScope' type variable, used From d688d9ee572797856854ac86b9cd90080aff4653 Mon Sep 17 00:00:00 2001 From: Daniel Matichuk Date: Wed, 6 Nov 2024 11:18:55 -0800 Subject: [PATCH 10/36] WIP: rework control flow merge logic to use mixed scopes --- src/Pate/Verification/PairGraph.hs | 47 +++++-- src/Pate/Verification/StrongestPosts.hs | 161 ++++++++++++++---------- src/Pate/Verification/Widening.hs | 116 ++++++++--------- 3 files changed, 188 insertions(+), 136 deletions(-) diff --git a/src/Pate/Verification/PairGraph.hs b/src/Pate/Verification/PairGraph.hs index fdc48dac..429f3e86 100644 --- a/src/Pate/Verification/PairGraph.hs +++ b/src/Pate/Verification/PairGraph.hs @@ -136,6 +136,7 @@ module Pate.Verification.PairGraph , queueExitMerges , setPropagationKind , initFnBindings + , addFnBindings ) where import Prettyprinter @@ -533,6 +534,26 @@ getSingleNodeData :: getSingleNodeData lens sne = getPG $ syncDataSet (singleNodeDivergePoint sne) (singleEntryBin sne) lens +addFnBindings :: + sym ~ W4B.ExprBuilder s st fs => + PA.ValidArch arch => + sym -> + PS.SimScope sym arch v -> + SingleNodeEntry arch bin -> + PFn.FnBindings sym bin v -> + PairGraph sym arch -> + IO (PFn.FnBindings sym bin v, PairGraph sym arch) +addFnBindings sym scope sne binds pg = case MapF.lookup sne (pg ^. (syncData dp . syncBindings)) of + Just (PS.AbsT bindsSpec_prev) -> do + binds_prev <- liftIO $ PS.bindSpec sym (PS.scopeVarsPair scope) bindsSpec_prev + -- FIXME: check for clashes? + true_ <- PS.concreteScope sym (W4.ConcreteBool True) + binds' <- PFn.merge sym true_ binds binds_prev + return $ (binds', pg & (syncData dp . syncBindings) %~ MapF.insert sne (PS.AbsT $ PS.mkSimSpec scope binds')) + Nothing -> return $ (binds, pg & (syncData dp . syncBindings) %~ MapF.insert sne (PS.AbsT $ PS.mkSimSpec scope binds)) + where + dp = singleNodeDivergence sne + -- | Retrieve the final state that binds the given scope to instead be -- "globally" scoped (i.e. scoped to the variables at the point of divergence). @@ -541,24 +562,26 @@ getSingleNodeData lens sne = initFnBindings :: forall sym arch s st fs v bin. sym ~ W4B.ExprBuilder s st fs => - MM.RegisterInfo (MM.ArchReg arch) => + PA.ValidArch arch => sym -> PS.SimScope sym arch v -> SingleNodeEntry arch bin -> PairGraph sym arch -> IO ((PS.SimState sym arch PS.GlobalScope bin, PFn.FnBindings sym bin v), PairGraph sym arch) initFnBindings sym scope sne pg = do - (PS.PopT st_global, binds) <- PFn.init sym (PS.PopT st) - let pg' = pg & (syncData dp . syncStates) %~ MapF.insert sne st_global - binds' <- case MapF.lookup sne (pg' ^. (syncData dp . syncBindings)) of - Just (PS.AbsT bindsSpec_prev) -> do - binds_prev <- liftIO $ PS.bindSpec sym (PS.scopeVarsPair scope) bindsSpec_prev - -- bindings cannot clash, since they are fresh, so the mux condition doesn't matter - true_ <- PS.concreteScope sym (W4.ConcreteBool True) - PFn.merge sym true_ binds binds_prev - Nothing -> return binds - let bindsSpec = PS.AbsT $ PS.mkSimSpec scope binds' - return $ ((st_global, binds), pg' & (syncData dp . syncBindings) %~ MapF.insert sne bindsSpec) + case MapF.lookup sne (pg ^. (syncData dp . syncStates)) of + -- if we already have a 'syncState' entry, then we should re-use those + -- uninterpreted functions rather than making new ones + Just st_global -> case MapF.lookup sne (pg ^. (syncData dp . syncBindings)) of + Just (PS.AbsT bindsSpec_prev) -> do + binds_prev <- liftIO $ PS.bindSpec sym (PS.scopeVarsPair scope) bindsSpec_prev + return ((st_global, binds_prev), pg) + Nothing -> fail $ "Missing binding information for node: " ++ show sne + Nothing -> do + (PS.PopT st_global, binds) <- PFn.init sym (PS.PopT st) + let pg' = pg & (syncData dp . syncStates) %~ MapF.insert sne st_global + (binds', pg'') <- addFnBindings sym scope sne binds pg' + return $ ((st_global, binds'), pg'') where dp = singleNodeDivergence sne bin = singleEntryBin sne diff --git a/src/Pate/Verification/StrongestPosts.hs b/src/Pate/Verification/StrongestPosts.hs index aaf309c7..3a82e8ed 100644 --- a/src/Pate/Verification/StrongestPosts.hs +++ b/src/Pate/Verification/StrongestPosts.hs @@ -720,54 +720,77 @@ mergeSingletons sneO sneP pg = fnTrace "mergeSingletons" $ withSym $ \sym -> do Nothing -> throwHere $ PEE.IncompatibleSingletonNodes blkO blkP let dp = singleNodeDivergence sneO - let syncNode = GraphNode syncNodeEntry - let snePair = PPa.PatchPair sneO sneP + let pre_refines = getDomainRefinements syncNode pg - pg1 <- withFreshScope blkPair $ \(scope :: PS.SimScope sym arch v) -> do - (bundles, pg') <- mergeBundles scope snePair pg - let pre_refines = getDomainRefinements syncNode pg - - --TODO: this isn't quite right, because the transition from single to two sided analysis immediately - -- results in everything getting dumped from the equivalence domain (since the "other" single-sided state - -- has now changed arbitrarily) - -- We need to give an interpretation for this state via the other side of the analysis, which means we - -- need to include both the original and patched pre-domains (and corresponding assumptions about the - -- uninterpreted functions) when widening both sides - - let go :: forall bin. PairGraph sym arch -> SingleNodeEntry arch bin -> EquivM_ sym arch (PairGraph sym arch) - go pg0 sne = do - let bin = singleEntryBin sne - let bin_other = PBi.flipRepr bin - sne_other <- PPa.get bin_other snePair - let nd = GraphNode $ singleToNodeEntry sne - domSpec <- evalPG pg $ getCurrentDomainM nd - dom <- liftIO $ PS.bindSpec sym (PS.scopeVarsPair scope) domSpec - (SingleBundle bundle binds) <- PPa.get bin bundles - withTracing @"node" nd $ do - emitTraceLabel @"domain" PAD.Predomain (Some dom) - withGraphNode' scope nd bundle dom pg0 $ do - let - collectCondition :: ConditionKind -> PFn.FnBindings sym (PBi.OtherBinary bin) v -> PFn.FnBindings sym (PBi.OtherBinary bin) v - collectCondition condK binds_acc = do - case getCondition pg0 nd condK of - Just condSpec -> PS.viewSpecBody condSpec $ \cond -> PFn.addUsedFns sym cond binds_acc - Nothing -> binds_acc - - pg2 <- propagateCondition scope bundle nd syncNode pg0 >>= \case - Just pg1 -> do - let binds_other = foldr collectCondition binds [minBound .. maxBound] - return $ pg1 & (syncData dp . syncBindings) %~ MapF.insert sne_other (PS.AbsT $ PS.mkSimSpec scope binds_other) - Nothing -> return pg0 - - -- re-apply any refinements that we processed for the other binary - let pg3 = case getDomainRefinements syncNode pg2 of - [] -> addDomainRefinements syncNode pre_refines pg2 - _ -> pg2 - widenAlongEdge scope bundle nd dom pg3 syncNode - TF.foldlMF go pg' snePair - return (syncNodeEntry, pg1) + -- we start with two scopes: one representing the program state at the point of divergence: 'init_scope', + -- and one representing the program state at the merge point + + pg_final <- withFreshScope (graphNodeBlocks dp) $ \(splitScope :: PS.SimScope sym arch init) -> do + withFreshScope blkPair $ \(mergeScope :: PS.SimScope sym arch merge) -> do + ((sbundlePair@(PPa.PatchPair sbundleO sbundleP)), pg') <- mergeBundles splitScope mergeScope snePair pg + dpDomSpec <- evalPG pg $ getCurrentDomainM dp + -- domain at the divergence point + dpDom <- liftIO $ PS.bindSpec sym (PS.scopeVarsPair splitScope) dpDomSpec + noop <- noopBundle splitScope (graphNodeBlocks dp) + + + withValidInit splitScope (graphNodeBlocks dp) $ + withPredomain splitScope noop dpDom $ + withValidInit (singleBundleScope sbundleO) (singleBundleBlocks sbundleO) $ + withValidInit (singleBundleScope sbundleP) (singleBundleBlocks sbundleP) $ + withPredomain (singleBundleScope sbundleO) (singleBundle sbundleO) (singleBundleDomain sbundleO) $ + withPredomain (singleBundleScope sbundleP) (singleBundle sbundleP) (singleBundleDomain sbundleP) $ + withConditionsAssumed (singleBundleScope sbundleO) (singleBundle sbundleO) (singleBundleDomain sbundleO) (GraphNode $ singleToNodeEntry sneO) pg' $ + withConditionsAssumed (singleBundleScope sbundleP) (singleBundle sbundleP) (singleBundleDomain sbundleP) (GraphNode $ singleToNodeEntry sneP) pg' $ do + + bindsOAsm <- IO.liftIO $ PFn.toPred sym $ singleBundleBinds sbundleO + bindsPAsm <- IO.liftIO $ PFn.toPred sym $ singleBundleBinds sbundleP + bindsAsms <- IO.liftIO $ W4.andPred sym bindsOAsm bindsPAsm + + withAssumption bindsAsms $ do + let + collectCondition :: forall bin v. PBi.WhichBinaryRepr bin -> GraphNode arch -> PairGraph sym arch -> ConditionKind -> PFn.FnBindings sym (PBi.OtherBinary bin) v -> PFn.FnBindings sym (PBi.OtherBinary bin) v + collectCondition _ nd pg_ condK binds_acc = do + case getCondition pg_ nd condK of + Just condSpec -> PS.viewSpecBody condSpec $ \cond -> PFn.addUsedFns sym cond binds_acc + Nothing -> binds_acc + + (new_bind_asms, pg'') <- withPG pg' $ PPa.forBinsC $ \bin -> do + sbundle <- PPa.get bin sbundlePair + sne <- PPa.get bin snePair + sne_other <- PPa.get (PBi.flipRepr bin) snePair + let nd = GraphNode $ singleToNodeEntry sne + let scope = singleBundleScope sbundle + liftEqM $ \pg_ -> propagateOne scope (singleBundle sbundle) nd syncNode ConditionAsserted pg_ >>= \case + Just pg_' -> do + let binds_other = foldr (collectCondition bin nd pg_') (singleBundleBinds sbundle) [minBound .. maxBound] + priority <- thisPriority + (binds, pg_'') <- IO.liftIO $ addFnBindings sym mergeScope sne_other binds_other pg_' + binds_asm <- IO.liftIO $ PFn.toPred sym binds + return $ (binds_asm, queueAncestors (priority PriorityHandleDesync) nd pg_'') + Nothing -> + -- bindings already assumed above + return (W4.truePred sym, pg_) + + new_bind_asm <- PPa.joinPatchPred (\x y -> IO.liftIO $ W4.andPred sym x y) $ \bin -> + PPa.getC bin new_bind_asms + + withAssumption new_bind_asm $ + withPG_ pg'' $ PPa.catBins $ \bin -> do + liftPG $ modify $ \pg_ -> case getDomainRefinements syncNode pg_ of + [] -> addDomainRefinements syncNode pre_refines pg_ + _ -> pg_ + liftEqM_ $ \pg_ -> do + sbundle <- PPa.get bin sbundlePair + sne <- PPa.get bin snePair + let nd = GraphNode $ singleToNodeEntry sne + let scope = singleBundleScope sbundle + withConditionsAssumed scope (singleBundle sbundle) (singleBundleDomain sbundle) nd pg_ $ + widenAlongEdge scope (singleBundle sbundle) nd (singleBundleDomain sbundle) pg_ syncNode + + return (syncNodeEntry, pg_final) -- | Choose some work item (optionally interactively) withWorkItem :: @@ -1136,28 +1159,40 @@ noopBundle scope pPair = withSym $ \sym -> do -- | Bundle that transitions from a single-sided analysis to a two-sided analysis. -- FIXME: do we actually need the bindings here? -data SingleBundle sym arch v bin = SingleBundle - { singleBundle :: SimBundle sym arch v, singleBundleBinds :: PFn.FnBindings sym (PBi.OtherBinary bin) v } +data SingleBundle sym arch (v_split :: PS.VarScope) (v_merge :: PS.VarScope) bin where + SingleBundle :: + { singleBundle :: SimBundle sym arch (PS.CompositeScope bin v_merge v_split) + , singleBundleBinds :: PFn.FnBindings sym (PBi.OtherBinary bin) v_merge + , singleBundleScope :: PS.SimScope sym arch (PS.CompositeScope bin v_merge v_split) + , singleBundleDomain :: AbstractDomain sym arch (PS.CompositeScope bin v_merge v_split) + , singleBundleBlocks :: PPa.PatchPair (PB.ConcreteBlock arch) + } -> + SingleBundle sym arch v_split v_merge bin + --- | Similar to 'noopBundle' but produces a pair of bundles, each specialized --- for the single-sided node to two-sided node mergeBundles :: - forall sym arch v. - PS.SimScope sym arch v -> + forall sym arch v_split v_merge. + PS.SimScope sym arch v_split -> + PS.SimScope sym arch v_merge -> PPa.PatchPair (SingleNodeEntry arch) -> PairGraph sym arch -> - EquivM sym arch (PPa.PatchPair (SingleBundle sym arch v), PairGraph sym arch) -mergeBundles scope snePair pg = withSym $ \sym -> do - blks <- PPa.forBins $ \bin -> singleNodeBlock <$> PPa.get bin snePair - bundle <- noopBundle scope blks - withPG pg $ do - PPa.forBins $ \bin -> do - let bin_other = PBi.flipRepr bin - sne_other <- PPa.get bin_other snePair - (st_other,binds) <- liftEqM $ \pg_ -> liftIO $ initFnBindings sym scope sne_other pg_ - output <- PPa.get bin_other (simOut bundle) - PS.PopT output' <- return $ PS.fromGlobalScope $ PS.PopT (output { PS.simOutState = st_other }) - return $ SingleBundle (bundle { simOut = PPa.set bin_other output' (simOut bundle) }) binds + EquivM sym arch (PPa.PatchPair (SingleBundle sym arch v_split v_merge), PairGraph sym arch) +mergeBundles splitScope mergeScope snePair pg = withSym $ \sym -> withPG pg $ do + PS.compositeScopeCases mergeScope splitScope $ \bin scope -> do + sne <- PPa.get bin snePair + let dp = singleNodeDivergence sne + let bin_other = PBi.flipRepr bin + dpBlk <- PPa.get bin_other (graphNodeBlocks dp) + let sneBlk = singleNodeBlock sne + let blks = PPa.mkPair bin sneBlk dpBlk + bundle <- lift $ noopBundle scope blks + sne_other <- PPa.get bin_other snePair + (st_other,binds) <- liftEqM $ \pg_ -> liftIO $ initFnBindings sym mergeScope sne_other pg_ + output <- PPa.get bin_other (simOut bundle) + PS.PopT output' <- return $ PS.fromGlobalScope $ PS.PopT (output { PS.simOutState = st_other }) + domSpec <- liftPG $ getCurrentDomainM (GraphNode $ singleToNodeEntry sne) + dom <- IO.liftIO $ PS.bindSpec sym (PS.scopeVarsPair scope) domSpec + return $ SingleBundle (bundle { simOut = PPa.set bin_other output' (simOut bundle) }) binds scope dom blks -- | For a given 'PSR.MacawRegEntry' (representing the initial state of a register) -- and a corresponding 'MAS.AbsValue' (its initial abstract value according to Macaw), diff --git a/src/Pate/Verification/Widening.hs b/src/Pate/Verification/Widening.hs index b5ef3b74..711ad0d6 100644 --- a/src/Pate/Verification/Widening.hs +++ b/src/Pate/Verification/Widening.hs @@ -35,6 +35,7 @@ module Pate.Verification.Widening , strengthenPredicate , getTraceFootprint , propagateCondition + , propagateOne ) where import GHC.Stack @@ -809,13 +810,57 @@ isEqCondSingleSided scope blks bin eqCond = withSym $ \sym -> do conds_eq <- liftIO $ W4.isEq sym eqCond_pred eqCond2_pred isPredTrue' goalTimeout conds_eq - +-- | Propagate the given condition kind backwards (from 'to' node to 'from' node). +-- Does not do any other graph maintenance (i.e. dropping stale domains or re-queuing nodes) +propagateOne :: + forall sym arch v. + PS.SimScope sym arch v -> + SimBundle sym arch v -> + GraphNode arch {- ^ from -} -> + GraphNode arch {- ^ to -} -> + ConditionKind -> + PairGraph sym arch -> + EquivM sym arch (Maybe (PairGraph sym arch)) +propagateOne scope bundle from to condK gr0 = withSym $ \sym -> case getCondition gr0 to condK of + Nothing -> do + emitTrace @"debug" "No condition to propagate" + return Nothing + Just{} -> do + -- take the condition of the target edge and bind it to + -- the output state of the bundle + cond_ <- getEquivPostCondition scope bundle to condK gr0 + simplifier <- PSi.mkSimplifier PSi.deepPredicateSimplifier + cond <- PSi.applySimplifier simplifier cond_ + -- check if the "to" condition is already satisifed, otherwise + -- we need to update our own condition + cond_pred <- PEC.toPred sym cond + goalTimeout <- CMR.asks (PC.cfgGoalTimeout . envConfig) + isPredSat' goalTimeout cond_pred >>= \case + Just False -> do + emitTrace @"message" "Condition is infeasible, dropping branch." + Just <$> pruneCurrentBranch scope (from,to) condK gr0 + _ | not (shouldPropagate (getPropagationKind gr0 to condK)) -> do + emitTrace @"debug" "Condition not propagated" + return Nothing + _ -> do + not_cond <- liftIO $ W4.notPred sym cond_pred + isPredSat' goalTimeout not_cond >>= \case + -- equivalence condition for this path holds, we + -- don't need any changes + Just False -> do + emitTraceLabel @"expr" (ExprLabel $ "Proven " ++ conditionName condK) (Some cond_pred) + return Nothing + -- we need more assumptions for this condition to hold + Just True -> do + emitTraceLabel @"expr" (ExprLabel $ "Propagated " ++ conditionName condK) (Some cond_pred) + let propK = getPropagationKind gr0 to condK + gr1 <- updateEquivCondition scope from condK (Just (nextPropagate propK)) cond gr0 + return $ Just $ (markEdge from to gr1) + Nothing -> throwHere $ PEE.InconclusiveSAT -- | Push an assertion back up the graph. -- Returns 'Nothing' if there is nothing to do (i.e. no assertion or -- existing assertion is already implied) - - propagateCondition :: forall sym arch v. PS.SimScope sym arch v -> @@ -832,64 +877,13 @@ propagateCondition scope bundle from to gr0_ = fnTrace "propagateCondition" $ do False -> return Nothing True -> return $ Just gr3 where - go condK gr = withSym $ \sym -> do - case getCondition gr to condK of - -- no target equivalence condition, nothing to do - Nothing -> do - emitTrace @"debug" "No condition to propagate" - return Nothing - Just{} -> do - -- take the condition of the target edge and bind it to - -- the output state of the bundle - cond_ <- getEquivPostCondition scope bundle to condK gr - simplifier <- PSi.mkSimplifier PSi.deepPredicateSimplifier - cond <- PSi.applySimplifier simplifier cond_ -{- - - - let blks = graphNodeBlocks from - skip <- case (blks, graphNodeBlocks to) of - -- this is a synchronization edge, so we attempt to filter the equivalence condition - -- based on whether or not it has variables scoped to only the other side of the analysis - -- FIXME: we can likely do better than this and formally separate the conditions, but - -- this is sufficient for now, and avoids the obvious case - (PPa.PatchPairSingle bin _,PPa.PatchPair{}) -> isEqCondSingleSided scope blks (PBi.flipRepr bin) cond - _ -> return False - case skip of - True -> do - emitTrace @"message" "Skipping single-sided propagation" - return Nothing - False -> do --} - -- check if the "to" condition is already satisifed, otherwise - -- we need to update our own condition - cond_pred <- PEC.toPred sym cond - goalTimeout <- CMR.asks (PC.cfgGoalTimeout . envConfig) - isPredSat' goalTimeout cond_pred >>= \case - Just False -> do - emitTrace @"message" "Condition is infeasible, dropping branch." - Just <$> pruneCurrentBranch scope (from,to) condK gr - _ | not (shouldPropagate (getPropagationKind gr to condK)) -> do - emitTrace @"debug" "Condition not propagated" - return Nothing - _ -> do - not_cond <- liftIO $ W4.notPred sym cond_pred - isPredSat' goalTimeout not_cond >>= \case - -- equivalence condition for this path holds, we - -- don't need any changes - Just False -> do - emitTraceLabel @"expr" (ExprLabel $ "Proven " ++ conditionName condK) (Some cond_pred) - return Nothing - -- we need more assumptions for this condition to hold - Just True -> do - priority <- thisPriority - emitTraceLabel @"expr" (ExprLabel $ "Propagated " ++ conditionName condK) (Some cond_pred) - let propK = getPropagationKind gr to condK - gr1 <- updateEquivCondition scope from condK (Just (nextPropagate propK)) cond gr - return $ Just $ queueAncestors (priority PriorityPropagation) from $ - queueNode (priority PriorityNodeRecheck) from $ - dropPostDomains from (priority PriorityDomainRefresh) (markEdge from to gr1) - Nothing -> throwHere $ PEE.InconclusiveSAT + go condK gr = propagateOne scope bundle from to condK gr >>= \case + Nothing -> return Nothing + Just gr' -> do + priority <- thisPriority + return $ Just $ queueAncestors (priority PriorityPropagation) from $ + queueNode (priority PriorityNodeRecheck) from $ + dropPostDomains from (priority PriorityDomainRefresh) (markEdge from to gr') -- | Given the results of symbolic execution, and an edge in the pair graph -- to consider, compute an updated abstract domain for the target node, From a01f3baea6671d40220d5908bb2d1aeff7bb176f Mon Sep 17 00:00:00 2001 From: Daniel Matichuk Date: Thu, 14 Nov 2024 13:59:15 -0800 Subject: [PATCH 11/36] add desync-assert tests --- tests/src/desync-assert.original.c | 25 ++++++++++++++++++++++++ tests/src/desync-assert.patched.c | 31 ++++++++++++++++++++++++++++++ 2 files changed, 56 insertions(+) create mode 100644 tests/src/desync-assert.original.c create mode 100644 tests/src/desync-assert.patched.c diff --git a/tests/src/desync-assert.original.c b/tests/src/desync-assert.original.c new file mode 100644 index 00000000..ddc05c55 --- /dev/null +++ b/tests/src/desync-assert.original.c @@ -0,0 +1,25 @@ +#include "util.h" + +int X = -11; +int Y = -11; +int OBSERVE __attribute__((section(".output"))) = -12; + +#pragma noinline +void g() { + Y--; +} + +#pragma noinline +void f() { + if (X < 0 || Y < 0 || X > 100 || Y > 100) { + return; + } + X++; + + // relation is that X - Y is the same between both programs + OBSERVE = X - Y; +} + +void _start() { + f(); +} diff --git a/tests/src/desync-assert.patched.c b/tests/src/desync-assert.patched.c new file mode 100644 index 00000000..39d824be --- /dev/null +++ b/tests/src/desync-assert.patched.c @@ -0,0 +1,31 @@ +#include "util.h" + +int X = -11; +int Y = -11; +int OBSERVE __attribute__((section(".output"))) = -12; + +#pragma noinline +void g() { + Y--; +} + +#pragma noinline +void f() { + if (X < 0 || Y < 0 || X > 100 || Y > 100) { + return; + } + g(); + asm("nop"); + asm("nop"); + asm("nop"); + asm("nop"); + asm("nop"); + asm("nop"); + + // relation is that X - Y is the same between both programs + OBSERVE = X - Y; +} + +void _start() { + f(); +} From 0f3ab935af04f45879087b2a7dec18ebdc99c219 Mon Sep 17 00:00:00 2001 From: Daniel Matichuk Date: Wed, 11 Dec 2024 13:18:33 -0800 Subject: [PATCH 12/36] resolve merge artifacts from Data.Quant --- src/Pate/Verification/PairGraph.hs | 16 ++++++++-------- src/Pate/Verification/StrongestPosts.hs | 14 +++++++------- 2 files changed, 15 insertions(+), 15 deletions(-) diff --git a/src/Pate/Verification/PairGraph.hs b/src/Pate/Verification/PairGraph.hs index 429f3e86..79430534 100644 --- a/src/Pate/Verification/PairGraph.hs +++ b/src/Pate/Verification/PairGraph.hs @@ -458,12 +458,12 @@ data SyncData sym arch = -- They are propagated backwards through the single-sided analysis until reaching the divergence point, -- where they are ultimately discharged by rewriting the uninterpreted functions according to the -- collected bindings. - , _syncBindings :: MapF (SingleNodeEntry arch) (PFn.FnBindingsSpec sym arch) + , _syncBindings :: MapF (Qu.AsSingle (NodeEntry' arch)) (PFn.FnBindingsSpec sym arch) -- | When a sync point has an assertion that needs to be propagated through the single-sided analysis, -- it generates a set of uninterpreted functions (implicitly scoped to the program state at the divergence point), -- that represent the single-sided program state at exactly that sync point. -- The domain should always be a subset of the sync points. - , _syncStates :: MapF (SingleNodeEntry arch) (PS.SimState sym arch PS.GlobalScope) + , _syncStates :: MapF (Qu.AsSingle (NodeEntry' arch)) (PS.SimState sym arch PS.GlobalScope) } @@ -543,14 +543,14 @@ addFnBindings :: PFn.FnBindings sym bin v -> PairGraph sym arch -> IO (PFn.FnBindings sym bin v, PairGraph sym arch) -addFnBindings sym scope sne binds pg = case MapF.lookup sne (pg ^. (syncData dp . syncBindings)) of +addFnBindings sym scope sne binds pg = case MapF.lookup (Qu.AsSingle sne) (pg ^. (syncData dp . syncBindings)) of Just (PS.AbsT bindsSpec_prev) -> do binds_prev <- liftIO $ PS.bindSpec sym (PS.scopeVarsPair scope) bindsSpec_prev -- FIXME: check for clashes? true_ <- PS.concreteScope sym (W4.ConcreteBool True) binds' <- PFn.merge sym true_ binds binds_prev - return $ (binds', pg & (syncData dp . syncBindings) %~ MapF.insert sne (PS.AbsT $ PS.mkSimSpec scope binds')) - Nothing -> return $ (binds, pg & (syncData dp . syncBindings) %~ MapF.insert sne (PS.AbsT $ PS.mkSimSpec scope binds)) + return $ (binds', pg & (syncData dp . syncBindings) %~ MapF.insert (Qu.AsSingle sne) (PS.AbsT $ PS.mkSimSpec scope binds')) + Nothing -> return $ (binds, pg & (syncData dp . syncBindings) %~ MapF.insert (Qu.AsSingle sne) (PS.AbsT $ PS.mkSimSpec scope binds)) where dp = singleNodeDivergence sne @@ -569,17 +569,17 @@ initFnBindings :: PairGraph sym arch -> IO ((PS.SimState sym arch PS.GlobalScope bin, PFn.FnBindings sym bin v), PairGraph sym arch) initFnBindings sym scope sne pg = do - case MapF.lookup sne (pg ^. (syncData dp . syncStates)) of + case MapF.lookup (Qu.AsSingle sne) (pg ^. (syncData dp . syncStates)) of -- if we already have a 'syncState' entry, then we should re-use those -- uninterpreted functions rather than making new ones - Just st_global -> case MapF.lookup sne (pg ^. (syncData dp . syncBindings)) of + Just st_global -> case MapF.lookup (Qu.AsSingle sne) (pg ^. (syncData dp . syncBindings)) of Just (PS.AbsT bindsSpec_prev) -> do binds_prev <- liftIO $ PS.bindSpec sym (PS.scopeVarsPair scope) bindsSpec_prev return ((st_global, binds_prev), pg) Nothing -> fail $ "Missing binding information for node: " ++ show sne Nothing -> do (PS.PopT st_global, binds) <- PFn.init sym (PS.PopT st) - let pg' = pg & (syncData dp . syncStates) %~ MapF.insert sne st_global + let pg' = pg & (syncData dp . syncStates) %~ MapF.insert (Qu.AsSingle sne) st_global (binds', pg'') <- addFnBindings sym scope sne binds pg' return $ ((st_global, binds'), pg'') where diff --git a/src/Pate/Verification/StrongestPosts.hs b/src/Pate/Verification/StrongestPosts.hs index 3a82e8ed..0166aa5a 100644 --- a/src/Pate/Verification/StrongestPosts.hs +++ b/src/Pate/Verification/StrongestPosts.hs @@ -721,7 +721,7 @@ mergeSingletons sneO sneP pg = fnTrace "mergeSingletons" $ withSym $ \sym -> do let dp = singleNodeDivergence sneO let syncNode = GraphNode syncNodeEntry - let snePair = PPa.PatchPair sneO sneP + let snePair = PPa.PatchPair (Qu.AsSingle sneO) (Qu.AsSingle sneP) let pre_refines = getDomainRefinements syncNode pg -- we start with two scopes: one representing the program state at the point of divergence: 'init_scope', @@ -759,8 +759,8 @@ mergeSingletons sneO sneP pg = fnTrace "mergeSingletons" $ withSym $ \sym -> do (new_bind_asms, pg'') <- withPG pg' $ PPa.forBinsC $ \bin -> do sbundle <- PPa.get bin sbundlePair - sne <- PPa.get bin snePair - sne_other <- PPa.get (PBi.flipRepr bin) snePair + Qu.AsSingle sne <- PPa.get bin snePair + Qu.AsSingle sne_other <- PPa.get (PBi.flipRepr bin) snePair let nd = GraphNode $ singleToNodeEntry sne let scope = singleBundleScope sbundle liftEqM $ \pg_ -> propagateOne scope (singleBundle sbundle) nd syncNode ConditionAsserted pg_ >>= \case @@ -784,7 +784,7 @@ mergeSingletons sneO sneP pg = fnTrace "mergeSingletons" $ withSym $ \sym -> do _ -> pg_ liftEqM_ $ \pg_ -> do sbundle <- PPa.get bin sbundlePair - sne <- PPa.get bin snePair + Qu.AsSingle sne <- PPa.get bin snePair let nd = GraphNode $ singleToNodeEntry sne let scope = singleBundleScope sbundle withConditionsAssumed scope (singleBundle sbundle) (singleBundleDomain sbundle) nd pg_ $ @@ -1174,19 +1174,19 @@ mergeBundles :: forall sym arch v_split v_merge. PS.SimScope sym arch v_split -> PS.SimScope sym arch v_merge -> - PPa.PatchPair (SingleNodeEntry arch) -> + PPa.PatchPair (Qu.AsSingle (NodeEntry' arch)) -> PairGraph sym arch -> EquivM sym arch (PPa.PatchPair (SingleBundle sym arch v_split v_merge), PairGraph sym arch) mergeBundles splitScope mergeScope snePair pg = withSym $ \sym -> withPG pg $ do PS.compositeScopeCases mergeScope splitScope $ \bin scope -> do - sne <- PPa.get bin snePair + Qu.AsSingle sne <- PPa.get bin snePair let dp = singleNodeDivergence sne let bin_other = PBi.flipRepr bin dpBlk <- PPa.get bin_other (graphNodeBlocks dp) let sneBlk = singleNodeBlock sne let blks = PPa.mkPair bin sneBlk dpBlk bundle <- lift $ noopBundle scope blks - sne_other <- PPa.get bin_other snePair + Qu.AsSingle sne_other <- PPa.get bin_other snePair (st_other,binds) <- liftEqM $ \pg_ -> liftIO $ initFnBindings sym mergeScope sne_other pg_ output <- PPa.get bin_other (simOut bundle) PS.PopT output' <- return $ PS.fromGlobalScope $ PS.PopT (output { PS.simOutState = st_other }) From d49e7c50cac39e6ad8725620ce7495ca586912cd Mon Sep 17 00:00:00 2001 From: Daniel Matichuk Date: Wed, 11 Dec 2024 15:36:11 -0800 Subject: [PATCH 13/36] more Node generalizations --- src/Data/Quant.hs | 7 ++-- src/Pate/Verification/PairGraph.hs | 54 ++++++++++++------------- src/Pate/Verification/PairGraph/Node.hs | 50 +++++++++++++++++------ src/Pate/Verification/StrongestPosts.hs | 24 +++++------ 4 files changed, 80 insertions(+), 55 deletions(-) diff --git a/src/Data/Quant.hs b/src/Data/Quant.hs index f83ebc2a..cc1e9b87 100644 --- a/src/Data/Quant.hs +++ b/src/Data/Quant.hs @@ -64,7 +64,8 @@ module Data.Quant , generateAllM , pattern All , pattern Single - , viewQuantEach + , quantEach + , QuantEach , pattern QuantEach , AsSingle(..) ) where @@ -508,8 +509,8 @@ instance forall f. ShowF f => ShowF (AsSingle f) where type QuantEach (f :: QuantK k -> Type) = Quant (AsSingle f) AllK -viewQuantEach :: HasReprK k => QuantEach f -> (forall (x :: k). ReprOf x -> f (OneK x)) -viewQuantEach (QuantAll f) = \r -> case TMF.apply f r of AsSingle x -> x +quantEach :: HasReprK k => QuantEach f -> (forall (x :: k). ReprOf x -> f (OneK x)) +quantEach (QuantAll f) = \r -> case TMF.apply f r of AsSingle x -> x viewQuantEach' :: HasReprK k => Quant (AsSingle f) tp -> Maybe (Dict (IsExistsOr tp AllK), forall (x :: k). ReprOf x -> f (OneK x)) viewQuantEach' q = case q of diff --git a/src/Pate/Verification/PairGraph.hs b/src/Pate/Verification/PairGraph.hs index 79430534..b98c5d86 100644 --- a/src/Pate/Verification/PairGraph.hs +++ b/src/Pate/Verification/PairGraph.hs @@ -90,7 +90,7 @@ module Pate.Verification.PairGraph , syncExceptions , syncStates , syncBindings - , singleNodeRepr + , nodeToSingleRepr , edgeActions , nodeActions , refineActions @@ -458,12 +458,12 @@ data SyncData sym arch = -- They are propagated backwards through the single-sided analysis until reaching the divergence point, -- where they are ultimately discharged by rewriting the uninterpreted functions according to the -- collected bindings. - , _syncBindings :: MapF (Qu.AsSingle (NodeEntry' arch)) (PFn.FnBindingsSpec sym arch) + , _syncBindings :: MapF (Qu.AsSingle (GraphNode' arch)) (PFn.FnBindingsSpec sym arch) -- | When a sync point has an assertion that needs to be propagated through the single-sided analysis, -- it generates a set of uninterpreted functions (implicitly scoped to the program state at the divergence point), -- that represent the single-sided program state at exactly that sync point. -- The domain should always be a subset of the sync points. - , _syncStates :: MapF (Qu.AsSingle (NodeEntry' arch)) (PS.SimState sym arch PS.GlobalScope) + , _syncStates :: MapF (Qu.AsSingle (GraphNode' arch)) (PS.SimState sym arch PS.GlobalScope) } @@ -529,17 +529,17 @@ getSingleNodeData :: HasCallStack => (OrdF x, Ord (x bin)) => L.Lens' (SyncData sym arch) (PPa.PatchPair (SetF x)) -> - SingleNodeEntry arch bin -> + SingleGraphNode arch bin -> PairGraphM sym arch (Set (x bin)) -getSingleNodeData lens sne = - getPG $ syncDataSet (singleNodeDivergePoint sne) (singleEntryBin sne) lens +getSingleNodeData lens sgn = + getPG $ syncDataSet (singleNodeDivergePoint sgn) (singleNodeRepr sgn) lens addFnBindings :: sym ~ W4B.ExprBuilder s st fs => PA.ValidArch arch => sym -> PS.SimScope sym arch v -> - SingleNodeEntry arch bin -> + SingleGraphNode arch bin -> PFn.FnBindings sym bin v -> PairGraph sym arch -> IO (PFn.FnBindings sym bin v, PairGraph sym arch) @@ -552,7 +552,7 @@ addFnBindings sym scope sne binds pg = case MapF.lookup (Qu.AsSingle sne) (pg ^. return $ (binds', pg & (syncData dp . syncBindings) %~ MapF.insert (Qu.AsSingle sne) (PS.AbsT $ PS.mkSimSpec scope binds')) Nothing -> return $ (binds, pg & (syncData dp . syncBindings) %~ MapF.insert (Qu.AsSingle sne) (PS.AbsT $ PS.mkSimSpec scope binds)) where - dp = singleNodeDivergence sne + dp = singleNodeDivergePoint sne -- | Retrieve the final state that binds the given scope to instead be @@ -565,7 +565,7 @@ initFnBindings :: PA.ValidArch arch => sym -> PS.SimScope sym arch v -> - SingleNodeEntry arch bin -> + SingleGraphNode arch bin -> PairGraph sym arch -> IO ((PS.SimState sym arch PS.GlobalScope bin, PFn.FnBindings sym bin v), PairGraph sym arch) initFnBindings sym scope sne pg = do @@ -583,8 +583,8 @@ initFnBindings sym scope sne pg = do (binds', pg'') <- addFnBindings sym scope sne binds pg' return $ ((st_global, binds'), pg'') where - dp = singleNodeDivergence sne - bin = singleEntryBin sne + dp = singleNodeDivergePoint sne + bin = singleNodeRepr sne st :: PS.SimState sym arch v bin st = PS.simVarState $ case bin of @@ -683,8 +683,8 @@ mkProcessMerge :: SingleNodeEntry arch (PBi.OtherBinary bin) -> Maybe (WorkItem arch) mkProcessMerge syncAtExit sne1 sne2 - | dp1 <- singleNodeDivergePoint sne1 - , dp2 <- singleNodeDivergePoint sne2 + | dp1 <- singleNodeDivergePoint (GraphNode sne1) + , dp2 <- singleNodeDivergePoint (GraphNode sne2) , dp1 == dp2 = case singleEntryBin sne1 of PBi.OriginalRepr -> case syncAtExit of True -> Just $ ProcessMergeAtExitsCtor sne1 sne2 @@ -698,7 +698,7 @@ mkProcessMerge _ _ _ = Nothing -- its own divergence point mkProcessSplit :: SingleNodeEntry arch bin -> Maybe (WorkItem arch) mkProcessSplit sne = do - GraphNode dp_ne <- return $ singleNodeDivergePoint sne + GraphNode dp_ne <- return $ singleNodeDivergePoint (GraphNode sne) sne_dp <- toSingleNodeEntry (singleEntryBin sne) dp_ne guard (sne_dp == sne) return (ProcessSplit sne) @@ -1388,8 +1388,8 @@ combineNodes node1 node2 = do guard $ divergeO == divergeP return $ GraphNode $ mkMergedNodeEntry divergeO (singleNodeBlock nodeO) (singleNodeBlock nodeP) -singleNodeRepr :: GraphNode arch -> Maybe (Some (PBi.WhichBinaryRepr)) -singleNodeRepr nd = case graphNodeBlocks nd of +nodeToSingleRepr :: GraphNode arch -> Maybe (Some (PBi.WhichBinaryRepr)) +nodeToSingleRepr nd = case graphNodeBlocks nd of PPa.PatchPairSingle bin _ -> return $ Some bin PPa.PatchPair{} -> Nothing @@ -1549,12 +1549,12 @@ getPendingActions lens = do return $ (pairGraphPendingActs pg) ^. lens isCutAddressFor :: - SingleNodeEntry arch bin -> + SingleGraphNode arch bin -> PAd.ConcreteAddress arch -> PairGraphM sym arch Bool isCutAddressFor sne addr = do cuts <- getSingleNodeData syncCutAddresses sne - return $ Set.member (PPa.WithBin (singleEntryBin sne) addr) cuts + return $ Set.member (PPa.WithBin (singleNodeRepr sne) addr) cuts isSyncExit :: forall sym arch bin. @@ -1562,12 +1562,12 @@ isSyncExit :: PB.BlockTarget arch bin -> PairGraphM sym arch (Maybe (SyncPoint arch bin)) isSyncExit sne blkt@(PB.BlockTarget{}) = do - excepts <- getSingleNodeData syncExceptions sne - syncs <- getSingleNodeData syncPoints sne + excepts <- getSingleNodeData syncExceptions (GraphNode sne) + syncs <- getSingleNodeData syncPoints (GraphNode sne) let isExcept = Set.member (TupleF2 (Qu.AsSingle sne) blkt) excepts case isExcept of True -> return Nothing - False -> isCutAddressFor sne (PB.targetRawPC blkt) >>= \case + False -> isCutAddressFor (GraphNode sne) (PB.targetRawPC blkt) >>= \case True -> do let sne_tgt = mkSingleNodeEntry (singleToNodeEntry sne) (PB.targetCall blkt) return $ Just $ SyncAtExit sne sne_tgt @@ -1592,7 +1592,7 @@ isSyncNode :: SingleNodeEntry arch bin -> PairGraphM sym arch Bool isSyncNode sne = do - cuts <- getSingleNodeData syncCutAddresses sne + cuts <- getSingleNodeData syncCutAddresses (GraphNode sne) return $ Set.member (singleNodeAddr sne) cuts -- | Filter a list of reachable block exits to @@ -1626,7 +1626,7 @@ filterSyncExits priority (ProcessSplit sne) blktPairs = pgValid $ do return [] False -> do let bin = singleEntryBin sne - desyncExits <- getSingleNodeData syncDesyncExits sne + desyncExits <- getSingleNodeData syncDesyncExits (GraphNode sne) let isDesyncExitPair blktPair = do blkt <- PPa.get bin blktPair return $ Set.member blkt desyncExits @@ -1654,8 +1654,8 @@ addReturnPointSync priority ne blktPair = case asSingleNodeEntry ne of blkt <- PPa.get bin blktPair case PB.targetReturn blkt of Just ret -> do - cuts <- getSingleNodeData syncCutAddresses sne - excepts <- getSingleNodeData syncExceptions sne + cuts <- getSingleNodeData syncCutAddresses (GraphNode sne) + excepts <- getSingleNodeData syncExceptions (GraphNode sne) let isExcept = Set.member (TupleF2 (Qu.AsSingle sne) blkt) excepts case (not isExcept) && Set.member (PPa.WithBin (singleEntryBin sne) (PB.concreteAddress ret)) cuts of @@ -1692,7 +1692,7 @@ queueExitMerges :: PairGraphM sym arch () queueExitMerges priority sp = do let sne = syncPointNode sp - let dp = singleNodeDivergePoint sne + let dp = singleNodeDivergence sne addToSyncData syncPoints (singleEntryBin sne) dp sp otherExits <- getSyncData syncPoints (PBi.flipRepr (singleEntryBin sne)) dp forM_ otherExits $ \syncOther -> queueSyncPoints priority sp syncOther @@ -1708,7 +1708,7 @@ handleSingleSidedReturnTo :: handleSingleSidedReturnTo priority ne = case asSingleNodeEntry ne of Just (Some (Qu.AsSingle sne)) -> do let bin = singleEntryBin sne - let dp = singleNodeDivergePoint sne + let dp = singleNodeDivergence sne syncAddrs <- getSyncData syncCutAddresses bin dp let blk = singleNodeBlock sne case Set.member (PPa.WithBin bin (PB.concreteAddress blk)) syncAddrs of diff --git a/src/Pate/Verification/PairGraph/Node.hs b/src/Pate/Verification/PairGraph/Node.hs index 8665278a..34812875 100644 --- a/src/Pate/Verification/PairGraph/Node.hs +++ b/src/Pate/Verification/PairGraph/Node.hs @@ -63,12 +63,14 @@ module Pate.Verification.PairGraph.Node ( , singleToNodeEntry , singleNodeBlock , combineSingleEntries - , singleNodeDivergence , toSingleNodeEntry , singleNodeAddr , SingleNodeReturn , SingleGraphNode , pattern SingleNodeReturn + , singleNodeRepr + , singleNodeDivergePoint + , singleNodeDivergence ) where import Prettyprinter ( Pretty(..), sep, (<+>), Doc ) @@ -109,6 +111,18 @@ data GraphNode' arch (bin :: QuantK PB.WhichBinary) type GraphNode arch = GraphNode' arch ExistsK +instance TestEquality (GraphNode' arch) where + testEquality nd1 nd2 | Just Refl <- testEquality (nodeRepr nd1) (nodeRepr nd2), nd1 == nd2 = Just Refl + testEquality _ _ = Nothing + +instance OrdF (GraphNode' arch) where + compareF nd1 nd2 = lexCompareF (nodeRepr nd1) (nodeRepr nd2) $ fromOrdering $ compare nd1 nd2 + +instance Qu.QuantCoercible (GraphNode' arch) where + coerceQuant = \case + GraphNode ne -> GraphNode (Qu.coerceQuant ne) + ReturnNode nr -> ReturnNode (Qu.coerceQuant nr) + instance PA.ValidArch arch => JSON.ToJSON (GraphNode' arch bin) where toJSON = \case GraphNode nd -> JSON.object [ ("graph_node_type", "entry"), "entry_body" JSON..= nd] @@ -161,6 +175,10 @@ nodeReturnRepr ne = Qu.quantToRepr $ nodeFuns ne nodeFuns :: NodeReturn' arch bin -> Quant (PB.FunctionEntry arch) bin nodeFuns = nodeContent +nodeRepr :: GraphNode' arch qbin -> Qu.QuantRepr qbin +nodeRepr (GraphNode ne) = nodeEntryRepr ne +nodeRepr (ReturnNode rn) = nodeReturnRepr rn + returnNodeContext :: NodeReturn' arch bin -> CallingContext arch returnNodeContext = nodeContentCtx @@ -175,7 +193,7 @@ graphNodeBlocks :: GraphNode' arch bin -> Quant (PB.ConcreteBlock arch) bin graphNodeBlocks (GraphNode ne) = nodeBlocks ne graphNodeBlocks (ReturnNode ret) = Qu.map PB.functionEntryToConcreteBlock (nodeFuns ret) -nodeContext :: GraphNode arch -> CallingContext arch +nodeContext :: GraphNode' arch qbin -> CallingContext arch nodeContext (GraphNode nd) = nodeContentCtx nd nodeContext (ReturnNode ret) = nodeContentCtx ret @@ -359,19 +377,19 @@ instance PA.ValidArch arch => Pretty (NodeEntry' arch bin) where False -> PB.ppBinaryPair' PB.ppBlockAddr (nodeBlocks e) <+> "[" <+> pretty (graphNodeContext (addContext (nodeBlocks (functionEntryOf e)) e)) <+> "]" -instance PA.ValidArch arch => Pretty (NodeReturn arch) where +instance PA.ValidArch arch => Pretty (NodeReturn' arch qbin) where pretty e = case returnNodeContext e of CallingContext [] _ -> pretty (nodeFuns e) _ -> pretty (nodeFuns e) <+> "[" <+> pretty (returnNodeContext e) <+> "]" -instance PA.ValidArch arch => Show (NodeReturn arch) where +instance PA.ValidArch arch => Show (NodeReturn' arch qbin) where show e = show (pretty e) -instance PA.ValidArch arch => Pretty (GraphNode arch) where +instance PA.ValidArch arch => Pretty (GraphNode' arch qbin) where pretty (GraphNode e) = "GraphNode" <+> pretty e pretty (ReturnNode e) = "ReturnNode" <+> pretty e -instance PA.ValidArch arch => Show (GraphNode arch) where +instance PA.ValidArch arch => Show (GraphNode' arch qbin) where show e = show (pretty e) tracePrettyNode :: @@ -451,11 +469,16 @@ mkSingleNodeEntry :: NodeEntry' arch qbin -> PB.ConcreteBlock arch bin -> Single mkSingleNodeEntry node blk = SingleNodeEntry (graphNodeContext node) blk -singleNodeDivergePoint :: SingleNodeEntry arch bin -> GraphNode arch -singleNodeDivergePoint (NodeEntry cctx _) = case divergePoint cctx of +singleNodeDivergePoint :: SingleGraphNode arch bin -> GraphNode arch +singleNodeDivergePoint sgn = case divergePoint (nodeContext sgn) of Just dp -> dp Nothing -> panic Verifier "singleNodeDivergePoint" ["missing diverge point for SingleNodeEntry"] + +singleNodeDivergence :: SingleNodeEntry arch bin -> GraphNode arch +singleNodeDivergence sne = singleNodeDivergePoint (GraphNode sne) + + asSingleNodeEntry :: PPa.PatchPairM m => NodeEntry' arch qbin -> m (Some (Qu.AsSingle (NodeEntry' arch))) asSingleNodeEntry (NodeEntry cctx blks) = do Pair _ blk <- PPa.asSingleton blks @@ -485,10 +508,8 @@ toSingleNodeEntry bin ne = do singleToNodeEntry :: SingleNodeEntry arch bin -> NodeEntry arch singleToNodeEntry sne = Qu.coerceQuant sne -singleNodeDivergence :: SingleNodeEntry arch bin -> GraphNode arch -singleNodeDivergence (SingleNodeEntry cctx _) = case divergePoint cctx of - Just dp -> dp - Nothing -> panic Verifier "singleNodeDivergence" ["Unexpected missing divergence point"] +singleToGraphNode :: SingleGraphNode arch bin -> GraphNode arch +singleToGraphNode sgn = Qu.coerceQuant sgn combineSingleEntries' :: SingleNodeEntry arch PB.Original -> @@ -521,4 +542,7 @@ pattern SingleNodeReturn cctx fn <- ((\l -> case l of NodeReturn cctx (Qu.Single where SingleNodeReturn cctx fn = NodeReturn cctx (Qu.Single (PB.functionBinRepr fn) fn) -type SingleGraphNode arch bin = GraphNode' arch (Qu.OneK bin) \ No newline at end of file +type SingleGraphNode arch bin = GraphNode' arch (Qu.OneK bin) + +singleNodeRepr :: SingleGraphNode arch bin -> PB.WhichBinaryRepr bin +singleNodeRepr sgn = case nodeRepr sgn of Qu.QuantOneRepr repr -> repr \ No newline at end of file diff --git a/src/Pate/Verification/StrongestPosts.hs b/src/Pate/Verification/StrongestPosts.hs index 0166aa5a..b82a02af 100644 --- a/src/Pate/Verification/StrongestPosts.hs +++ b/src/Pate/Verification/StrongestPosts.hs @@ -625,7 +625,7 @@ handleProcessSplit :: PairGraph sym arch -> EquivM sym arch (Maybe (GraphNode arch), PairGraph sym arch) handleProcessSplit sne pg = withPG pg $ do - let divergeNode = singleNodeDivergePoint sne + let divergeNode = singleNodeDivergence sne priority <- lift $ thisPriority case getCurrentDomain pg divergeNode of Nothing -> do @@ -645,7 +645,7 @@ handleProcessMerge sneO sneP pg = withPG pg $ do let ndO = GraphNode $ singleToNodeEntry sneO ndP = GraphNode $ singleToNodeEntry sneP - divergeNode = singleNodeDivergePoint sneO + divergeNode = singleNodeDivergence sneO priority <- lift $ thisPriority case getCurrentDomain pg divergeNode of Nothing -> do @@ -721,7 +721,7 @@ mergeSingletons sneO sneP pg = fnTrace "mergeSingletons" $ withSym $ \sym -> do let dp = singleNodeDivergence sneO let syncNode = GraphNode syncNodeEntry - let snePair = PPa.PatchPair (Qu.AsSingle sneO) (Qu.AsSingle sneP) + let snePair = Qu.QuantEach (\case PBi.OriginalRepr -> sneO; PBi.PatchedRepr -> sneP) let pre_refines = getDomainRefinements syncNode pg -- we start with two scopes: one representing the program state at the point of divergence: 'init_scope', @@ -759,15 +759,15 @@ mergeSingletons sneO sneP pg = fnTrace "mergeSingletons" $ withSym $ \sym -> do (new_bind_asms, pg'') <- withPG pg' $ PPa.forBinsC $ \bin -> do sbundle <- PPa.get bin sbundlePair - Qu.AsSingle sne <- PPa.get bin snePair - Qu.AsSingle sne_other <- PPa.get (PBi.flipRepr bin) snePair + let sne = Qu.quantEach snePair bin + let sne_other = Qu.quantEach snePair (PBi.flipRepr bin) let nd = GraphNode $ singleToNodeEntry sne let scope = singleBundleScope sbundle liftEqM $ \pg_ -> propagateOne scope (singleBundle sbundle) nd syncNode ConditionAsserted pg_ >>= \case Just pg_' -> do let binds_other = foldr (collectCondition bin nd pg_') (singleBundleBinds sbundle) [minBound .. maxBound] priority <- thisPriority - (binds, pg_'') <- IO.liftIO $ addFnBindings sym mergeScope sne_other binds_other pg_' + (binds, pg_'') <- IO.liftIO $ addFnBindings sym mergeScope (GraphNode sne_other) binds_other pg_' binds_asm <- IO.liftIO $ PFn.toPred sym binds return $ (binds_asm, queueAncestors (priority PriorityHandleDesync) nd pg_'') Nothing -> @@ -784,7 +784,7 @@ mergeSingletons sneO sneP pg = fnTrace "mergeSingletons" $ withSym $ \sym -> do _ -> pg_ liftEqM_ $ \pg_ -> do sbundle <- PPa.get bin sbundlePair - Qu.AsSingle sne <- PPa.get bin snePair + let sne = Qu.quantEach snePair bin let nd = GraphNode $ singleToNodeEntry sne let scope = singleBundleScope sbundle withConditionsAssumed scope (singleBundle sbundle) (singleBundleDomain sbundle) nd pg_ $ @@ -1174,20 +1174,20 @@ mergeBundles :: forall sym arch v_split v_merge. PS.SimScope sym arch v_split -> PS.SimScope sym arch v_merge -> - PPa.PatchPair (Qu.AsSingle (NodeEntry' arch)) -> + Qu.QuantEach (NodeEntry' arch) -> PairGraph sym arch -> EquivM sym arch (PPa.PatchPair (SingleBundle sym arch v_split v_merge), PairGraph sym arch) mergeBundles splitScope mergeScope snePair pg = withSym $ \sym -> withPG pg $ do PS.compositeScopeCases mergeScope splitScope $ \bin scope -> do - Qu.AsSingle sne <- PPa.get bin snePair + let sne = Qu.quantEach snePair bin let dp = singleNodeDivergence sne let bin_other = PBi.flipRepr bin dpBlk <- PPa.get bin_other (graphNodeBlocks dp) let sneBlk = singleNodeBlock sne let blks = PPa.mkPair bin sneBlk dpBlk bundle <- lift $ noopBundle scope blks - Qu.AsSingle sne_other <- PPa.get bin_other snePair - (st_other,binds) <- liftEqM $ \pg_ -> liftIO $ initFnBindings sym mergeScope sne_other pg_ + let sne_other = Qu.quantEach snePair bin_other + (st_other,binds) <- liftEqM $ \pg_ -> liftIO $ initFnBindings sym mergeScope (GraphNode sne_other) pg_ output <- PPa.get bin_other (simOut bundle) PS.PopT output' <- return $ PS.fromGlobalScope $ PS.PopT (output { PS.simOutState = st_other }) domSpec <- liftPG $ getCurrentDomainM (GraphNode $ singleToNodeEntry sne) @@ -1300,7 +1300,7 @@ withCurrentAbsDomain node gr f = do -- node but we don't have a singleton variant of the entry point case getDivergePoint (GraphNode node) of Just (GraphNode divergeNode) -> do - Just (Some bin) <- return $ singleNodeRepr (GraphNode node) + Just (Some bin) <- return $ nodeToSingleRepr (GraphNode node) let fnNode_diverge = functionEntryOf divergeNode fnNode_diverge_single <- toSingleNode bin fnNode_diverge case getCurrentDomain gr (GraphNode fnNode_diverge) of From 5a6d730f57391b9eb89557acdf94edce53778ab7 Mon Sep 17 00:00:00 2001 From: Daniel Matichuk Date: Wed, 11 Dec 2024 15:48:40 -0800 Subject: [PATCH 14/36] WIP: transplant function binding propagation --- src/Pate/Monad/PairGraph.hs | 12 ++++ src/Pate/SimulatorRegisters.hs | 7 +++ src/Pate/Verification/FnBindings.hs | 38 +++++++++++- src/Pate/Verification/PairGraph.hs | 46 ++++++++------ src/Pate/Verification/StrongestPosts.hs | 58 ++++++++++++++++-- src/Pate/Verification/Widening.hs | 80 +++++++++++++++++++++++-- 6 files changed, 211 insertions(+), 30 deletions(-) diff --git a/src/Pate/Monad/PairGraph.hs b/src/Pate/Monad/PairGraph.hs index a83879a3..f6726cfd 100644 --- a/src/Pate/Monad/PairGraph.hs +++ b/src/Pate/Monad/PairGraph.hs @@ -33,6 +33,7 @@ module Pate.Monad.PairGraph , runPG , execPG , liftPartEqM_ + , lookupFnBindings ) where import Control.Monad.State.Strict @@ -325,3 +326,14 @@ runPendingActions lens edge result pg0 = do case didchange of True -> return $ Just pg1 False -> return Nothing + +lookupFnBindings :: + PS.SimScope sym arch v -> + SingleNodeEntry arch bin -> + PairGraph sym arch -> + EquivM sym arch (Maybe (PFn.FnBindings sym bin v)) +lookupFnBindings scope sne pg = withSym $ \sym -> case MapF.lookup sne (pg ^. (syncData dp . syncBindings)) of + Just (PS.AbsT bindsSpec) -> Just <$> (IO.liftIO $ PS.bindSpec sym (PS.scopeVarsPair scope) bindsSpec) + Nothing -> return Nothing + where + dp = singleNodeDivergePoint sne \ No newline at end of file diff --git a/src/Pate/SimulatorRegisters.hs b/src/Pate/SimulatorRegisters.hs index 4f2117ed..dba2e73a 100644 --- a/src/Pate/SimulatorRegisters.hs +++ b/src/Pate/SimulatorRegisters.hs @@ -98,6 +98,13 @@ data MacawRegVar sym (tp :: MT.Type) where , macawVarBVs :: Ctx.Assignment (WI.SymExpr sym) (CrucBaseTypes (MS.ToCrucibleType tp)) } -> MacawRegVar sym tp +instance PEM.ExprFoldable sym (MacawRegVar sym tp) where + foldExpr sym f entry b = PEM.withSymExprFoldable sym $ + PEM.foldExpr sym f (macawVarBVs entry) b >>= PEM.foldExpr sym f (macawVarEntry entry) + + +instance forall sym. PEM.ExprFoldableF sym (MacawRegVar sym) + instance (WI.IsExpr (WI.SymExpr sym)) => Show (MacawRegEntry sym tp) where show (MacawRegEntry repr v) = case repr of CLM.LLVMPointerRepr{} | CLM.LLVMPointer rg bv <- v -> show (WI.printSymNat rg) ++ "+" ++ show (WI.printSymExpr bv) diff --git a/src/Pate/Verification/FnBindings.hs b/src/Pate/Verification/FnBindings.hs index 40b30467..77173626 100644 --- a/src/Pate/Verification/FnBindings.hs +++ b/src/Pate/Verification/FnBindings.hs @@ -27,15 +27,19 @@ module Pate.Verification.FnBindings ( FnBindings , FnBindingsSpec , init + , empty , merge + , mux , toScopedPred , toPred , addUsedFns + , toExprBindings ) where import Prelude hiding (init) import Control.Monad.Reader import Control.Monad.Trans.State +import Control.Monad.Trans.Maybe import Data.Functor.Identity import qualified Data.Parameterized.Context as Ctx @@ -126,6 +130,10 @@ init :: IO (f PS.GlobalScope, FnBindings sym bin v) init sym e = runStateT (PS.scopedExprMap sym e (mkFreshFns sym)) (FnBindings MapF.empty Set.empty) +empty :: FnBindings sym bin v +empty = FnBindings MapF.empty Set.empty + + mkFreshFns :: W4.IsSymExprBuilder sym => sym -> @@ -140,10 +148,10 @@ mkFreshFns sym_ e_scoped = case W4.asConcrete (PS.unSE e_scoped) of modify $ \(FnBindings binds s) -> FnBindings (MapF.insert fn (PS.PopScope e_scoped) binds) s return e_global --- | Merge the two given function bindings, muxing the individual bindings +-- | Mux the two given function bindings, muxing the individual bindings -- with the given predicate (i.e. path condition) in the case of -- key (uninterpreted function) clashes -merge :: +mux :: forall sym bin v. W4.IsSymExprBuilder sym => sym -> @@ -151,7 +159,7 @@ merge :: FnBindings sym bin v -> FnBindings sym bin v -> IO (FnBindings sym bin v) -merge sym p (FnBindings binds1 s1) (FnBindings binds2 s2) = do +mux sym p (FnBindings binds1 s1) (FnBindings binds2 s2) = do FnBindings <$> MapF.mergeWithKeyM go return return binds1 binds2 <*> (return $ Set.union s1 s2) where go :: forall tp. @@ -163,6 +171,23 @@ merge sym p (FnBindings binds1 s1) (FnBindings binds2 s2) = do Just{} -> return $ Just (PS.PopScope e1) Nothing -> (Just . PS.PopScope) <$> (liftIO $ (PS.liftScope3 sym W4.baseTypeIte p e1 e2 )) +merge :: + forall sym bin v. + W4.IsSymExprBuilder sym => + FnBindings sym bin v -> + FnBindings sym bin v -> + Maybe (FnBindings sym bin v) +merge (FnBindings binds1 s1) (FnBindings binds2 s2) = + FnBindings <$> MapF.mergeWithKeyM go return return binds1 binds2 <*> (return $ Set.union s1 s2) + where + go :: forall tp. + BoundFn sym tp -> + PS.PopScope (PS.ScopedExpr sym) v tp -> + PS.PopScope (PS.ScopedExpr sym) v tp -> + Maybe (Maybe (PS.PopScope (PS.ScopedExpr sym) v tp)) + go _fn se1 se2 = case W4.testEquality se1 se2 of + Just{} -> return $ Just se1 + Nothing -> fail "FnBindings: key mismatch" toScopedPred :: forall sym bin v. @@ -192,7 +217,14 @@ toPred :: IO (W4.Pred sym) toPred sym binds = PS.unSE <$> toScopedPred sym binds +type ExprBindings sym = MapF.MapF (W4.SymExpr sym) (W4.SymExpr sym) +toExprBindings :: + W4.IsSymExprBuilder sym => + FnBindings sym bin v -> + ExprBindings sym +toExprBindings binds = + MapF.fromList $ map (\(MapF.Pair (BoundFn e) (PS.PopScope se)) -> MapF.Pair e (PS.unSE se)) $ MapF.toList (fnBindings binds) -- Note we don't require that 'f' has the same scope as -- the bindings, since we can collect used bindings from any scope diff --git a/src/Pate/Verification/PairGraph.hs b/src/Pate/Verification/PairGraph.hs index b98c5d86..d446545e 100644 --- a/src/Pate/Verification/PairGraph.hs +++ b/src/Pate/Verification/PairGraph.hs @@ -137,6 +137,7 @@ module Pate.Verification.PairGraph , setPropagationKind , initFnBindings , addFnBindings + , getAllSyncPoints ) where import Prettyprinter @@ -529,30 +530,30 @@ getSingleNodeData :: HasCallStack => (OrdF x, Ord (x bin)) => L.Lens' (SyncData sym arch) (PPa.PatchPair (SetF x)) -> - SingleGraphNode arch bin -> + SingleNodeEntry arch bin -> PairGraphM sym arch (Set (x bin)) -getSingleNodeData lens sgn = - getPG $ syncDataSet (singleNodeDivergePoint sgn) (singleNodeRepr sgn) lens +getSingleNodeData lens sne = + getPG $ syncDataSet (singleNodeDivergePoint sne) (singleEntryBin sne) lens addFnBindings :: sym ~ W4B.ExprBuilder s st fs => PA.ValidArch arch => sym -> PS.SimScope sym arch v -> - SingleGraphNode arch bin -> + SingleNodeEntry arch bin -> PFn.FnBindings sym bin v -> PairGraph sym arch -> IO (PFn.FnBindings sym bin v, PairGraph sym arch) -addFnBindings sym scope sne binds pg = case MapF.lookup (Qu.AsSingle sne) (pg ^. (syncData dp . syncBindings)) of +addFnBindings sym scope sne binds pg = case MapF.lookup sne (pg ^. (syncData dp . syncBindings)) of Just (PS.AbsT bindsSpec_prev) -> do binds_prev <- liftIO $ PS.bindSpec sym (PS.scopeVarsPair scope) bindsSpec_prev - -- FIXME: check for clashes? - true_ <- PS.concreteScope sym (W4.ConcreteBool True) - binds' <- PFn.merge sym true_ binds binds_prev - return $ (binds', pg & (syncData dp . syncBindings) %~ MapF.insert (Qu.AsSingle sne) (PS.AbsT $ PS.mkSimSpec scope binds')) - Nothing -> return $ (binds, pg & (syncData dp . syncBindings) %~ MapF.insert (Qu.AsSingle sne) (PS.AbsT $ PS.mkSimSpec scope binds)) + binds' <- case PFn.merge binds binds_prev of + Just binds' -> return binds' + Nothing -> fail "addFnBindings: unexpected binding clash" + return $ (binds', pg & (syncData dp . syncBindings) %~ MapF.insert sne (PS.AbsT $ PS.mkSimSpec scope binds')) + Nothing -> return $ (binds, pg & (syncData dp . syncBindings) %~ MapF.insert sne (PS.AbsT $ PS.mkSimSpec scope binds)) where - dp = singleNodeDivergePoint sne + dp = singleNodeDivergence sne -- | Retrieve the final state that binds the given scope to instead be @@ -565,26 +566,26 @@ initFnBindings :: PA.ValidArch arch => sym -> PS.SimScope sym arch v -> - SingleGraphNode arch bin -> + SingleNodeEntry arch bin -> PairGraph sym arch -> IO ((PS.SimState sym arch PS.GlobalScope bin, PFn.FnBindings sym bin v), PairGraph sym arch) initFnBindings sym scope sne pg = do - case MapF.lookup (Qu.AsSingle sne) (pg ^. (syncData dp . syncStates)) of + case MapF.lookup sne (pg ^. (syncData dp . syncStates)) of -- if we already have a 'syncState' entry, then we should re-use those -- uninterpreted functions rather than making new ones - Just st_global -> case MapF.lookup (Qu.AsSingle sne) (pg ^. (syncData dp . syncBindings)) of + Just st_global -> case MapF.lookup sne (pg ^. (syncData dp . syncBindings)) of Just (PS.AbsT bindsSpec_prev) -> do binds_prev <- liftIO $ PS.bindSpec sym (PS.scopeVarsPair scope) bindsSpec_prev return ((st_global, binds_prev), pg) Nothing -> fail $ "Missing binding information for node: " ++ show sne Nothing -> do (PS.PopT st_global, binds) <- PFn.init sym (PS.PopT st) - let pg' = pg & (syncData dp . syncStates) %~ MapF.insert (Qu.AsSingle sne) st_global + let pg' = pg & (syncData dp . syncStates) %~ MapF.insert sne st_global (binds', pg'') <- addFnBindings sym scope sne binds pg' return $ ((st_global, binds'), pg'') where - dp = singleNodeDivergePoint sne - bin = singleNodeRepr sne + dp = singleNodeDivergence sne + bin = singleEntryBin sne st :: PS.SimState sym arch v bin st = PS.simVarState $ case bin of @@ -674,6 +675,17 @@ handleKnownDesync priority ne blkt = fmap (fromMaybe False) $ tryPG $ do return True False -> return False +-- | Queue all the sync points to be processed (merged) for a given +-- divergence +getAllSyncPoints :: + GraphNode arch -> + PairGraphM sym arch [PPa.PatchPair (SyncPoint arch)] +getAllSyncPoints nd = do + syncsO <- getSyncData syncPoints PBi.OriginalRepr nd + syncsP <- getSyncData syncPoints PBi.PatchedRepr nd + forM (Set.toList (Set.cartesianProduct syncsO syncsP)) $ \(sO,sP) -> do + return $ PPa.PatchPair sO sP + -- | Combine two single-sided nodes into a 'WorkItem' to process their -- merge. Returns 'Nothing' if the two single-sided nodes have different -- divergence points. diff --git a/src/Pate/Verification/StrongestPosts.hs b/src/Pate/Verification/StrongestPosts.hs index b82a02af..13052c63 100644 --- a/src/Pate/Verification/StrongestPosts.hs +++ b/src/Pate/Verification/StrongestPosts.hs @@ -597,12 +597,48 @@ initSingleSidedDomain sne pg0 = withPG_ pg0 $ do let dom_single_spec = PS.mkSimSpec scope dom_single liftPG $ modify $ \pg -> initDomain pg nd nd_single (priority PriorityHandleDesync) dom_single_spec -} + sne_other <- toSingleNodeEntry (PBi.flipRepr bin) ne + bundle <- lift $ noopBundle scope (graphNodeBlocks nd) - liftEqM_ $ \pg -> do - pr <- currentPriority - atPriority (raisePriority pr) (Just "Starting Split Analysis") $ - withGraphNode' scope nd bundle dom pg $ - widenAlongEdge scope bundle nd dom_single pg nd_single + mbindsThis <- lift $ lookupFnBindings scope sne pg0 + mbindsOther <- lift $ lookupFnBindings scope sne_other pg0 + + + + let do_widen pg = do + pr <- currentPriority + atPriority (raisePriority pr) (Just "Starting Split Analysis") $ + withGraphNode' scope nd bundle dom pg $ + widenAlongEdge scope bundle nd dom_single pg nd_single + + let rewrite_assert exprBinds pg = case getCondition pg nd ConditionAsserted of + Just condSpec -> do + cond <- liftIO $ PS.bindSpec sym (PS.scopeVarsPair scope) condSpec + cond' <- PSi.applySimpStrategy (PSi.rewriteStrategy exprBinds) cond + let condSpec' = PS.mkSimSpec scope cond' + return $ setCondition nd ConditionAsserted PropagateFull condSpec' pg + Nothing -> return pg + + case (mbindsThis, mbindsOther) of + + (Just bindsThis, Just bindsOther) -> do + binds <- IO.liftIO $ WEH.mergeBindings sym (PFn.toExprBindings bindsThis) (PFn.toExprBindings bindsOther) + liftEqM_ $ \pg -> (withAssumptionSet (PAS.fromExprBindings binds) $ do_widen pg) >>= rewrite_assert binds + (Just{}, Nothing) -> do + pr <- lift $ currentPriority + -- Should we lower the priority here? Is it possible to get caught in a loop otherwise? + -- Formally we should be able to find all relevant nodes based on which bindings + -- we're missing + liftPG $ getAllSyncPoints nd >>= \syncs -> forM_ syncs $ \syncPair -> do + sp <- PPa.get (PBi.flipRepr bin) syncPair + modify $ queueAncestors pr (GraphNode $ singleToNodeEntry (syncPointNode sp)) + + (Nothing, Just bindsOther) -> do + let binds = PFn.toExprBindings bindsOther + liftEqM_ $ \pg -> + (withAssumptionSet (PAS.fromExprBindings binds) $ do_widen pg) >>= rewrite_assert binds + (Nothing, Nothing) -> liftEqM_ do_widen + return (PS.WithScope ()) withGraphNode' :: @@ -1448,8 +1484,18 @@ withConditionsAssumed :: EquivM_ sym arch (PairGraph sym arch) -> EquivM sym arch (PairGraph sym arch) withConditionsAssumed scope bundle d node gr0 f = do - foldr go f [minBound..maxBound] + foldr go f' [minBound..maxBound] where + f' = withSym $ \sym -> case node of + GraphNode ne | Just (Some sne) <- asSingleNodeEntry ne -> + lookupFnBindings scope sne gr0 >>= \case + Just binds -> do + bindsPred <- IO.liftIO $ PFn.toPred sym binds + emitTraceLabel @"expr" "Bindings" (Some bindsPred) + withAssumption bindsPred $ f + Nothing -> f + _ -> f + go condK g = withSatConditionAssumed scope bundle d node condK gr0 g diff --git a/src/Pate/Verification/Widening.hs b/src/Pate/Verification/Widening.hs index 711ad0d6..14ba3ba0 100644 --- a/src/Pate/Verification/Widening.hs +++ b/src/Pate/Verification/Widening.hs @@ -810,6 +810,68 @@ isEqCondSingleSided scope blks bin eqCond = withSym $ \sym -> do conds_eq <- liftIO $ W4.isEq sym eqCond_pred eqCond2_pred isPredTrue' goalTimeout conds_eq +-- FIXME: the scope of the path condition isn't explicitly +-- maintained, so we assume it here. +-- We could check if the predicate is well-scoped +scopedPathCondition :: + PS.SimScope sym arch v -> + EquivM sym arch (PS.ScopedExpr sym W4.BaseBoolType v) +scopedPathCondition _scope = withSym $ \sym -> do + pathCond <- CMR.asks envPathCondition >>= PAs.toPred sym + Some scopedPathCond <- return $ PS.mkScopedExpr pathCond + return $ PS.unsafeCoerceScope scopedPathCond + +propagateBindings :: + forall sym arch v. + PS.SimScope sym arch v -> + SimBundle sym arch v -> + GraphNode arch {- ^ from -} -> + GraphNode arch {- ^ to -} -> + PairGraph sym arch -> + EquivM sym arch (Maybe (PairGraph sym arch)) +propagateBindings scope bundle from to gr0 = withSym $ \sym -> case (from,to) of + (GraphNode fromE, GraphNode toE) + | Just (Some fromSNE) <- asSingleNodeEntry fromE + , Just (Some toSNE) <- asSingleNodeEntry toE + -- nodes are both single-sided and the same side + , Just Refl <- testEquality (singleEntryBin fromSNE) (singleEntryBin toSNE) + -- nodes have the same divergence point + , fromDP <- singleNodeDivergePoint fromSNE + , dp <- singleNodeDivergePoint toSNE + , fromDP == dp + -- 'to' node has defined bindings that need to be propagated + , Just (PS.AbsT toBindsSpec) <- MapF.lookup toSNE (gr0 ^. (syncData dp . syncBindings)) + -> do + let outVars = PS.bundleOutVars scope bundle + toBinds <- liftIO $ PS.bindSpec sym outVars toBindsSpec + lookupFnBindings scope fromSNE gr0 >>= \case + -- 'from' has existing binds so we check if we actually need to propagate + -- FIXME: can we check this without the solver? do we need to check it? + Just fromBinds -> do + emitTrace @"debug" "Propagating and merging with existing bindings" + fromBindsPred <- IO.liftIO $ PFn.toPred sym fromBinds + withAssumption fromBindsPred $ do + toBindsPred <- IO.liftIO $ PFn.toPred sym toBinds + not_toBindsPred <- liftIO $ W4.notPred sym toBindsPred + goalTimeout <- CMR.asks (PC.cfgGoalTimeout . envConfig) + isPredSat' goalTimeout not_toBindsPred >>= \case + Just False -> do + emitTraceLabel @"expr" (ExprLabel $ "Proved bindings") (Some toBindsPred) + return Nothing + _ -> do + -- FIXME: use 'addFnBindings' instead? needs to take a mux condition + pathCond <- scopedPathCondition scope + bindsCombined <- IO.liftIO $ PFn.mux sym pathCond toBinds fromBinds + return $ Just $ gr0 & (syncData dp . syncBindings) %~ MapF.insert fromSNE (PS.AbsT $ PS.mkSimSpec scope bindsCombined) + -- 'from' has no binds so we propagate unconditionally + Nothing -> do + -- FIXME: do we care about the path condition here? + emitTrace @"debug" "Propagating bindings" + return $ Just $ gr0 & (syncData dp . syncBindings) %~ MapF.insert fromSNE (PS.AbsT $ PS.mkSimSpec scope toBinds) + _ -> do + emitTrace @"debug" "No bindings to propagate" + return Nothing + -- | Propagate the given condition kind backwards (from 'to' node to 'from' node). -- Does not do any other graph maintenance (i.e. dropping stale domains or re-queuing nodes) propagateOne :: @@ -873,10 +935,16 @@ propagateCondition scope bundle from to gr0_ = fnTrace "propagateCondition" $ do (upd1, gr1) <- maybeUpdate' gr0_ $ go ConditionAsserted gr0_ (upd2, gr2) <- maybeUpdate' gr1 $ go ConditionAssumed gr1 (upd3, gr3) <- maybeUpdate' gr2 $ go ConditionEquiv gr2 - case upd1 || upd2 || upd3 of + (upd4, gr4) <- maybeUpdate' gr3 $ propagateBindings scope bundle from to gr3 >>= \case + Nothing -> return Nothing + Just gr' -> do + priority <- thisPriority + return $ Just $ queueAncestors (priority PriorityPropagation) from (markEdge from to gr') + case upd1 || upd2 || upd3 || upd4 of False -> return Nothing - True -> return $ Just gr3 + True -> return $ Just gr4 where + go condK gr = propagateOne scope bundle from to condK gr >>= \case Nothing -> return Nothing Just gr' -> do @@ -951,6 +1019,7 @@ widenAlongEdge scope bundle from d gr0 to = withSym $ \sym -> do md <- widenPostcondition scope bundle d d' case md of NoWideningRequired -> do + emitTrace @"debug" "NoWideningRequired" emitTraceLabel @"domain" PAD.Postdomain (Some d') postSpec' <- abstractOverVars scope bundle from to postSpec d' let gr1 = initDomain gr from to (priority PriorityWidening) postSpec' @@ -960,7 +1029,8 @@ widenAlongEdge scope bundle from d gr0 to = withSym $ \sym -> do err <- emitError' (PEE.WideningError msg') postSpec' <- abstractOverVars scope bundle from to postSpec d'' return $ recordMiscAnalysisError (initDomain gr from to (priority PriorityWidening) postSpec') to err - Widen _ _ d'' -> do + Widen wk _ d'' -> do + emitTrace @"debug" (show wk) emitTraceLabel @"domain" PAD.Postdomain (Some d'') postSpec' <- abstractOverVars scope bundle from to postSpec d'' let gr1 = initDomain gr from to (priority PriorityWidening) postSpec' @@ -986,6 +1056,7 @@ widenAlongEdge scope bundle from d gr0 to = withSym $ \sym -> do md <- widenPostcondition scope bundle d d' case md of NoWideningRequired -> do + emitTrace @"debug" "NoWideningRequired" traceBundle bundle "Did not need to widen" emitTraceLabel @"domain" PAD.Postdomain (Some d') finalizeGraphEdge scope bundle d d' from to gr @@ -1000,7 +1071,8 @@ widenAlongEdge scope bundle from d gr0 to = withSym $ \sym -> do return $ recordMiscAnalysisError gr' to err Right gr' -> return $ recordMiscAnalysisError gr' to err - Widen _ _ d'' -> do + Widen wk _ d'' -> do + emitTrace @"debug" (show wk) emitTraceLabel @"domain" PAD.Postdomain (Some d'') postSpec' <- abstractOverVars scope bundle from to postSpec d'' case updateDomain gr from to postSpec' (priority PriorityWidening) of From 815762237040b9830524b69b70e233c39da5dd43 Mon Sep 17 00:00:00 2001 From: Daniel Matichuk Date: Wed, 11 Dec 2024 16:13:39 -0800 Subject: [PATCH 15/36] more Quant refinements --- src/Pate/Monad/PairGraph.hs | 6 ++++-- src/Pate/SimulatorRegisters.hs | 7 ------- src/Pate/Verification/PairGraph.hs | 26 ++++++++++++------------- src/Pate/Verification/StrongestPosts.hs | 17 +++++++++++----- 4 files changed, 29 insertions(+), 27 deletions(-) diff --git a/src/Pate/Monad/PairGraph.hs b/src/Pate/Monad/PairGraph.hs index f6726cfd..0b207339 100644 --- a/src/Pate/Monad/PairGraph.hs +++ b/src/Pate/Monad/PairGraph.hs @@ -70,6 +70,8 @@ import qualified Prettyprinter as PP import qualified What4.Interface as W4 import qualified Pate.Verification.FnBindings as PFn import qualified What4.Concrete as W4 +import qualified Data.Quant as Qu + instance IsTraceNode (k :: l) "pg_trace" where type TraceNodeType k "pg_trace" = [String] @@ -329,10 +331,10 @@ runPendingActions lens edge result pg0 = do lookupFnBindings :: PS.SimScope sym arch v -> - SingleNodeEntry arch bin -> + SingleGraphNode arch bin -> PairGraph sym arch -> EquivM sym arch (Maybe (PFn.FnBindings sym bin v)) -lookupFnBindings scope sne pg = withSym $ \sym -> case MapF.lookup sne (pg ^. (syncData dp . syncBindings)) of +lookupFnBindings scope sne pg = withSym $ \sym -> case MapF.lookup (Qu.AsSingle sne) (pg ^. (syncData dp . syncBindings)) of Just (PS.AbsT bindsSpec) -> Just <$> (IO.liftIO $ PS.bindSpec sym (PS.scopeVarsPair scope) bindsSpec) Nothing -> return Nothing where diff --git a/src/Pate/SimulatorRegisters.hs b/src/Pate/SimulatorRegisters.hs index dba2e73a..4f2117ed 100644 --- a/src/Pate/SimulatorRegisters.hs +++ b/src/Pate/SimulatorRegisters.hs @@ -98,13 +98,6 @@ data MacawRegVar sym (tp :: MT.Type) where , macawVarBVs :: Ctx.Assignment (WI.SymExpr sym) (CrucBaseTypes (MS.ToCrucibleType tp)) } -> MacawRegVar sym tp -instance PEM.ExprFoldable sym (MacawRegVar sym tp) where - foldExpr sym f entry b = PEM.withSymExprFoldable sym $ - PEM.foldExpr sym f (macawVarBVs entry) b >>= PEM.foldExpr sym f (macawVarEntry entry) - - -instance forall sym. PEM.ExprFoldableF sym (MacawRegVar sym) - instance (WI.IsExpr (WI.SymExpr sym)) => Show (MacawRegEntry sym tp) where show (MacawRegEntry repr v) = case repr of CLM.LLVMPointerRepr{} | CLM.LLVMPointer rg bv <- v -> show (WI.printSymNat rg) ++ "+" ++ show (WI.printSymExpr bv) diff --git a/src/Pate/Verification/PairGraph.hs b/src/Pate/Verification/PairGraph.hs index d446545e..71fb0332 100644 --- a/src/Pate/Verification/PairGraph.hs +++ b/src/Pate/Verification/PairGraph.hs @@ -530,30 +530,30 @@ getSingleNodeData :: HasCallStack => (OrdF x, Ord (x bin)) => L.Lens' (SyncData sym arch) (PPa.PatchPair (SetF x)) -> - SingleNodeEntry arch bin -> + SingleGraphNode arch bin -> PairGraphM sym arch (Set (x bin)) getSingleNodeData lens sne = - getPG $ syncDataSet (singleNodeDivergePoint sne) (singleEntryBin sne) lens + getPG $ syncDataSet (singleNodeDivergePoint sne) (singleNodeRepr sne) lens addFnBindings :: sym ~ W4B.ExprBuilder s st fs => PA.ValidArch arch => sym -> PS.SimScope sym arch v -> - SingleNodeEntry arch bin -> + SingleGraphNode arch bin -> PFn.FnBindings sym bin v -> PairGraph sym arch -> IO (PFn.FnBindings sym bin v, PairGraph sym arch) -addFnBindings sym scope sne binds pg = case MapF.lookup sne (pg ^. (syncData dp . syncBindings)) of +addFnBindings sym scope sne binds pg = case MapF.lookup (Qu.AsSingle sne) (pg ^. (syncData dp . syncBindings)) of Just (PS.AbsT bindsSpec_prev) -> do binds_prev <- liftIO $ PS.bindSpec sym (PS.scopeVarsPair scope) bindsSpec_prev binds' <- case PFn.merge binds binds_prev of Just binds' -> return binds' Nothing -> fail "addFnBindings: unexpected binding clash" - return $ (binds', pg & (syncData dp . syncBindings) %~ MapF.insert sne (PS.AbsT $ PS.mkSimSpec scope binds')) - Nothing -> return $ (binds, pg & (syncData dp . syncBindings) %~ MapF.insert sne (PS.AbsT $ PS.mkSimSpec scope binds)) + return $ (binds', pg & (syncData dp . syncBindings) %~ MapF.insert (Qu.AsSingle sne) (PS.AbsT $ PS.mkSimSpec scope binds')) + Nothing -> return $ (binds, pg & (syncData dp . syncBindings) %~ MapF.insert (Qu.AsSingle sne) (PS.AbsT $ PS.mkSimSpec scope binds)) where - dp = singleNodeDivergence sne + dp = singleNodeDivergePoint sne -- | Retrieve the final state that binds the given scope to instead be @@ -566,26 +566,26 @@ initFnBindings :: PA.ValidArch arch => sym -> PS.SimScope sym arch v -> - SingleNodeEntry arch bin -> + SingleGraphNode arch bin -> PairGraph sym arch -> IO ((PS.SimState sym arch PS.GlobalScope bin, PFn.FnBindings sym bin v), PairGraph sym arch) initFnBindings sym scope sne pg = do - case MapF.lookup sne (pg ^. (syncData dp . syncStates)) of + case MapF.lookup (Qu.AsSingle sne) (pg ^. (syncData dp . syncStates)) of -- if we already have a 'syncState' entry, then we should re-use those -- uninterpreted functions rather than making new ones - Just st_global -> case MapF.lookup sne (pg ^. (syncData dp . syncBindings)) of + Just st_global -> case MapF.lookup (Qu.AsSingle sne) (pg ^. (syncData dp . syncBindings)) of Just (PS.AbsT bindsSpec_prev) -> do binds_prev <- liftIO $ PS.bindSpec sym (PS.scopeVarsPair scope) bindsSpec_prev return ((st_global, binds_prev), pg) Nothing -> fail $ "Missing binding information for node: " ++ show sne Nothing -> do (PS.PopT st_global, binds) <- PFn.init sym (PS.PopT st) - let pg' = pg & (syncData dp . syncStates) %~ MapF.insert sne st_global + let pg' = pg & (syncData dp . syncStates) %~ MapF.insert (Qu.AsSingle sne) st_global (binds', pg'') <- addFnBindings sym scope sne binds pg' return $ ((st_global, binds'), pg'') where - dp = singleNodeDivergence sne - bin = singleEntryBin sne + dp = singleNodeDivergePoint sne + bin = singleNodeRepr sne st :: PS.SimState sym arch v bin st = PS.simVarState $ case bin of diff --git a/src/Pate/Verification/StrongestPosts.hs b/src/Pate/Verification/StrongestPosts.hs index 13052c63..b1419958 100644 --- a/src/Pate/Verification/StrongestPosts.hs +++ b/src/Pate/Verification/StrongestPosts.hs @@ -144,6 +144,7 @@ import Data.Parameterized.PairF (PairF(..)) import qualified What4.Concrete as W4 import Data.Parameterized (Pair(..)) import qualified Pate.Verification.FnBindings as PFn +import Data.Parameterized.WithRepr (withRepr) -- Overall module notes/thoughts -- @@ -578,13 +579,17 @@ addImmediateEqDomRefinementChoice nd preD gr0 = do -- If there is no single-sided domain, then it is initialized to be the split -- version of the two-sided analysis. initSingleSidedDomain :: + forall sym arch bin. SingleNodeEntry arch bin -> PairGraph sym arch -> EquivM sym arch (PairGraph sym arch) -initSingleSidedDomain sne pg0 = withPG_ pg0 $ do +initSingleSidedDomain sne pg0 = withRepr bin $ withSym $ \sym -> withPG_ pg0 $ do priority <- lift $ thisPriority - let bin = singleEntryBin sne - let nd = singleNodeDivergence sne + + let nd = singleNodeDivergePoint (GraphNode sne) + nd' <- case Qu.convertQuant nd of + Just (nd' :: GraphNode' arch Qu.AllK) -> return nd' + Nothing -> fail $ "Unexpected single-sided diverge point: " ++ show nd let nd_single = GraphNode (singleToNodeEntry sne) dom_spec <- liftPG $ getCurrentDomainM nd PS.forSpec dom_spec $ \scope dom -> do @@ -597,10 +602,10 @@ initSingleSidedDomain sne pg0 = withPG_ pg0 $ do let dom_single_spec = PS.mkSimSpec scope dom_single liftPG $ modify $ \pg -> initDomain pg nd nd_single (priority PriorityHandleDesync) dom_single_spec -} - sne_other <- toSingleNodeEntry (PBi.flipRepr bin) ne + let (sne_other :: SingleGraphNode arch (PBi.OtherBinary bin)) = Qu.coerceQuant nd' bundle <- lift $ noopBundle scope (graphNodeBlocks nd) - mbindsThis <- lift $ lookupFnBindings scope sne pg0 + mbindsThis <- lift $ lookupFnBindings scope (GraphNode sne) pg0 mbindsOther <- lift $ lookupFnBindings scope sne_other pg0 @@ -640,6 +645,8 @@ initSingleSidedDomain sne pg0 = withPG_ pg0 $ do (Nothing, Nothing) -> liftEqM_ do_widen return (PS.WithScope ()) + where + bin = singleNodeRepr (GraphNode sne) withGraphNode' :: PS.SimScope sym arch v -> From 1ed1b2cccc4cf80df081bd849fe9e7d44249294d Mon Sep 17 00:00:00 2001 From: Daniel Matichuk Date: Wed, 11 Dec 2024 16:14:51 -0800 Subject: [PATCH 16/36] pull in rewriteStrategy --- src/Pate/Verification/Simplify.hs | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/src/Pate/Verification/Simplify.hs b/src/Pate/Verification/Simplify.hs index 62714b5a..d2813685 100644 --- a/src/Pate/Verification/Simplify.hs +++ b/src/Pate/Verification/Simplify.hs @@ -22,6 +22,7 @@ module Pate.Verification.Simplify ( , coreStrategy , applySimpStrategy , unfoldDefsStrategy + , rewriteStrategy ) where import Control.Monad (foldM) @@ -46,6 +47,7 @@ import What4.ExprHelpers (Simplifier, SimpStrategy) import Pate.TraceTree import qualified Data.Set as Set import Pate.AssumptionSet +import qualified Data.Parameterized.Map as MapF -- | Under the current assumptions, attempt to collapse a predicate -- into either trivially true or false @@ -304,3 +306,10 @@ emitIfChanged :: emitIfChanged msg e1 e2 = case W4.testEquality e1 e2 of Just W4.Refl -> return () Nothing -> emitTraceLabel @"expr" msg (Some e2) >> return () + +type ExprBindings sym = MapF.MapF (W4.SymExpr sym) (W4.SymExpr sym) + +rewriteStrategy :: ExprBindings sym -> SimpStrategy sym (EquivM_ sym arch) +rewriteStrategy binds = WEH.joinStrategy $ withValid $ return $ WEH.SimpStrategy $ \sym _check -> do + cache <- IO.liftIO $ WEH.freshVarBindCache + return $ WEH.Simplifier $ \e -> IO.liftIO $ WEH.applyExprBindings' sym cache binds e From 43c87542ca0781058396b1c71a3653a0648a482b Mon Sep 17 00:00:00 2001 From: Daniel Matichuk Date: Fri, 13 Dec 2024 09:46:05 -0800 Subject: [PATCH 17/36] Data.Quant: misc interface changes --- src/Data/Parameterized/TotalMapF.hs | 1 + src/Data/Quant.hs | 284 +++++++++++++++++++++++++--- 2 files changed, 256 insertions(+), 29 deletions(-) diff --git a/src/Data/Parameterized/TotalMapF.hs b/src/Data/Parameterized/TotalMapF.hs index 9a3f4ccc..ce7add66 100644 --- a/src/Data/Parameterized/TotalMapF.hs +++ b/src/Data/Parameterized/TotalMapF.hs @@ -32,6 +32,7 @@ module Data.Parameterized.TotalMapF , zip , mapWithKey , traverseWithKey + , toList ) where import Prelude hiding ( zip ) diff --git a/src/Data/Quant.hs b/src/Data/Quant.hs index cc1e9b87..b45c9d19 100644 --- a/src/Data/Quant.hs +++ b/src/Data/Quant.hs @@ -38,6 +38,7 @@ are generalized over concrete, existential and universal quantification. {-# LANGUAGE EmptyCase #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE TypeFamilyDependencies #-} module Data.Quant ( @@ -68,12 +69,27 @@ module Data.Quant , QuantEach , pattern QuantEach , AsSingle(..) + , toSingleQuant + , pattern SomeSingle + , coerceToExists + , KnownConversion + , KnownCoercion + , pattern CoerceToExists + , Exists + , pattern Exists + , pattern ExistsOne + , pattern ExistsAll + , IsExistsOr(..) + , TheOneK + , IfIsOneK + , coerceExists ) where import Prelude hiding (map, traverse) import Data.Kind (Type) import Data.Constraint +import qualified Data.List as List import Data.Functor.Const import Data.Proxy @@ -84,6 +100,7 @@ import Data.Parameterized.Some import qualified Data.Parameterized.TotalMapF as TMF import Data.Parameterized.TotalMapF ( TotalMapF, HasTotalMapF ) import Data.Parameterized.WithRepr +import qualified Data.Parameterized.Map as MapF -- | Wraps the kind 'k' with additional cases for existential and -- universal quantification @@ -291,8 +308,21 @@ instance (HasReprK k, forall x. Ord (f x)) => Ord (Quant (f :: k -> Type) tp) wh data QuantCoercion (t1 :: QuantK k) (t2 :: QuantK k) where CoerceAllToOne :: ReprOf x -> QuantCoercion AllK (OneK x) CoerceAllToExists :: QuantCoercion AllK ExistsK - CoerceOneToExists :: QuantCoercion (OneK x) ExistsK - CoerceRefl :: QuantCoercion x x + CoerceOneToExists :: ReprOf x -> QuantCoercion (OneK x) ExistsK + CoerceRefl :: QuantRepr x -> QuantCoercion x x + + +pattern CoerceToExists :: forall t1 t2. () => (t2 ~ ExistsK) => QuantRepr t1 -> QuantCoercion t1 t2 +pattern CoerceToExists repr <- + ((\l -> case l of + CoerceAllToExists -> Just (QuantAllRepr, Refl) + CoerceOneToExists repr -> Just (QuantOneRepr repr, Refl) + CoerceRefl QuantSomeRepr -> Just (QuantSomeRepr, Refl) + _ -> Nothing) + -> Just (repr :: QuantRepr t1, Refl :: t2 :~: ExistsK)) + +{-# COMPLETE CoerceAllToOne, CoerceAllToExists, CoerceOneToExists, CoerceRefl #-} +{-# COMPLETE CoerceAllToOne, CoerceToExists, CoerceRefl #-} class QuantCoercible (f :: QuantK k -> Type) where applyQuantCoercion :: forall t1 t2. HasReprK k => QuantCoercion t1 t2 -> f t1 -> f t2 @@ -301,19 +331,25 @@ class QuantCoercible (f :: QuantK k -> Type) where coerceQuant :: forall t1 t2. (HasReprK k, KnownCoercion t1 t2) => f t1 -> f t2 coerceQuant = applyQuantCoercion knownRepr +coerceToExists :: forall {k} f (tp :: QuantK k). (HasReprK k, QuantCoercible f, KnownRepr QuantRepr tp) => f tp -> f ExistsK +coerceToExists x = case knownRepr :: QuantRepr tp of + QuantOneRepr repr -> applyQuantCoercion (CoerceOneToExists repr) x + QuantAllRepr -> applyQuantCoercion CoerceAllToExists x + QuantSomeRepr -> x + instance HasReprK k => IsRepr (QuantCoercion (t1 :: QuantK k)) where withRepr x f = case x of CoerceAllToOne repr -> withRepr repr $ f CoerceAllToExists -> f - CoerceOneToExists -> f - CoerceRefl -> f + CoerceOneToExists repr -> withRepr repr $ f + CoerceRefl qrepr -> withRepr qrepr $ f instance QuantCoercible (Quant (f :: k -> Type)) where applyQuantCoercion qc q = case (qc, q) of (CoerceAllToOne repr, QuantAll f) -> QuantOne repr (TMF.apply f repr) (CoerceAllToExists, QuantAll{}) -> QuantAny q - (CoerceOneToExists, QuantOne{}) -> QuantExists q - (CoerceRefl, _) -> q + (CoerceOneToExists{}, QuantOne{}) -> QuantExists q + (CoerceRefl{}, _) -> q type KnownCoercion (tp1 :: QuantK k) (tp2 :: QuantK k) = KnownRepr (QuantCoercion tp1) tp2 @@ -324,25 +360,18 @@ instance (KnownRepr (ReprOf :: k -> Type) (x :: k)) => KnownRepr (QuantCoercion instance KnownRepr (QuantCoercion AllK) ExistsK where knownRepr = CoerceAllToExists -instance KnownRepr (QuantCoercion (OneK x)) ExistsK where - knownRepr = CoerceOneToExists - -instance KnownRepr (QuantCoercion x) x where - knownRepr = CoerceRefl +instance KnownRepr ReprOf x => KnownRepr (QuantCoercion (OneK x)) ExistsK where + knownRepr = CoerceOneToExists knownRepr +instance KnownRepr QuantRepr tp => KnownRepr (QuantCoercion tp) tp where + knownRepr = CoerceRefl knownRepr data QuantConversion (t1 :: QuantK k) (t2 :: QuantK k) where - ConvertWithCoerce :: QuantCoercion t1 t2 -> QuantConversion t1 t2 ConvertExistsToAll :: QuantConversion ExistsK AllK ConvertExistsToOne :: ReprOf x -> QuantConversion ExistsK (OneK x) instance HasReprK k => IsRepr (QuantConversion (t1 :: QuantK k)) where withRepr x f = case x of - ConvertWithCoerce y -> case y of - CoerceAllToOne repr -> withRepr repr $ f - CoerceAllToExists -> f - CoerceOneToExists -> f - CoerceRefl -> f ConvertExistsToAll -> f ConvertExistsToOne repr -> withRepr repr $ f @@ -353,19 +382,75 @@ class QuantConvertible (f :: QuantK k -> Type) where convertQuant :: forall t1 t2. (HasReprK k, KnownConversion t1 t2) => f t1 -> Maybe (f t2) convertQuant = applyQuantConversion knownRepr -type KnownConversion (tp1 :: QuantK k) (tp2 :: QuantK k) = KnownRepr (QuantConversion tp1) tp2 - -instance (KnownRepr (ReprOf :: k -> Type) (x :: k)) => KnownRepr (QuantConversion AllK) (OneK x) where - knownRepr = ConvertWithCoerce knownRepr +findFirst :: (a -> Maybe b) -> [a] -> Maybe b +findFirst _ [] = Nothing +findFirst f (x:xs) = case f x of + Just y -> Just y + Nothing -> findFirst f xs + +data MaybeF f tp = JustF (f tp) | NothingF + +-- | Project out a 'Quant' of singletons from a given 'f' parameterized by 'QuantK k'. +-- Uses the 'QuantCoercible' and 'QuantConvertible' instances to attempt to coerce/convert +-- 'f' into each possible single value. +toSingleQuant :: + forall {k} f (tp :: QuantK k). + ( HasReprK k + , QuantCoercible f + , QuantConvertible f + , KnownRepr QuantRepr tp) => + f tp -> + Maybe (Quant (AsSingle f) tp) +toSingleQuant f = case knownRepr :: QuantRepr tp of + QuantOneRepr repr -> Just $ Single repr (AsSingle f) + QuantAllRepr -> Just $ All (\r -> AsSingle $ applyQuantCoercion (CoerceAllToOne r) f) + QuantSomeRepr -> case applyQuantConversion ConvertExistsToAll f of + Just f' -> QuantAny <$> toSingleQuant f' + Nothing -> + let y = TMF.mapWithKey + (\r _ -> case applyQuantConversion (ConvertExistsToOne r) f of + Just x -> JustF (AsSingle x) + Nothing -> NothingF) + (allReprs :: TMF.TotalMapF (ReprOf :: k -> Type) (Const ())) + in case TMF.traverseWithKey (\_ -> \case JustF x -> Just x; NothingF -> Nothing) y of + -- if we can convert to each individual singleton, then we can take all of the results and turn this into a QuantAll + -- (i.e. likely all of the inner Quants are QuantAny, and so can be converted to any single value) + Just z -> Just (QuantAny $ QuantAll z) + -- otherwise we just take the first successful conversion + Nothing -> findFirst + (\(MapF.Pair repr x) -> case x of + JustF (AsSingle z) -> Just (QuantExists $ QuantOne repr (AsSingle z)) + NothingF -> Nothing) + (TMF.toList y) + +data SomeSingle f tp where + SomeSingleCtor :: (IsExistsOr tp (OneK (TheOneK tp)), IfIsOneK tp (x ~ TheOneK tp)) => ReprOf x -> f (OneK x) -> SomeSingle f tp + +toSomeSingle :: HasReprK k => Quant (AsSingle f) (tp :: QuantK k) -> Maybe (SomeSingle f tp) +toSomeSingle = \case + QuantExists (QuantOne repr (AsSingle x)) -> Just $ SomeSingleCtor repr x + QuantOne repr (AsSingle x) -> Just $ SomeSingleCtor repr x + _ -> Nothing + +pattern SomeSingle :: + forall {k} (f :: QuantK k -> Type) (tp :: QuantK k). + ( HasReprK k + , QuantCoercible f + , QuantConvertible f + , KnownRepr QuantRepr tp) => + forall (x :: k). (IsExistsOr tp (OneK (TheOneK tp)), IfIsOneK tp (x ~ TheOneK tp)) => + ReprOf x -> + f (OneK x) -> + f tp +pattern SomeSingle repr x <- ((\l -> toSingleQuant l >>= toSomeSingle) -> (Just (SomeSingleCtor repr x))) + where + SomeSingle repr x = case (isExistsOr :: ExistsOrCases tp (OneK (TheOneK tp))) of + ExistsOrExists -> withRepr repr $ coerceQuant x + ExistsOrRefl -> x -instance KnownRepr (QuantConversion AllK) ExistsK where - knownRepr = ConvertWithCoerce knownRepr -instance KnownRepr (QuantConversion (OneK x)) ExistsK where - knownRepr = ConvertWithCoerce knownRepr +type KnownConversion (tp1 :: QuantK k) (tp2 :: QuantK k) = KnownRepr (QuantConversion tp1) tp2 -instance KnownRepr (QuantConversion x) x where - knownRepr = ConvertWithCoerce knownRepr instance KnownRepr (QuantConversion ExistsK) AllK where knownRepr = ConvertExistsToAll @@ -376,7 +461,6 @@ instance (KnownRepr (ReprOf :: k -> Type) (x :: k)) => KnownRepr (QuantConversio instance QuantConvertible (Quant (f :: k -> Type)) where applyQuantConversion qc q = case (qc, q) of - (ConvertWithCoerce qc', _) -> Just (applyQuantCoercion qc' q) (ConvertExistsToAll, QuantAny q') -> Just q' (ConvertExistsToAll, QuantExists{}) -> Nothing (ConvertExistsToOne repr, QuantAny q') -> Just (applyQuantCoercion (CoerceAllToOne repr) q') @@ -535,4 +619,146 @@ _testQuantEach = \case _testQuantEach1 :: HasReprK k => Quant (AsSingle (f :: QuantK k -> Type)) AllK -> () _testQuantEach1 = \case QuantEach (_f :: forall (x :: k). ReprOf x -> f (OneK x)) -> () - -- complete match, since Single has an unsolvable constraint \ No newline at end of file + -- complete match, since Single has an unsolvable constraint + +instance HasTotalMapF (ReprOf :: k -> Type) => HasTotalMapF (QuantRepr :: QuantK k -> Type) where + allValues = (Some QuantAllRepr:Some QuantSomeRepr:List.map (\(Some r) -> Some (QuantOneRepr r)) TMF.allValues) + +instance HasReprK k => HasReprK (QuantK k) where + type ReprOf = QuantRepr + + +-- | Augment a type with an existential case +data Exists f (tp :: QuantK k) where + TheOne :: ReprOf x -> f (OneK x) -> Exists f (OneK x) + TheAll :: f AllK -> Exists f AllK + ExistsOneCtor :: ReprOf x -> f (OneK x) -> Exists f ExistsK + ExistsAllCtor :: f AllK -> Exists f ExistsK + +instance (HasReprK k, forall (x :: QuantK k). Eq (f x)) => Eq (Exists f tp) where + a == b = case (a, b) of + (TheOne _ a', TheOne _ b') -> a' == b' + (ExistsOneCtor repra a', ExistsOneCtor reprb b') -> case testEquality repra reprb of + Just Refl -> a' == b' + Nothing -> False + (TheAll a', TheAll b') -> a' == b' + (ExistsAllCtor a', ExistsAllCtor b') -> a' == b' + _ -> False + +instance (HasReprK k, forall (x :: QuantK k). Ord (f x)) => Ord (Exists f tp) where + compare a b = case (a, b) of + (ExistsOneCtor repra a', ExistsOneCtor reprb b') -> case compareF repra reprb of + EQF -> compare a' b' + LTF -> LT + GTF -> GT + (ExistsAllCtor a', ExistsAllCtor b') -> compare a' b' + (TheOne _ a', TheOne _ b') -> compare a' b' + (TheAll a', TheAll b') -> compare a' b' + + (ExistsOneCtor{}, ExistsAllCtor{}) -> LT + (ExistsAllCtor{}, ExistsOneCtor{}) -> GT + +data ExistsOneProof f tp where + ExistsOneProof :: (IsExistsOr tp (OneK (TheOneK tp)), IfIsOneK tp (x ~ (TheOneK tp))) => ReprOf x -> f (OneK x) -> ExistsOneProof f tp + +existsOne :: HasReprK k => Exists f (tp :: QuantK k) -> Maybe (ExistsOneProof f tp) +existsOne = \case + TheOne repr x -> Just $ ExistsOneProof repr x + ExistsOneCtor repr x -> Just $ ExistsOneProof repr x + _ -> Nothing + +pattern ExistsOne :: + forall {k} f (tp :: QuantK k). + (HasReprK k) => + forall x. (IsExistsOr tp (OneK (TheOneK tp)), IfIsOneK tp (x ~ TheOneK tp)) => + ReprOf x -> + f (OneK x) -> + Exists f tp +pattern ExistsOne repr x <- (existsOne -> Just (ExistsOneProof repr x)) + where + ExistsOne repr x = existsOrCases @tp @(OneK (TheOneK tp)) (ExistsOneCtor repr x) (TheOne repr x) + +data ExistsAllProof f tp where + ExistsAllProof :: (KnownRepr QuantRepr tp, IsExistsOr tp AllK) => f AllK -> ExistsAllProof f tp + +existsAll :: Exists f tp -> Maybe (ExistsAllProof f tp) +existsAll = \case + TheAll x -> Just $ ExistsAllProof x + ExistsAllCtor x -> Just $ ExistsAllProof x + _ -> Nothing + +pattern ExistsAll :: forall f tp. () => (KnownRepr QuantRepr tp, IsExistsOr tp AllK) => f AllK -> Exists f tp +pattern ExistsAll x <- (existsAll -> Just (ExistsAllProof x)) + where + ExistsAll x = existsOrCases @tp @AllK (ExistsAllCtor x) (TheAll x) + +{-# COMPLETE ExistsOne, ExistsAll #-} + + +data ExistsProof f tp where + ExistsProof :: (IsExistsOr tp tp', NotExists tp') => QuantRepr tp' -> f tp' -> ExistsProof f tp + +existsProof :: Exists f tp -> ExistsProof f tp +existsProof = \case + TheOne repr x -> ExistsProof (QuantOneRepr repr) x + TheAll x -> ExistsProof QuantAllRepr x + ExistsAllCtor x -> ExistsProof QuantAllRepr x + ExistsOneCtor repr x -> ExistsProof (QuantOneRepr repr) x + +type family NotExists (tp :: QuantK k) :: Constraint where + NotExists ExistsK = True ~ False + NotExists _ = () + +pattern Exists :: forall f tp. () => forall tp'. (IsExistsOr tp tp', NotExists tp') => QuantRepr tp' -> f tp' -> Exists f tp +pattern Exists repr x <- (existsProof -> ExistsProof repr x) + where + Exists (repr :: QuantRepr tp') x = case repr of + QuantOneRepr repr' -> existsOrCases @tp @tp' (ExistsOneCtor repr' x) (TheOne repr' x) + QuantAllRepr -> existsOrCases @tp @tp' (ExistsAllCtor x) (TheAll x) + +coerceExists :: Exists f tp -> Exists f ExistsK +coerceExists e = case e of + TheOne repr x -> ExistsOneCtor repr x + TheAll x -> ExistsAllCtor x + ExistsAllCtor{} -> e + ExistsOneCtor{} -> e + +{-# COMPLETE Exists #-} + +instance QuantCoercible f => QuantCoercible (Exists f) where + applyQuantCoercion qc e = case (qc, e) of + (CoerceAllToExists, TheAll x) -> ExistsAllCtor x + (CoerceOneToExists{}, TheOne repr x) -> ExistsOneCtor repr x + (CoerceAllToOne repr, TheAll x) -> TheOne repr (applyQuantCoercion qc x) + (CoerceRefl{}, _) -> e + +instance QuantCoercible f => QuantConvertible (Exists f) where + applyQuantConversion qc e = case (qc, e) of + (ConvertExistsToAll, ExistsAllCtor x) -> Just $ TheAll x + (ConvertExistsToOne repr, ExistsOneCtor repr' x) -> case testEquality repr repr' of + Just Refl -> Just $ TheOne repr x + Nothing -> Nothing + (ConvertExistsToAll, ExistsOneCtor{}) -> Nothing + (ConvertExistsToOne repr, ExistsAllCtor x) -> Just $ TheOne repr (applyQuantCoercion (CoerceAllToOne repr) x) + + +instance FunctorFC Exists where + fmapFC f = \case + TheOne repr x -> TheOne repr (f x) + TheAll x -> TheAll (f x) + ExistsOneCtor repr x -> ExistsOneCtor repr (f x) + ExistsAllCtor x -> ExistsAllCtor (f x) + +instance FoldableFC Exists where + foldrFC f b = \case + TheOne _ x -> f x b + TheAll x -> f x b + ExistsOneCtor _ x -> f x b + ExistsAllCtor x -> f x b + +instance TraversableFC Exists where + traverseFC f = \case + TheOne repr x -> TheOne <$> pure repr <*> f x + TheAll x -> TheAll <$> f x + ExistsOneCtor repr x -> ExistsOneCtor <$> pure repr <*> f x + ExistsAllCtor x -> ExistsAllCtor <$> f x From d652078af3c0ed3ae3024abed5220d33c84f50e1 Mon Sep 17 00:00:00 2001 From: Daniel Matichuk Date: Wed, 18 Dec 2024 15:50:48 -0800 Subject: [PATCH 18/36] properly track divergence points for single-sided nodes ensures that when a two-sided node is split, the resulting single-sided nodes mark the original node as the divergence point previously this was checked at run-time. With the 'Quant' module we can enforce this statically by restricting the allowed cases for divergence points --- src/Data/Quant.hs | 42 ++-- src/Pate/Verification/PairGraph.hs | 44 ++-- src/Pate/Verification/PairGraph/Node.hs | 285 +++++++++++++++++------- src/Pate/Verification/StrongestPosts.hs | 51 +++-- src/Pate/Verification/Widening.hs | 89 ++++---- 5 files changed, 327 insertions(+), 184 deletions(-) diff --git a/src/Data/Quant.hs b/src/Data/Quant.hs index b45c9d19..afbfd9fc 100644 --- a/src/Data/Quant.hs +++ b/src/Data/Quant.hs @@ -80,6 +80,7 @@ module Data.Quant , pattern ExistsOne , pattern ExistsAll , IsExistsOr(..) + , ExistsOrCases(..) , TheOneK , IfIsOneK , coerceExists @@ -367,11 +368,15 @@ instance KnownRepr QuantRepr tp => KnownRepr (QuantCoercion tp) tp where knownRepr = CoerceRefl knownRepr data QuantConversion (t1 :: QuantK k) (t2 :: QuantK k) where + ConvertRefl :: ReprOf x -> QuantConversion x x + ConvertNone :: ReprOf x -> ReprOf y -> QuantConversion x y ConvertExistsToAll :: QuantConversion ExistsK AllK ConvertExistsToOne :: ReprOf x -> QuantConversion ExistsK (OneK x) instance HasReprK k => IsRepr (QuantConversion (t1 :: QuantK k)) where withRepr x f = case x of + ConvertRefl repr -> withRepr repr $ f + ConvertNone repr1 repr2 -> withRepr repr1 $ withRepr repr2 $ f ConvertExistsToAll -> f ConvertExistsToOne repr -> withRepr repr $ f @@ -451,16 +456,27 @@ pattern SomeSingle repr x <- ((\l -> toSingleQuant l >>= toSomeSingle) -> (Just type KnownConversion (tp1 :: QuantK k) (tp2 :: QuantK k) = KnownRepr (QuantConversion tp1) tp2 - +{- instance KnownRepr (QuantConversion ExistsK) AllK where knownRepr = ConvertExistsToAll instance (KnownRepr (ReprOf :: k -> Type) (x :: k)) => KnownRepr (QuantConversion ExistsK) (OneK x) where knownRepr = ConvertExistsToOne knownRepr +-} + +instance forall k x1 x2. (HasReprK k, KnownRepr QuantRepr (x1 :: QuantK k), KnownRepr QuantRepr x2) => KnownRepr (QuantConversion x1) x2 where + knownRepr = case (knownRepr :: QuantRepr x1, knownRepr :: QuantRepr x2) of + (QuantSomeRepr, QuantAllRepr) -> ConvertExistsToAll + (QuantSomeRepr, QuantOneRepr repr) -> ConvertExistsToOne repr + (x, y) | Just Refl <- testEquality x y -> ConvertRefl x + _ -> ConvertNone knownRepr knownRepr + instance QuantConvertible (Quant (f :: k -> Type)) where applyQuantConversion qc q = case (qc, q) of + (ConvertRefl{}, _) -> Just q + (ConvertNone{}, _) -> Nothing (ConvertExistsToAll, QuantAny q') -> Just q' (ConvertExistsToAll, QuantExists{}) -> Nothing (ConvertExistsToOne repr, QuantAny q') -> Just (applyQuantCoercion (CoerceAllToOne repr) q') @@ -495,13 +511,13 @@ data ExistsOrCases (tp1 :: QuantK k) (tp2 :: QuantK k) where ExistsOrRefl :: ExistsOrCases tp tp ExistsOrExists :: ExistsOrCases ExistsK tp -type family IsExistsOrConstraint (tp1 :: QuantK k) (tp2 :: QuantK k) :: Constraint +type family IsExistsOrConstraint (tp1 :: QuantK k) (tp2 :: QuantK k) :: Constraint where + IsExistsOrConstraint (OneK x) tp = (OneK x ~ tp) + IsExistsOrConstraint (AllK :: QuantK k) tp = ((AllK :: QuantK k) ~ tp) + IsExistsOrConstraint ExistsK _ = () -class IsExistsOrConstraint tp1 tp2 => IsExistsOr (tp1 :: QuantK k) (tp2 :: QuantK k) where +class (IsExistsOr tp1 tp1, IsExistsOr tp2 tp2, IsExistsOrConstraint tp1 tp2) => IsExistsOr (tp1 :: QuantK k) (tp2 :: QuantK k) where isExistsOr :: ExistsOrCases tp1 tp2 - -type instance IsExistsOrConstraint (OneK x) tp = ((OneK x) ~ tp) -type instance IsExistsOrConstraint (AllK :: QuantK k) tp = ((AllK :: QuantK k) ~ tp) instance IsExistsOr (OneK x) (OneK x) where isExistsOr = ExistsOrRefl @@ -512,8 +528,6 @@ instance IsExistsOr AllK AllK where instance IsExistsOr ExistsK ExistsK where isExistsOr = ExistsOrRefl -type instance IsExistsOrConstraint ExistsK x = () - instance IsExistsOr ExistsK (OneK k) where isExistsOr = ExistsOrExists @@ -521,7 +535,7 @@ instance IsExistsOr ExistsK AllK where isExistsOr = ExistsOrExists data QuantAsAllProof (f :: k -> Type) (tp :: QuantK k) where - QuantAsAllProof :: (IsExistsOr tp AllK) => (forall x. ReprOf x -> f x) -> QuantAsAllProof f tp + QuantAsAllProof :: (IsExistsOr tp AllK, KnownRepr QuantRepr tp) => (forall x. ReprOf x -> f x) -> QuantAsAllProof f tp quantAsAll :: HasReprK k => Quant (f :: k -> Type) tp -> Maybe (QuantAsAllProof f tp) quantAsAll q = case q of @@ -532,7 +546,7 @@ quantAsAll q = case q of Nothing -> Nothing -- | Pattern for creating or matching a universally quantified 'Quant', generalized over the existential cases -pattern All :: forall {k} f tp. (HasReprK k) => (IsExistsOr tp AllK) => (forall x. ReprOf x -> f x) -> Quant (f :: k -> Type) tp +pattern All :: forall {k} f tp. (HasReprK k) => (IsExistsOr tp AllK, KnownRepr QuantRepr tp) => (forall x. ReprOf x -> f x) -> Quant (f :: k -> Type) tp pattern All f <- (quantAsAll -> Just (QuantAsAllProof f)) where All f = case (isExistsOr :: ExistsOrCases tp AllK) of @@ -540,7 +554,7 @@ pattern All f <- (quantAsAll -> Just (QuantAsAllProof f)) ExistsOrRefl -> QuantAll (TMF.mapWithKey (\repr _ -> f repr) (allReprs @k)) data QuantAsOneProof (f :: k -> Type) (tp :: QuantK k) where - QuantAsOneProof :: (IsExistsOr tp (OneK x), IfIsOneK tp (x ~ TheOneK tp)) => ReprOf x -> f x -> QuantAsOneProof f tp + QuantAsOneProof :: (IsExistsOr tp (OneK x), IfIsOneK tp (x ~ TheOneK tp), KnownRepr QuantRepr tp) => ReprOf x -> f x -> QuantAsOneProof f tp quantAsOne :: forall k f tp. HasReprK k => Quant (f :: k -> Type) (tp :: QuantK k) -> Maybe (QuantAsOneProof f tp) quantAsOne q = case q of @@ -556,10 +570,10 @@ existsOrCases f g = case (isExistsOr :: ExistsOrCases tp tp') of ExistsOrRefl -> g -- | Pattern for creating or matching a singleton 'Quant', generalized over the existential cases -pattern Single :: forall {k} f tp. (HasReprK k) => forall x. (IsExistsOr tp (OneK x), IfIsOneK tp (x ~ TheOneK tp)) => ReprOf x -> f x -> Quant (f :: k -> Type) tp +pattern Single :: forall {k} f tp. (HasReprK k) => forall x. (IsExistsOr tp (OneK x), IfIsOneK tp (x ~ TheOneK tp), KnownRepr QuantRepr tp) => ReprOf x -> f x -> Quant (f :: k -> Type) tp pattern Single repr x <- (quantAsOne -> Just (QuantAsOneProof repr x)) where - Single (repr :: ReprOf x) x = existsOrCases @tp @(OneK x) (QuantExists (Single repr x)) (QuantOne repr x) + Single (repr :: ReprOf x) x = existsOrCases @tp @(OneK x) (withRepr repr $ QuantExists (Single repr x)) (QuantOne repr x) {-# COMPLETE Single, All #-} @@ -734,6 +748,8 @@ instance QuantCoercible f => QuantCoercible (Exists f) where instance QuantCoercible f => QuantConvertible (Exists f) where applyQuantConversion qc e = case (qc, e) of + (ConvertRefl{}, _) -> Just e + (ConvertNone{}, _) -> Nothing (ConvertExistsToAll, ExistsAllCtor x) -> Just $ TheAll x (ConvertExistsToOne repr, ExistsOneCtor repr' x) -> case testEquality repr repr' of Just Refl -> Just $ TheOne repr x diff --git a/src/Pate/Verification/PairGraph.hs b/src/Pate/Verification/PairGraph.hs index 71fb0332..40b106b3 100644 --- a/src/Pate/Verification/PairGraph.hs +++ b/src/Pate/Verification/PairGraph.hs @@ -325,7 +325,7 @@ data PairGraph sym arch = -- | Mapping from singleton nodes to their "synchronization" point, representing -- the case where two independent program analysis steps have occurred and now -- their control-flows have re-synchronized - , pairGraphSyncData :: !(Map (GraphNode arch) (SyncData sym arch)) + , pairGraphSyncData :: !(Map (GraphNode' arch Qu.AllK) (SyncData sym arch)) , pairGraphPendingActs :: ActionQueue sym arch , pairGraphDomainRefinements :: !(Map (GraphNode arch) [DomainRefinement sym arch]) @@ -521,7 +521,7 @@ getSyncData :: (OrdF x, Ord (x bin)) => L.Lens' (SyncData sym arch) (PPa.PatchPair (SetF x)) -> PBi.WhichBinaryRepr bin -> - GraphNode arch {- ^ The divergent node -} -> + GraphNode' arch Qu.AllK {- ^ The divergent node -} -> PairGraphM sym arch (Set (x bin)) getSyncData lens bin nd = getPG $ syncDataSet nd bin lens @@ -594,7 +594,7 @@ initFnBindings sym scope sne pg = do syncData :: forall sym arch. - GraphNode arch -> + GraphNode' arch Qu.AllK -> L.Lens' (PairGraph sym arch) (SyncData sym arch) syncData nd f pg = fmap set_ (f get_) where @@ -609,7 +609,7 @@ syncData nd f pg = fmap set_ (f get_) syncDataSet :: forall k sym arch bin. (OrdF k, Ord (k bin)) => - GraphNode arch -> + GraphNode' arch Qu.AllK -> PBi.WhichBinaryRepr bin -> L.Lens' (SyncData sym arch) (PPa.PatchPair (SetF k)) -> L.Lens' (PairGraph sym arch) (Set (k bin)) @@ -622,7 +622,7 @@ modifySyncData :: (OrdF x, Ord (x bin)) => L.Lens' (SyncData sym arch) (PPa.PatchPair (SetF x)) -> PBi.WhichBinaryRepr bin -> - GraphNode arch -> + GraphNode' arch Qu.AllK -> (Set (x bin) -> Set (x bin)) -> PairGraphM sym arch () modifySyncData lens bin dp f = setPG f $ syncDataSet dp bin lens @@ -633,14 +633,14 @@ addToSyncData :: HasCallStack => L.Lens' (SyncData sym arch) (PPa.PatchPair (SetF x)) -> PBi.WhichBinaryRepr bin -> - GraphNode arch {- ^ The divergent node -} -> + GraphNode' arch Qu.AllK {- ^ The divergent node -} -> x bin -> PairGraphM sym arch () addToSyncData lens bin nd x = modifySyncData lens bin nd (Set.insert x) addSyncAddress :: forall sym arch bin. - GraphNode arch {- ^ The divergent node -} -> + GraphNode' arch Qu.AllK {- ^ The divergent node -} -> PBi.WhichBinaryRepr bin -> PAd.ConcreteAddress arch -> PairGraphM sym arch () @@ -648,7 +648,7 @@ addSyncAddress nd bin syncAddr = addToSyncData syncCutAddresses bin nd (PPa.With addDesyncExits :: forall sym arch. - GraphNode arch {- ^ The divergent node -} -> + GraphNode' arch Qu.AllK {- ^ The divergent node -} -> PPa.PatchPair (PB.BlockTarget arch) -> PairGraphM sym arch () addDesyncExits dp blktPair = do @@ -665,7 +665,7 @@ handleKnownDesync :: PPa.PatchPair (PB.BlockTarget arch) -> PairGraphM sym arch Bool handleKnownDesync priority ne blkt = fmap (fromMaybe False) $ tryPG $ do - let dp = GraphNode ne + dp <- toTwoSidedNode $ GraphNode ne desyncExitsO <- getSyncData syncDesyncExits PBi.OriginalRepr dp desyncExitsP <- getSyncData syncDesyncExits PBi.PatchedRepr dp case not (Set.null desyncExitsO) && not (Set.null desyncExitsP) of @@ -678,7 +678,7 @@ handleKnownDesync priority ne blkt = fmap (fromMaybe False) $ tryPG $ do -- | Queue all the sync points to be processed (merged) for a given -- divergence getAllSyncPoints :: - GraphNode arch -> + GraphNode' arch Qu.AllK -> PairGraphM sym arch [PPa.PatchPair (SyncPoint arch)] getAllSyncPoints nd = do syncsO <- getSyncData syncPoints PBi.OriginalRepr nd @@ -948,9 +948,9 @@ getReturnVectors gr fPair = fromMaybe mempty (Map.lookup fPair (pairGraphReturnV -- | Look up the current abstract domain for the given graph node. getCurrentDomain :: PairGraph sym arch -> - GraphNode arch -> + GraphNode' arch qbin -> Maybe (AbstractDomainSpec sym arch) -getCurrentDomain pg nd = Map.lookup nd (pairGraphDomains pg) +getCurrentDomain pg nd = withKnownBin nd $ Map.lookup (Qu.coerceToExists nd) (pairGraphDomains pg) getCurrentDomainM :: GraphNode arch -> @@ -1044,8 +1044,8 @@ queueAncestors :: NodePriority -> GraphNode arch -> PairGraph sym arch -> PairGr queueAncestors priority nd pg = snd $ Set.foldr (queueNode' priority) (Set.singleton nd, pg) (getBackEdgesFrom pg nd) -queueNode :: NodePriority -> GraphNode arch -> PairGraph sym arch -> PairGraph sym arch -queueNode priority nd__ pg__ = snd $ queueNode' priority nd__ (Set.empty, pg__) +queueNode :: NodePriority -> GraphNode' arch qbin -> PairGraph sym arch -> PairGraph sym arch +queueNode priority nd__ pg__ = withKnownBin nd__ $ snd $ queueNode' priority (Qu.coerceToExists nd__) (Set.empty, pg__) -- | Calls 'queueNode' for 'ProcessNode' work items. -- For 'ProcessMerge' work items, queues up the merge if @@ -1072,7 +1072,7 @@ queueWorkItem priority wi pg = case wi of Just{} -> addItemToWorkList wi priority pg Nothing -> queueNode priority (singleNodeDivergence sne) pg -queueSplitAnalysis :: NodePriority -> NodeEntry arch -> PairGraphM sym arch () +queueSplitAnalysis :: NodePriority -> NodeEntry' arch qbin -> PairGraphM sym arch () queueSplitAnalysis priority ne = do sneO <- toSingleNodeEntry PBi.OriginalRepr ne sneP <- toSingleNodeEntry PBi.PatchedRepr ne @@ -1240,8 +1240,10 @@ hasWorkLeft pg = case RevMap.minView_value (pairGraphWorklist pg) of Just{} -> True isDivergeNode :: - GraphNode arch -> PairGraph sym arch -> Bool -isDivergeNode nd pg = Map.member nd (pairGraphSyncData pg) + GraphNode' arch qbin -> PairGraph sym arch -> Bool +isDivergeNode nd pg = withKnownBin nd $ case Qu.convertQuant nd of + Just nd' -> Map.member nd' (pairGraphSyncData pg) + Nothing -> False -- | Given a pair graph, chose the next node in the graph to visit -- from the work list, updating the necessary bookeeping. If the @@ -1387,7 +1389,7 @@ pgMaybe msg Nothing = throwError $ PEE.PairGraphErr msg -- | Compute a merged node for two diverging nodes -- FIXME: do we need to support mismatched node kinds here? -combineNodes :: SingleNodeEntry arch bin -> SingleNodeEntry arch (PBi.OtherBinary bin) -> Maybe (GraphNode arch) +combineNodes :: SingleNodeEntry arch bin -> SingleNodeEntry arch (PBi.OtherBinary bin) -> Maybe (GraphNode' arch Qu.AllK) combineNodes node1 node2 = do let ndPair = PPa.mkPair (singleEntryBin node1) (Qu.AsSingle node1) (Qu.AsSingle node2) Qu.AsSingle nodeO <- PPa.get PBi.OriginalRepr ndPair @@ -1581,11 +1583,11 @@ isSyncExit sne blkt@(PB.BlockTarget{}) = do True -> return Nothing False -> isCutAddressFor (GraphNode sne) (PB.targetRawPC blkt) >>= \case True -> do - let sne_tgt = mkSingleNodeEntry (singleToNodeEntry sne) (PB.targetCall blkt) + let sne_tgt = mkSingleNodeEntry sne (PB.targetCall blkt) return $ Just $ SyncAtExit sne sne_tgt False -> case PB.targetReturn blkt of Just ret -> do - let sne_tgt = mkSingleNodeEntry (singleToNodeEntry sne) ret + let sne_tgt = mkSingleNodeEntry sne ret let sync = SyncAtExit sne sne_tgt -- special case where this block target -- has already been marked as a sync exit for this node, but @@ -1672,7 +1674,7 @@ addReturnPointSync priority ne blktPair = case asSingleNodeEntry ne of case (not isExcept) && Set.member (PPa.WithBin (singleEntryBin sne) (PB.concreteAddress ret)) cuts of True -> do - let syncExit = mkSingleNodeEntry (singleToNodeEntry sne) ret + let syncExit = mkSingleNodeEntry sne ret queueExitMerges priority (SyncAtExit sne syncExit) False -> return () Nothing -> return () diff --git a/src/Pate/Verification/PairGraph/Node.hs b/src/Pate/Verification/PairGraph/Node.hs index 34812875..ede18e6d 100644 --- a/src/Pate/Verification/PairGraph/Node.hs +++ b/src/Pate/Verification/PairGraph/Node.hs @@ -45,7 +45,6 @@ module Pate.Verification.PairGraph.Node ( , returnToEntry , functionEntryOf , returnOfEntry - , toSingleReturn , toSingleNode , toSingleGraphNode , isSingleNode @@ -71,6 +70,9 @@ module Pate.Verification.PairGraph.Node ( , singleNodeRepr , singleNodeDivergePoint , singleNodeDivergence + , withKnownBin + , toTwoSidedNode + , asSingleNode ) where import Prettyprinter ( Pretty(..), sep, (<+>), Doc ) @@ -93,6 +95,7 @@ import Data.Parameterized.Classes import Pate.Panic import qualified Pate.Address as PAd import Data.Kind (Type) +import Data.Parameterized.WithRepr -- | Nodes in the program graph consist either of a pair of -- program points (GraphNode), or a synthetic node representing @@ -118,10 +121,29 @@ instance TestEquality (GraphNode' arch) where instance OrdF (GraphNode' arch) where compareF nd1 nd2 = lexCompareF (nodeRepr nd1) (nodeRepr nd2) $ fromOrdering $ compare nd1 nd2 +coerceContext :: Qu.QuantCoercion t1 t2 -> GraphNode' arch t1 -> CallingContext' arch t1 -> CallingContext' arch t2 +coerceContext qc nd x@(CallingContext' cctx dp) = case qc of + Qu.CoerceAllToOne repr -> CallingContext' cctx (DivergePointSingle repr nd) + Qu.CoerceToExists _ -> CallingContext' cctx (divergePointExists dp) + Qu.CoerceRefl{} -> x + instance Qu.QuantCoercible (GraphNode' arch) where - coerceQuant = \case - GraphNode ne -> GraphNode (Qu.coerceQuant ne) - ReturnNode nr -> ReturnNode (Qu.coerceQuant nr) + applyQuantCoercion qc nd = case nd of + GraphNode (NodeEntry cctx blks) -> GraphNode (NodeEntry (coerceContext qc nd cctx) (Qu.applyQuantCoercion qc blks)) + ReturnNode (NodeReturn cctx fns) -> ReturnNode (NodeReturn (coerceContext qc nd cctx) (Qu.applyQuantCoercion qc fns)) + +instance Qu.QuantConvertible (CallingContext' arch) where + applyQuantConversion qc (CallingContext' cctx dp) = CallingContext' <$> pure cctx <*> Qu.applyQuantConversion qc dp + +instance Qu.QuantConvertible (GraphNode' arch) where + convertQuant = \case + GraphNode (NodeEntry cctx blks) -> (\cctx' blks' -> GraphNode (NodeEntry cctx' blks')) <$> Qu.convertQuant cctx <*> Qu.convertQuant blks + ReturnNode (NodeReturn cctx fns) -> (\cctx' fns' -> ReturnNode (NodeReturn cctx' fns')) <$> Qu.convertQuant cctx <*> Qu.convertQuant fns + +withKnownBin :: GraphNode' arch qbin -> ((KnownRepr Qu.QuantRepr qbin, Qu.IsExistsOr qbin qbin) => a) -> a +withKnownBin nd f = case graphNodeBlocks nd of + Qu.All{} -> f + Qu.Single{} -> f instance PA.ValidArch arch => JSON.ToJSON (GraphNode' arch bin) where toJSON = \case @@ -135,13 +157,13 @@ instance PA.ValidArch arch => W4S.W4Serializable sym (NodeEntry' arch bin) where w4Serialize r = return $ JSON.toJSON r data NodeContent arch (f :: PB.WhichBinary -> Type) (qbin :: QuantK PB.WhichBinary) = - NodeContent { nodeContentCtx :: CallingContext arch, nodeContent :: Quant f qbin } + NodeContent { nodeContentCtx :: CallingContext' arch qbin, nodeContent :: Quant f qbin } deriving instance (forall x. Eq (f x)) => Eq (NodeContent arch f qbin) deriving instance (forall x. Ord (f x)) => Ord (NodeContent arch f qbin) instance (forall x. Eq (f x)) => TestEquality (NodeContent arch f) where - testEquality (NodeContent cctx1 x1) (NodeContent cctx2 x2) | cctx1 == cctx2, Just Refl <- testEquality x1 x2 = Just Refl + testEquality (NodeContent cctx1 x1) (NodeContent cctx2 x2) | Just Refl <- testEquality x1 x2, cctx1 == cctx2 = Just Refl testEquality _ _ = Nothing instance (forall x. Ord (f x)) => OrdF (NodeContent arch f) where @@ -150,10 +172,7 @@ instance (forall x. Ord (f x)) => OrdF (NodeContent arch f) where type NodeEntry' arch = NodeContent arch (PB.ConcreteBlock arch) type NodeEntry arch = NodeEntry' arch ExistsK -instance Qu.QuantCoercible (NodeEntry' arch) where - coerceQuant (NodeEntry cctx blks) = NodeEntry cctx (Qu.coerceQuant blks) - -pattern NodeEntry :: CallingContext arch -> Quant (PB.ConcreteBlock arch) bin -> NodeEntry' arch bin +pattern NodeEntry :: CallingContext' arch bin -> Quant (PB.ConcreteBlock arch) bin -> NodeEntry' arch bin pattern NodeEntry ctx bp = NodeContent ctx bp {-# COMPLETE NodeEntry #-} @@ -163,7 +182,7 @@ nodeEntryRepr ne = Qu.quantToRepr $ nodeBlocks ne nodeBlocks :: NodeEntry' arch bin -> Quant (PB.ConcreteBlock arch) bin nodeBlocks = nodeContent -graphNodeContext :: NodeEntry' arch bin -> CallingContext arch +graphNodeContext :: NodeEntry' arch bin -> CallingContext' arch bin graphNodeContext = nodeContentCtx type NodeReturn' arch = NodeContent arch (PB.FunctionEntry arch) @@ -179,21 +198,18 @@ nodeRepr :: GraphNode' arch qbin -> Qu.QuantRepr qbin nodeRepr (GraphNode ne) = nodeEntryRepr ne nodeRepr (ReturnNode rn) = nodeReturnRepr rn -returnNodeContext :: NodeReturn' arch bin -> CallingContext arch +returnNodeContext :: NodeReturn' arch bin -> CallingContext' arch bin returnNodeContext = nodeContentCtx -pattern NodeReturn :: CallingContext arch -> Quant (PB.FunctionEntry arch) bin -> NodeReturn' arch bin +pattern NodeReturn :: CallingContext' arch bin -> Quant (PB.FunctionEntry arch) bin -> NodeReturn' arch bin pattern NodeReturn ctx bp = NodeContent ctx bp {-# COMPLETE NodeReturn #-} -instance Qu.QuantCoercible (NodeReturn' arch) where - coerceQuant (NodeReturn cctx fns) = NodeReturn cctx (Qu.coerceQuant fns) - graphNodeBlocks :: GraphNode' arch bin -> Quant (PB.ConcreteBlock arch) bin graphNodeBlocks (GraphNode ne) = nodeBlocks ne graphNodeBlocks (ReturnNode ret) = Qu.map PB.functionEntryToConcreteBlock (nodeFuns ret) -nodeContext :: GraphNode' arch qbin -> CallingContext arch +nodeContext :: GraphNode' arch qbin -> CallingContext' arch qbin nodeContext (GraphNode nd) = nodeContentCtx nd nodeContext (ReturnNode ret) = nodeContentCtx ret @@ -205,35 +221,126 @@ pattern GraphNodeReturn blks <- (ReturnNode (NodeContent _ blks)) {-# COMPLETE GraphNodeEntry, GraphNodeReturn #-} +data DivergePoint arch (tp :: Qu.QuantK PB.WhichBinary) where + DivergePointSingle :: PB.WhichBinaryRepr bin -> GraphNode' arch Qu.AllK -> DivergePoint arch (Qu.OneK bin) + DivergePointTwoSided :: GraphNode' arch Qu.AllK -> DivergePoint arch Qu.AllK + NoDivergePointCtor :: DivergePoint arch Qu.AllK + SomeDivergePoint :: Maybe (GraphNode' arch Qu.AllK) -> DivergePoint arch Qu.ExistsK + +divergePointExists :: DivergePoint arch tp -> DivergePoint arch Qu.ExistsK +divergePointExists = \case + DivergePointSingle _ nd -> SomeDivergePoint (Just nd) + DivergePointTwoSided nd -> SomeDivergePoint (Just nd) + NoDivergePointCtor -> SomeDivergePoint Nothing + x@SomeDivergePoint{} -> x + +instance Qu.QuantConvertible (DivergePoint arch) where + applyQuantConversion qc dp = case (qc, dp) of + (Qu.ConvertExistsToAll, SomeDivergePoint (Just nd)) -> Just $ (DivergePointTwoSided nd) + (Qu.ConvertExistsToAll, SomeDivergePoint Nothing) -> Just $ NoDivergePointCtor + (Qu.ConvertExistsToOne repr, SomeDivergePoint (Just nd)) -> Just $ (DivergePointSingle repr nd) + (Qu.ConvertExistsToOne{}, SomeDivergePoint Nothing) -> Nothing + (Qu.ConvertRefl _, _) -> Just dp + (Qu.ConvertNone{},_) -> Nothing + + +deriving instance Eq (DivergePoint arch tp) +deriving instance Ord (DivergePoint arch tp) + +data DivergePointProof arch tp where + DivergePointProof :: (KnownRepr Qu.QuantRepr tp, Qu.IsExistsOr tp tp) => GraphNode' arch Qu.AllK -> DivergePointProof arch tp + +divergePointProof :: DivergePoint arch tp -> Maybe (DivergePointProof arch tp) +divergePointProof = \case + DivergePointSingle repr nd -> withRepr repr $ Just $ DivergePointProof nd + DivergePointTwoSided nd -> Just $ DivergePointProof nd + NoDivergePointCtor -> Nothing + SomeDivergePoint (Just nd) -> Just $ DivergePointProof nd + SomeDivergePoint Nothing -> Nothing + +pattern DivergePoint :: forall arch tp. () => (KnownRepr Qu.QuantRepr tp, Qu.IsExistsOr tp tp) => GraphNode' arch Qu.AllK -> DivergePoint arch tp +pattern DivergePoint nd <- (divergePointProof -> Just (DivergePointProof nd)) where + DivergePoint nd = case knownRepr :: Qu.QuantRepr tp of + Qu.QuantOneRepr repr -> DivergePointSingle repr nd + Qu.QuantAllRepr -> DivergePointTwoSided nd + Qu.QuantSomeRepr -> SomeDivergePoint (Just (Qu.coerceQuant nd)) + +data NoDivergePointProof arch tp where + NoDivergePointProof :: (Qu.IsExistsOr tp Qu.AllK, KnownRepr Qu.QuantRepr tp) => NoDivergePointProof arch tp + +noDivergePointProof :: DivergePoint arch tp -> Maybe (NoDivergePointProof arch tp) +noDivergePointProof = \case + NoDivergePointCtor -> Just NoDivergePointProof + SomeDivergePoint Nothing -> Just NoDivergePointProof + _ -> Nothing + +pattern NoDivergePoint :: forall arch tp. () => (KnownRepr Qu.QuantRepr tp, Qu.IsExistsOr tp Qu.AllK) => DivergePoint arch tp +pattern NoDivergePoint <- (noDivergePointProof -> Just NoDivergePointProof) where + NoDivergePoint = case knownRepr :: Qu.QuantRepr tp of + Qu.QuantAllRepr -> NoDivergePointCtor + Qu.QuantSomeRepr -> SomeDivergePoint Nothing + +{-# COMPLETE NoDivergePoint, DivergePoint #-} + +divergePointNode :: DivergePoint arch tp -> Maybe (GraphNode' arch Qu.AllK) +divergePointNode = \case + DivergePoint nd -> Just nd + NoDivergePoint -> Nothing + +divergePoint :: CallingContext' arch tp -> Maybe (GraphNode' arch Qu.AllK) +divergePoint cctx = divergePointNode $ divergePoint' cctx + + -- | Additional context used to distinguish function calls -- "Freezing" one binary in a node indicates that it should not continue -- execution until the other binary has returned -data CallingContext arch = CallingContext { _ctxAncestors :: [PB.BlockPair arch], divergePoint :: Maybe (GraphNode arch) } +data CallingContext' arch (tp :: Qu.QuantK PB.WhichBinary) = CallingContext' { ctxAncestors :: [PB.BlockPair arch], divergePoint' :: DivergePoint arch tp } deriving (Eq, Ord) +type CallingContext arch = CallingContext' arch Qu.ExistsK -instance PA.ValidArch arch => Pretty (CallingContext arch) where +data CallingContextProof arch tp where + CallingContextProof :: (Qu.IsExistsOr tp2 tp1, KnownRepr Qu.QuantRepr tp1, KnownRepr Qu.QuantRepr tp2) => [PB.BlockPair arch] -> DivergePoint arch tp1 -> CallingContextProof arch tp2 + +callingContextProof :: CallingContext' arch tp -> CallingContextProof arch tp +callingContextProof cctx = let dp = divergePoint' cctx in case dp of + DivergePoint{} -> CallingContextProof (ctxAncestors cctx) dp + NoDivergePoint -> CallingContextProof (ctxAncestors cctx) dp + +pattern CallingContext :: forall arch tp2. () => forall tp1. (Qu.IsExistsOr tp2 tp1, KnownRepr Qu.QuantRepr tp2, KnownRepr Qu.QuantRepr tp1) => [PB.BlockPair arch] -> DivergePoint arch tp1 -> CallingContext' arch tp2 +pattern CallingContext blks dp <- (callingContextProof -> CallingContextProof blks dp) where + CallingContext blks (dp :: DivergePoint arch tp1) = case Qu.isExistsOr @_ @tp2 @tp1 of + Qu.ExistsOrExists -> case dp of + DivergePoint nd -> CallingContext' blks (SomeDivergePoint (Just (Qu.coerceQuant nd))) + NoDivergePoint -> CallingContext' blks (SomeDivergePoint Nothing) + Qu.ExistsOrRefl -> CallingContext' blks dp + + +{-# COMPLETE CallingContext #-} + +instance PA.ValidArch arch => Pretty (CallingContext' arch qbin) where pretty (CallingContext bps mdivisionPoint) = let bs = [ pretty bp | bp <- bps ] divP = case mdivisionPoint of - Just _p -> [] -- ["Diverged at:", pretty p] -- too noisy - Nothing -> [] + DivergePoint _p -> [] -- ["Diverged at:", pretty p] -- too noisy + NoDivergePoint -> [] in sep (((zipWith (<+>) ( "via:" : repeat "<-") bs)) ++ divP) -instance PA.ValidArch arch => JSON.ToJSON (CallingContext arch) where - toJSON (CallingContext bps mdivisionPoint) = JSON.object [ "ancestors" JSON..= bps, "divergedAt" JSON..= mdivisionPoint] +instance PA.ValidArch arch => JSON.ToJSON (CallingContext' arch qbin) where + toJSON (CallingContext bps mdivisionPoint) = JSON.object [ "ancestors" JSON..= bps, "divergedAt" JSON..= divergePointNode mdivisionPoint] getDivergePoint :: GraphNode arch -> Maybe (GraphNode arch) -getDivergePoint nd = case nd of - GraphNode (NodeEntry ctx _) -> divergePoint ctx - ReturnNode (NodeReturn ctx _) -> divergePoint ctx +getDivergePoint nd = case nodeContext nd of + CallingContext _ (DivergePoint dp) -> Just (Qu.coerceQuant dp) + CallingContext _ NoDivergePoint -> Nothing + -rootEntry :: PB.BinaryPair (PB.ConcreteBlock arch) qbin -> NodeEntry' arch qbin -rootEntry pPair = NodeEntry (CallingContext [] Nothing) pPair +rootEntry :: PPa.PatchPair (PB.ConcreteBlock arch) -> NodeEntry arch +rootEntry pPair = NodeEntry (CallingContext [] (SomeDivergePoint Nothing)) pPair -rootReturn :: PB.BinaryPair (PB.FunctionEntry arch) qbin -> NodeReturn' arch qbin -rootReturn pPair = NodeReturn (CallingContext [] Nothing) pPair +rootReturn :: PPa.PatchPair (PB.FunctionEntry arch) -> NodeReturn arch +rootReturn pPair = NodeReturn (CallingContext [] (SomeDivergePoint Nothing)) pPair addContext :: PB.BinaryPair (PB.ConcreteBlock arch) qbin1 -> NodeEntry' arch qbin2 -> NodeEntry' arch qbin2 addContext newCtx' ne@(NodeEntry (CallingContext ctx d) blks) = @@ -247,13 +354,13 @@ addContext newCtx' ne@(NodeEntry (CallingContext ctx d) blks) = -- Strip diverge points from two-sided nodes. This is used so that -- merged nodes (which are two-sided) can meaningfully retain their -- diverge point, but it will be stripped on any subsequent nodes. -mkNextContext :: Quant a (bin :: QuantK PB.WhichBinary) -> CallingContext arch -> CallingContext arch +mkNextContext :: Quant a (bin :: QuantK PB.WhichBinary) -> CallingContext' arch bin -> CallingContext' arch bin mkNextContext q cctx = case q of Qu.All{} -> dropDivergePoint cctx Qu.Single{} -> cctx - -dropDivergePoint :: CallingContext arch -> CallingContext arch -dropDivergePoint (CallingContext cctx _) = CallingContext cctx Nothing + +dropDivergePoint :: Qu.IsExistsOr qbin Qu.AllK => CallingContext' arch qbin -> CallingContext' arch qbin +dropDivergePoint (CallingContext cctx _) = CallingContext cctx NoDivergePointCtor mkNodeEntry :: NodeEntry arch -> PB.BlockPair arch -> NodeEntry arch mkNodeEntry node pPair = NodeEntry (mkNextContext pPair (graphNodeContext node)) pPair @@ -266,41 +373,38 @@ mkNodeReturn :: NodeEntry arch -> PB.FunPair arch -> NodeReturn arch mkNodeReturn node fPair = NodeReturn (mkNextContext fPair (graphNodeContext node)) fPair mkMergedNodeEntry :: - GraphNode arch -> + GraphNode' arch Qu.AllK -> PB.ConcreteBlock arch PB.Original -> PB.ConcreteBlock arch PB.Patched -> - NodeEntry arch -mkMergedNodeEntry nd blkO blkP = NodeEntry (CallingContext cctx (Just nd)) (PPa.PatchPair blkO blkP) + NodeEntry' arch Qu.AllK +mkMergedNodeEntry nd blkO blkP = NodeEntry (CallingContext cctx (DivergePoint nd)) (Qu.All $ \case PB.OriginalRepr -> blkO; PB.PatchedRepr -> blkP) where CallingContext cctx _ = nodeContext nd mkMergedNodeReturn :: - GraphNode arch -> + GraphNode' arch Qu.AllK -> PB.FunctionEntry arch PB.Original -> PB.FunctionEntry arch PB.Patched -> - NodeReturn arch -mkMergedNodeReturn nd fnO fnP = NodeReturn (CallingContext cctx (Just nd)) (PPa.PatchPair fnO fnP) + NodeReturn' arch Qu.AllK +mkMergedNodeReturn nd fnO fnP = NodeReturn (CallingContext cctx (DivergePoint nd)) (Qu.All $ \case PB.OriginalRepr -> fnO; PB.PatchedRepr -> fnP) where CallingContext cctx _ = nodeContext nd - --- | Project the given 'NodeReturn' into a singleton node for the given binary -toSingleReturn :: PPa.PatchPairM m => PB.WhichBinaryRepr bin -> GraphNode arch -> NodeReturn arch -> m (NodeReturn arch) -toSingleReturn bin divergedAt (NodeReturn ctx fPair) = do - fPair' <- PPa.toSingleton bin fPair - return $ NodeReturn (ctx {divergePoint = Just divergedAt}) fPair' - -- | Project the given 'NodeEntry' into a singleton node for the given binary -toSingleNode:: PPa.PatchPairM m => PB.WhichBinaryRepr bin -> NodeEntry arch -> m (NodeEntry arch) -toSingleNode bin node@(NodeEntry ctx bPair) = do - fPair' <- PPa.toSingleton bin bPair - return $ NodeEntry (ctx {divergePoint = Just (GraphNode node)}) fPair' +toSingleNode:: forall m arch bin qbin. PPa.PatchPairM m => PB.WhichBinaryRepr bin -> NodeEntry' arch qbin -> m (NodeEntry arch) +toSingleNode bin divergedAt = toSingleGraphNode bin (GraphNode divergedAt) >>= \case + GraphNode nd -> return nd + _ -> PPa.throwPairErr + +toSingleGraphNode :: forall m arch bin qbin. PPa.PatchPairM m => PB.WhichBinaryRepr bin -> GraphNode' arch qbin -> m (GraphNode arch) +toSingleGraphNode bin node = withKnownBin node $ withRepr bin $ case Qu.convertQuant node of + Just (nd :: GraphNode' arch Qu.AllK) | (sgn :: SingleGraphNode arch bin) <- Qu.coerceQuant nd -> return $ Qu.coerceToExists sgn + Nothing -> case Qu.convertQuant node of + Just (nd :: SingleGraphNode arch bin) -> return $ Qu.coerceToExists nd + Nothing -> PPa.throwPairErr -toSingleGraphNode :: PPa.PatchPairM m => PB.WhichBinaryRepr bin -> GraphNode arch -> m (GraphNode arch) -toSingleGraphNode bin node = case node of - GraphNode ne -> GraphNode <$> toSingleNode bin ne - ReturnNode nr -> ReturnNode <$> toSingleReturn bin node nr + isSingleNodeEntry :: PPa.PatchPairM m => NodeEntry arch -> @@ -332,11 +436,11 @@ eqUptoDivergePoint :: GraphNode arch -> Bool eqUptoDivergePoint (GraphNode (NodeEntry ctx1 blks1)) (GraphNode (NodeEntry ctx2 blks2)) - | (ctx1{divergePoint = Nothing} == ctx2{divergePoint = Nothing}) + | (ctxAncestors ctx1 == ctxAncestors ctx2) , blks1 == blks2 = True eqUptoDivergePoint (ReturnNode (NodeReturn ctx1 blks1)) (ReturnNode (NodeReturn ctx2 blks2)) - | (ctx1{divergePoint = Nothing} == ctx2{divergePoint = Nothing}) + | (ctxAncestors ctx1 == ctxAncestors ctx2) , blks1 == blks2 = True eqUptoDivergePoint _ _ = False @@ -350,6 +454,11 @@ splitGraphNode nd = do nodeP <- PPa.getC PB.PatchedRepr nodes return (nodeO, nodeP) +toTwoSidedNode :: PPa.PatchPairM m => GraphNode' arch qbin -> m (GraphNode' arch Qu.AllK) +toTwoSidedNode nd = withKnownBin nd $ case Qu.convertQuant nd of + Just (nd' :: GraphNode' arch Qu.AllK) -> return nd' + Nothing -> PPa.throwPairErr + -- | Get the node corresponding to the entry point for the function returnToEntry :: NodeReturn' arch bin -> NodeEntry' arch bin returnToEntry (NodeReturn ctx fns) = NodeEntry (mkNextContext fns ctx) (Qu.map PB.functionEntryToConcreteBlock fns) @@ -393,7 +502,7 @@ instance PA.ValidArch arch => Show (GraphNode' arch qbin) where show e = show (pretty e) tracePrettyNode :: - PA.ValidArch arch => GraphNode arch -> String -> Doc a + PA.ValidArch arch => GraphNode' arch qbin -> String -> Doc a tracePrettyNode nd msg = case nd of GraphNode e -> case (functionEntryOf e == e,msg) of (True,"") -> "Function Entry" <+> pretty e @@ -425,9 +534,6 @@ instance PA.ValidArch arch => JSON.ToJSON (NodeReturn' arch bin) where -- HMS.fromList [ ("data", JSON.Object content) ] - - - instance forall sym arch. PA.ValidArch arch => IsTraceNode '(sym, arch) "node" where type TraceNodeType '(sym, arch) "node" = GraphNode arch type TraceNodeLabel "node" = String @@ -452,10 +558,10 @@ instance forall sym arch. PA.ValidArch arch => IsTraceNode '(sym, arch) "entryno type SingleNodeEntry arch bin = NodeEntry' arch (Qu.OneK bin) -pattern SingleNodeEntry :: CallingContext arch -> PB.ConcreteBlock arch bin -> SingleNodeEntry arch bin +pattern SingleNodeEntry :: CallingContext' arch (Qu.OneK bin) -> PB.ConcreteBlock arch bin -> SingleNodeEntry arch bin pattern SingleNodeEntry cctx blk <- ((\l -> case l of NodeEntry cctx (Qu.Single _ blk) -> (cctx,blk)) -> (cctx,blk)) where - SingleNodeEntry cctx blk = NodeEntry cctx (Qu.Single (PB.blockBinRepr blk) blk) + SingleNodeEntry cctx blk = NodeEntry cctx (withRepr (PB.blockBinRepr blk) $ Qu.Single (PB.blockBinRepr blk) blk) {-# COMPLETE SingleNodeEntry #-} @@ -465,27 +571,30 @@ singleEntryBin (nodeEntryRepr -> Qu.QuantOneRepr repr) = repr singleNodeAddr :: SingleNodeEntry arch bin -> PPa.WithBin (PAd.ConcreteAddress arch) bin singleNodeAddr se = PPa.WithBin (singleEntryBin se) (PB.concreteAddress (singleNodeBlock se)) -mkSingleNodeEntry :: NodeEntry' arch qbin -> PB.ConcreteBlock arch bin -> SingleNodeEntry arch bin +mkSingleNodeEntry :: SingleNodeEntry arch bin -> PB.ConcreteBlock arch bin -> SingleNodeEntry arch bin mkSingleNodeEntry node blk = SingleNodeEntry (graphNodeContext node) blk -singleNodeDivergePoint :: SingleGraphNode arch bin -> GraphNode arch -singleNodeDivergePoint sgn = case divergePoint (nodeContext sgn) of - Just dp -> dp - Nothing -> panic Verifier "singleNodeDivergePoint" ["missing diverge point for SingleNodeEntry"] - +singleNodeDivergePoint :: SingleGraphNode arch bin -> GraphNode' arch Qu.AllK +singleNodeDivergePoint sgn = case divergePoint' (nodeContext sgn) of + DivergePoint nd -> nd -singleNodeDivergence :: SingleNodeEntry arch bin -> GraphNode arch +singleNodeDivergence :: SingleNodeEntry arch bin -> GraphNode' arch Qu.AllK singleNodeDivergence sne = singleNodeDivergePoint (GraphNode sne) asSingleNodeEntry :: PPa.PatchPairM m => NodeEntry' arch qbin -> m (Some (Qu.AsSingle (NodeEntry' arch))) -asSingleNodeEntry (NodeEntry cctx blks) = do - Pair _ blk <- PPa.asSingleton blks - case divergePoint cctx of - Just{} -> return $ Some (Qu.AsSingle $ SingleNodeEntry cctx blk) +asSingleNodeEntry nd = asSingleNode (GraphNode nd) >>= \case + Some (Qu.AsSingle (GraphNode nd')) -> return $ Some (Qu.AsSingle nd') + _ -> PPa.throwPairErr + +asSingleNode:: PPa.PatchPairM m => GraphNode' arch qbin -> m (Some (Qu.AsSingle (GraphNode' arch))) +asSingleNode nd = case graphNodeBlocks nd of + Qu.All{} -> PPa.throwPairErr + Qu.Single (repr :: PB.WhichBinaryRepr bin) _ -> withRepr repr $ case Qu.convertQuant nd of + Just (nd' :: GraphNode' arch (Qu.OneK bin)) -> return $ Some (Qu.AsSingle nd') Nothing -> PPa.throwPairErr - + singleNodeBlock :: SingleNodeEntry arch bin -> PB.ConcreteBlock arch bin singleNodeBlock (SingleNodeEntry _ blk) = blk @@ -496,30 +605,34 @@ singleNodeBlock (SingleNodeEntry _ blk) = blk toSingleNodeEntry :: PPa.PatchPairM m => PB.WhichBinaryRepr bin -> - NodeEntry arch -> + NodeEntry' arch qbin -> m (SingleNodeEntry arch bin) toSingleNodeEntry bin ne = do case toSingleNode bin ne of - Just (NodeEntry cctx bPair) -> do - blk <- PPa.get bin bPair - return $ SingleNodeEntry cctx blk + Just ne' -> do + Some (Qu.AsSingle sne) <- asSingleNodeEntry ne' + case testEquality (nodeEntryRepr sne) (Qu.QuantOneRepr bin) of + Just Refl -> return sne + Nothing -> PPa.throwPairErr _ -> PPa.throwPairErr singleToNodeEntry :: SingleNodeEntry arch bin -> NodeEntry arch -singleToNodeEntry sne = Qu.coerceQuant sne +singleToNodeEntry sne = case singleToGraphNode (GraphNode sne) of + GraphNode sne' -> sne' + ReturnNode _ -> error "singleToNodeEntry: unexpected node kind swap" singleToGraphNode :: SingleGraphNode arch bin -> GraphNode arch -singleToGraphNode sgn = Qu.coerceQuant sgn +singleToGraphNode sgn = withRepr (singleNodeRepr sgn) $ Qu.coerceQuant sgn combineSingleEntries' :: SingleNodeEntry arch PB.Original -> SingleNodeEntry arch PB.Patched -> Maybe (NodeEntry arch) combineSingleEntries' (SingleNodeEntry cctxO blksO) (SingleNodeEntry cctxP blksP) = do - GraphNode divergeO <- divergePoint $ cctxO - GraphNode divergeP <- divergePoint $ cctxP + divergeO <- divergePoint $ cctxO + divergeP <- divergePoint $ cctxP guard $ divergeO == divergeP - return $ mkNodeEntry divergeO (PPa.PatchPair blksO blksP) + return $ mkNodeEntry' (Qu.coerceQuant divergeO) (PPa.PatchPair blksO blksP) -- | Create a combined two-sided 'NodeEntry' based on -- a pair of single-sided entries. The given entries @@ -537,10 +650,10 @@ combineSingleEntries sne1 sne2 = case singleEntryBin sne1 of type SingleNodeReturn arch bin = NodeReturn' arch (Qu.OneK bin) -pattern SingleNodeReturn :: CallingContext arch -> PB.FunctionEntry arch bin -> SingleNodeReturn arch bin +pattern SingleNodeReturn :: CallingContext' arch (Qu.OneK bin) -> PB.FunctionEntry arch bin -> SingleNodeReturn arch bin pattern SingleNodeReturn cctx fn <- ((\l -> case l of NodeReturn cctx (Qu.Single _ fn) -> (cctx,fn)) -> (cctx,fn)) where - SingleNodeReturn cctx fn = NodeReturn cctx (Qu.Single (PB.functionBinRepr fn) fn) + SingleNodeReturn cctx fn = NodeReturn cctx (withRepr (PB.functionBinRepr fn) $ Qu.Single (PB.functionBinRepr fn) fn) type SingleGraphNode arch bin = GraphNode' arch (Qu.OneK bin) diff --git a/src/Pate/Verification/StrongestPosts.hs b/src/Pate/Verification/StrongestPosts.hs index b1419958..ce36929d 100644 --- a/src/Pate/Verification/StrongestPosts.hs +++ b/src/Pate/Verification/StrongestPosts.hs @@ -404,10 +404,11 @@ addIntraBlockCut segOff blk = fnTrace "addIntraBlockCut" $ do _ -> throwHere $ PEE.MissingBlockAtAddress segOff (map MD.pblockAddr pblks) repr blk chooseDesyncPoint :: - GraphNode arch -> + GraphNode' arch Qu.AllK -> PairGraph sym arch -> EquivM sym arch (PairGraph sym arch) -chooseDesyncPoint nd pg0 = do +chooseDesyncPoint dp pg0 = do + let nd = Qu.coerceToExists dp divergePair@(PPa.PatchPairC divergeO divergeP) <- PPa.forBinsC $ \bin -> do blk <- PPa.get bin (graphNodeBlocks nd) pblks <- PD.lookupBlocks blk @@ -425,10 +426,11 @@ chooseDesyncPoint nd pg0 = do -- | Given a source divergent node, pick a synchronization point where -- control flow should again match between the two binaries chooseSyncPoint :: - GraphNode arch -> + GraphNode' arch Qu.AllK -> PairGraph sym arch -> EquivM sym arch (PairGraph sym arch) -chooseSyncPoint nd pg0 = do +chooseSyncPoint dp pg0 = do + let nd = Qu.coerceToExists dp (PPa.PatchPairC divergeO divergeP) <- PPa.forBinsC $ \bin -> do blk <- PPa.get bin (graphNodeBlocks nd) pblks <- PD.lookupBlocks blk @@ -436,7 +438,7 @@ chooseSyncPoint nd pg0 = do return $ (divergeSingle, Some blk, pblks) cuts <- pickCutPoints True syncMsg [divergeO, divergeP] execPG pg0 $ forM_ cuts $ \(Some (PPa.WithBin bin addr)) -> do - addSyncAddress nd bin addr + addSyncAddress dp bin addr where syncMsg = "Choose a synchronization point:" @@ -583,10 +585,11 @@ initSingleSidedDomain :: SingleNodeEntry arch bin -> PairGraph sym arch -> EquivM sym arch (PairGraph sym arch) -initSingleSidedDomain sne pg0 = withRepr bin $ withSym $ \sym -> withPG_ pg0 $ do +initSingleSidedDomain sne pg0 = withRepr bin $ withRepr (PBi.flipRepr bin) $ withSym $ \sym -> withPG_ pg0 $ do priority <- lift $ thisPriority - let nd = singleNodeDivergePoint (GraphNode sne) + let dp = singleNodeDivergePoint (GraphNode sne) + let nd = Qu.coerceToExists dp nd' <- case Qu.convertQuant nd of Just (nd' :: GraphNode' arch Qu.AllK) -> return nd' Nothing -> fail $ "Unexpected single-sided diverge point: " ++ show nd @@ -634,7 +637,7 @@ initSingleSidedDomain sne pg0 = withRepr bin $ withSym $ \sym -> withPG_ pg0 $ d -- Should we lower the priority here? Is it possible to get caught in a loop otherwise? -- Formally we should be able to find all relevant nodes based on which bindings -- we're missing - liftPG $ getAllSyncPoints nd >>= \syncs -> forM_ syncs $ \syncPair -> do + liftPG $ getAllSyncPoints dp >>= \syncs -> forM_ syncs $ \syncPair -> do sp <- PPa.get (PBi.flipRepr bin) syncPair modify $ queueAncestors pr (GraphNode $ singleToNodeEntry (syncPointNode sp)) @@ -672,7 +675,7 @@ handleProcessSplit sne pg = withPG pg $ do priority <- lift $ thisPriority case getCurrentDomain pg divergeNode of Nothing -> do - liftPG $ modify $ queueAncestors (priority PriorityDomainRefresh) divergeNode + liftPG $ modify $ queueAncestors (priority PriorityDomainRefresh) (Qu.coerceToExists divergeNode) return Nothing Just{} -> do let nd = GraphNode (singleToNodeEntry sne) @@ -763,6 +766,8 @@ mergeSingletons sneO sneP pg = fnTrace "mergeSingletons" $ withSym $ \sym -> do Nothing -> throwHere $ PEE.IncompatibleSingletonNodes blkO blkP let dp = singleNodeDivergence sneO + let nd = Qu.coerceToExists dp + let syncNode = GraphNode syncNodeEntry let snePair = Qu.QuantEach (\case PBi.OriginalRepr -> sneO; PBi.PatchedRepr -> sneP) let pre_refines = getDomainRefinements syncNode pg @@ -770,16 +775,16 @@ mergeSingletons sneO sneP pg = fnTrace "mergeSingletons" $ withSym $ \sym -> do -- we start with two scopes: one representing the program state at the point of divergence: 'init_scope', -- and one representing the program state at the merge point - pg_final <- withFreshScope (graphNodeBlocks dp) $ \(splitScope :: PS.SimScope sym arch init) -> do + pg_final <- withFreshScope (graphNodeBlocks nd) $ \(splitScope :: PS.SimScope sym arch init) -> do withFreshScope blkPair $ \(mergeScope :: PS.SimScope sym arch merge) -> do ((sbundlePair@(PPa.PatchPair sbundleO sbundleP)), pg') <- mergeBundles splitScope mergeScope snePair pg - dpDomSpec <- evalPG pg $ getCurrentDomainM dp + dpDomSpec <- evalPG pg $ getCurrentDomainM nd -- domain at the divergence point dpDom <- liftIO $ PS.bindSpec sym (PS.scopeVarsPair splitScope) dpDomSpec - noop <- noopBundle splitScope (graphNodeBlocks dp) + noop <- noopBundle splitScope (graphNodeBlocks nd) - withValidInit splitScope (graphNodeBlocks dp) $ + withValidInit splitScope (graphNodeBlocks nd) $ withPredomain splitScope noop dpDom $ withValidInit (singleBundleScope sbundleO) (singleBundleBlocks sbundleO) $ withValidInit (singleBundleScope sbundleP) (singleBundleBlocks sbundleP) $ @@ -1224,8 +1229,9 @@ mergeBundles splitScope mergeScope snePair pg = withSym $ \sym -> withPG pg $ do PS.compositeScopeCases mergeScope splitScope $ \bin scope -> do let sne = Qu.quantEach snePair bin let dp = singleNodeDivergence sne + let nd = Qu.coerceToExists dp let bin_other = PBi.flipRepr bin - dpBlk <- PPa.get bin_other (graphNodeBlocks dp) + dpBlk <- PPa.get bin_other (graphNodeBlocks nd) let sneBlk = singleNodeBlock sne let blks = PPa.mkPair bin sneBlk dpBlk bundle <- lift $ noopBundle scope blks @@ -1493,9 +1499,9 @@ withConditionsAssumed :: withConditionsAssumed scope bundle d node gr0 f = do foldr go f' [minBound..maxBound] where - f' = withSym $ \sym -> case node of - GraphNode ne | Just (Some sne) <- asSingleNodeEntry ne -> - lookupFnBindings scope sne gr0 >>= \case + f' = withSym $ \sym -> case asSingleNode node of + Just (Some (Qu.AsSingle snode)) -> + lookupFnBindings scope snode gr0 >>= \case Just binds -> do bindsPred <- IO.liftIO $ PFn.toPred sym binds emitTraceLabel @"expr" "Bindings" (Some bindsPred) @@ -2986,7 +2992,8 @@ handleDivergingPaths scope bundle currBlock st dom blkt = fnTrace "handleDivergi emitTrace @"message" $ "Known desynchronization point. Queue split analysis." return $ st{ branchGraph = gr1 } False -> do - let divergeNode = GraphNode currBlock + divergeNode <- toTwoSidedNode $ GraphNode currBlock + let someDivergeNode = Qu.coerceToExists divergeNode let pg = gr1 let msg = "Control flow desynchronization found at: " ++ show divergeNode a <- case mchoice of @@ -3015,20 +3022,20 @@ handleDivergingPaths scope bundle currBlock st dom blkt = fnTrace "handleDivergi pg1 <- chooseDesyncPoint divergeNode pg -- drop domains from any outgoing edges, since the set of outgoing edges -- from this node will likely change - let pg2 = dropPostDomains divergeNode (priority PriorityDomainRefresh) pg1 + let pg2 = dropPostDomains someDivergeNode (priority PriorityDomainRefresh) pg1 -- re-queue the node after picking a de-synchronization point let pg3 = queueNode (priority PriorityHandleActions) divergeNode pg2 return $ st'{ branchGraph = pg3 } IsInfeasible condK -> do - gr2 <- pruneCurrentBranch scope (divergeNode, GraphNode currBlockO) condK pg - gr3 <- pruneCurrentBranch scope (divergeNode, GraphNode currBlockP) condK gr2 + gr2 <- pruneCurrentBranch scope (someDivergeNode, GraphNode currBlockO) condK pg + gr3 <- pruneCurrentBranch scope (someDivergeNode, GraphNode currBlockP) condK gr2 return $ st'{ branchGraph = gr3 } DeferDecision -> do -- add this back to the work list at a low priority -- this allows, for example, the analysis to determine -- that this is unreachable (potentially after refinements) and therefore -- doesn't need synchronization - Just pg1 <- return $ addToWorkList divergeNode (priority PriorityDeferred) pg + Just pg1 <- return $ addToWorkList someDivergeNode (priority PriorityDeferred) pg return $ st'{ branchGraph = pg1 } AlignControlFlow condK -> withSym $ \sym -> do traces <- bundleToInstrTraces bundle diff --git a/src/Pate/Verification/Widening.hs b/src/Pate/Verification/Widening.hs index 14ba3ba0..e56d9f56 100644 --- a/src/Pate/Verification/Widening.hs +++ b/src/Pate/Verification/Widening.hs @@ -39,7 +39,7 @@ module Pate.Verification.Widening ) where import GHC.Stack -import Control.Lens ( (.~), (&), (^.) ) +import Control.Lens ( (.~), (&), (^.), (%~) ) import Control.Monad (when, forM_, unless, filterM, foldM, void) import Control.Monad.IO.Class import qualified Control.Monad.IO.Unlift as IO @@ -107,7 +107,7 @@ import qualified Pate.TraceCollection as PTc import Pate.Verification.PairGraph import qualified Pate.Verification.ConditionalEquiv as PVC import qualified Pate.Verification.Validity as PVV -import Pate.Verification.PairGraph.Node ( GraphNode(..), pattern GraphNodeEntry, pattern GraphNodeReturn, nodeFuns, graphNodeBlocks ) +import Pate.Verification.PairGraph.Node ( GraphNode, GraphNode'(..), pattern GraphNodeEntry, pattern GraphNodeReturn, nodeFuns, graphNodeBlocks, asSingleNode, singleNodeDivergence, singleNodeDivergePoint, singleNodeRepr ) import qualified Pate.Verification.StrongestPosts.CounterExample as CE import qualified Pate.AssumptionSet as PAs @@ -132,6 +132,8 @@ import Pate.Verification.Domain (universalDomain) import qualified Data.Parameterized.TraversableF as TF import qualified Data.IORef as IO import qualified Data.Parameterized.TraversableFC as TFC +import qualified Data.Quant as Qu +import qualified Pate.Verification.FnBindings as PFn -- | Generate a fresh abstract domain value for the given graph node. -- This should represent the most information we can ever possibly @@ -829,47 +831,50 @@ propagateBindings :: GraphNode arch {- ^ to -} -> PairGraph sym arch -> EquivM sym arch (Maybe (PairGraph sym arch)) -propagateBindings scope bundle from to gr0 = withSym $ \sym -> case (from,to) of - (GraphNode fromE, GraphNode toE) - | Just (Some fromSNE) <- asSingleNodeEntry fromE - , Just (Some toSNE) <- asSingleNodeEntry toE - -- nodes are both single-sided and the same side - , Just Refl <- testEquality (singleEntryBin fromSNE) (singleEntryBin toSNE) - -- nodes have the same divergence point - , fromDP <- singleNodeDivergePoint fromSNE - , dp <- singleNodeDivergePoint toSNE - , fromDP == dp - -- 'to' node has defined bindings that need to be propagated - , Just (PS.AbsT toBindsSpec) <- MapF.lookup toSNE (gr0 ^. (syncData dp . syncBindings)) - -> do - let outVars = PS.bundleOutVars scope bundle - toBinds <- liftIO $ PS.bindSpec sym outVars toBindsSpec - lookupFnBindings scope fromSNE gr0 >>= \case - -- 'from' has existing binds so we check if we actually need to propagate - -- FIXME: can we check this without the solver? do we need to check it? - Just fromBinds -> do - emitTrace @"debug" "Propagating and merging with existing bindings" - fromBindsPred <- IO.liftIO $ PFn.toPred sym fromBinds - withAssumption fromBindsPred $ do - toBindsPred <- IO.liftIO $ PFn.toPred sym toBinds - not_toBindsPred <- liftIO $ W4.notPred sym toBindsPred - goalTimeout <- CMR.asks (PC.cfgGoalTimeout . envConfig) - isPredSat' goalTimeout not_toBindsPred >>= \case - Just False -> do - emitTraceLabel @"expr" (ExprLabel $ "Proved bindings") (Some toBindsPred) - return Nothing - _ -> do - -- FIXME: use 'addFnBindings' instead? needs to take a mux condition - pathCond <- scopedPathCondition scope - bindsCombined <- IO.liftIO $ PFn.mux sym pathCond toBinds fromBinds - return $ Just $ gr0 & (syncData dp . syncBindings) %~ MapF.insert fromSNE (PS.AbsT $ PS.mkSimSpec scope bindsCombined) - -- 'from' has no binds so we propagate unconditionally - Nothing -> do - -- FIXME: do we care about the path condition here? - emitTrace @"debug" "Propagating bindings" - return $ Just $ gr0 & (syncData dp . syncBindings) %~ MapF.insert fromSNE (PS.AbsT $ PS.mkSimSpec scope toBinds) +propagateBindings scope bundle from to gr0 = withSym $ \sym -> case (asSingleNode from,asSingleNode to) of + (Just (Some (Qu.AsSingle fromS)), Just (Some (Qu.AsSingle toS))) -> + case testEquality (singleNodeRepr fromS) (singleNodeRepr toS) of + Nothing -> do + fail $ "Unexpected mismatched single-sided nodes" ++ show from ++ " vs. " ++ show to + Just Refl -> do + let dp = singleNodeDivergePoint fromS + unless (dp == singleNodeDivergePoint toS) $ + fail $ "Unexpected mismatched divergence points" ++ show from ++ "vs. " ++ show to + case MapF.lookup (Qu.AsSingle toS) (gr0 ^. (syncData dp . syncBindings)) of + -- no bindings to propagate, nothing to do + Nothing -> do + emitTrace @"debug" "No bindings to propagate" + return Nothing + -- 'to' node has defined bindings that need to be propagated + Just (PS.AbsT toBindsSpec) -> do + let outVars = PS.bundleOutVars scope bundle + toBinds <- liftIO $ PS.bindSpec sym outVars toBindsSpec + lookupFnBindings scope fromS gr0 >>= \case + -- 'from' has existing binds so we check if we actually need to propagate + -- FIXME: can we check this without the solver? do we need to check it? + Just fromBinds -> do + emitTrace @"debug" "Propagating and merging with existing bindings" + fromBindsPred <- IO.liftIO $ PFn.toPred sym fromBinds + withAssumption fromBindsPred $ do + toBindsPred <- IO.liftIO $ PFn.toPred sym toBinds + not_toBindsPred <- liftIO $ W4.notPred sym toBindsPred + goalTimeout <- CMR.asks (PC.cfgGoalTimeout . envConfig) + isPredSat' goalTimeout not_toBindsPred >>= \case + Just False -> do + emitTraceLabel @"expr" (ExprLabel $ "Proved bindings") (Some toBindsPred) + return Nothing + _ -> do + -- FIXME: use 'addFnBindings' instead? needs to take a mux condition + pathCond <- scopedPathCondition scope + bindsCombined <- IO.liftIO $ PFn.mux sym pathCond toBinds fromBinds + return $ Just $ gr0 & (syncData dp . syncBindings) %~ MapF.insert (Qu.AsSingle fromS) (PS.AbsT $ PS.mkSimSpec scope bindsCombined) + -- 'from' has no binds so we propagate unconditionally + Nothing -> do + -- FIXME: do we care about the path condition here? + emitTrace @"debug" "Propagating bindings" + return $ Just $ gr0 & (syncData dp . syncBindings) %~ MapF.insert (Qu.AsSingle fromS) (PS.AbsT $ PS.mkSimSpec scope toBinds) _ -> do - emitTrace @"debug" "No bindings to propagate" + emitTrace @"debug" "Not a pair of single-sided nodes" return Nothing -- | Propagate the given condition kind backwards (from 'to' node to 'from' node). From 89fa195a67ad6c072682b9f1786cd0e58e87923a Mon Sep 17 00:00:00 2001 From: Daniel Matichuk Date: Mon, 6 Jan 2025 12:09:17 -0800 Subject: [PATCH 19/36] use global uninterpreted function to define "caller" stack base for return site bundle avoids issues with assertion propagation where the free variable used to specify this value would escape its scope and cause unpredictable behavior (i.e. infinite loops) --- src/Pate/SimState.hs | 66 ++++++++++++++++++++++++- src/Pate/Verification/StrongestPosts.hs | 6 ++- 2 files changed, 68 insertions(+), 4 deletions(-) diff --git a/src/Pate/SimState.hs b/src/Pate/SimState.hs index 29b2b07d..e8e001e8 100644 --- a/src/Pate/SimState.hs +++ b/src/Pate/SimState.hs @@ -38,8 +38,9 @@ Functionality for handling the inputs and outputs of crucible. module Pate.SimState ( -- simulator state SimState(..) - , StackBase(..) + , StackBase , freshStackBase + , nextStackBase , SimInput(..) , SimOutput(..) , type VarScope @@ -83,6 +84,7 @@ module Pate.SimState , simOutRegs , simPair , simSP + , simPC -- variable binding , SimVars(..) , bindSpec @@ -109,6 +111,7 @@ import qualified Prettyprinter as PP import Data.Parameterized.Some import Data.Parameterized.Classes +import Data.Parameterized.Context ( pattern (:>) ) import qualified Data.Parameterized.Context as Ctx import qualified Data.Parameterized.Map as MapF import qualified Data.Parameterized.TraversableF as TF @@ -141,6 +144,8 @@ import Pate.AssumptionSet import Pate.TraceTree import Data.Coerce ( coerce ) +import qualified Data.Parameterized.TraversableFC as TFC +import qualified What4.UninterpFns as W4U ------------------------------------ -- Crucible inputs and outputs @@ -170,6 +175,27 @@ simSP :: MM.RegisterInfo (MM.ArchReg arch) => SimState sym arch v bin -> PSR.MacawRegEntry sym (MT.BVType (MM.ArchAddrWidth arch)) simSP st = (simRegs st) ^. (MM.boundValue MM.sp_reg) +simPC :: MM.RegisterInfo (MM.ArchReg arch) => SimState sym arch v bin -> + PSR.MacawRegEntry sym (MT.BVType (MM.ArchAddrWidth arch)) +simPC st = (simRegs st) ^. (MM.boundValue MM.ip_reg) + +-- | By convention, the symbolic values in the register state +-- for a 'SimState' should be scoped to the associated 'v'. +-- Although this is not reflected in the internal +-- representation, 'scopedRegValue' recovers this by allowing register +-- contents to be projected to an appropriately scoped 'ScopedExpr'. +-- NB: The scoping rules are enforced by requiring that the projection +-- from the 'MacawRegEntry' be valid over any expression builder, ensuring +-- that out-of-scope expressions can't be used to define it. +scopedRegValue :: + MM.RegisterInfo (MM.ArchReg arch) => + SimState sym arch v bin -> + MM.ArchReg arch tp -> + (forall sym'. PSR.MacawRegEntry sym' tp -> W4.SymExpr sym' tp') -> + ScopedExpr sym tp' v +scopedRegValue st reg f = ScopedExpr $ f (simRegs st ^. MM.boundValue reg) + + instance Scoped (PopT (SimState sym arch) bin) where unsafeCoerceScope (PopT s) = PopT (coerce s) @@ -721,6 +747,20 @@ forScopedExpr :: IO (ScopedExpr sym tp2 v) forScopedExpr sym (ScopedExpr e1) f = ScopedExpr <$> f sym e1 +-- | Generalization of above that takes m to n scoped expressions. +forScopedExprs :: + forall sym v ctx1 ctx2 m. + Functor m => + W4.IsSymExprBuilder sym => + sym -> + Ctx.Assignment (PopScope (ScopedExpr sym) v) ctx1 -> + (forall sym'. W4.IsSymExprBuilder sym' => sym' -> Ctx.Assignment (W4.SymExpr sym') ctx1 -> m (Ctx.Assignment (W4.SymExpr sym') ctx2)) -> + m (Ctx.Assignment (PopScope (ScopedExpr sym) v) ctx2) +forScopedExprs sym scopedExprs f = + let + (exprs :: Ctx.Assignment (W4.SymExpr sym) ctx1) = TFC.fmapFC (\(PopScope e) -> unSE e) scopedExprs + in (\x -> TFC.fmapFC (\e -> PopScope (ScopedExpr e)) x) <$> f sym exprs + -- | Similar to 'forScopedExpr' but may return a value as well forScopedExprRet :: W4.IsSymExprBuilder sym => @@ -927,9 +967,31 @@ freshStackBase :: PBi.WhichBinaryRepr bin -> Proxy arch -> IO (StackBase sym arch v) -freshStackBase sym bin _arch = liftScope0 sym $ \sym' -> +freshStackBase sym bin _arch = liftScope0 sym $ \sym' -> do W4.freshConstant sym' (W4.safeSymbol ("stack_base" ++ PBi.short bin)) (W4.BaseBVRepr (MM.memWidthNatRepr @(MM.ArchAddrWidth arch))) +-- | Similar to 'freshStackBase' but defines the resulting stack base as an uninterpreted function +-- of the given state's stack base and instruction pointer. +nextStackBase :: + forall sym arch v bin. + W4.IsSymExprBuilder sym => + MM.RegisterInfo (MM.ArchReg arch) => + MM.MemWidth (MM.ArchAddrWidth arch) => + sym -> + PBi.WhichBinaryRepr bin -> + SimState sym arch v bin -> + IO (StackBase sym arch v) +nextStackBase sym bin st = do + let old_base = simStackBase st + let old_ip = scopedRegValue st MM.ip_reg (\re -> let CLM.LLVMPointer _ ip = PSR.macawRegValue re in ip) + (Ctx.Empty Ctx.:> PopScope stackBase) <- forScopedExprs sym (Ctx.Empty :> PopScope old_base :> PopScope old_ip) $ \sym' exprs -> do + let stackRepr = (W4.BaseBVRepr (MM.memWidthNatRepr @(MM.ArchAddrWidth arch))) + fn <- W4U.mkUninterpretedSymFn sym' ("stack_base" ++ PBi.short bin) (TFC.fmapFC W4.exprType exprs) stackRepr + e <- W4.applySymFn sym' fn exprs + return $ Ctx.singleton e + return stackBase + + ------------------------------------ -- ExprMappable instances diff --git a/src/Pate/Verification/StrongestPosts.hs b/src/Pate/Verification/StrongestPosts.hs index ce36929d..119d0d85 100644 --- a/src/Pate/Verification/StrongestPosts.hs +++ b/src/Pate/Verification/StrongestPosts.hs @@ -1780,8 +1780,10 @@ returnSiteBundle scope vars _preD pPair = withSym $ \sym -> do simOut_ <- PPa.forBins $ \bin -> do input <- PPa.get bin simIn_ let inSt = PS.simInState input - postFrame <- liftIO $ PS.freshStackBase sym bin (Proxy @arch) - let postSt = inSt { PS.simStackBase = PS.simCallerStackBase inSt, PS.simCallerStackBase = postFrame } + let postSt_ = inSt { PS.simStackBase = PS.simCallerStackBase inSt } + postFrame <- liftIO $ PS.nextStackBase sym bin postSt_ + let postSt = postSt_ { PS.simCallerStackBase = postFrame } + return $ PS.SimOutput postSt blockEndVal bundle <- applyCurrentAsms $ SimBundle simIn_ simOut_ From 8d6da883f4132d627907df99f5fd0819263d7cd0 Mon Sep 17 00:00:00 2001 From: Daniel Matichuk Date: Mon, 6 Jan 2025 12:13:12 -0800 Subject: [PATCH 20/36] always add divergence point when combining single-sided nodes when combining single-sided nodes, the resulting (two-sided) node should be annotated with the initial divergence point (which must be shared between the single-sided nodes) this is a convention that simplifies recovering control flow divergence information, but needs to be consistently applied to avoid inconsistencies --- src/Pate/Verification/PairGraph.hs | 16 +--------- src/Pate/Verification/PairGraph/Node.hs | 41 ++++++++++++++----------- 2 files changed, 24 insertions(+), 33 deletions(-) diff --git a/src/Pate/Verification/PairGraph.hs b/src/Pate/Verification/PairGraph.hs index 40b106b3..960a9823 100644 --- a/src/Pate/Verification/PairGraph.hs +++ b/src/Pate/Verification/PairGraph.hs @@ -69,7 +69,6 @@ module Pate.Verification.PairGraph , dropPostDomains , markEdge , getBackEdgesFrom - , combineNodes , NodePriority(..) , addToWorkList , WorkItem(ProcessNode, ProcessSplit) @@ -1387,20 +1386,7 @@ pgMaybe msg Nothing = throwError $ PEE.PairGraphErr msg --- | Compute a merged node for two diverging nodes --- FIXME: do we need to support mismatched node kinds here? -combineNodes :: SingleNodeEntry arch bin -> SingleNodeEntry arch (PBi.OtherBinary bin) -> Maybe (GraphNode' arch Qu.AllK) -combineNodes node1 node2 = do - let ndPair = PPa.mkPair (singleEntryBin node1) (Qu.AsSingle node1) (Qu.AsSingle node2) - Qu.AsSingle nodeO <- PPa.get PBi.OriginalRepr ndPair - Qu.AsSingle nodeP <- PPa.get PBi.PatchedRepr ndPair - -- it only makes sense to combine nodes that share a divergence point, - -- where that divergence point will be used as the calling context for the - -- merged point - let divergeO = singleNodeDivergence nodeO - let divergeP = singleNodeDivergence nodeP - guard $ divergeO == divergeP - return $ GraphNode $ mkMergedNodeEntry divergeO (singleNodeBlock nodeO) (singleNodeBlock nodeP) + nodeToSingleRepr :: GraphNode arch -> Maybe (Some (PBi.WhichBinaryRepr)) nodeToSingleRepr nd = case graphNodeBlocks nd of diff --git a/src/Pate/Verification/PairGraph/Node.hs b/src/Pate/Verification/PairGraph/Node.hs index ede18e6d..330175e3 100644 --- a/src/Pate/Verification/PairGraph/Node.hs +++ b/src/Pate/Verification/PairGraph/Node.hs @@ -52,6 +52,7 @@ module Pate.Verification.PairGraph.Node ( , isSingleReturn , splitGraphNode , getDivergePoint + , getDivergePoint' , eqUptoDivergePoint , mkMergedNodeEntry , mkMergedNodeReturn @@ -123,7 +124,9 @@ instance OrdF (GraphNode' arch) where coerceContext :: Qu.QuantCoercion t1 t2 -> GraphNode' arch t1 -> CallingContext' arch t1 -> CallingContext' arch t2 coerceContext qc nd x@(CallingContext' cctx dp) = case qc of - Qu.CoerceAllToOne repr -> CallingContext' cctx (DivergePointSingle repr nd) + Qu.CoerceAllToOne repr -> case divergePoint' (nodeContext nd) of + DivergePoint nd' -> CallingContext' cctx (DivergePointSingle repr nd') + NoDivergePoint -> CallingContext' cctx (DivergePointSingle repr nd) Qu.CoerceToExists _ -> CallingContext' cctx (divergePointExists dp) Qu.CoerceRefl{} -> x @@ -331,10 +334,12 @@ instance PA.ValidArch arch => JSON.ToJSON (CallingContext' arch qbin) where toJSON (CallingContext bps mdivisionPoint) = JSON.object [ "ancestors" JSON..= bps, "divergedAt" JSON..= divergePointNode mdivisionPoint] getDivergePoint :: GraphNode arch -> Maybe (GraphNode arch) -getDivergePoint nd = case nodeContext nd of - CallingContext _ (DivergePoint dp) -> Just (Qu.coerceQuant dp) - CallingContext _ NoDivergePoint -> Nothing +getDivergePoint nd = fmap Qu.coerceQuant $ getDivergePoint' nd +getDivergePoint' :: GraphNode' arch qbin -> Maybe (GraphNode' arch Qu.AllK) +getDivergePoint' nd = case nodeContext nd of + CallingContext _ (DivergePoint dp) -> Just dp + CallingContext _ NoDivergePoint -> Nothing rootEntry :: PPa.PatchPair (PB.ConcreteBlock arch) -> NodeEntry arch rootEntry pPair = NodeEntry (CallingContext [] (SomeDivergePoint Nothing)) pPair @@ -624,16 +629,6 @@ singleToNodeEntry sne = case singleToGraphNode (GraphNode sne) of singleToGraphNode :: SingleGraphNode arch bin -> GraphNode arch singleToGraphNode sgn = withRepr (singleNodeRepr sgn) $ Qu.coerceQuant sgn -combineSingleEntries' :: - SingleNodeEntry arch PB.Original -> - SingleNodeEntry arch PB.Patched -> - Maybe (NodeEntry arch) -combineSingleEntries' (SingleNodeEntry cctxO blksO) (SingleNodeEntry cctxP blksP) = do - divergeO <- divergePoint $ cctxO - divergeP <- divergePoint $ cctxP - guard $ divergeO == divergeP - return $ mkNodeEntry' (Qu.coerceQuant divergeO) (PPa.PatchPair blksO blksP) - -- | Create a combined two-sided 'NodeEntry' based on -- a pair of single-sided entries. The given entries -- must have the same diverge point (returns 'Nothing' otherwise), @@ -642,11 +637,21 @@ combineSingleEntries' (SingleNodeEntry cctxO blksO) (SingleNodeEntry cctxP blksP -- the either single-sided analysis is discarded) combineSingleEntries :: SingleNodeEntry arch bin -> - SingleNodeEntry arch (PB.OtherBinary bin) -> + SingleNodeEntry arch (PB.OtherBinary bin) -> Maybe (NodeEntry arch) -combineSingleEntries sne1 sne2 = case singleEntryBin sne1 of - PB.OriginalRepr -> combineSingleEntries' sne1 sne2 - PB.PatchedRepr -> combineSingleEntries' sne2 sne1 +combineSingleEntries node1 node2 = do + let ndPair = PPa.mkPair (singleEntryBin node1) (Qu.AsSingle node1) (Qu.AsSingle node2) + Qu.AsSingle nodeO <- PPa.get PB.OriginalRepr ndPair + Qu.AsSingle nodeP <- PPa.get PB.PatchedRepr ndPair + -- it only makes sense to combine nodes that share a divergence point, + -- where that divergence point will be used as the calling context for the + -- merged point + let divergeO = singleNodeDivergence nodeO + let divergeP = singleNodeDivergence nodeP + guard $ divergeO == divergeP + let ne = mkMergedNodeEntry divergeO (singleNodeBlock nodeO) (singleNodeBlock nodeP) + GraphNode ne' <- return $ Qu.coerceToExists (GraphNode ne) + return ne' type SingleNodeReturn arch bin = NodeReturn' arch (Qu.OneK bin) From 66ed8efa645ac010fd7b136fb85c2a8ad95a3185 Mon Sep 17 00:00:00 2001 From: Daniel Matichuk Date: Mon, 6 Jan 2025 12:19:03 -0800 Subject: [PATCH 21/36] avoid scheduling loop when re-processing control flow divergence adds a flag to "ProcessNode" that indicates when additional control flow merge logic should fire when the node is processed. --- src/Pate/Verification/PairGraph.hs | 83 +++++++++++++++++++------ src/Pate/Verification/StrongestPosts.hs | 27 ++++++-- 2 files changed, 86 insertions(+), 24 deletions(-) diff --git a/src/Pate/Verification/PairGraph.hs b/src/Pate/Verification/PairGraph.hs index 960a9823..3e6204d7 100644 --- a/src/Pate/Verification/PairGraph.hs +++ b/src/Pate/Verification/PairGraph.hs @@ -137,6 +137,7 @@ module Pate.Verification.PairGraph , initFnBindings , addFnBindings , getAllSyncPoints + , queueSyncNodeMerge ) where import Prettyprinter @@ -335,8 +336,9 @@ type WorkList arch = RevMap (WorkItem arch) NodePriority -- | Operations that can be a scheduled and handled -- at the top-level. data WorkItem arch = - -- | Handle all normal node processing logic - ProcessNode (GraphNode arch) + -- | Handle all normal node processing logic. Boolean flag indicates if + -- additional processing should be scheduled to handled control flow diverge/convergence. + ProcessNode { _handleMerge :: Bool, _workItemNode :: GraphNode arch } -- | Handle merging two single-sided analyses (both nodes must share a diverge point) | ProcessMergeAtExitsCtor (SingleNodeEntry arch PBi.Original) @@ -352,7 +354,7 @@ deriving instance Ord (WorkItem arch) instance PA.ValidArch arch => Show (WorkItem arch) where show = \case - ProcessNode nd -> "ProcessNode " ++ show nd + ProcessNode handleMerge nd -> "ProcessNode " ++ if handleMerge then "" else "(no merge) " ++ show nd ProcessMergeAtEntry sneO sneP -> "ProcessMergeAtEntry " ++ show sneO ++ " vs. " ++ show sneP ProcessMergeAtExits sneO sneP -> "ProcessMergeAtExits " ++ show sneO ++ " vs. " ++ show sneP ProcessSplit sne -> "ProcessSplit " ++ show sne @@ -717,7 +719,7 @@ mkProcessSplit sne = do workItemNode :: WorkItem arch -> GraphNode arch workItemNode = \case - ProcessNode nd -> nd + ProcessNode _ nd -> nd ProcessMerge spO spP -> case combineSingleEntries spO spP of Just merged -> GraphNode merged Nothing -> panic Verifier "workItemNode" ["Unexpected mismatched single-sided nodes"] @@ -1019,7 +1021,7 @@ dropDomain nd priority pg = case getCurrentDomain pg nd of pg' = case Set.null (getBackEdgesFrom pg nd) of -- don't drop the domain for a toplevel entrypoint, but mark it for -- re-analysis - True -> pg { pairGraphWorklist = RevMap.insertWith (min) (ProcessNode nd) priority (pairGraphWorklist pg) } + True -> pg { pairGraphWorklist = RevMap.insertWith (min) (ProcessNode True nd) priority (pairGraphWorklist pg) } False -> pg { pairGraphDomains = Map.delete nd (pairGraphDomains pg), pairGraphWorklist = dropNodeFromWorkList nd (pairGraphWorklist pg) } @@ -1041,10 +1043,20 @@ queueEntryPoints priority pg = queueAncestors :: NodePriority -> GraphNode arch -> PairGraph sym arch -> PairGraph sym arch queueAncestors priority nd pg = - snd $ Set.foldr (queueNode' priority) (Set.singleton nd, pg) (getBackEdgesFrom pg nd) + snd $ Set.foldr (queueNode' priority True) (Set.singleton nd, pg) (getBackEdgesFrom pg nd) queueNode :: NodePriority -> GraphNode' arch qbin -> PairGraph sym arch -> PairGraph sym arch -queueNode priority nd__ pg__ = withKnownBin nd__ $ snd $ queueNode' priority (Qu.coerceToExists nd__) (Set.empty, pg__) +queueNode priority nd__ pg__ = queueNode'' priority True nd__ pg__ + +queueNode'' :: + NodePriority -> + Bool {- ^ true if control flow merge processing should occur when node is handled -} -> + GraphNode' arch qbin -> + PairGraph sym arch -> + PairGraph sym arch +queueNode'' priority handleMerge nd__ pg__ = + withKnownBin nd__ $ snd $ queueNode' priority handleMerge (Qu.coerceToExists nd__) (Set.empty, pg__) + -- | Calls 'queueNode' for 'ProcessNode' work items. -- For 'ProcessMerge' work items, queues up the merge if @@ -1054,7 +1066,7 @@ queueNode priority nd__ pg__ = withKnownBin nd__ $ snd $ queueNode' priority (Qu -- it has a domain, otherwise queues the source (two-sided) diverging node. queueWorkItem :: NodePriority -> WorkItem arch -> PairGraph sym arch -> PairGraph sym arch queueWorkItem priority wi pg = case wi of - ProcessNode nd -> queueNode priority nd pg + ProcessNode handleMerge nd -> queueNode'' priority handleMerge nd pg ProcessMerge spO spP -> let neO = GraphNode (singleToNodeEntry spO) @@ -1082,14 +1094,19 @@ queueSplitAnalysis priority ne = do -- | Adds a node to the work list. If it doesn't have a domain, queue its ancestors. -- Takes a set of nodes that have already been considerd, and returns all considered nodes -queueNode' :: NodePriority -> GraphNode arch -> (Set (GraphNode arch), PairGraph sym arch) -> (Set (GraphNode arch), PairGraph sym arch) -queueNode' priority nd_ (considered, pg_) = case Set.member nd_ considered of +queueNode' :: + NodePriority -> + Bool {- ^ true if control flow merge processing should occur when node is handled -} -> + GraphNode arch -> + (Set (GraphNode arch), PairGraph sym arch) -> + (Set (GraphNode arch), PairGraph sym arch) +queueNode' priority handleMerge nd_ (considered, pg_) = case Set.member nd_ considered of True -> (considered, pg_) - False -> case addToWorkList nd_ priority pg_ of + False -> case addToWorkList handleMerge nd_ priority pg_ of Just pg' -> (Set.insert nd_ considered, pg') -- if this node has no defined domain (i.e it was dropped as part of the previous -- step) then we consider further ancestors - Nothing -> Set.foldr' (queueNode' priority) (Set.insert nd_ considered, pg_) (getBackEdgesFrom pg_ nd_) + Nothing -> Set.foldr' (queueNode' priority handleMerge) (Set.insert nd_ considered, pg_) (getBackEdgesFrom pg_ nd_) getCondition :: PairGraph sym arch -> @@ -1322,7 +1339,7 @@ updateDomain' :: PairGraph sym arch updateDomain' gr pFrom pTo d priority = markEdge pFrom pTo $ gr { pairGraphDomains = Map.insert pTo d (pairGraphDomains gr) - , pairGraphWorklist = RevMap.insertWith (min) (ProcessNode pTo) priority (pairGraphWorklist gr) + , pairGraphWorklist = RevMap.insertWith (min) (ProcessNode True pTo) priority (pairGraphWorklist gr) , pairGraphEdges = Map.insertWith Set.union pFrom (Set.singleton pTo) (pairGraphEdges gr) , pairGraphBackEdges = Map.insertWith Set.union pTo (Set.singleton pFrom) (pairGraphBackEdges gr) } @@ -1378,7 +1395,7 @@ addReturnVector gr funPair retPair priority = f Nothing = Just (Set.singleton retPair) f (Just s) = Just (Set.insert retPair s) - wl = RevMap.insertWith (min) (ProcessNode (ReturnNode funPair)) priority (pairGraphWorklist gr) + wl = RevMap.insertWith (min) (ProcessNode True (ReturnNode funPair)) priority (pairGraphWorklist gr) pgMaybe :: String -> Maybe a -> PairGraphM sym arch a pgMaybe _ (Just a) = return a @@ -1401,12 +1418,13 @@ tryPG f = catchError (Just <$> f) (\_ -> return Nothing) -- | Add a node back to the worklist to be re-analyzed if there is -- an existing abstract domain for it. Otherwise return Nothing. addToWorkList :: + Bool {- ^ true if control flow merge processing should occur when node is handled -} -> GraphNode arch -> NodePriority -> PairGraph sym arch -> Maybe (PairGraph sym arch) -addToWorkList nd priority gr = case getCurrentDomain gr nd of - Just{} -> Just $ addItemToWorkList (ProcessNode nd) priority gr +addToWorkList handleMerge nd priority gr = case getCurrentDomain gr nd of + Just{} -> Just $ addItemToWorkList (ProcessNode handleMerge nd) priority gr Nothing -> Nothing -- | Add a work item to the worklist to be processed @@ -1444,7 +1462,7 @@ freshDomain :: PairGraph sym arch freshDomain gr pTo priority d = gr{ pairGraphDomains = Map.insert pTo d (pairGraphDomains gr) - , pairGraphWorklist = RevMap.insertWith (min) (ProcessNode pTo) priority (pairGraphWorklist gr) + , pairGraphWorklist = RevMap.insertWith (min) (ProcessNode True pTo) priority (pairGraphWorklist gr) } initDomain :: @@ -1607,7 +1625,7 @@ filterSyncExits :: WorkItem arch -> [PPa.PatchPair (PB.BlockTarget arch)] -> PairGraphM sym arch [PPa.PatchPair (PB.BlockTarget arch)] -filterSyncExits _ (ProcessNode (ReturnNode{})) _ = fail "Unexpected ReturnNode work item" +filterSyncExits _ (ProcessNode _ (ReturnNode{})) _ = fail "Unexpected ReturnNode work item" filterSyncExits _ (ProcessMergeAtExits sneO sneP) blktPairs = do let isSyncExitPair blktPair = do blktO <- PPa.get PBi.OriginalRepr blktPair @@ -1632,12 +1650,13 @@ filterSyncExits priority (ProcessSplit sne) blktPairs = pgValid $ do return $ Set.member blkt desyncExits x <- filterM isDesyncExitPair blktPairs return x -filterSyncExits priority (ProcessNode (GraphNode ne)) blktPairs = case asSingleNodeEntry ne of +filterSyncExits priority (ProcessNode _ (GraphNode ne)) blktPairs = case asSingleNodeEntry ne of Nothing -> return blktPairs Just (Some (Qu.AsSingle sne)) -> do let bin = singleEntryBin sne blkts <- mapM (PPa.get bin) blktPairs syncExits <- catMaybes <$> mapM (isSyncExit sne) blkts + -- TODO: should we only queue exit merges if 'handleMerge' from 'ProcessNode' is set? forM_ syncExits $ \exit -> queueExitMerges priority exit return blktPairs @@ -1714,4 +1733,28 @@ handleSingleSidedReturnTo priority ne = case asSingleNodeEntry ne of case Set.member (PPa.WithBin bin (PB.concreteAddress blk)) syncAddrs of True -> queueExitMerges priority (SyncAtStart sne) False -> return () - Nothing -> return () \ No newline at end of file + Nothing -> return () + + +-- | Queue all sync points that correspond to this node. +-- Returns False if the given node is not a sync point. +queueSyncNodeMerge :: + forall sym arch qbin. + (NodePriorityK -> NodePriority) -> + GraphNode' arch qbin -> + PairGraphM sym arch Bool +queueSyncNodeMerge priority node = fmap (fromMaybe False) <$> tryPG $ do + dp <- pgMaybe "getDivergePoint" $ getDivergePoint' node + GraphNode node' <- toTwoSidedNode node + + syncO <- getSyncData syncPoints PBi.OriginalRepr dp + syncP <- getSyncData syncPoints PBi.PatchedRepr dp + + GraphNode (sneO :: SingleNodeEntry arch PBi.Original) <- return $ Qu.coerceQuant (GraphNode node') + GraphNode (sneP :: SingleNodeEntry arch PBi.Patched) <- return $ Qu.coerceQuant (GraphNode node') + + let hasO = filter (\sp -> syncPointNode sp == sneO) (Set.toList syncO) + let hasP = filter (\sp -> syncPointNode sp == sneP) (Set.toList syncP) + let syncs = [(x,y) | x <- hasO, y <- hasP] + forM_ syncs $ \(x,y) -> queueSyncPoints priority x y + return $ not (null syncs) diff --git a/src/Pate/Verification/StrongestPosts.hs b/src/Pate/Verification/StrongestPosts.hs index 119d0d85..5bc89755 100644 --- a/src/Pate/Verification/StrongestPosts.hs +++ b/src/Pate/Verification/StrongestPosts.hs @@ -855,19 +855,38 @@ withWorkItem gr0 f = do let nd = workItemNode wi res <- subTraceLabel @"node" (printPriorityKind priority) nd $ atPriority priority Nothing $ do (mnext, gr2) <- case wi of - ProcessNode (GraphNode ne) | Just (Some (Qu.AsSingle sne)) <- asSingleNodeEntry ne -> do + ProcessNode True (GraphNode ne) | Just (Some (Qu.AsSingle sne)) <- asSingleNodeEntry ne -> do (evalPG gr1 $ isSyncNode sne) >>= \case True -> do gr2 <- execPG gr1 $ queueExitMerges (\pk -> mkPriority pk priority) (SyncAtStart sne) return $ (Nothing, gr2) False -> processNode (GraphNode ne) gr1 - ProcessNode nd' -> processNode nd' gr1 + ProcessNode True nd' -> do + emitTrace @"debug" $ "ProcessNode: " ++ show nd' + p <- thisPriority + (isSync, gr2) <- (runPG gr1 $ queueSyncNodeMerge p nd') + case isSync of + True -> do + emitTrace @"debug" $ "Sync node found, scheduling merge" + return (Nothing, gr2) + False -> processNode nd' gr1 + ProcessNode False nd' -> do + emitTrace @"debug" $ "ProcessNode: (no merge)" ++ show nd' + processNode nd' gr1 ProcessSplit sne -> do emitTrace @"debug" $ "ProcessSplit: " ++ show sne handleProcessSplit sne gr1 ProcessMerge sneO sneP -> do emitTrace @"debug" $ "ProcessMerge: " ++ show sneO ++ " vs. " ++ show sneP - handleProcessMerge sneO sneP gr1 + (mnext, gr2) <- handleProcessMerge sneO sneP gr1 + case mnext of + Just next -> do + emitTrace @"debug" $ "Drop and re-queue: " ++ show next + let gr3 = queueWorkItem priority (ProcessNode False next) $ dropWorkItem (ProcessNode True next) gr2 + return $ (Nothing, gr3) + Nothing -> do + emitTrace @"debug" $ "No merge possible" + return (Nothing, gr2) case (mnext, getCurrentDomain gr2 nd) of (Just next, Just spec) | next == nd -> fmap Right $ f (priority, gr2, wi, spec) _ -> return $ Left (mnext, gr2) @@ -3037,7 +3056,7 @@ handleDivergingPaths scope bundle currBlock st dom blkt = fnTrace "handleDivergi -- this allows, for example, the analysis to determine -- that this is unreachable (potentially after refinements) and therefore -- doesn't need synchronization - Just pg1 <- return $ addToWorkList someDivergeNode (priority PriorityDeferred) pg + Just pg1 <- return $ addToWorkList True someDivergeNode (priority PriorityDeferred) pg return $ st'{ branchGraph = pg1 } AlignControlFlow condK -> withSym $ \sym -> do traces <- bundleToInstrTraces bundle From c9937d6a7bfefc2c8c2c38a88404d419917bde19 Mon Sep 17 00:00:00 2001 From: Daniel Matichuk Date: Mon, 6 Jan 2025 12:25:10 -0800 Subject: [PATCH 22/36] rewrite propagated assertion using function bindings ensures that, in the case where the assertion is not discharged, the resulting predicate fully internalizes the two single-sided analyses (i.e. converts the two independent assertions back into a relation) --- src/Pate/Verification/StrongestPosts.hs | 35 ++++++++++++++----------- 1 file changed, 20 insertions(+), 15 deletions(-) diff --git a/src/Pate/Verification/StrongestPosts.hs b/src/Pate/Verification/StrongestPosts.hs index 5bc89755..e23816f6 100644 --- a/src/Pate/Verification/StrongestPosts.hs +++ b/src/Pate/Verification/StrongestPosts.hs @@ -586,8 +586,6 @@ initSingleSidedDomain :: PairGraph sym arch -> EquivM sym arch (PairGraph sym arch) initSingleSidedDomain sne pg0 = withRepr bin $ withRepr (PBi.flipRepr bin) $ withSym $ \sym -> withPG_ pg0 $ do - priority <- lift $ thisPriority - let dp = singleNodeDivergePoint (GraphNode sne) let nd = Qu.coerceToExists dp nd' <- case Qu.convertQuant nd of @@ -611,28 +609,33 @@ initSingleSidedDomain sne pg0 = withRepr bin $ withRepr (PBi.flipRepr bin) $ wit mbindsThis <- lift $ lookupFnBindings scope (GraphNode sne) pg0 mbindsOther <- lift $ lookupFnBindings scope sne_other pg0 - - - let do_widen pg = do - pr <- currentPriority - atPriority (raisePriority pr) (Just "Starting Split Analysis") $ - withGraphNode' scope nd bundle dom pg $ - widenAlongEdge scope bundle nd dom_single pg nd_single - - let rewrite_assert exprBinds pg = case getCondition pg nd ConditionAsserted of + let rewrite_assert exprBinds pg = fnTrace "rewrite_assert" $ case getCondition pg nd ConditionAsserted of Just condSpec -> do cond <- liftIO $ PS.bindSpec sym (PS.scopeVarsPair scope) condSpec cond' <- PSi.applySimpStrategy (PSi.rewriteStrategy exprBinds) cond let condSpec' = PS.mkSimSpec scope cond' return $ setCondition nd ConditionAsserted PropagateFull condSpec' pg Nothing -> return pg + + let do_widen binds pg = fnTrace "do_widen" $ do + pr <- currentPriority + atPriority (raisePriority pr) (Just "Starting Split Analysis") $ do + pg2 <- propagateOne scope bundle nd nd_single ConditionAsserted pg >>= \case + Just pg1 -> rewrite_assert binds pg1 + Nothing -> return pg + + withAssumptionSet (PAS.fromExprBindings binds) $ withGraphNode' scope nd bundle dom pg2 $ do + widenAlongEdge scope bundle nd dom_single pg2 nd_single + case (mbindsThis, mbindsOther) of (Just bindsThis, Just bindsOther) -> do + emitTrace @"debug" "Case: Bindings on both sides" binds <- IO.liftIO $ WEH.mergeBindings sym (PFn.toExprBindings bindsThis) (PFn.toExprBindings bindsOther) - liftEqM_ $ \pg -> (withAssumptionSet (PAS.fromExprBindings binds) $ do_widen pg) >>= rewrite_assert binds + liftEqM_ $ \pg -> do_widen binds pg (Just{}, Nothing) -> do + emitTrace @"debug" "Case: Bindings on only this side" pr <- lift $ currentPriority -- Should we lower the priority here? Is it possible to get caught in a loop otherwise? -- Formally we should be able to find all relevant nodes based on which bindings @@ -642,10 +645,12 @@ initSingleSidedDomain sne pg0 = withRepr bin $ withRepr (PBi.flipRepr bin) $ wit modify $ queueAncestors pr (GraphNode $ singleToNodeEntry (syncPointNode sp)) (Nothing, Just bindsOther) -> do + emitTrace @"debug" "Case: Bindings on only other side" let binds = PFn.toExprBindings bindsOther - liftEqM_ $ \pg -> - (withAssumptionSet (PAS.fromExprBindings binds) $ do_widen pg) >>= rewrite_assert binds - (Nothing, Nothing) -> liftEqM_ do_widen + liftEqM_ $ \pg -> do_widen binds pg + (Nothing, Nothing) -> do + emitTrace @"debug" "Case: No bindings" + liftEqM_ $ do_widen MapF.empty return (PS.WithScope ()) where From eab0181dcfe811e02d534577b54827098ebed1fe Mon Sep 17 00:00:00 2001 From: Daniel Matichuk Date: Mon, 6 Jan 2025 12:28:16 -0800 Subject: [PATCH 23/36] add debugging information when function bindings need to be propagated --- src/Pate/Verification/Widening.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Pate/Verification/Widening.hs b/src/Pate/Verification/Widening.hs index e56d9f56..de1469fe 100644 --- a/src/Pate/Verification/Widening.hs +++ b/src/Pate/Verification/Widening.hs @@ -863,9 +863,12 @@ propagateBindings scope bundle from to gr0 = withSym $ \sym -> case (asSingleNod Just False -> do emitTraceLabel @"expr" (ExprLabel $ "Proved bindings") (Some toBindsPred) return Nothing - _ -> do + _ -> withTracing @"message" "Fail to prove bindings" $ do + emitTraceLabel @"expr" (ExprLabel $ "To Bindings") (Some toBindsPred) + emitTraceLabel @"expr" (ExprLabel $ "From Bindings") (Some fromBindsPred) -- FIXME: use 'addFnBindings' instead? needs to take a mux condition pathCond <- scopedPathCondition scope + emitTraceLabel @"expr" (ExprLabel $ "Path Condition") (Some (PS.unSE pathCond)) bindsCombined <- IO.liftIO $ PFn.mux sym pathCond toBinds fromBinds return $ Just $ gr0 & (syncData dp . syncBindings) %~ MapF.insert (Qu.AsSingle fromS) (PS.AbsT $ PS.mkSimSpec scope bindsCombined) -- 'from' has no binds so we propagate unconditionally From 6b4b2477dd5bd13a17d99706373be327b6f9a2c1 Mon Sep 17 00:00:00 2001 From: Daniel Matichuk Date: Tue, 7 Jan 2025 15:30:12 -0800 Subject: [PATCH 24/36] add type-level case distinction for QuantK --- src/Data/Quant.hs | 28 +++++++++++++++++++--------- 1 file changed, 19 insertions(+), 9 deletions(-) diff --git a/src/Data/Quant.hs b/src/Data/Quant.hs index afbfd9fc..c9fd13f0 100644 --- a/src/Data/Quant.hs +++ b/src/Data/Quant.hs @@ -83,10 +83,13 @@ module Data.Quant , ExistsOrCases(..) , TheOneK , IfIsOneK + , IfIsOneKElse + , NotAllK , coerceExists ) where import Prelude hiding (map, traverse) +import GHC.TypeLits (TypeError, ErrorMessage(..)) import Data.Kind (Type) import Data.Constraint @@ -111,6 +114,12 @@ type OneK = 'OneK type ExistsK = 'ExistsK type AllK = 'AllK +type family QuantKCases (tp :: QuantK k) (caseOne :: l) (caseExists :: l) (caseAll :: l) :: l where + QuantKCases (OneK _) k _ _ = k + QuantKCases AllK _ _ k = k + QuantKCases ExistsK _ k _ = k + + type KnownHasRepr (k0 :: k) = KnownRepr (ReprOf :: k -> Type) k0 -- | Similar to 'KnownRepr' and 'IsRepr' but defines a specific type 'ReprOf' that serves as the runtime representation of @@ -487,10 +496,14 @@ instance QuantConvertible (Quant (f :: k -> Type)) where type family TheOneK (tp :: QuantK k) :: k where TheOneK (OneK k) = k -type family IfIsOneK (tp :: QuantK k) (c :: Constraint) :: Constraint where - IfIsOneK (OneK k) c = c - IfIsOneK AllK c = () - IfIsOneK ExistsK c = () +type family IfIsOneKElse (tp :: QuantK k) (cT :: Constraint) (cF :: Constraint) :: Constraint where + IfIsOneKElse (OneK k) cT _ = cT + IfIsOneKElse AllK _ cF = cF + IfIsOneKElse ExistsK _ cF = cF + +type IfIsOneK tp (c :: Constraint) = QuantKCases tp c (() :: Constraint) (() :: Constraint) + +type NotAllK tp = QuantKCases tp (() :: Constraint) (() :: Constraint) (TypeError ('Text "NotAllK: Cannot match with AllK")) asQuantOne :: forall k (x :: k) f tp. HasReprK k => ReprOf x -> Quant (f :: k -> Type) (tp :: QuantK k) -> Maybe (Dict (KnownRepr QuantRepr tp), Dict (IfIsOneK tp (x ~ TheOneK tp)), ReprOf x, f x) asQuantOne repr = \case @@ -511,10 +524,7 @@ data ExistsOrCases (tp1 :: QuantK k) (tp2 :: QuantK k) where ExistsOrRefl :: ExistsOrCases tp tp ExistsOrExists :: ExistsOrCases ExistsK tp -type family IsExistsOrConstraint (tp1 :: QuantK k) (tp2 :: QuantK k) :: Constraint where - IsExistsOrConstraint (OneK x) tp = (OneK x ~ tp) - IsExistsOrConstraint (AllK :: QuantK k) tp = ((AllK :: QuantK k) ~ tp) - IsExistsOrConstraint ExistsK _ = () +type IsExistsOrConstraint (tp1 :: QuantK k) (tp2 :: QuantK k) = QuantKCases tp1 (tp1 ~ tp2) (() :: Constraint) (tp1 ~ tp2) class (IsExistsOr tp1 tp1, IsExistsOr tp2 tp2, IsExistsOrConstraint tp1 tp2) => IsExistsOr (tp1 :: QuantK k) (tp2 :: QuantK k) where isExistsOr :: ExistsOrCases tp1 tp2 @@ -570,7 +580,7 @@ existsOrCases f g = case (isExistsOr :: ExistsOrCases tp tp') of ExistsOrRefl -> g -- | Pattern for creating or matching a singleton 'Quant', generalized over the existential cases -pattern Single :: forall {k} f tp. (HasReprK k) => forall x. (IsExistsOr tp (OneK x), IfIsOneK tp (x ~ TheOneK tp), KnownRepr QuantRepr tp) => ReprOf x -> f x -> Quant (f :: k -> Type) tp +pattern Single :: forall {k} f tp. (HasReprK k) => forall x. (KnownRepr QuantRepr tp, IsExistsOr tp (OneK x), IfIsOneK tp (x ~ TheOneK tp)) => ReprOf x -> f x -> Quant (f :: k -> Type) tp pattern Single repr x <- (quantAsOne -> Just (QuantAsOneProof repr x)) where Single (repr :: ReprOf x) x = existsOrCases @tp @(OneK x) (withRepr repr $ QuantExists (Single repr x)) (QuantOne repr x) From ba4e782476f68f0a68b306e6792fc2b6d7e6533e Mon Sep 17 00:00:00 2001 From: Daniel Matichuk Date: Tue, 7 Jan 2025 15:31:34 -0800 Subject: [PATCH 25/36] drop divergence point from two-sided nodes this was causing issues where two variants of the same node would be created (one with the divergence point and one without) I don't believe this is actually needed anymore, but in the worst case we can store a reverse map in the pairgraph to recover the original single-sided nodes from a merged node --- src/Pate/Verification/PairGraph/Node.hs | 28 +++++++------------------ 1 file changed, 7 insertions(+), 21 deletions(-) diff --git a/src/Pate/Verification/PairGraph/Node.hs b/src/Pate/Verification/PairGraph/Node.hs index 330175e3..3a9e9312 100644 --- a/src/Pate/Verification/PairGraph/Node.hs +++ b/src/Pate/Verification/PairGraph/Node.hs @@ -50,7 +50,6 @@ module Pate.Verification.PairGraph.Node ( , isSingleNode , isSingleNodeEntry , isSingleReturn - , splitGraphNode , getDivergePoint , getDivergePoint' , eqUptoDivergePoint @@ -226,20 +225,18 @@ pattern GraphNodeReturn blks <- (ReturnNode (NodeContent _ blks)) data DivergePoint arch (tp :: Qu.QuantK PB.WhichBinary) where DivergePointSingle :: PB.WhichBinaryRepr bin -> GraphNode' arch Qu.AllK -> DivergePoint arch (Qu.OneK bin) - DivergePointTwoSided :: GraphNode' arch Qu.AllK -> DivergePoint arch Qu.AllK NoDivergePointCtor :: DivergePoint arch Qu.AllK SomeDivergePoint :: Maybe (GraphNode' arch Qu.AllK) -> DivergePoint arch Qu.ExistsK divergePointExists :: DivergePoint arch tp -> DivergePoint arch Qu.ExistsK divergePointExists = \case DivergePointSingle _ nd -> SomeDivergePoint (Just nd) - DivergePointTwoSided nd -> SomeDivergePoint (Just nd) NoDivergePointCtor -> SomeDivergePoint Nothing x@SomeDivergePoint{} -> x instance Qu.QuantConvertible (DivergePoint arch) where applyQuantConversion qc dp = case (qc, dp) of - (Qu.ConvertExistsToAll, SomeDivergePoint (Just nd)) -> Just $ (DivergePointTwoSided nd) + (Qu.ConvertExistsToAll, SomeDivergePoint (Just _)) -> Nothing -- invalid case (Qu.ConvertExistsToAll, SomeDivergePoint Nothing) -> Just $ NoDivergePointCtor (Qu.ConvertExistsToOne repr, SomeDivergePoint (Just nd)) -> Just $ (DivergePointSingle repr nd) (Qu.ConvertExistsToOne{}, SomeDivergePoint Nothing) -> Nothing @@ -250,22 +247,21 @@ instance Qu.QuantConvertible (DivergePoint arch) where deriving instance Eq (DivergePoint arch tp) deriving instance Ord (DivergePoint arch tp) + data DivergePointProof arch tp where - DivergePointProof :: (KnownRepr Qu.QuantRepr tp, Qu.IsExistsOr tp tp) => GraphNode' arch Qu.AllK -> DivergePointProof arch tp + DivergePointProof :: (KnownRepr Qu.QuantRepr tp, Qu.IsExistsOr tp tp, Qu.NotAllK tp) => GraphNode' arch Qu.AllK -> DivergePointProof arch tp divergePointProof :: DivergePoint arch tp -> Maybe (DivergePointProof arch tp) divergePointProof = \case DivergePointSingle repr nd -> withRepr repr $ Just $ DivergePointProof nd - DivergePointTwoSided nd -> Just $ DivergePointProof nd NoDivergePointCtor -> Nothing SomeDivergePoint (Just nd) -> Just $ DivergePointProof nd SomeDivergePoint Nothing -> Nothing -pattern DivergePoint :: forall arch tp. () => (KnownRepr Qu.QuantRepr tp, Qu.IsExistsOr tp tp) => GraphNode' arch Qu.AllK -> DivergePoint arch tp +pattern DivergePoint :: forall arch tp. () => (KnownRepr Qu.QuantRepr tp, Qu.IsExistsOr tp tp, Qu.NotAllK tp) => GraphNode' arch Qu.AllK -> DivergePoint arch tp pattern DivergePoint nd <- (divergePointProof -> Just (DivergePointProof nd)) where DivergePoint nd = case knownRepr :: Qu.QuantRepr tp of Qu.QuantOneRepr repr -> DivergePointSingle repr nd - Qu.QuantAllRepr -> DivergePointTwoSided nd Qu.QuantSomeRepr -> SomeDivergePoint (Just (Qu.coerceQuant nd)) data NoDivergePointProof arch tp where @@ -382,7 +378,7 @@ mkMergedNodeEntry :: PB.ConcreteBlock arch PB.Original -> PB.ConcreteBlock arch PB.Patched -> NodeEntry' arch Qu.AllK -mkMergedNodeEntry nd blkO blkP = NodeEntry (CallingContext cctx (DivergePoint nd)) (Qu.All $ \case PB.OriginalRepr -> blkO; PB.PatchedRepr -> blkP) +mkMergedNodeEntry nd blkO blkP = NodeEntry (CallingContext cctx NoDivergePoint) (Qu.All $ \case PB.OriginalRepr -> blkO; PB.PatchedRepr -> blkP) where CallingContext cctx _ = nodeContext nd @@ -391,7 +387,7 @@ mkMergedNodeReturn :: PB.FunctionEntry arch PB.Original -> PB.FunctionEntry arch PB.Patched -> NodeReturn' arch Qu.AllK -mkMergedNodeReturn nd fnO fnP = NodeReturn (CallingContext cctx (DivergePoint nd)) (Qu.All $ \case PB.OriginalRepr -> fnO; PB.PatchedRepr -> fnP) +mkMergedNodeReturn nd fnO fnP = NodeReturn (CallingContext cctx NoDivergePoint) (Qu.All $ \case PB.OriginalRepr -> fnO; PB.PatchedRepr -> fnP) where CallingContext cctx _ = nodeContext nd @@ -450,14 +446,6 @@ eqUptoDivergePoint (ReturnNode (NodeReturn ctx1 blks1)) (ReturnNode (NodeReturn = True eqUptoDivergePoint _ _ = False --- | Split a graph node into two single-sided nodes (original, patched) --- The input node is marked as the diverge point in the two resulting nodes. -splitGraphNode :: PPa.PatchPairM m => GraphNode arch -> m (GraphNode arch, GraphNode arch) -splitGraphNode nd = do - nodes <- PPa.forBinsC $ \bin -> toSingleGraphNode bin nd - nodeO <- PPa.getC PB.OriginalRepr nodes - nodeP <- PPa.getC PB.PatchedRepr nodes - return (nodeO, nodeP) toTwoSidedNode :: PPa.PatchPairM m => GraphNode' arch qbin -> m (GraphNode' arch Qu.AllK) toTwoSidedNode nd = withKnownBin nd $ case Qu.convertQuant nd of @@ -643,9 +631,7 @@ combineSingleEntries node1 node2 = do let ndPair = PPa.mkPair (singleEntryBin node1) (Qu.AsSingle node1) (Qu.AsSingle node2) Qu.AsSingle nodeO <- PPa.get PB.OriginalRepr ndPair Qu.AsSingle nodeP <- PPa.get PB.PatchedRepr ndPair - -- it only makes sense to combine nodes that share a divergence point, - -- where that divergence point will be used as the calling context for the - -- merged point + -- it only makes sense to combine nodes that share a divergence point let divergeO = singleNodeDivergence nodeO let divergeP = singleNodeDivergence nodeP guard $ divergeO == divergeP From 47ab6aa995d0582e4074d990ccc3e602991685a8 Mon Sep 17 00:00:00 2001 From: Daniel Matichuk Date: Tue, 7 Jan 2025 15:36:22 -0800 Subject: [PATCH 26/36] avoid implicit condition propagation when widening between one and two sided nodes --- src/Pate/Verification/StrongestPosts.hs | 20 ++- src/Pate/Verification/Widening.hs | 183 ++++++++++++++++-------- 2 files changed, 128 insertions(+), 75 deletions(-) diff --git a/src/Pate/Verification/StrongestPosts.hs b/src/Pate/Verification/StrongestPosts.hs index e23816f6..9010bf36 100644 --- a/src/Pate/Verification/StrongestPosts.hs +++ b/src/Pate/Verification/StrongestPosts.hs @@ -621,9 +621,9 @@ initSingleSidedDomain sne pg0 = withRepr bin $ withRepr (PBi.flipRepr bin) $ wit pr <- currentPriority atPriority (raisePriority pr) (Just "Starting Split Analysis") $ do pg2 <- propagateOne scope bundle nd nd_single ConditionAsserted pg >>= \case - Just pg1 -> rewrite_assert binds pg1 - Nothing -> return pg - + (ConditionNotPropagated, pg1) -> return pg1 + (_, pg1) -> rewrite_assert binds pg1 + withAssumptionSet (PAS.fromExprBindings binds) $ withGraphNode' scope nd bundle dom pg2 $ do widenAlongEdge scope bundle nd dom_single pg2 nd_single @@ -775,7 +775,6 @@ mergeSingletons sneO sneP pg = fnTrace "mergeSingletons" $ withSym $ \sym -> do let syncNode = GraphNode syncNodeEntry let snePair = Qu.QuantEach (\case PBi.OriginalRepr -> sneO; PBi.PatchedRepr -> sneP) - let pre_refines = getDomainRefinements syncNode pg -- we start with two scopes: one representing the program state at the point of divergence: 'init_scope', -- and one representing the program state at the merge point @@ -817,24 +816,21 @@ mergeSingletons sneO sneP pg = fnTrace "mergeSingletons" $ withSym $ \sym -> do let nd = GraphNode $ singleToNodeEntry sne let scope = singleBundleScope sbundle liftEqM $ \pg_ -> propagateOne scope (singleBundle sbundle) nd syncNode ConditionAsserted pg_ >>= \case - Just pg_' -> do + (ConditionNotPropagated, pg_') -> + -- bindings already assumed above + return (W4.truePred sym, pg_) + (_, pg_') -> do let binds_other = foldr (collectCondition bin nd pg_') (singleBundleBinds sbundle) [minBound .. maxBound] priority <- thisPriority (binds, pg_'') <- IO.liftIO $ addFnBindings sym mergeScope (GraphNode sne_other) binds_other pg_' binds_asm <- IO.liftIO $ PFn.toPred sym binds return $ (binds_asm, queueAncestors (priority PriorityHandleDesync) nd pg_'') - Nothing -> - -- bindings already assumed above - return (W4.truePred sym, pg_) new_bind_asm <- PPa.joinPatchPred (\x y -> IO.liftIO $ W4.andPred sym x y) $ \bin -> PPa.getC bin new_bind_asms withAssumption new_bind_asm $ withPG_ pg'' $ PPa.catBins $ \bin -> do - liftPG $ modify $ \pg_ -> case getDomainRefinements syncNode pg_ of - [] -> addDomainRefinements syncNode pre_refines pg_ - _ -> pg_ liftEqM_ $ \pg_ -> do sbundle <- PPa.get bin sbundlePair let sne = Qu.quantEach snePair bin @@ -3063,7 +3059,7 @@ handleDivergingPaths scope bundle currBlock st dom blkt = fnTrace "handleDivergi -- doesn't need synchronization Just pg1 <- return $ addToWorkList True someDivergeNode (priority PriorityDeferred) pg return $ st'{ branchGraph = pg1 } - AlignControlFlow condK -> withSym $ \sym -> do + AlignControlFlow condK -> fnTrace "AlignControlFlow" $ withSym $ \sym -> do traces <- bundleToInstrTraces bundle pg2 <- case traces of PPa.PatchPairC traceO traceP -> do diff --git a/src/Pate/Verification/Widening.hs b/src/Pate/Verification/Widening.hs index de1469fe..928ddd7a 100644 --- a/src/Pate/Verification/Widening.hs +++ b/src/Pate/Verification/Widening.hs @@ -36,6 +36,7 @@ module Pate.Verification.Widening , getTraceFootprint , propagateCondition , propagateOne + , PropagateCase(..) ) where import GHC.Stack @@ -107,7 +108,7 @@ import qualified Pate.TraceCollection as PTc import Pate.Verification.PairGraph import qualified Pate.Verification.ConditionalEquiv as PVC import qualified Pate.Verification.Validity as PVV -import Pate.Verification.PairGraph.Node ( GraphNode, GraphNode'(..), pattern GraphNodeEntry, pattern GraphNodeReturn, nodeFuns, graphNodeBlocks, asSingleNode, singleNodeDivergence, singleNodeDivergePoint, singleNodeRepr ) +import Pate.Verification.PairGraph.Node ( GraphNode, GraphNode'(..), pattern GraphNodeEntry, pattern GraphNodeReturn, nodeFuns, graphNodeBlocks, asSingleNode, singleNodeDivergence, singleNodeDivergePoint, singleNodeRepr, isSingleNode ) import qualified Pate.Verification.StrongestPosts.CounterExample as CE import qualified Pate.AssumptionSet as PAs @@ -134,6 +135,7 @@ import qualified Data.IORef as IO import qualified Data.Parameterized.TraversableFC as TFC import qualified Data.Quant as Qu import qualified Pate.Verification.FnBindings as PFn +import Control.Monad.State (modify) -- | Generate a fresh abstract domain value for the given graph node. -- This should represent the most information we can ever possibly @@ -610,7 +612,16 @@ getTraceFromModel scope evalFn' bundle preD postCond = withSym $ \sym -> do return $ CE.TraceEventsOne ground_rop evs return $ CE.TraceEvents trace_pair (Some ground_preCond) (fmap Some ground_postCond) +-- | Apply all existing domain refinements to the 'to' node by adding assertions/assumptions to +-- the 'from' node that are sufficient to imply the desired post-domain. +-- +-- NB: Previously this would remove the refinements afterwards, with the intention that the +-- added assertion was now sufficient to imply the desired domain. This is not the case +-- when there are multiple ancestors to 'to', as each ancestor will require its own assertion. +-- We can safely re-apply the refinements each time 'to' is reached, as this will be +-- effectively a no-op if a sufficient condition has already been added to 'from'. applyDomainRefinements :: + forall sym arch v. PS.SimScope sym arch v -> (GraphNode arch,GraphNode arch) -> PS.SimBundle sym arch v -> @@ -618,36 +629,44 @@ applyDomainRefinements :: AbstractDomain sym arch v {- ^ post-domain -} -> PairGraph sym arch -> EquivM sym arch (PairGraph sym arch) -applyDomainRefinements scope (from,to) bundle preD postD gr0 = fnTrace "applyDomainRefinements" $ withSym $ \sym -> do - let next = applyDomainRefinements scope (from,to) bundle preD postD - case getNextDomainRefinement to gr0 of - Nothing -> do +applyDomainRefinements scope (from,to) bundle preD postD gr0_ = fnTrace "applyDomainRefinements" $ go (getDomainRefinements to gr0_) gr0_ + where + go :: + [DomainRefinement sym arch] -> + PairGraph sym arch -> + EquivM sym arch (PairGraph sym arch) + go [] gr0 = do emitTrace @"debug" ("No refinements found for: " ++ show to) return gr0 - Just (PruneBranch condK,gr1) -> withTracing @"debug" ("Applying PruneBranch to " ++ show to) $ do - gr2 <- pruneCurrentBranch scope (from,to) condK gr1 - next gr2 - - Just (LocationRefinement condK refineK refine,gr1) -> withTracing @"debug" ("Applying LocationRefinement to " ++ show to) $ do - -- refine the domain of the predecessor node and drop this domain - eqCond <- case refineK of - RefineUsingIntraBlockPaths -> computeEquivCondition scope bundle preD postD (\l -> refine (PL.SomeLocation l)) - RefineUsingExactEquality -> domainToEquivCondition scope bundle preD postD (\l -> refine (PL.SomeLocation l)) - eqCond_pred <- PEC.toPred sym eqCond - goalTimeout <- CMR.asks (PC.cfgGoalTimeout . envConfig) - emitTraceLabel @"expr" "Generated Condition" (Some eqCond_pred) - isPredTrue' goalTimeout eqCond_pred >>= \case - True -> do - emitTrace @"debug" "Equivalence condition holds, no propagation needed" - return gr1 - False -> do - gr2 <- updateEquivCondition scope from condK Nothing eqCond gr1 - -- since its equivalence condition has been modified, we need to re-examine - -- all outgoing edges from the predecessor node - priority <- thisPriority - gr3 <- return $ queueAncestors (priority PriorityPropagation) from $ - dropPostDomains from (priority PriorityDomainRefresh) (markEdge from to gr2) - next gr3 + go (x:xs) gr1 = withSym $ \sym -> do + let next = go xs + case x of + -- FIXME: unclear if this is reachable + AlignControlFlowRefinment{} -> fail "applyDomainRefinements: NOT IMPLEMENTED AlignControlFlowRefinment" + PruneBranch condK -> withTracing @"debug" ("Applying PruneBranch to " ++ show to) $ do + gr2 <- pruneCurrentBranch scope (from,to) condK gr1 + next gr2 + + LocationRefinement condK refineK refine -> withTracing @"debug" ("Applying LocationRefinement to " ++ show to) $ do + -- refine the domain of the predecessor node and drop this domain + eqCond <- case refineK of + RefineUsingIntraBlockPaths -> computeEquivCondition scope bundle preD postD (\l -> refine (PL.SomeLocation l)) + RefineUsingExactEquality -> domainToEquivCondition scope bundle preD postD (\l -> refine (PL.SomeLocation l)) + eqCond_pred <- PEC.toPred sym eqCond + goalTimeout <- CMR.asks (PC.cfgGoalTimeout . envConfig) + emitTraceLabel @"expr" "Generated Condition" (Some eqCond_pred) + isPredTrue' goalTimeout eqCond_pred >>= \case + True -> do + emitTrace @"debug" "Equivalence condition holds, no propagation needed" + return gr1 + False -> do + gr2 <- updateEquivCondition scope from condK Nothing eqCond gr1 + -- since its equivalence condition has been modified, we need to re-examine + -- all outgoing edges from the predecessor node + priority <- thisPriority + gr3 <- return $ queueAncestors (priority PriorityPropagation) from $ + dropPostDomains from (priority PriorityDomainRefresh) (markEdge from to gr2) + next gr3 -- | Unlike 'computeEquivCondition', this simply generates a trivial equivalence condition @@ -880,8 +899,23 @@ propagateBindings scope bundle from to gr0 = withSym $ \sym -> case (asSingleNod emitTrace @"debug" "Not a pair of single-sided nodes" return Nothing +data PropagateCase = + ConditionInfeasible -- ^ condition cannot be satisfied + | ConditionNotPropagated + | ConditionPropagated + deriving (Eq, Ord, Show) + +-- | True if the given 'PropagateCase' indicates that the 'PairGraph' was left unmodified. +propagateCaseNoop :: PropagateCase -> Bool +propagateCaseNoop = \case + ConditionInfeasible -> False + ConditionNotPropagated -> True + ConditionPropagated -> False + -- | Propagate the given condition kind backwards (from 'to' node to 'from' node). --- Does not do any other graph maintenance (i.e. dropping stale domains or re-queuing nodes) +-- Does not do any other graph maintenance (i.e. dropping stale domains or re-queuing nodes). +-- Returns the resulting (possibly unmodified) PairGraph, with a 'PropagateCase' indicating +-- which case occured. propagateOne :: forall sym arch v. PS.SimScope sym arch v -> @@ -890,11 +924,11 @@ propagateOne :: GraphNode arch {- ^ to -} -> ConditionKind -> PairGraph sym arch -> - EquivM sym arch (Maybe (PairGraph sym arch)) + EquivM sym arch (PropagateCase, PairGraph sym arch) propagateOne scope bundle from to condK gr0 = withSym $ \sym -> case getCondition gr0 to condK of Nothing -> do emitTrace @"debug" "No condition to propagate" - return Nothing + return (ConditionNotPropagated, gr0) Just{} -> do -- take the condition of the target edge and bind it to -- the output state of the bundle @@ -908,10 +942,11 @@ propagateOne scope bundle from to condK gr0 = withSym $ \sym -> case getConditio isPredSat' goalTimeout cond_pred >>= \case Just False -> do emitTrace @"message" "Condition is infeasible, dropping branch." - Just <$> pruneCurrentBranch scope (from,to) condK gr0 + gr1 <- pruneCurrentBranch scope (from,to) condK gr0 + return (ConditionInfeasible, gr1) _ | not (shouldPropagate (getPropagationKind gr0 to condK)) -> do emitTrace @"debug" "Condition not propagated" - return Nothing + return (ConditionNotPropagated, gr0) _ -> do not_cond <- liftIO $ W4.notPred sym cond_pred isPredSat' goalTimeout not_cond >>= \case @@ -919,15 +954,17 @@ propagateOne scope bundle from to condK gr0 = withSym $ \sym -> case getConditio -- don't need any changes Just False -> do emitTraceLabel @"expr" (ExprLabel $ "Proven " ++ conditionName condK) (Some cond_pred) - return Nothing + return (ConditionNotPropagated, gr0) -- we need more assumptions for this condition to hold Just True -> do emitTraceLabel @"expr" (ExprLabel $ "Propagated " ++ conditionName condK) (Some cond_pred) let propK = getPropagationKind gr0 to condK gr1 <- updateEquivCondition scope from condK (Just (nextPropagate propK)) cond gr0 - return $ Just $ (markEdge from to gr1) + return $ (ConditionPropagated, markEdge from to gr1) Nothing -> throwHere $ PEE.InconclusiveSAT + + -- | Push an assertion back up the graph. -- Returns 'Nothing' if there is nothing to do (i.e. no assertion or -- existing assertion is already implied) @@ -938,28 +975,44 @@ propagateCondition :: GraphNode arch {- ^ from -} -> GraphNode arch {- ^ to -} -> PairGraph sym arch -> - EquivM sym arch (Maybe (PairGraph sym arch)) -propagateCondition scope bundle from to gr0_ = fnTrace "propagateCondition" $ do - (upd1, gr1) <- maybeUpdate' gr0_ $ go ConditionAsserted gr0_ - (upd2, gr2) <- maybeUpdate' gr1 $ go ConditionAssumed gr1 - (upd3, gr3) <- maybeUpdate' gr2 $ go ConditionEquiv gr2 - (upd4, gr4) <- maybeUpdate' gr3 $ propagateBindings scope bundle from to gr3 >>= \case - Nothing -> return Nothing - Just gr' -> do - priority <- thisPriority - return $ Just $ queueAncestors (priority PriorityPropagation) from (markEdge from to gr') - case upd1 || upd2 || upd3 || upd4 of - False -> return Nothing - True -> return $ Just gr4 + EquivM sym arch (PropagateCase, PairGraph sym arch) +propagateCondition scope bundle from to gr0 = fnTrace "propagateCondition" $ do + priority <- thisPriority + (pcase, gr1) <- withPG gr0 $ do + pcases <- mapM go [minBound..maxBound] + let anyInfeasible = any ((==) ConditionInfeasible) pcases + case anyInfeasible of + True -> return ConditionInfeasible + False -> liftPartEqM_ (propagateBindings scope bundle from to) >>= \case + True -> do + liftPG $ modify $ \gr_ -> + queueAncestors (priority PriorityPropagation) from (markEdge from to gr_) + return $ ConditionPropagated + False -> case all propagateCaseNoop pcases of + True -> return ConditionNotPropagated + False -> do + liftPG $ modify $ \gr_ -> + queueAncestors (priority PriorityPropagation) from $ + queueNode (priority PriorityNodeRecheck) from $ + dropPostDomains from (priority PriorityDomainRefresh) (markEdge from to gr_) + return ConditionPropagated + + -- When transitioning between single and two-sided analyses, we + -- want to avoid propagating conditions implicitly during widening. + -- Instead this happens explicitly during ProcessMerge or ProcessSplit, which + -- manages all of the needed bookkeeping surrounding matching up variables + -- from both sides of the analysis. + case (isSingleNode from, isSingleNode to) of + (Just{}, Just{}) -> return $ (pcase, gr1) + (Nothing, Nothing) -> return $ (pcase, gr1) + -- special case, where we want to retain the fact that one of the + -- conditions is infeasible but we don't want to do any graph maintenance + _ | pcase == ConditionInfeasible -> return $ (ConditionInfeasible, gr0) + _ -> return (ConditionNotPropagated, gr0) + where - - go condK gr = propagateOne scope bundle from to condK gr >>= \case - Nothing -> return Nothing - Just gr' -> do - priority <- thisPriority - return $ Just $ queueAncestors (priority PriorityPropagation) from $ - queueNode (priority PriorityNodeRecheck) from $ - dropPostDomains from (priority PriorityDomainRefresh) (markEdge from to gr') + go condK = liftEqM (propagateOne scope bundle from to condK) + -- | Given the results of symbolic execution, and an edge in the pair graph -- to consider, compute an updated abstract domain for the target node, @@ -994,23 +1047,27 @@ widenAlongEdge :: GraphNode arch {- ^ target graph node -} -> EquivM sym arch (PairGraph sym arch) widenAlongEdge scope bundle from d gr0 to = withSym $ \sym -> do - gr <- addRefinementChoice to gr0 + gr1 <- addRefinementChoice to gr0 priority <- thisPriority - propagateCondition scope bundle from to gr >>= \case - Just gr1 -> do + propagateCondition scope bundle from to gr1 >>= \case + (ConditionPropagated, gr2) -> do -- since this 'to' edge has propagated backwards -- an equivalence condition, we need to restart the analysis -- for 'from' -- 'dropDomain' clears domains for all nodes following 'from' (including 'to') -- and re-adds ancestors of 'from' to be considered for analysis - emitTrace @"message" "Analysis Skipped - Equivalence Domain Propagation" + emitTrace @"message" "Analysis Skipped - Condition Propagation" - return $ gr1 + return $ gr2 + (ConditionInfeasible, gr2) -> do + emitTrace @"message" "Analysis Skipped - Target branch has condition that is infeasible" + return $ gr2 + -- if no postcondition propagation is needed, we continue under -- the strengthened assumption that the equivalence postcondition -- is satisfied (potentially allowing for a stronger equivalence -- domain to be established) - Nothing -> do + (ConditionNotPropagated, gr) -> do postCond_assume1 <- getEquivPostCondition scope bundle to ConditionAssumed gr postCond_assume2 <- getEquivPostCondition scope bundle to ConditionEquiv gr postCond_assume <- liftIO $ PEC.merge sym postCond_assume1 postCond_assume2 >>= PEC.toPred sym From 9132cfe6cfcb3350bed544669fde4ead05e85000 Mon Sep 17 00:00:00 2001 From: Daniel Matichuk Date: Tue, 7 Jan 2025 16:48:46 -0800 Subject: [PATCH 27/36] queue ancestors of divergence point when propagating assertions --- src/Pate/Verification/StrongestPosts.hs | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/src/Pate/Verification/StrongestPosts.hs b/src/Pate/Verification/StrongestPosts.hs index 9010bf36..d36a971d 100644 --- a/src/Pate/Verification/StrongestPosts.hs +++ b/src/Pate/Verification/StrongestPosts.hs @@ -588,6 +588,8 @@ initSingleSidedDomain :: initSingleSidedDomain sne pg0 = withRepr bin $ withRepr (PBi.flipRepr bin) $ withSym $ \sym -> withPG_ pg0 $ do let dp = singleNodeDivergePoint (GraphNode sne) let nd = Qu.coerceToExists dp + pr <- lift $ currentPriority + nd' <- case Qu.convertQuant nd of Just (nd' :: GraphNode' arch Qu.AllK) -> return nd' Nothing -> fail $ "Unexpected single-sided diverge point: " ++ show nd @@ -614,12 +616,15 @@ initSingleSidedDomain sne pg0 = withRepr bin $ withRepr (PBi.flipRepr bin) $ wit cond <- liftIO $ PS.bindSpec sym (PS.scopeVarsPair scope) condSpec cond' <- PSi.applySimpStrategy (PSi.rewriteStrategy exprBinds) cond let condSpec' = PS.mkSimSpec scope cond' - return $ setCondition nd ConditionAsserted PropagateFull condSpec' pg + let pg' = setCondition nd ConditionAsserted PropagateFull condSpec' pg + -- we need to schedule the ancestors here to ensure that the resulting + -- assertion is propagated (if needed), since 'propagateOne' doesn't do this step + return $ queueAncestors (lowerPriority pr) nd pg' + Nothing -> return pg let do_widen binds pg = fnTrace "do_widen" $ do - pr <- currentPriority - atPriority (raisePriority pr) (Just "Starting Split Analysis") $ do + atPriority (raisePriority pr) (Just "Starting Split Analysis") $ do pg2 <- propagateOne scope bundle nd nd_single ConditionAsserted pg >>= \case (ConditionNotPropagated, pg1) -> return pg1 (_, pg1) -> rewrite_assert binds pg1 @@ -636,7 +641,7 @@ initSingleSidedDomain sne pg0 = withRepr bin $ withRepr (PBi.flipRepr bin) $ wit liftEqM_ $ \pg -> do_widen binds pg (Just{}, Nothing) -> do emitTrace @"debug" "Case: Bindings on only this side" - pr <- lift $ currentPriority + -- Should we lower the priority here? Is it possible to get caught in a loop otherwise? -- Formally we should be able to find all relevant nodes based on which bindings -- we're missing From 7f1839bba9abbda7513c3a20d3c4d4bf5aee8827 Mon Sep 17 00:00:00 2001 From: Daniel Matichuk Date: Wed, 8 Jan 2025 14:27:40 -0800 Subject: [PATCH 28/36] ensure that fresh domains have the expected original/patched shape --- src/Pate/PatchPair.hs | 24 ++++++++++++++++++++++++ src/Pate/Verification/Widening.hs | 20 ++++++++++++-------- 2 files changed, 36 insertions(+), 8 deletions(-) diff --git a/src/Pate/PatchPair.hs b/src/Pate/PatchPair.hs index ce56769b..f092ebf9 100644 --- a/src/Pate/PatchPair.hs +++ b/src/Pate/PatchPair.hs @@ -77,6 +77,7 @@ module Pate.PatchPair ( , toSingleton , zip , WithBin(..) + , matchShape ) where import Prelude hiding (zip, map, traverse) @@ -356,12 +357,35 @@ asSingleton _ = throwPairErr -- | Convert a 'PatchPair' into a singleton containing only -- a value for the given binary 'bin'. toSingleton :: + HasCallStack => PatchPairM m => PB.WhichBinaryRepr bin -> PatchPair tp -> m (PatchPair tp) toSingleton bin pPair = PatchPairSingle bin <$> get bin pPair +-- | Produce a 'PatchPair' with the same shape as a given pair by filling missing fields +-- with a given default value, or dropping values, as needed. +matchShape :: + Monad m => + PatchPair tp1 -> + PatchPair tp2 -> + (forall bin. PB.WhichBinaryRepr bin -> m (tp2 bin)) -> + m (PatchPair tp2) +matchShape p1 p2 f = case (p1, p2) of + (PatchPair{}, PatchPair{}) -> return p2 + (PatchPairSingle bin1 _, PatchPairSingle bin2 x2) -> case PB.binCases bin1 bin2 of + Left Refl -> return p2 + Right Refl -> do + x1 <- f bin1 + return $ mkPair bin1 x1 x2 + (PatchPair{}, PatchPairSingle bin2 x2) -> do + x1 <- f (PB.flipRepr bin2) + return $ mkPair bin2 x2 x1 + (PatchPairSingle bin1 _, PatchPair x1 x2) -> case bin1 of + PB.OriginalRepr -> return $ PatchPairSingle PB.OriginalRepr x1 + PB.PatchedRepr -> return $ PatchPairSingle PB.PatchedRepr x2 + -- | Create a 'PatchPair' with a shape according to 'getPairRepr'. -- The provided function execution for both the original and patched binaries -- (i.e. given 'PB.OriginalRepr' and 'PB.PatchedRepr'), but may fail early diff --git a/src/Pate/Verification/Widening.hs b/src/Pate/Verification/Widening.hs index 928ddd7a..04668ff4 100644 --- a/src/Pate/Verification/Widening.hs +++ b/src/Pate/Verification/Widening.hs @@ -148,13 +148,13 @@ makeFreshAbstractDomain :: GraphNode arch {- ^ source node -} -> GraphNode arch {- ^ target graph node -} -> EquivM sym arch (PAD.AbstractDomain sym arch v) -makeFreshAbstractDomain scope bundle preDom from _to = withTracing @"debug" "makeFreshAbstractDomain" $ do +makeFreshAbstractDomain scope bundle preDom from to = withTracing @"debug" "makeFreshAbstractDomain" $ do case from of -- graph node GraphNodeEntry{} -> startTimer $ do initDom <- initialDomain - vals <- getInitalAbsDomainVals bundle preDom - evSeq <- getEventSequence scope bundle preDom + vals <- getInitalAbsDomainVals to bundle preDom + evSeq <- getEventSequence to scope bundle preDom return $ initDom { PAD.absDomVals = vals, PAD.absDomEvents = evSeq } -- return node GraphNodeReturn{} -> do @@ -162,7 +162,7 @@ makeFreshAbstractDomain scope bundle preDom from _to = withTracing @"debug" "mak -- as a small optimization, we know that the return nodes leave the values -- unmodified, and therefore any previously-established value constraints -- will still hold - evSeq <- getEventSequence scope bundle preDom + evSeq <- getEventSequence to scope bundle preDom return $ initDom { PAD.absDomVals = PAD.absDomVals preDom , PAD.absDomEvents = evSeq } @@ -1438,12 +1438,13 @@ abstractOverVars scope_pre bundle _from _to postSpec postResult = do -- Returns empty sequences for two-sided analysis, since those are checked -- for equality at each verification step. getEventSequence :: + GraphNode arch -> PS.SimScope sym arch v -> SimBundle sym arch v -> PAD.AbstractDomain sym arch v -> EquivM sym arch (PPa.PatchPair (PAD.EventSequence sym arch)) -getEventSequence _scope bundle preDom = withTracing @"function_name" "getEventSequence" $ withSym $ \sym -> do - case PS.simOut bundle of +getEventSequence to _scope bundle preDom = withTracing @"function_name" "getEventSequence" $ withSym $ \sym -> do + evs <- case PS.simOut bundle of PPa.PatchPair{} -> PPa.PatchPair <$> PAD.emptyEvents sym <*> PAD.emptyEvents sym PPa.PatchPairSingle bin out -> do PAD.EventSequence prev_seq <- PPa.get bin (PAD.absDomEvents preDom) @@ -1457,6 +1458,7 @@ getEventSequence _scope bundle preDom = withTracing @"function_name" "getEventSe -- otherwise, append new events onto the previous ones fin_seq <- liftIO $ appendSymSequence sym next_seq prev_seq return $ PPa.PatchPairSingle bin (PAD.EventSequence fin_seq) + PPa.matchShape (graphNodeBlocks to) evs $ \_ -> PAD.emptyEvents sym -- | Extract the sequence of observable events for the given -- symbolic execution step @@ -1773,20 +1775,22 @@ widenPostcondition scope bundle preD postD0 = do -- Uses the default concretization strategies from 'Pate.Verification.Concretize' getInitalAbsDomainVals :: forall sym arch v. + GraphNode arch -> SimBundle sym arch v -> PAD.AbstractDomain sym arch v {- ^ incoming pre-domain -} -> EquivM sym arch (PPa.PatchPair (PAD.AbstractDomainVals sym arch)) -getInitalAbsDomainVals bundle preDom = withTracing @"debug" "getInitalAbsDomainVals" $ withSym $ \sym -> do +getInitalAbsDomainVals to bundle preDom = withTracing @"debug" "getInitalAbsDomainVals" $ withSym $ \sym -> do getConcreteRange <- PAD.mkGetAbsRange (\es -> TFC.fmapFC (PAD.extractAbsRange sym) <$> concretizeWithSolverBatch es) eqCtx <- equivalenceContext - forkBins $ \bin -> do + vals <- forkBins $ \bin -> do out <- PPa.get bin (PS.simOut bundle) pre <- PPa.get bin (PAD.absDomVals preDom) PAD.batchGetAbsRange getConcreteRange $ \getConcreteRangeBatch -> PAD.initAbsDomainVals sym eqCtx getConcreteRangeBatch out pre + PPa.matchShape (graphNodeBlocks to) vals $ \_ -> return PAD.emptyDomainVals widenUsingCounterexample :: From adb874a27a1650bb6be29302d117aac613b75d05 Mon Sep 17 00:00:00 2001 From: Daniel Matichuk Date: Wed, 8 Jan 2025 14:48:47 -0800 Subject: [PATCH 29/36] desync-zerostep: set desync to be before pushing any arguents to the stack --- tests/aarch32/desync-zerostep.pate | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/tests/aarch32/desync-zerostep.pate b/tests/aarch32/desync-zerostep.pate index 0c1b7f3b..dddcc5e5 100644 --- a/tests/aarch32/desync-zerostep.pate +++ b/tests/aarch32/desync-zerostep.pate @@ -10,12 +10,12 @@ Function Entry "f" ... Choose a desynchronization point: - > 0x1015c (original) - > 0x1015c (patched) + > 0x10154 (original) + > 0x10154 (patched) -0x1015c [ via: "f" +0x10154 [ via: "f" ... Call to: "puts" (0x10110) Returns to: "f" ... @@ -24,7 +24,7 @@ Function Entry "f" ... Choose a synchronization point: - > 0x1015c (original) + > 0x10154 (original) > 0x1016c (patched) > Finish Choosing From 739dc5d71e3c37fbb1b9a7affb1dac789f29f6e9 Mon Sep 17 00:00:00 2001 From: Daniel Matichuk Date: Fri, 10 Jan 2025 10:04:33 -0800 Subject: [PATCH 30/36] fix symbolic pointer support when adding domain refinements when defining a domain refinment (i.e. asserting/assuming that locations are equal) there are two steps: 1) defining the set of locations 2) computing a sufficient condition to make those locations equal these steps occur in different variable scopes, and so the bound variables in any symbolic locations from step 1) are re-bound to the corresponding variables during step 2) without this step, attempting to refine a domain that contains symbolic pointers would have no effect --- src/Pate/Location.hs | 3 ++ src/Pate/Verification/PairGraph.hs | 13 +++++-- src/Pate/Verification/StrongestPosts.hs | 7 ++-- src/Pate/Verification/Widening.hs | 48 ++++++++++++++----------- 4 files changed, 46 insertions(+), 25 deletions(-) diff --git a/src/Pate/Location.hs b/src/Pate/Location.hs index 7709d109..2aa624f3 100644 --- a/src/Pate/Location.hs +++ b/src/Pate/Location.hs @@ -287,6 +287,9 @@ instance Ord (SomeLocation sym arch) where LTF -> LT GTF -> GT +instance forall sym arch. PEM.ExprMappable sym (SomeLocation sym arch) where + mapExpr sym f (SomeLocation l) = SomeLocation <$> PEM.mapExpr sym f l + instance (W4.IsSymExprBuilder sym, MM.RegisterInfo (MM.ArchReg arch)) => IsTraceNode '(sym :: DK.Type,arch :: DK.Type) "loc" where type TraceNodeType '(sym,arch) "loc" = SomeLocation sym arch prettyNode () (SomeLocation l) = PP.pretty (showLoc l) PP.<> ":" PP.<+> PP.pretty l diff --git a/src/Pate/Verification/PairGraph.hs b/src/Pate/Verification/PairGraph.hs index 3e6204d7..e1f4bb64 100644 --- a/src/Pate/Verification/PairGraph.hs +++ b/src/Pate/Verification/PairGraph.hs @@ -103,6 +103,7 @@ module Pate.Verification.PairGraph , emptyPairGraph , DomainRefinementKind(..) , DomainRefinement(..) + , RefineLocations(..) , addDomainRefinement , getNextDomainRefinement , conditionPrefix @@ -158,7 +159,7 @@ import Data.Kind (Type) import qualified Data.Foldable as F import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe (fromMaybe, catMaybes) +import Data.Maybe (fromMaybe, catMaybes, mapMaybe) import Data.Parameterized.Classes import Data.Parameterized.Map ( MapF ) import qualified Data.Parameterized.Map as MapF @@ -196,6 +197,7 @@ import Pate.Verification.AbstractDomain ( AbstractDomain, AbstractDoma import Pate.TraceTree import qualified Pate.Binary as PBi import qualified Pate.Verification.FnBindings as PFn +import qualified Pate.ExprMappable as PEM import Control.Applicative (Const(..), Alternative(..)) @@ -400,8 +402,15 @@ data DomainRefinementKind = RefineUsingIntraBlockPaths | RefineUsingExactEquality +data RefineLocations sym arch (v :: PS.VarScope) = RefineLocations (Set (PL.SomeLocation sym arch)) + +instance PEM.ExprMappable sym (RefineLocations sym arch v) where + mapExpr sym f (RefineLocations locs) = (RefineLocations . Set.fromList) <$> PEM.mapExpr sym f (Set.toList locs) + +instance PS.Scoped (RefineLocations sym arch) + data DomainRefinement sym arch = - LocationRefinement ConditionKind DomainRefinementKind (PL.SomeLocation sym arch -> Bool) + LocationRefinement ConditionKind DomainRefinementKind (PS.SimSpec sym arch (RefineLocations sym arch)) | PruneBranch ConditionKind | AlignControlFlowRefinment ConditionKind diff --git a/src/Pate/Verification/StrongestPosts.hs b/src/Pate/Verification/StrongestPosts.hs index d36a971d..3971efe2 100644 --- a/src/Pate/Verification/StrongestPosts.hs +++ b/src/Pate/Verification/StrongestPosts.hs @@ -557,21 +557,22 @@ cutAfterAddress addr blk = do False -> go (addr_next:addrs) addImmediateEqDomRefinementChoice :: + PS.SimScope sym arch v -> GraphNode arch -> PAD.AbstractDomain sym arch v -> PairGraph sym arch -> EquivM sym arch (PairGraph sym arch) -addImmediateEqDomRefinementChoice nd preD gr0 = do +addImmediateEqDomRefinementChoice scope nd preD gr0 = do let gr1 = gr0 choose @"()" ("Refine equivalence domain for sync point?") $ \choice -> do let go condK = do let msg = conditionAction condK choice (msg ++ " condition") () $ do locFilter <- refineEquivalenceDomain preD - return $ addDomainRefinement nd (LocationRefinement condK RefineUsingExactEquality locFilter) gr1 + return $ addDomainRefinement nd (LocationRefinement condK RefineUsingExactEquality (PS.mkSimSpec scope locFilter)) gr1 choice (msg ++ " condition (using intra-block path conditions)") () $ do locFilter <- refineEquivalenceDomain preD - return $ addDomainRefinement nd (LocationRefinement condK RefineUsingIntraBlockPaths locFilter) gr1 + return $ addDomainRefinement nd (LocationRefinement condK RefineUsingIntraBlockPaths (PS.mkSimSpec scope locFilter)) gr1 choice (msg ++ " that branch is infeasible") () $ return $ addDomainRefinement nd (PruneBranch condK) gr1 choice ("No refinements") () $ return gr1 diff --git a/src/Pate/Verification/Widening.hs b/src/Pate/Verification/Widening.hs index 04668ff4..7976c21a 100644 --- a/src/Pate/Verification/Widening.hs +++ b/src/Pate/Verification/Widening.hs @@ -231,15 +231,20 @@ strengthenPredicate values_ eqPred = withSym $ \sym -> do emitWarning $ PEE.UnsatisfiableEquivalenceCondition (PEE.SomeExpr @_ @sym cond3) return $ W4.truePred sym +-- | TODO: formally this should actually be a predicate, but we'll stick with +-- structural equivalence for now +isRefinedLoc :: RefineLocations sym arch v -> PL.Location sym arch nm k -> Bool +isRefinedLoc (RefineLocations locs) l = Set.member (PL.SomeLocation l) locs + computeEquivCondition :: forall sym arch v. PS.SimScope sym arch v -> SimBundle sym arch v -> AbstractDomain sym arch v {- ^ incoming predomain -} -> AbstractDomain sym arch v {- ^ resulting target postdomain -} -> - (forall nm k. PL.Location sym arch nm k -> Bool) {- ^ filter for locations to force equal -} -> + RefineLocations sym arch v {- ^ filter for locations to force equal -} -> EquivM sym arch (PEC.EquivalenceCondition sym arch v) -computeEquivCondition scope bundle preD postD f = withTracing @"debug" "computeEquivCondition" $ withSym $ \sym -> do +computeEquivCondition scope bundle preD postD refine = withTracing @"debug" "computeEquivCondition" $ withSym $ \sym -> do eqCtx <- equivalenceContext emitTraceLabel @"domain" PAD.Postdomain (Some postD) let @@ -248,7 +253,7 @@ computeEquivCondition scope bundle preD postD f = withTracing @"debug" "computeE regsP = PS.simRegs stP memO = PS.simMem stO memP = PS.simMem stP - postD_eq' <- PL.traverseLocation @sym @arch sym (PAD.absDomEq postD) $ \loc p -> case f loc of + postD_eq' <- PL.traverseLocation @sym @arch sym (PAD.absDomEq postD) $ \loc p -> case isRefinedLoc refine loc of False -> return (PL.getLoc loc, p) -- modify postdomain to unconditionally include target locations True -> case loc of @@ -259,7 +264,7 @@ computeEquivCondition scope bundle preD postD f = withTracing @"debug" "computeE eqCond' <- applyCurrentAsms eqCond subTree @"loc" "Locations" $ - PEC.fromLocationTraversable @sym @arch sym eqCond' $ \loc eqPred -> case f loc of + PEC.fromLocationTraversable @sym @arch sym eqCond' $ \loc eqPred -> case isRefinedLoc refine loc of -- irrelevant location False -> return $ W4.truePred sym True -> subTrace (PL.SomeLocation loc) $ do @@ -367,12 +372,12 @@ addEqDomRefinementChoice :: addEqDomRefinementChoice condK nd gr0 = do addLazyAction refineActions nd gr0 ("Add " ++ conditionName condK) $ \choice -> do let msg = conditionAction condK - choice (msg ++ " condition") $ \(TupleF2 _ preD) gr1 -> do + choice (msg ++ " condition") $ \(TupleF2 scope preD) gr1 -> do locFilter <- refineEquivalenceDomain preD - return $ addDomainRefinement nd (LocationRefinement condK RefineUsingExactEquality locFilter) gr1 - choice (msg ++ " condition (using intra-block path conditions)") $ \(TupleF2 _ preD) gr1 -> do + return $ addDomainRefinement nd (LocationRefinement condK RefineUsingExactEquality (PS.mkSimSpec scope locFilter)) gr1 + choice (msg ++ " condition (using intra-block path conditions)") $ \(TupleF2 scope preD) gr1 -> do locFilter <- refineEquivalenceDomain preD - return $ addDomainRefinement nd (LocationRefinement condK RefineUsingIntraBlockPaths locFilter) gr1 + return $ addDomainRefinement nd (LocationRefinement condK RefineUsingIntraBlockPaths (PS.mkSimSpec scope locFilter)) gr1 choice (msg ++ " that branch is infeasible") $ \_ gr1 -> return $ addDomainRefinement nd (PruneBranch condK) gr1 @@ -647,11 +652,12 @@ applyDomainRefinements scope (from,to) bundle preD postD gr0_ = fnTrace "applyDo gr2 <- pruneCurrentBranch scope (from,to) condK gr1 next gr2 - LocationRefinement condK refineK refine -> withTracing @"debug" ("Applying LocationRefinement to " ++ show to) $ do + LocationRefinement condK refineK refineSpec -> withTracing @"debug" ("Applying LocationRefinement to " ++ show to) $ do -- refine the domain of the predecessor node and drop this domain + refine <- IO.liftIO $ PS.bindSpec sym (PS.scopeVarsPair scope) refineSpec eqCond <- case refineK of - RefineUsingIntraBlockPaths -> computeEquivCondition scope bundle preD postD (\l -> refine (PL.SomeLocation l)) - RefineUsingExactEquality -> domainToEquivCondition scope bundle preD postD (\l -> refine (PL.SomeLocation l)) + RefineUsingIntraBlockPaths -> computeEquivCondition scope bundle preD postD refine + RefineUsingExactEquality -> domainToEquivCondition scope bundle preD postD refine eqCond_pred <- PEC.toPred sym eqCond goalTimeout <- CMR.asks (PC.cfgGoalTimeout . envConfig) emitTraceLabel @"expr" "Generated Condition" (Some eqCond_pred) @@ -677,10 +683,10 @@ domainToEquivCondition :: PS.SimBundle sym arch v -> AbstractDomain sym arch v {- ^ pre-domain -} -> AbstractDomain sym arch v {- ^ post-domain -} -> - (forall nm k. PL.Location sym arch nm k -> Bool) -> + RefineLocations sym arch v -> EquivM sym arch (PEC.EquivalenceCondition sym arch v) domainToEquivCondition scope bundle preD postD refine = withSym $ \sym -> do - postD_eq' <- PL.traverseLocation @sym @arch sym (PAD.absDomEq postD) $ \loc p -> case refine loc of + postD_eq' <- PL.traverseLocation @sym @arch sym (PAD.absDomEq postD) $ \loc p -> case isRefinedLoc refine loc of False -> return (PL.getLoc loc, p) -- modify postdomain to unconditionally include target locations True -> case loc of @@ -690,7 +696,7 @@ domainToEquivCondition scope bundle preD postD refine = withSym $ \sym -> do eqCtx <- equivalenceContext eqCond <- liftIO $ PEq.getPostdomain sym scope bundle eqCtx (PAD.absDomEq preD) postD_eq' - PEC.fromLocationTraversable @sym @arch sym eqCond $ \loc eqPred -> case refine loc of + PEC.fromLocationTraversable @sym @arch sym eqCond $ \loc eqPred -> case isRefinedLoc refine loc of False -> return $ W4.truePred sym True -> return eqPred @@ -783,7 +789,7 @@ pickMany pickIn = go mempty pickIn refineEquivalenceDomain :: forall sym arch v. AbstractDomain sym arch v -> - EquivM sym arch (PL.SomeLocation sym arch -> Bool) + EquivM sym arch (RefineLocations sym arch v) refineEquivalenceDomain dom = withSym $ \sym -> do let regDom = PEE.eqDomainRegisters (PAD.absDomEq dom) let allRegs = map fst $ PER.toList (PER.universal sym) @@ -800,11 +806,13 @@ refineEquivalenceDomain dom = withSym $ \sym -> do picked <- pickMany pickIn - return $ \(PL.SomeLocation loc) -> - case loc of - PL.Register r -> elem (Some r) (pickRegs picked) - PL.Cell c -> elem (Some c) (pickStack picked) || elem (Some c) (pickGlobal picked) - _ -> False + let + regLocs = map (\(Some r) -> PL.SomeLocation (PL.Register r)) (pickRegs picked) + stackLocs = map (\(Some c) -> PL.SomeLocation (PL.Cell c)) (pickStack picked) + memLocs = map (\(Some c) -> PL.SomeLocation (PL.Cell c)) (pickGlobal picked) + + return $ RefineLocations (Set.fromList $ regLocs ++ stackLocs ++ memLocs) + -- | True if the satisfiability of the predicate only depends on -- variables from the given binary From 023739c71a8e4b23805d26ab8f2f5b48ce9a6e57 Mon Sep 17 00:00:00 2001 From: Daniel Matichuk Date: Fri, 10 Jan 2025 10:19:26 -0800 Subject: [PATCH 31/36] queueSyncNodeMerge: fix after dropping diverge points from two-sided nodes now merged sync points don't have a corresponding diverge point, so to determine if a two-sided node is a merged sync point we need to consult the graph --- src/Pate/Verification/PairGraph.hs | 53 ++++++++++++++++++++++-------- 1 file changed, 39 insertions(+), 14 deletions(-) diff --git a/src/Pate/Verification/PairGraph.hs b/src/Pate/Verification/PairGraph.hs index e1f4bb64..a3bc0275 100644 --- a/src/Pate/Verification/PairGraph.hs +++ b/src/Pate/Verification/PairGraph.hs @@ -1744,6 +1744,29 @@ handleSingleSidedReturnTo priority ne = case asSingleNodeEntry ne of False -> return () Nothing -> return () +-- | Determine if a two-sided node is the result of a control flow merge, and return +-- the divergence point. +-- Previously this was stored in the node itself, now it must be recovered by +-- considering the single-sided ancestors of the given node. +divergeOfMergedSync :: + forall sym arch qbin. + GraphNode' arch qbin -> + PairGraphM sym arch (Maybe (GraphNode' arch Qu.AllK)) +divergeOfMergedSync nd = withKnownBin nd $ do + pg <- get + let backs = getBackEdgesFrom pg (Qu.coerceToExists nd) + let singles = mapMaybe asSingleNode (Set.toList backs) + let (singleO :: [SingleNodeEntry arch PBi.Original]) = do + Some (Qu.AsSingle (GraphNode ne)) <- singles + Just Refl <- return $ testEquality (singleEntryBin ne) PBi.OriginalRepr + return ne + let (singleP :: [SingleNodeEntry arch PBi.Patched]) = do + Some (Qu.AsSingle (GraphNode ne)) <- singles + Just Refl <- return $ testEquality (singleEntryBin ne) PBi.PatchedRepr + return ne + let merged = [ (GraphNode m, singleNodeDivergence nO) | nO <- singleO, nP <- singleP, Just m <- [combineSingleEntries nO nP] ] + return $ lookup (Qu.coerceToExists nd) merged + -- | Queue all sync points that correspond to this node. -- Returns False if the given node is not a sync point. @@ -1753,17 +1776,19 @@ queueSyncNodeMerge :: GraphNode' arch qbin -> PairGraphM sym arch Bool queueSyncNodeMerge priority node = fmap (fromMaybe False) <$> tryPG $ do - dp <- pgMaybe "getDivergePoint" $ getDivergePoint' node - GraphNode node' <- toTwoSidedNode node - - syncO <- getSyncData syncPoints PBi.OriginalRepr dp - syncP <- getSyncData syncPoints PBi.PatchedRepr dp - - GraphNode (sneO :: SingleNodeEntry arch PBi.Original) <- return $ Qu.coerceQuant (GraphNode node') - GraphNode (sneP :: SingleNodeEntry arch PBi.Patched) <- return $ Qu.coerceQuant (GraphNode node') - - let hasO = filter (\sp -> syncPointNode sp == sneO) (Set.toList syncO) - let hasP = filter (\sp -> syncPointNode sp == sneP) (Set.toList syncP) - let syncs = [(x,y) | x <- hasO, y <- hasP] - forM_ syncs $ \(x,y) -> queueSyncPoints priority x y - return $ not (null syncs) + divergeOfMergedSync node >>= \case + Just dp -> do + GraphNode node' <- toTwoSidedNode node + + syncO <- getSyncData syncPoints PBi.OriginalRepr dp + syncP <- getSyncData syncPoints PBi.PatchedRepr dp + + GraphNode (sneO :: SingleNodeEntry arch PBi.Original) <- return $ Qu.coerceQuant (GraphNode node') + GraphNode (sneP :: SingleNodeEntry arch PBi.Patched) <- return $ Qu.coerceQuant (GraphNode node') + + let hasO = filter (\sp -> syncPointNode sp == sneO) (Set.toList syncO) + let hasP = filter (\sp -> syncPointNode sp == sneP) (Set.toList syncP) + let syncs = [(x,y) | x <- hasO, y <- hasP] + forM_ syncs $ \(x,y) -> queueSyncPoints priority x y + return $ not (null syncs) + Nothing -> return False \ No newline at end of file From 79732d9fbc8dc6b433fa5f9197c1e9b11f455684 Mon Sep 17 00:00:00 2001 From: Daniel Matichuk Date: Fri, 10 Jan 2025 10:21:52 -0800 Subject: [PATCH 32/36] use a runtime error when expected quantifier convertion fails --- src/Pate/Verification/PairGraph/Node.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Pate/Verification/PairGraph/Node.hs b/src/Pate/Verification/PairGraph/Node.hs index 3a9e9312..c96e5dd1 100644 --- a/src/Pate/Verification/PairGraph/Node.hs +++ b/src/Pate/Verification/PairGraph/Node.hs @@ -586,7 +586,7 @@ asSingleNode nd = case graphNodeBlocks nd of Qu.All{} -> PPa.throwPairErr Qu.Single (repr :: PB.WhichBinaryRepr bin) _ -> withRepr repr $ case Qu.convertQuant nd of Just (nd' :: GraphNode' arch (Qu.OneK bin)) -> return $ Some (Qu.AsSingle nd') - Nothing -> PPa.throwPairErr + Nothing -> error "asSingleNode: unexpected failed conversion" singleNodeBlock :: SingleNodeEntry arch bin -> PB.ConcreteBlock arch bin singleNodeBlock (SingleNodeEntry _ blk) = blk From ad19598d2233c693dbe892485dc336eb21203a30 Mon Sep 17 00:00:00 2001 From: Daniel Matichuk Date: Fri, 10 Jan 2025 10:24:11 -0800 Subject: [PATCH 33/36] ignore "handleMerge" flag when scheduling single-sided sync points attempting to schedule a single-sided sync point should always trigger a merge --- src/Pate/Verification/StrongestPosts.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Pate/Verification/StrongestPosts.hs b/src/Pate/Verification/StrongestPosts.hs index 3971efe2..5b63935b 100644 --- a/src/Pate/Verification/StrongestPosts.hs +++ b/src/Pate/Verification/StrongestPosts.hs @@ -862,7 +862,7 @@ withWorkItem gr0 f = do let nd = workItemNode wi res <- subTraceLabel @"node" (printPriorityKind priority) nd $ atPriority priority Nothing $ do (mnext, gr2) <- case wi of - ProcessNode True (GraphNode ne) | Just (Some (Qu.AsSingle sne)) <- asSingleNodeEntry ne -> do + ProcessNode _ (GraphNode ne) | Just (Some (Qu.AsSingle sne)) <- asSingleNodeEntry ne -> do (evalPG gr1 $ isSyncNode sne) >>= \case True -> do gr2 <- execPG gr1 $ queueExitMerges (\pk -> mkPriority pk priority) (SyncAtStart sne) @@ -878,7 +878,7 @@ withWorkItem gr0 f = do return (Nothing, gr2) False -> processNode nd' gr1 ProcessNode False nd' -> do - emitTrace @"debug" $ "ProcessNode: (no merge)" ++ show nd' + emitTrace @"debug" $ "ProcessNode: (no merge) " ++ show nd' processNode nd' gr1 ProcessSplit sne -> do emitTrace @"debug" $ "ProcessSplit: " ++ show sne From 9dd8ad81e0c46f2c76166a8847daa1f3364d7a42 Mon Sep 17 00:00:00 2001 From: Daniel Matichuk Date: Fri, 10 Jan 2025 10:25:27 -0800 Subject: [PATCH 34/36] add informative error message when a scheduled node has no domain --- src/Pate/Verification/StrongestPosts.hs | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/src/Pate/Verification/StrongestPosts.hs b/src/Pate/Verification/StrongestPosts.hs index 5b63935b..de50cf5a 100644 --- a/src/Pate/Verification/StrongestPosts.hs +++ b/src/Pate/Verification/StrongestPosts.hs @@ -914,14 +914,16 @@ withWorkItem gr0 f = do PairGraph sym arch -> EquivM sym arch (Maybe (GraphNode arch), PairGraph sym arch) processNode nd gr1 = do - spec <- evalPG gr1 $ getCurrentDomainM nd - PS.viewSpec spec $ \scope d -> do - emitTrace @"debug" $ "runPendingActions" - runPendingActions refineActions nd (TupleF2 scope d) gr1 >>= \case - Just gr2 -> do - emitTrace @"debug" $ "Actions Executed, returning..." - return $ (Nothing, gr2) - Nothing -> return $ (Just nd, gr1) + case getCurrentDomain gr1 nd of + Just spec -> do + PS.viewSpec spec $ \scope d -> do + emitTrace @"debug" $ "runPendingActions" + runPendingActions refineActions nd (TupleF2 scope d) gr1 >>= \case + Just gr2 -> do + emitTrace @"debug" $ "Actions Executed, returning..." + return $ (Nothing, gr2) + Nothing -> return $ (Just nd, gr1) + Nothing -> fail $ "Missing domain for: " ++ show nd -- | Execute the forward dataflow fixpoint algorithm. -- Visit nodes and compute abstract domains until we propagate information From 3111d0ab75e0b846041788bb01ad5ed6d09596d3 Mon Sep 17 00:00:00 2001 From: Daniel Matichuk Date: Fri, 10 Jan 2025 11:01:54 -0800 Subject: [PATCH 35/36] give Inequivalent result when entry point has unsolved assertions --- src/Pate/Verification/PairGraph.hs | 11 +++++++++++ src/Pate/Verification/PairGraph/Node.hs | 8 ++++++++ 2 files changed, 19 insertions(+) diff --git a/src/Pate/Verification/PairGraph.hs b/src/Pate/Verification/PairGraph.hs index a3bc0275..dbcd08a8 100644 --- a/src/Pate/Verification/PairGraph.hs +++ b/src/Pate/Verification/PairGraph.hs @@ -1243,6 +1243,7 @@ pairGraphComputeVerdict :: pairGraphComputeVerdict gr = if Map.null (pairGraphObservableReports gr) && Map.null (pairGraphDesyncReports gr) && + not (unsolvedAsserts gr) && Set.null (pairGraphGasExhausted gr) then case filter (\(_,condK) -> case condK of {ConditionEquiv{} -> True; _ -> False}) (Map.keys (pairGraphConditions gr)) of [] -> PE.Equivalent @@ -1250,6 +1251,16 @@ pairGraphComputeVerdict gr = else PE.Inequivalent +unsolvedAsserts :: + PairGraph sym arch -> Bool +unsolvedAsserts pg = + let + cond_nodes = Map.keys (pairGraphConditions pg) + go (nd, condK) = case condK of + ConditionAsserted{} -> isRootNode nd + _ -> False + in any go cond_nodes + -- | Drop the given node from the work queue if it is queued. -- Otherwise do nothing. dropNodeFromWorkList :: diff --git a/src/Pate/Verification/PairGraph/Node.hs b/src/Pate/Verification/PairGraph/Node.hs index c96e5dd1..2d324a0b 100644 --- a/src/Pate/Verification/PairGraph/Node.hs +++ b/src/Pate/Verification/PairGraph/Node.hs @@ -40,6 +40,7 @@ module Pate.Verification.PairGraph.Node ( , mkNodeReturn , rootEntry , rootReturn + , isRootNode , nodeBlocks , nodeFuns , returnToEntry @@ -343,6 +344,13 @@ rootEntry pPair = NodeEntry (CallingContext [] (SomeDivergePoint Nothing)) pPair rootReturn :: PPa.PatchPair (PB.FunctionEntry arch) -> NodeReturn arch rootReturn pPair = NodeReturn (CallingContext [] (SomeDivergePoint Nothing)) pPair +-- | A root node is a function entry point without any ancestors in its calling context +isRootNode :: GraphNode' arch qbin -> Bool +isRootNode nd = case nd of + GraphNode ne | functionEntryOf ne == ne, CallingContext [] _ <- nodeContext nd -> True + _ -> False + + addContext :: PB.BinaryPair (PB.ConcreteBlock arch) qbin1 -> NodeEntry' arch qbin2 -> NodeEntry' arch qbin2 addContext newCtx' ne@(NodeEntry (CallingContext ctx d) blks) = case elem newCtx ctx of From 65e520896665360ac1a6361df3af1803b2717bfb Mon Sep 17 00:00:00 2001 From: Daniel Matichuk Date: Fri, 10 Jan 2025 11:03:18 -0800 Subject: [PATCH 36/36] add desync-assert test --- tests/aarch32/desync-assert.original.exe | Bin 0 -> 128132 bytes tests/aarch32/desync-assert.patched.exe | Bin 0 -> 128132 bytes tests/aarch32/desync-assert.pate | 53 ++++++++++++++++++ tests/aarch32/desync-assert.toml | 1 + .../unequal/desync-assert.original.exe | Bin 0 -> 128132 bytes .../aarch32/unequal/desync-assert.patched.exe | Bin 0 -> 128136 bytes tests/aarch32/unequal/desync-assert.pate | 53 ++++++++++++++++++ tests/aarch32/unequal/desync-assert.toml | 1 + tests/src/desync-assert.original.c | 6 ++ tests/src/desync-assert.patched-bad.c | 35 ++++++++++++ tests/src/desync-assert.patched.c | 10 +++- 11 files changed, 156 insertions(+), 3 deletions(-) create mode 100755 tests/aarch32/desync-assert.original.exe create mode 100755 tests/aarch32/desync-assert.patched.exe create mode 100644 tests/aarch32/desync-assert.pate create mode 100644 tests/aarch32/desync-assert.toml create mode 100755 tests/aarch32/unequal/desync-assert.original.exe create mode 100755 tests/aarch32/unequal/desync-assert.patched.exe create mode 100644 tests/aarch32/unequal/desync-assert.pate create mode 100644 tests/aarch32/unequal/desync-assert.toml create mode 100644 tests/src/desync-assert.patched-bad.c diff --git a/tests/aarch32/desync-assert.original.exe b/tests/aarch32/desync-assert.original.exe new file mode 100755 index 0000000000000000000000000000000000000000..b6e10d494e80700e52552c0100a2f963a0e78232 GIT binary patch literal 128132 zcmeIxPl%Ld7y$71+Zk7lAQdaKvL*JQ)sCyJ7wM3S>A{NpM^UuQI+JebD!bo69x5n^ zAUxSYf~aFh4|^z~V<6$dTOM<3p$Njvx=znKGha+wL6>g77oK_E=Y5}fzjuE7?c4hg zJyR4#s>Vp#nsT)mYg3W$+>UA_t(r<>sUCZGrM12Net+&P($z>gR`nK(-hO{=B-TgL zQ$H8I7#-}_BQN%%h+L%cnCHmrIbK*UTao@Y^7q$87mI_meb_Lxce`h(RPj9B{A1u``fBgNH z?)ID4;*M4S%Dr@O;>UWN^Lw}ZQ#m**r6b>MO6kg}p*rq!<>;Vp#eUrL>w`n}-BC{s z>SFTUrLBXzjODeli_6tLYm6w(vNN`0 zM`NlnIkBVDD|fuLb7y06YTIBr?b#MLX||g)v#EF_rmJ=xO{29n#oA&+ePeNNaer-7 z@j$V8WXtHk+;}k+y`9=1-}tj0>8)Qa`ni^Be>tI+>MQD1{rXnFua-s!C-s->>6h;2 zm{#YdI4{>}(4V6J;V7%;r!>;ruNVFM%`VjYT~c z`yWQ$5a&G_IX`c5P>)9*?%x^pwfKJirR(GSQ!DoON1dOyF>*fd=@t8jR@6tM&iCIG zIrkrroPU4+{L%Dkl*7+&uc%*-I{Q`kNv-z6`MDDl&4q>beAzfVKYMa^u6ep~B8|7w zcr(40PNwPUnT3Vvg|azcPEV(o26cO`71hvQ%=>Gn((`+d>_2>bf0}N$nq@Q6Tr0hp zQe)x#nX)+(xt#CkQ`KzlY}sy{oa;1ZI#T<@Y3y`mG{8-knMhE-N$ct4Jk&Cn?<~j0uj%Sz3PNct${Qb2Nxo3SuBjUg_$I`x)AN+pwt51)v z+;#EL#^2U#{Pq6MOX4!o!F0ietvMMzCG$M z}^d$%U$%d}GIs*2L7d!E)NYEpF28wr6Hjac@jlJbE;ZHdYm@i*?QQ#ht}njSa=d z;_i{nqyKW_#Z*)~jX}QpXFXD_Un=^!ks5zFp^=))>J|O^M!&C-Mh7SLmz(LQ-o}{L z=cPC=*J;q7qJLAA_4892srH*i|9-j7`>TfP{QXac>b$==R8K{HWpMws@w^N)7W?l- zUKi)x7dby~Vo*O2dANTv>dW!{{7dhM??19^e_z!3dFvzR^L8!Ue{xxUB9Y1~QRCg}Q-G`rUwafDC z?94*holmXP3+0)GGJey49rr}z%82|%=J$3n@|K8tWS2Zz5&5mj?|lCIUX6Ssq8@eM zR4nAa{KjV2OHr(v@_Uj;^G1;#>QAfByq9BdM4WY|T8xkF(f43oM9w{V z Function Entry "_start" + +0x1012c [ via: "f" (0x10120) <- "_start" (0x101c0) ] + Handle observable difference: + > Emit warning and continue + + +0x1012c [ via: "f" (0x10120) <- "_start" (0x101c0) ] + ... + Return (original) vs. Call to: "g" (0x100d8) + ... + ... + > Choose desynchronization points + + Choose a desynchronization point: + > 0x1016c (patched) + > 0x1016c (original) + +0x1016c [ via: "f" (0x10120) <- "_start" (0x101c0) ] + ... + Return (original) vs. Call to: "g" (0x100d8) + ... + ... + > Choose synchronization points + + Choose a synchronization point: + > 0x10180 (patched) + > 0x10180 (original) + > Finish Choosing + + +0x10180 [ via: "f" + Modify Proof Node + Add Assertion + > 0: Assert condition + + Handle observable difference: + > Emit warning and continue + + Include Location: + > 1+bvSum cstack_base + > Finish + + Handle observable difference + > Assert difference is infeasible (defer proof) + + +Verification Finished +Continue verification? + > Finish and view final result + + diff --git a/tests/aarch32/desync-assert.toml b/tests/aarch32/desync-assert.toml new file mode 100644 index 00000000..a8015481 --- /dev/null +++ b/tests/aarch32/desync-assert.toml @@ -0,0 +1 @@ +observable-memory = [ { start-address = 0x0003f000, length=4000 } ] \ No newline at end of file diff --git a/tests/aarch32/unequal/desync-assert.original.exe b/tests/aarch32/unequal/desync-assert.original.exe new file mode 100755 index 0000000000000000000000000000000000000000..b6e10d494e80700e52552c0100a2f963a0e78232 GIT binary patch literal 128132 zcmeIxPl%Ld7y$71+Zk7lAQdaKvL*JQ)sCyJ7wM3S>A{NpM^UuQI+JebD!bo69x5n^ zAUxSYf~aFh4|^z~V<6$dTOM<3p$Njvx=znKGha+wL6>g77oK_E=Y5}fzjuE7?c4hg zJyR4#s>Vp#nsT)mYg3W$+>UA_t(r<>sUCZGrM12Net+&P($z>gR`nK(-hO{=B-TgL zQ$H8I7#-}_BQN%%h+L%cnCHmrIbK*UTao@Y^7q$87mI_meb_Lxce`h(RPj9B{A1u``fBgNH z?)ID4;*M4S%Dr@O;>UWN^Lw}ZQ#m**r6b>MO6kg}p*rq!<>;Vp#eUrL>w`n}-BC{s z>SFTUrLBXzjODeli_6tLYm6w(vNN`0 zM`NlnIkBVDD|fuLb7y06YTIBr?b#MLX||g)v#EF_rmJ=xO{29n#oA&+ePeNNaer-7 z@j$V8WXtHk+;}k+y`9=1-}tj0>8)Qa`ni^Be>tI+>MQD1{rXnFua-s!C-s->>6h;2 zm{#YdI4{>}(4V6J;V7%;r!>;ruNVFM%`VjYT~c z`yWQ$5a&G_IX`c5P>)9*?%x^pwfKJirR(GSQ!DoON1dOyF>*fd=@t8jR@6tM&iCIG zIrkrroPU4+{L%Dkl*7+&uc%*-I{Q`kNv-z6`MDDl&4q>beAzfVKYMa^u6ep~B8|7w zcr(40PNwPUnT3Vvg|azcPEV(o26cO`71hvQ%=>Gn((`+d>_2>bf0}N$nq@Q6Tr0hp zQe)x#nX)+(xt#CkQ`KzlY}sy{oa;1ZI#T<@Y3y`mG{8-kppU3L)=i|&hb(Ve=p)j&lkwWzoo&wVpb#;D-N-FM;4x#!+9_ucvO^6LJ_ zA1#U^)ng=WOSxK!wW-LzUyEuat(!{YsTq6Mrw!G9zdv^t>0G27>#D_~+V8K8#QI2j z7n9mC~W_x1@A-eyEQ7oSh!jo!F0iesy4|z9H&w z+@p&*IuueBS;Ja z1PBlyK!5-N0t5&UAV7cs0RjXF5FkK+009C72oNAZfB*pk1PBlyK!5-N0t5&UAV7cs z0RjXF5FkK+009C72oNAZfB*pk1PBlyK!5-N0t5&UAV7cs0RjXF5FkK+009C72oNAZ zfB*pk1PBlyK!5-N0t5&UAV7cs0RjXF5FkK+009C72oNAZfB*pk1PBlyK!5-N0t5&U zAV7cs0RjXF5FkK+009C72oNAZfB*pk1PBlyK!5-N0t5&UAV7cs0RjXF5FkK+009C7 z2oNAZfB*pk1PBlyK!5-N0t5&UAV7cs0RjXF5FkK+009C72oNAZfB*pk1PBlyK!5-N z0t5&UAV7cs0RjXF5FkK+009C72oNAZfB*pk1PBlyK!5-N0t5&UAV7cs0RjXF5FkK+ z009C72oNAZfB*pk1PBlyK!5-N0t5&UAV7cs0RjXF5FkK+009C72oNAZfB*pk1PBly zK!5-N0t5&UAV7cs0RjXF5FkK+009C72oNAZfB*pk1PBlyK!5-N0t5&UAV7cs0RjXF z5FkK+009C72oNAZfB*pk1PBlyK!5-N0t5&UAV7cs0RjXF5FkK+009C72oNAZfB*pk z1PBlyK!5-N0t5&UAV7cs0RjXF5FkK+009C72oNAZfB*pk1PBlyK!5-N0t5&UAV7cs z0RjXF5FkK+009C72oNAZfB*pk1PBlyK!5-N0{@%9FTGyxv3>h?k8gWsc6qT}9^bK} zHPxD&*s)xdJ6_qjvo$$&-(WfIxi4m9=FfVhT0d9xb0anWazZ0D*VOC!_0@h~BaIGD>Mu9b&%HZh zTA!EVyj-V2e~SL`DC_5^G*az1i~jv`o%h!d)%p9M4%K;oWvG5Q>I;MWkHz!uj(R-y z--)~_&budae%|DuzBlr4|E{Rd$M^Fu-5B40XwCkCsPpqSN6zQ%TeE*~P5oTd`Tko5 z{f8sx-`_ufG_|7~e*XNL`e@YIuf9*}beB#o&P}wJmbxd(*70^ZH{b0{%(gqNxwN&D zwzktt=}4NHnO$0%St{En%9)vTcu;p2J5deo#k{{ZpAPOlwEyX6_ota|r(L!qEq2oL zDYceP9WC3lk;@bPJYUZikCollk;UcK?DE3Por#4`YL(rSWolIiwC0W-J=$H2a?jIG zwAy8PVqtc<>@KC&vE}mkav8ttzmD6Y@w$loR_1qiCGysYdSshCS`qop$?tvs8-Ek| zYD7KizNuKqefh1;w&$W)UpGar`*z1X_vLpbkLJ}PJL&SC z>mqXQ$>UH&p6BOQ{{zuiKPxZQ^W4+_56r76y%>ELVlm(G#)#ZE7O^3sIxBJ>4_+(M WvHrCBte?9vs^Pv5qVI)&==%eDJ`Q&P literal 0 HcmV?d00001 diff --git a/tests/aarch32/unequal/desync-assert.pate b/tests/aarch32/unequal/desync-assert.pate new file mode 100644 index 00000000..5b6e6533 --- /dev/null +++ b/tests/aarch32/unequal/desync-assert.pate @@ -0,0 +1,53 @@ +Choose Entry Point + > Function Entry "_start" + +0x1012c [ via: "f" (0x10120) <- "_start" (0x101c0) ] + Handle observable difference: + > Emit warning and continue + + +0x1012c [ via: "f" (0x10120) <- "_start" (0x101c0) ] + ... + Return (original) vs. Call to: "g" (0x100d8) + ... + ... + > Choose desynchronization points + + Choose a desynchronization point: + > 0x1016c (patched) + > 0x1016c (original) + +0x1016c [ via: "f" (0x10120) <- "_start" (0x101c0) ] + ... + Return (original) vs. Call to: "g" (0x100d8) + ... + ... + > Choose synchronization points + + Choose a synchronization point: + > 0x10180 (patched) + > 0x10180 (original) + > Finish Choosing + + +0x10180 [ via: "f" + Modify Proof Node + Add Assertion + > 0: Assert condition + + Handle observable difference: + > Emit warning and continue + + Include Location: + > 1+bvSum cstack_base + > Finish + + Handle observable difference + > Assert difference is infeasible (defer proof) + + +Verification Finished +Continue verification? + > Finish and view final result + + diff --git a/tests/aarch32/unequal/desync-assert.toml b/tests/aarch32/unequal/desync-assert.toml new file mode 100644 index 00000000..a8015481 --- /dev/null +++ b/tests/aarch32/unequal/desync-assert.toml @@ -0,0 +1 @@ +observable-memory = [ { start-address = 0x0003f000, length=4000 } ] \ No newline at end of file diff --git a/tests/src/desync-assert.original.c b/tests/src/desync-assert.original.c index ddc05c55..11672bfe 100644 --- a/tests/src/desync-assert.original.c +++ b/tests/src/desync-assert.original.c @@ -9,8 +9,14 @@ void g() { Y--; } +#pragma noinline +void h() { + return; +} + #pragma noinline void f() { + h(); if (X < 0 || Y < 0 || X > 100 || Y > 100) { return; } diff --git a/tests/src/desync-assert.patched-bad.c b/tests/src/desync-assert.patched-bad.c new file mode 100644 index 00000000..9440d8f5 --- /dev/null +++ b/tests/src/desync-assert.patched-bad.c @@ -0,0 +1,35 @@ +#include "util.h" + +int X = -11; +int Y = -11; +int OBSERVE __attribute__((section(".output"))) = -12; + +#pragma noinline +void g() { + Y = Y - 2; +} + +#pragma noinline +void h() { + return; +} + +#pragma noinline +void f() { + h(); + if (X < 0 || Y < 0 || X > 100 || Y > 100) { + return; + } + g(); + asm("nop"); + asm("nop"); + asm("nop"); + asm("nop"); + + // relation is that X - Y is the same between both programs + OBSERVE = X - Y; +} + +void _start() { + f(); +} diff --git a/tests/src/desync-assert.patched.c b/tests/src/desync-assert.patched.c index 39d824be..ec51f448 100644 --- a/tests/src/desync-assert.patched.c +++ b/tests/src/desync-assert.patched.c @@ -6,11 +6,17 @@ int OBSERVE __attribute__((section(".output"))) = -12; #pragma noinline void g() { - Y--; + Y = Y - 1; +} + +#pragma noinline +void h() { + return; } #pragma noinline void f() { + h(); if (X < 0 || Y < 0 || X > 100 || Y > 100) { return; } @@ -19,8 +25,6 @@ void f() { asm("nop"); asm("nop"); asm("nop"); - asm("nop"); - asm("nop"); // relation is that X - Y is the same between both programs OBSERVE = X - Y;