From 9d66afc87e2afe70fbea40033f7f887c6a02558a Mon Sep 17 00:00:00 2001 From: Santiago Cuellar Date: Wed, 1 Mar 2023 21:31:19 -0500 Subject: [PATCH 01/27] Heapster ide info (#1821) * add basic IDE logging, start error cleanup * clean up additional implication errors * add structure to stmt fail in line with impl fail * redesign error message types, pipe through to log * fix default heapster environments missing ioref * carry more information through on most common implication error * remove Some from error constructor * Export valueperms in full json detail * Avoid generating orphan ToJSON instances and using Given * refine jsonexport instances * Document JSONExport * Remove need for passing undefined * JSONExport support for PermImpls * export entrypoint and caller ID information * cleanup imports, 80 char columns * heapster: export function name for IDE * heapster-saw: LogEntry with names and structure * Incorporate names from bindings in JsonExport * Update PPInfo while exporting * checkpoint * Use types to generate names for pretty permissions where possible * WIP: fixing errors introduced by the merge. * got SAW to compile after the latest merge of master * Updtate deps * bumping the cryptol submodule to match master * moved nuMatching and Liftable instances to the top of the file in NamedMb.hs, to help with GHC 9 support * GHC 9 fixes * renamed the Mb' datatype to the more accessible name NamedMb, and changed the names of all of its operationsto use 'Named' as a suffix instead of just using a prime --------- Co-authored-by: Karl Smeltzer Co-authored-by: Eric Mertens Co-authored-by: Eddy Westbrook --- heapster-saw/heapster-saw.cabal | 8 +- .../src/Verifier/SAW/Heapster/CruUtil.hs | 10 + .../src/Verifier/SAW/Heapster/GenMonad.hs | 31 +- .../src/Verifier/SAW/Heapster/IDESupport.hs | 331 +++++++++++++++++ .../src/Verifier/SAW/Heapster/Implication.hs | 321 ++++++++++++----- .../Verifier/SAW/Heapster/ImplicationError.hs | 0 .../src/Verifier/SAW/Heapster/JSONExport.hs | 211 +++++++++++ .../src/Verifier/SAW/Heapster/NamedMb.hs | 95 +++++ .../src/Verifier/SAW/Heapster/Permissions.hs | 94 ++++- .../Verifier/SAW/Heapster/SAWTranslation.hs | 18 +- .../Verifier/SAW/Heapster/TypedCrucible.hs | 332 +++++++++++++----- src/SAWScript/HeapsterBuiltins.hs | 24 +- src/SAWScript/Interpreter.hs | 7 + src/SAWScript/Value.hs | 4 +- 14 files changed, 1267 insertions(+), 219 deletions(-) create mode 100644 heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs create mode 100644 heapster-saw/src/Verifier/SAW/Heapster/ImplicationError.hs create mode 100644 heapster-saw/src/Verifier/SAW/Heapster/JSONExport.hs create mode 100644 heapster-saw/src/Verifier/SAW/Heapster/NamedMb.hs diff --git a/heapster-saw/heapster-saw.cabal b/heapster-saw/heapster-saw.cabal index 02a65a041c..de796b54d1 100644 --- a/heapster-saw/heapster-saw.cabal +++ b/heapster-saw/heapster-saw.cabal @@ -38,7 +38,10 @@ library filepath, language-rust, hobbits ^>= 1.4, - extra, + aeson ^>= 1.5, + th-abstraction, + template-haskell, + extra hs-source-dirs: src build-tool-depends: alex:alex, @@ -46,12 +49,15 @@ library exposed-modules: Verifier.SAW.Heapster.CruUtil Verifier.SAW.Heapster.GenMonad + Verifier.SAW.Heapster.IDESupport Verifier.SAW.Heapster.HintExtract Verifier.SAW.Heapster.Implication Verifier.SAW.Heapster.IRTTranslation Verifier.SAW.Heapster.Lexer Verifier.SAW.Heapster.LLVMGlobalConst Verifier.SAW.Heapster.Located + Verifier.SAW.Heapster.NamedMb + Verifier.SAW.Heapster.JSONExport Verifier.SAW.Heapster.ParsedCtx Verifier.SAW.Heapster.Parser Verifier.SAW.Heapster.Permissions diff --git a/heapster-saw/src/Verifier/SAW/Heapster/CruUtil.hs b/heapster-saw/src/Verifier/SAW/Heapster/CruUtil.hs index e4c09c3703..a864a538d7 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/CruUtil.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/CruUtil.hs @@ -25,6 +25,7 @@ import Data.Text (Text) import qualified Data.Text as Text import Data.Reflection import Data.List.NonEmpty (NonEmpty(..)) +import Data.Functor.Constant import Data.ByteString import Numeric import Numeric.Natural @@ -570,6 +571,15 @@ instance Liftable (KnownReprObj f a) where instance LiftableAny1 (KnownReprObj f) where mbLiftAny1 = mbLift +instance Liftable a => LiftableAny1 (Constant a) where + mbLiftAny1 = mbLift + +instance Liftable a => Liftable (Constant a b) where + mbLift (mbMatch -> [nuMP| Data.Functor.Constant.Constant x |]) = Data.Functor.Constant.Constant (mbLift x) + +instance (Liftable a, Liftable b, Liftable c) => Liftable (a,b,c) where + mbLift (mbMatch -> [nuMP| (x,y,z) |]) = (mbLift x, mbLift y, mbLift z) + -- FIXME: this change for issue #28 requires ClosableAny1 to be exported from -- Hobbits {- diff --git a/heapster-saw/src/Verifier/SAW/Heapster/GenMonad.hs b/heapster-saw/src/Verifier/SAW/Heapster/GenMonad.hs index 7ac7aa75b6..f70a89cbae 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/GenMonad.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/GenMonad.hs @@ -8,17 +8,20 @@ module Verifier.SAW.Heapster.GenMonad ( -- * Core definitions GenStateContT(..), (>>>=), (>>>), -- * Continuation operations - gcaptureCC, gmapRet, gabortM, gparallel, gopenBinding, + gcaptureCC, gmapRet, gabortM, gparallel, startBinding, + startNamedBinding, gopenBinding, gopenNamedBinding, -- * State operations gmodify, -- * Transformations addReader, ) where -import Data.Binding.Hobbits ( nuMultiWithElim1, Mb, Name, RAssign ) +import Data.Binding.Hobbits ( nuMulti, nuMultiWithElim1, Mb, Name, RAssign ) import Control.Monad.State ( ap, MonadState(get, put) ) import Control.Monad.Trans.Class ( MonadTrans(lift) ) import Control.Monad.Trans.Reader +import Data.Proxy +import Verifier.SAW.Heapster.NamedMb -- | The generalized state-continuation monad newtype GenStateContT s1 r1 s2 r2 m a = GenStateContT { @@ -107,6 +110,30 @@ gopenBinding f_ret mb_a = f_ret $ flip nuMultiWithElim1 mb_a $ \names a -> k (names, a) +-- | Name-binding in the generalized continuation monad (FIXME: explain) +gopenNamedBinding :: + (NamedMb ctx (m b1) -> m r2) -> + NamedMb ctx b2 -> + GenStateContT s b1 s r2 m (RAssign Name ctx, b2) +gopenNamedBinding f_ret mb_a = + gcaptureCC \k -> + f_ret $ flip nuMultiWithElim1Named mb_a $ \names a -> + k (names, a) + +-- | Name-binding in the generalized continuation monad (FIXME: explain) +startBinding :: + RAssign Proxy ctx -> + (Mb ctx (m r1) -> m r2) -> + GenStateContT s r1 s r2 m (RAssign Name ctx) +startBinding tps f_ret = gcaptureCC (f_ret . nuMulti tps) + +-- | Name-binding in the generalized continuation monad (FIXME: explain) +startNamedBinding :: + RAssign StringF ctx -> + (NamedMb ctx (m r1) -> m r2) -> + GenStateContT s r1 s r2 m (RAssign Name ctx) +startNamedBinding tps f_ret = gcaptureCC (f_ret . nuMultiNamed tps) + addReader :: GenStateContT s1 r1 s2 r2 m a -> GenStateContT s1 r1 s2 r2 (ReaderT e m) a addReader (GenStateContT m) = GenStateContT \s2 k -> diff --git a/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs b/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs new file mode 100644 index 0000000000..b86c58b836 --- /dev/null +++ b/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs @@ -0,0 +1,331 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PolyKinds #-} +module Verifier.SAW.Heapster.IDESupport where + +import Control.Monad.Reader + ( MonadReader (ask, local), + ReaderT (..), + ) +import Data.Aeson (ToJSON, Value, encodeFile) +import Data.Binding.Hobbits + ( Liftable (..), + Mb, + NuMatching (..), + RList, + mbMatch, + nuMP, + nuMultiWithElim1, + unsafeMbTypeRepr, + Name, + ) +import Data.Maybe (catMaybes, listToMaybe, mapMaybe) +import Data.Parameterized.Some (Some (..)) +import qualified Data.Text as T +import qualified Data.Type.RList as RL +import GHC.Generics (Generic) +import Lang.Crucible.FunctionHandle +import Lang.Crucible.Types (CrucibleType) +import What4.FunctionName (FunctionName (functionName)) +import What4.ProgramLoc + ( Position (BinaryPos, InternalPos, OtherPos, SourcePos), + ProgramLoc (..), + ) + +import Verifier.SAW.Heapster.CruUtil +import Verifier.SAW.Heapster.Permissions +import Verifier.SAW.Heapster.Implication +import Verifier.SAW.Heapster.TypedCrucible +import Verifier.SAW.Heapster.SAWTranslation (SomeTypedCFG (..)) +import Verifier.SAW.Heapster.JSONExport(ppToJson) +import Data.Type.RList (mapRAssign) +import Data.Functor.Constant +import Control.Monad.Writer +import Data.Binding.Hobbits.NameMap (NameMap) +import qualified Data.Binding.Hobbits.NameMap as NameMap +import Verifier.SAW.Heapster.NamedMb + +-- | The entry point for dumping a Heapster environment to a file for IDE +-- consumption. +printIDEInfo :: PermEnv -> [Some SomeTypedCFG] -> FilePath -> PPInfo -> IO () +printIDEInfo _penv tcfgs file ppinfo = + encodeFile file $ IDELog (runWithLoc ppinfo tcfgs) + + +type ExtractionM = ReaderT (PPInfo, ProgramLoc, String) (Writer [LogEntry]) + +emit :: LogEntry -> ExtractionM () +emit entry = tell [entry] + +gather :: ExtractionM () -> ExtractionM [LogEntry] +gather m = snd <$> listen m + +-- | A single entry in the IDE info dump log. At a bare minimum, this must +-- include a location and corresponding permission. Once the basics are +-- working, we can enrich the information we log. +data LogEntry + = LogEntry + { leLocation :: String + , leEntryId :: LogEntryID + , leCallers :: [LogEntryID] + , leFunctionName :: String + , lePermissions :: [(String, String, Value)] + } + | LogError + { lerrLocation :: String + , lerrError :: String + , lerrFunctionName :: String + } + | LogImpl + { limplLocation :: String + , limplExport :: Value + , limplFunctionName :: String + } + + deriving (Generic, Show) +instance ToJSON LogEntry +instance NuMatching LogEntry where + nuMatchingProof = unsafeMbTypeRepr +instance Liftable LogEntry where + mbLift mb = case mbMatch mb of + [nuMP| LogEntry v w x y z |] -> + LogEntry (mbLift v) (mbLift w) (mbLift x) (mbLift y) (mbLift z) + [nuMP| LogError x y z |] -> + LogError (mbLift x) (mbLift y) (mbLift z) + [nuMP| LogImpl x y z |] -> + LogImpl (mbLift x) (mbLift y) (mbLift z) + +data LogEntryID = LogEntryID + { leIdBlock :: Int + , leIdHeapster :: Int + } + deriving (Generic, Show) +instance ToJSON LogEntryID +instance NuMatching LogEntryID where + nuMatchingProof = unsafeMbTypeRepr +instance Liftable LogEntryID where + mbLift mb = case mbMatch mb of + [nuMP| LogEntryID x y |] -> LogEntryID (mbLift x) (mbLift y) + +-- | A complete IDE info dump log, which is just a sequence of entries. Once +-- the basics are working, we can enrich the information we log. +newtype IDELog = IDELog { + lmfEntries :: [LogEntry] +} deriving (Generic, Show) +instance ToJSON IDELog + + +class ExtractLogEntries a where + extractLogEntries :: a -> ExtractionM () + +instance (PermCheckExtC ext extExpr) + => ExtractLogEntries + (TypedEntry TransPhase ext blocks tops ret args ghosts) where + extractLogEntries te = do + let loc = mbLiftNamed $ fmap getFirstProgramLocTS (typedEntryBody te) + withLoc loc (mb'ExtractLogEntries (typedEntryBody te)) + let entryId = mkLogEntryID $ typedEntryID te + let callers = callerIDs $ typedEntryCallers te + (ppi, _, fname) <- ask + let loc' = snd (ppLoc loc) + let debugNames = _mbNames (typedEntryBody te) + let insertNames :: + RL.RAssign Name (x :: RList CrucibleType) -> + RL.RAssign StringF x -> + NameMap (StringF :: CrucibleType -> *)-> + NameMap (StringF :: CrucibleType -> *) + insertNames RL.MNil RL.MNil m = m + insertNames (ns RL.:>: n) (xs RL.:>: StringF name) m = + insertNames ns xs (NameMap.insert n (StringF name) m) + inputs = mbLift + $ flip nuMultiWithElim1 (typedEntryPermsIn te) + $ \ns body -> + let ppi' = ppi { ppExprNames = insertNames ns debugNames (ppExprNames ppi) } + f :: + (Pair StringF ValuePerm) x -> + Constant (String, String, Value) x + f (Pair (StringF name) vp) = Constant (name, permPrettyString ppi' vp, ppToJson ppi' vp) + in RL.toList (mapRAssign f (zipRAssign debugNames body)) + tell [LogEntry loc' entryId callers fname inputs] + +mkLogEntryID :: TypedEntryID blocks args -> LogEntryID +mkLogEntryID = uncurry LogEntryID . entryIDIndices + +callerIDs :: [Some (TypedCallSite phase blocks tops args ghosts)] -> [LogEntryID] +callerIDs = map $ \(Some tcs) -> case typedCallSiteID tcs of + TypedCallSiteID tei _ _ _ -> mkLogEntryID tei + +data Pair f g x = Pair (f x) (g x) + +zipRAssign :: RL.RAssign f x -> RL.RAssign g x -> RL.RAssign (Pair f g) x +zipRAssign RL.MNil RL.MNil = RL.MNil +zipRAssign (xs RL.:>: x) (ys RL.:>: y) = zipRAssign xs ys RL.:>: Pair x y + +instance ExtractLogEntries (TypedStmtSeq ext blocks tops ret ps_in) where + extractLogEntries (TypedImplStmt (AnnotPermImpl _str pimpl)) = + -- fmap (setErrorMsg str) <$> extractLogEntries pimpl + extractLogEntries pimpl + extractLogEntries (TypedConsStmt loc _ _ rest) = do + withLoc loc $ mb'ExtractLogEntries rest + extractLogEntries (TypedTermStmt _ _) = pure () + +instance ExtractLogEntries + (PermImpl (TypedStmtSeq ext blocks tops ret) ps_in) where + extractLogEntries (PermImpl_Step pi1 mbpis) = do + pi1Entries <- extractLogEntries pi1 + pisEntries <- extractLogEntries mbpis + return $ pi1Entries <> pisEntries + extractLogEntries (PermImpl_Done stmts) = extractLogEntries stmts + +instance ExtractLogEntries (PermImpl1 ps_in ps_outs) where + extractLogEntries (Impl1_Fail err) = + do (_, loc, fname) <- ask + emit (LogError (snd (ppLoc loc)) (ppError err) fname) + -- The error message is available further up the stack, so we just leave it + extractLogEntries impl = + do (ppi, loc, fname) <- ask + emit (LogImpl (snd (ppLoc loc)) (ppToJson ppi impl) fname) + +instance ExtractLogEntries + (MbPermImpls (TypedStmtSeq ext blocks tops ret) ps_outs) where + extractLogEntries (MbPermImpls_Cons ctx mbpis pis) = do + mbExtractLogEntries ctx pis + extractLogEntries mbpis + extractLogEntries MbPermImpls_Nil = pure () + +instance (PermCheckExtC ext extExpr) + => ExtractLogEntries (TypedCFG ext blocks ghosts inits gouts ret) where + extractLogEntries tcfg = extractLogEntries $ tpcfgBlockMap tcfg + +instance (PermCheckExtC ext extExpr) + => ExtractLogEntries (TypedBlockMap TransPhase ext blocks tops ret) where + extractLogEntries tbm = + sequence_ $ RL.mapToList extractLogEntries tbm + +instance (PermCheckExtC ext extExpr) + => ExtractLogEntries (TypedBlock TransPhase ext blocks tops ret args) where + extractLogEntries tb = + mapM_ (\(Some te) -> extractLogEntries te) $ _typedBlockEntries tb + +mbExtractLogEntries + :: ExtractLogEntries a => CruCtx ctx -> Mb (ctx :: RList CrucibleType) a -> ExtractionM () +mbExtractLogEntries ctx mb_a = + ReaderT $ \(ppi, loc, fname) -> + tell $ mbLift $ flip nuMultiWithElim1 mb_a $ \ns x -> + let ppi' = ppInfoAddTypedExprNames ctx ns ppi in + execWriter $ runReaderT (extractLogEntries x) (ppi', loc, fname) + +mb'ExtractLogEntries + :: ExtractLogEntries a => NamedMb (ctx :: RList CrucibleType) a -> ExtractionM () +mb'ExtractLogEntries mb_a = + ReaderT $ \(ppi, loc, fname) -> + tell $ mbLift $ flip nuMultiWithElim1 (_mbBinding mb_a) $ \ns x -> + let ppi' = ppInfoApplyAllocation ns (_mbNames mb_a) ppi in + execWriter $ runReaderT (extractLogEntries x) (ppi', loc, fname) + +typedStmtOutCtx :: TypedStmt ext rets ps_in ps_next -> CruCtx rets +typedStmtOutCtx = error "FIXME: write typedStmtOutCtx" + +withLoc :: ProgramLoc -> ExtractionM a -> ExtractionM a +withLoc loc = local (\(ppinfo, _, fname) -> (ppinfo, loc, fname)) + +setErrorMsg :: String -> LogEntry -> LogEntry +setErrorMsg msg le@LogError {} = le { lerrError = msg } +setErrorMsg msg le@LogImpl {} = + LogError { lerrError = msg + , lerrLocation = limplLocation le + , lerrFunctionName = limplFunctionName le} +setErrorMsg msg le@LogEntry {} = + LogError { lerrError = msg + , lerrLocation = leLocation le + , lerrFunctionName = leFunctionName le + } + +runWithLoc :: PPInfo -> [Some SomeTypedCFG] -> [LogEntry] +runWithLoc ppi = + concatMap (runWithLocHelper ppi) + where + runWithLocHelper :: PPInfo -> Some SomeTypedCFG -> [LogEntry] + runWithLocHelper ppi' sstcfg = case sstcfg of + Some (SomeTypedCFG _ _ tcfg) -> do + let env = (ppi', getFirstProgramLoc tcfg, getFunctionName tcfg) + execWriter (runReaderT (extractLogEntries tcfg) env) + +getFunctionName :: TypedCFG ext blocks ghosts inits gouts ret -> String +getFunctionName tcfg = case tpcfgHandle tcfg of + TypedFnHandle _ _ handle -> show $ handleName handle + +getFirstProgramLoc + :: PermCheckExtC ext extExpr + => TypedCFG ext blocks ghosts inits gouts ret -> ProgramLoc +getFirstProgramLoc tcfg = + case listToMaybe $ catMaybes $ + RL.mapToList getFirstProgramLocBM $ tpcfgBlockMap tcfg of + Just pl -> pl + _ -> error "Unable to get initial program location" + +getFirstProgramLocBM + :: PermCheckExtC ext extExpr + => TypedBlock TransPhase ext blocks tops ret ctx + -> Maybe ProgramLoc +getFirstProgramLocBM block = + listToMaybe $ mapMaybe helper (_typedBlockEntries block) + where + helper + :: PermCheckExtC ext extExpr + => Some (TypedEntry TransPhase ext blocks tops ret ctx) + -> Maybe ProgramLoc + helper ste = case ste of + Some TypedEntry { typedEntryBody = stmts } -> + Just $ mbLiftNamed $ fmap getFirstProgramLocTS stmts + +-- | From the sequence, get the first program location we encounter, which +-- should correspond to the permissions for the entry point we want to log +getFirstProgramLocTS :: PermCheckExtC ext extExpr + => TypedStmtSeq ext blocks tops ret ctx + -> ProgramLoc +getFirstProgramLocTS (TypedImplStmt (AnnotPermImpl _ pis)) = + getFirstProgramLocPI pis +getFirstProgramLocTS (TypedConsStmt loc _ _ _) = loc +getFirstProgramLocTS (TypedTermStmt loc _) = loc + +getFirstProgramLocPI + :: PermCheckExtC ext extExpr + => PermImpl (TypedStmtSeq ext blocks tops ret) ctx + -> ProgramLoc +getFirstProgramLocPI (PermImpl_Done stmts) = getFirstProgramLocTS stmts +getFirstProgramLocPI (PermImpl_Step _ mbps) = getFirstProgramLocMBPI mbps + +getFirstProgramLocMBPI + :: PermCheckExtC ext extExpr + => MbPermImpls (TypedStmtSeq ext blocks tops ret) ctx + -> ProgramLoc +getFirstProgramLocMBPI MbPermImpls_Nil = + error "Error finding program location for IDE log" +getFirstProgramLocMBPI (MbPermImpls_Cons _ _ pis) = + mbLift $ fmap getFirstProgramLocPI pis + +-- | Print a `ProgramLoc` in a way that is useful for an IDE, i.e., machine +-- readable +ppLoc :: ProgramLoc -> (String, String) +ppLoc pl = + let fnName = T.unpack $ functionName $ plFunction pl + locStr = ppPos $ plSourceLoc pl + + ppPos (SourcePos file line column) = + T.unpack file <> ":" <> show line <> ":" <> show column + ppPos (BinaryPos _ _) = "" + ppPos (OtherPos _) = "" + ppPos InternalPos = "" + in (fnName, locStr) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs b/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs index 889a234fc0..392120d423 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs @@ -68,6 +68,8 @@ import Verifier.SAW.Heapster.GenMonad import GHC.Stack import Unsafe.Coerce import Data.Functor.Constant (Constant(..)) +import Data.Functor.Product (Product(..)) + ---------------------------------------------------------------------- @@ -353,6 +355,81 @@ unSomeEqProof (SomeEqProofCons some_eqp eq_step) UnSomeEqProof $ EqProofCons eqp eq_step +---------------------------------------------------------------------- +-- * Implication Errors +---------------------------------------------------------------------- + +data ImplError where + GeneralError :: Doc ann -> ImplError + NoFrameInScopeError :: ImplError + ArrayStepError :: ImplError + MuUnfoldError :: ImplError + FunctionPermissionError :: ImplError + PartialSubstitutionError :: String -> Doc ann -> ImplError + LifetimeError :: LifetimeErrorType -> ImplError + MemBlockError :: Doc ann -> ImplError + EqualityProofError :: Doc ann -> Doc ann -> ImplError + InsufficientVariablesError :: Doc ann -> ImplError + ExistentialError :: Doc ann -> Doc ann -> ImplError + ImplVariableError + :: Doc ann -> String + -> (Doc ann, ExprVar tp) -> (Doc ann, ValuePerm tp) -> CruCtx vars + -> DistPerms ps + -> ImplError + +data LifetimeErrorType where + EndLifetimeError :: LifetimeErrorType + ImplicationLifetimeError :: LifetimeErrorType + LifetimeCurrentError :: PP.Doc ann -> LifetimeErrorType + +$(concatMapM mkNuMatching + [ [t| ImplError |] + , [t| LifetimeErrorType |] + ]) + +instance Liftable LifetimeErrorType where + mbLift e = case mbMatch e of + [nuMP| EndLifetimeError |] -> EndLifetimeError + [nuMP| ImplicationLifetimeError |] -> ImplicationLifetimeError + [nuMP| LifetimeCurrentError doc |] -> LifetimeCurrentError $ mbLift doc + +instance SubstVar PermVarSubst m => + Substable PermVarSubst ImplError m where + genSubst s mb_impl = case mbMatch mb_impl of + [nuMP| GeneralError doc |] -> + return $ GeneralError $ mbLift doc + [nuMP| NoFrameInScopeError |] -> + return NoFrameInScopeError + [nuMP| ArrayStepError |] -> + return ArrayStepError + [nuMP| MuUnfoldError |] -> + return MuUnfoldError + [nuMP| FunctionPermissionError |] -> + return FunctionPermissionError + [nuMP| PartialSubstitutionError str doc |] -> + return $ PartialSubstitutionError (mbLift str) (mbLift doc) + [nuMP| LifetimeError le |] -> + return $ LifetimeError $ mbLift le + [nuMP| MemBlockError doc |] -> + return $ MemBlockError (mbLift doc) + [nuMP| EqualityProofError docl docr |] -> + return $ EqualityProofError (mbLift docl) (mbLift docr) + [nuMP| InsufficientVariablesError doc |] -> + return $ InsufficientVariablesError $ mbLift doc + [nuMP| ExistentialError doc1 doc2 |] -> + return $ ExistentialError (mbLift doc1) (mbLift doc2) + [nuMP| ImplVariableError doc f (xdoc, x) (pdoc, p) ctx mb_dp |] -> do + x' <- genSubst s x + p' <- genSubst s p + dp <- genSubst s mb_dp + return $ ImplVariableError (mbLift doc) (mbLift f) (mbLift xdoc, x') (mbLift pdoc, p') (mbLift ctx) dp + +-- The reason this isn't just Show is to sort of future-proof things. For +-- instance, we may want to dump a limited amount of information to stdout, but +-- something more comprehensive to a log for an IDE. +class ErrorPretty a where + ppError :: a -> String + ---------------------------------------------------------------------- -- * Permission Implications ---------------------------------------------------------------------- @@ -1380,7 +1457,7 @@ data PermImpl1 ps_in ps_outs where -- the failure, which is a proof of 0 disjuncts: -- -- > ps -o . - Impl1_Fail :: String -> PermImpl1 ps RNil + Impl1_Fail :: ImplError -> PermImpl1 ps RNil -- | Catch any failure in the first branch by calling the second, passing the -- same input permissions to both branches: @@ -1677,12 +1754,12 @@ permImplStep impl1@(Impl1_TryProveBVProp _ _ _) mb_impls = permImplStepUnary impl1 mb_impls -- An or elimination fails if both branches fail -permImplStep (Impl1_ElimOrs _ _ _) (MbPermImpls_Cons _ - (MbPermImpls_Cons _ MbPermImpls_Nil - (matchMbImplFail -> Just msg1)) - (matchMbImplFail -> Just msg2)) = - PermImpl_Step (Impl1_Fail - (msg1 ++ "\n\n--------------------\n\n" ++ msg2)) +permImplStep (Impl1_ElimOr _ _ _) (MbPermImpls_Cons _ + (MbPermImpls_Cons _ MbPermImpls_Nil + (matchMbImplFail -> Just msg1)) + (matchMbImplFail -> Just msg2)) = + PermImpl_Step (Impl1_Fail $ GeneralError $ pretty + (msg1 ++ "\n\n--------------------\n\n" ++ msg2)) MbPermImpls_Nil -- Default case: just apply PermImpl_Step @@ -1698,7 +1775,7 @@ permImplStepUnary :: NuMatchingAny1 r => -- If the continuation implication is a failure, percolate it up permImplStepUnary _ (MbPermImpls_Cons _ _ (matchMbImplFail -> Just msg)) = - PermImpl_Step (Impl1_Fail msg) MbPermImpls_Nil + PermImpl_Step (Impl1_Fail $ GeneralError $ pretty msg) MbPermImpls_Nil -- If the continuation implication is a catch with a failure on the right-hand -- side, percolate up the catch @@ -1721,7 +1798,7 @@ permImplStepUnary impl1 mb_impls = PermImpl_Step impl1 mb_impls -- 'NuMatchingAny1' constraint on the @r@ variable matchMbImplFail :: NuMatchingAny1 r => Mb ctx (PermImpl r ps) -> Maybe String matchMbImplFail mb_impl = case mbMatch mb_impl of - [nuMP| PermImpl_Step (Impl1_Fail msg) _ |] -> Just $ mbLift msg + [nuMP| PermImpl_Step (Impl1_Fail err) _ |] -> Just $ mbLift $ fmap ppError err _ -> Nothing -- | Pattern-matchin an implication inside a binding to see if it is a catch @@ -1749,7 +1826,9 @@ permImplCatch pimpl (PermImpl_Step (Impl1_Fail _) _) | pruneFailingBranches = pimpl permImplCatch (PermImpl_Step (Impl1_Fail str1) _) (PermImpl_Step (Impl1_Fail str2) mb_impls) = - PermImpl_Step (Impl1_Fail (str1 ++ "\n\n--------------------\n\n" ++ str2)) mb_impls + PermImpl_Step (Impl1_Fail $ GeneralError $ + pretty (ppError str1 ++ "\n\n--------------------\n\n" ++ ppError str2)) + mb_impls permImplCatch pimpl1@(PermImpl_Step (Impl1_Fail _) _) pimpl2 = permImplCatch pimpl2 pimpl1 permImplCatch (PermImpl_Step Impl1_Catch @@ -3174,7 +3253,7 @@ instance SubstVar PermVarSubst m => instance SubstVar PermVarSubst m => Substable PermVarSubst (PermImpl1 ps_in ps_out) m where genSubst s mb_impl = case mbMatch mb_impl of - [nuMP| Impl1_Fail str |] -> return (Impl1_Fail $ mbLift str) + [nuMP| Impl1_Fail err |] -> Impl1_Fail <$> genSubst s err [nuMP| Impl1_Catch |] -> return Impl1_Catch [nuMP| Impl1_Push x p |] -> Impl1_Push <$> genSubst s x <*> genSubst s p @@ -3465,12 +3544,11 @@ partialSubstForceM :: (NuMatchingAny1 r, PermPretty a, Mb vars a -> String -> ImplM vars s r ps ps a partialSubstForceM mb_e caller = do psubst <- getPSubst - case partialSubst psubst mb_e of - Just e -> pure e - Nothing -> - implTraceM (\i -> sep [pretty ("Incomplete substitution in " ++ caller - ++ " for:"), - permPretty i mb_e]) >>= implFailM + use implStatePPInfo >>>= \ppinfo -> + case partialSubst psubst mb_e of + Just e -> pure e + Nothing -> + implFailM $ PartialSubstitutionError caller (permPretty ppinfo mb_e) -- | Modify the current partial substitution modifyPSubst :: (PartialSubst vars -> PartialSubst vars) -> @@ -3573,7 +3651,7 @@ implRecFlagCaseM f p m1 m2 = implSetRecRecurseRightM :: NuMatchingAny1 r => ImplM vars s r ps ps () implSetRecRecurseRightM = use implStateRecRecurseFlag >>= \case - RecLeft -> implFailMsgM "Tried to unfold a mu on the right after unfolding on the left" + RecLeft -> implFailM MuUnfoldError _ -> implStateRecRecurseFlag .= RecRight -- | Set the recursive recursion flag to indicate recursion on the left, or fail @@ -3582,7 +3660,7 @@ implSetRecRecurseLeftM :: NuMatchingAny1 r => ImplM vars s r ps ps () implSetRecRecurseLeftM = use implStateRecRecurseFlag >>= \case RecRight -> - implFailMsgM "Tried to unfold a mu on the left after unfolding on the right" + implFailM MuUnfoldError _ -> implStateRecRecurseFlag .= RecLeft -- | Look up the 'NamedPerm' structure for a named permssion @@ -3715,6 +3793,34 @@ implSetNameTypes (ns :>: n) (CruCtxCons tps tp) = handleUnitVar tp n implSetNameTypes ns tps +-- | TODO: Move this in to Hobbits +nameMapFind + :: (forall tp. f tp -> Bool) + -> NameMap f + -> Maybe (Some (Product Name f)) +nameMapFind predicate nm = + case find (\(NameAndElem _ f) -> predicate f) $ NameMap.assocs nm of + Just (NameAndElem name f) -> Just $ Some $ Pair name f + Nothing -> Nothing + +-- | Traverse a permissions to determine whether it refers to a particular variable. +permContainsVar :: ExprVar a -> ValuePerm b -> Bool +permContainsVar x p = NameSet.member x (freeVars p) + +-- | Build a 'DistPerms' sequence of a permission @y1:p1@ we currently hold such +-- that @p1@ contains @x@, a permission @y2:p2@ we currently hold such that @p2@ +-- contains @p1@, etc. +-- +-- FIXME: what is the purpose of this? Don't we want all permissions recursively +-- containing @x@? +findPermsContainingVar :: ExprVar tp -> ImplM vars s r ps ps (Some DistPerms) +findPermsContainingVar x = + getPerms >>>= \perms -> + case nameMapFind (permContainsVar x) (view varPermMap perms) of + Just (Some (Pair y p)) -> findPermsContainingVar y >>>= \(Some dps) -> + return $ Some $ DistPermsCons dps y p + Nothing -> return $ Some DistPermsNil + -- | When adding a new existential unit-typed variable, instantiate it with the -- underlying global unit if available; if not, update the global unit variable -- with a fresh variable @@ -3754,7 +3860,6 @@ handleUnitEVars = ImplM vars s r ps ps () handleUnitEVarM mem m = handleUnitEVar mem >>> m - -- | When adding a new universal unit-typed variable, unify with the underlying -- global unit if available, and if not, update the global unit variable with -- the variable provided @@ -3869,18 +3974,6 @@ implWithoutTracingM m = (implStateDebugLevel .= saved) >> pure a --- | Terminate the current proof branch with a failure -implFailM :: NuMatchingAny1 r => String -> ImplM vars s r ps_any ps a -implFailM str = - use implStateFailPrefix >>>= \prefix -> - implTraceM (const $ pretty (prefix ++ "Implication failed")) >>> - implApplyImpl1 (Impl1_Fail (prefix ++ str)) MNil - --- | Call 'implFailM' and also output a debugging message -implFailMsgM :: NuMatchingAny1 r => String -> ImplM vars s r ps_any ps a -implFailMsgM msg = - implTraceM (const $ pretty msg) >>>= implFailM - -- | Pretty print an implication @x:p -o (vars).p'@ ppImpl :: PPInfo -> ExprVar tp -> ValuePerm tp -> Mb (vars :: RList CrucibleType) (ValuePerm tp) -> PP.Doc ann @@ -3889,15 +3982,6 @@ ppImpl i x p mb_p = PP.pretty "-o", PP.group (PP.align (permPretty i mb_p))] --- | Terminate the current proof branch with a failure proving @x:p -o mb_p@ -implFailVarM :: NuMatchingAny1 r => String -> ExprVar tp -> ValuePerm tp -> - Mb vars (ValuePerm tp) -> ImplM vars s r ps_any ps a -implFailVarM f x p mb_p = - implTraceM (\i -> - sep [pretty f <> colon <+> pretty "Could not prove", - ppImpl i x p mb_p]) >>>= - implFailM - -- | Produce a branching proof tree that performs the first implication and, if -- that one fails, falls back on the second. The supplied 'String' says what -- proof-search function is performing the catch, while the @p@ argument says @@ -4197,7 +4281,7 @@ implElimLLVMBlockToEq x bp = pure y -- | Try to prove a proposition about bitvectors dynamically, failing as in --- 'implFailM' if the proposition does not hold +-- 'implFailM if the proposition does not hold implTryProveBVProp :: (1 <= w, KnownNat w, NuMatchingAny1 r) => ExprVar (LLVMPointerType w) -> BVProp w -> ImplM vars s r (ps :> LLVMPointerType w) ps () @@ -4760,8 +4844,7 @@ implEndLifetimeM ps l tps_in tps_out ps_in ps_out implTraceM (\i -> pretty "Ending lifetime:" <+> permPretty i l) >>> implDropLifetimePermsM l >>> recombinePermsPartial ps (DistPermsCons dps_out l ValPerm_LFinished) -implEndLifetimeM _ _ _ _ _ _ = - implFailM "implEndLifetimeM: exprPermsToDistPerms" +implEndLifetimeM _ _ _ _ _ _ = implFailM (LifetimeError EndLifetimeError) -- | Drop any permissions of the form @x:[l]p@ in the primary permissions for -- @x@, which are supplied as an argument @@ -5448,9 +5531,8 @@ implElimLLVMBlock x bp@(LLVMBlockPerm { llvmBlockShape = -- If none of the above cases matched, we cannot eliminate, so fail implElimLLVMBlock _ bp = - implTraceM (\i -> pretty "Could not eliminate permission" <+> - permPretty i (Perm_LLVMBlock bp)) >>>= - implFailM + use implStatePPInfo >>>= \ppinfo -> + implFailM $ MemBlockError $ permPretty ppinfo (Perm_LLVMBlock bp) -- | Destruct a shape @sh1 orsh (sh2 orsh (... orsh shn))@ that is a -- right-nested disjunctive shape into the list @[sh1,...,shn]@ of disjuncts @@ -5658,9 +5740,8 @@ getLifetimeCurrentPerms (PExpr_Var l) = case some_cur_perms of Some cur_perms -> pure $ Some $ CurrentTransPerms cur_perms l _ -> - implTraceM (\i -> pretty "Could not prove lifetime is current:" <+> - permPretty i l) >>= - implFailM + use implStatePPInfo >>>= \ppinfo -> + implFailM $ LifetimeError (LifetimeCurrentError $ permPretty ppinfo l) -- | Prove the permissions represented by a 'LifetimeCurrentPerms' proveLifetimeCurrent :: NuMatchingAny1 r => LifetimeCurrentPerms ps_l -> @@ -5951,16 +6032,6 @@ recombineLifetimeCurrentPerms (CurrentTransPerms cur_perms l) = -- * Proving Equalities ---------------------------------------------------------------------- --- | Fail when trying to prove an equality -proveEqFail :: (NuMatchingAny1 r, PermPretty (f a)) => f a -> Mb vars (f a) -> - ImplM vars s r ps ps any -proveEqFail e mb_e = - implTraceM (\i -> - sep [pretty "proveEq" <> colon <+> pretty "Could not prove", - sep [permPretty i e <+> - pretty "=" <+> permPretty i mb_e]]) >>>= - implFailM - -- | Typeclass for the generic function that tries to extend the current partial -- substitution to unify an expression with an expression pattern and returns a -- proof of the equality on success @@ -5999,7 +6070,11 @@ instance ProveEq (LLVMFramePerm w) where do eqp1 <- proveEq e mb_e eqp2 <- proveEq fperms mb_fperms pure (liftA2 (\x y -> (x,i):y) eqp1 eqp2) - proveEq perms mb = proveEqFail perms mb + proveEq perms mb = + use implStatePPInfo >>>= \ppinfo -> + implFailM $ EqualityProofError + (permPretty ppinfo perms) + (permPretty ppinfo mb) instance ProveEq (LLVMBlockPerm w) where proveEq bp mb_bp = @@ -6086,7 +6161,11 @@ proveEqH psubst e mb_e = case (e, mbMatch mb_e) of Just _ -> proveEqH psubst e mb_e Nothing -> getVarEqPerm y >>= \case Just _ -> proveEqH psubst e mb_e - Nothing -> proveEqFail e mb_e + Nothing -> + use implStatePPInfo >>>= \ppinfo -> + implFailM $ EqualityProofError + (permPretty ppinfo e) + (permPretty ppinfo mb_e) -- To prove @x &+ o = e@, we subtract @o@ from the RHS and recurse (PExpr_LLVMOffset x off, _) -> @@ -6112,7 +6191,11 @@ proveEqH psubst e mb_e = case (e, mbMatch mb_e) of Just e' -> proveEq e' mb_e >>= \eqp2 -> pure (someEqProofTrans (someEqProof1 x e' True) eqp2) - Nothing -> proveEqFail e mb_e + Nothing -> + use implStatePPInfo >>>= \ppinfo -> + implFailM $ EqualityProofError + (permPretty ppinfo e) + (permPretty ppinfo mb_e) -- To prove e=x, try to see if x:eq(e') and proceed by transitivity (_, [nuMP| PExpr_Var z |]) @@ -6123,7 +6206,11 @@ proveEqH psubst e mb_e = case (e, mbMatch mb_e) of Just e' -> proveEq e (mbConst e' mb_e) >>= \eqp -> pure (someEqProofTrans eqp (someEqProof1 x e' False)) - Nothing -> proveEqFail e mb_e + Nothing -> + use implStatePPInfo >>>= \ppinfo -> + implFailM $ EqualityProofError + (permPretty ppinfo e) + (permPretty ppinfo mb_e) -- FIXME: if proving word(e1)=word(e2) for ground e2, we could add an assertion -- that e1=e2 using a BVProp_Eq @@ -6147,7 +6234,10 @@ proveEqH psubst e mb_e = case (e, mbMatch mb_e) of -- FIXME: add cases to prove struct(es1)=struct(es2) -- Otherwise give up! - _ -> proveEqFail e mb_e + _ -> use implStatePPInfo >>>= \ppinfo -> + implFailM $ EqualityProofError + (permPretty ppinfo e) + (permPretty ppinfo mb_e) -- | Build a proof on the top of the stack that @x:eq(e)@ @@ -7158,11 +7248,9 @@ proveVarLLVMArray_FromArrayH x ap_lhs _ bs mb_ap = localMbProveVars dps_in dps_out >>>= \mb_impl -> implSimplM Proxy (SImpl_LLVMArrayContents x ap_lhs'' sh mb_impl) >>> return (ap_lhs'' { llvmArrayCellShape = sh })) >>>= \ap_lhs''' -> - -- Finally, rearrange the borrows of ap_lhs to match bs implLLVMArrayRearrange x ap_lhs''' bs - ---------------------------------------------------------------------- -- * Proving Named Permission Arguments ---------------------------------------------------------------------- @@ -8444,7 +8532,7 @@ proveVarAtomicImpl x ps mb_p = case mbMatch mb_p of exprPermsToDistPerms ps_inR, exprPermsToDistPerms ps_outR) of (Just dps_inL, Just dps_outL, Just dps_inR, Just dps_outR) -> pure (dps_inL, dps_outL, dps_inR, dps_outR) - _ -> implFailMsgM "proveVarAtomicImpl: exprPermsToDistPerms") + _ -> implFailM (LifetimeError ImplicationLifetimeError)) >>>= \(dps_inL, dps_outL, dps_inR, dps_outR) -> localProveVars (RL.append ps1 dps_inR) dps_inL >>>= \impl_in -> localProveVars (RL.append ps2 dps_outL) dps_outR >>>= \impl_out -> @@ -8635,12 +8723,10 @@ proveVarConjImpl x ps_lhs mb_ps = partialSubstForceM mb_p "proveVarConjImpl" >>>= \p -> implInsertConjM x p ps' i [nuMP| Nothing |] -> - implTraceM - (\i -> - sep [PP.fillSep [PP.pretty - "Could not determine enough variables to prove permissions:", - permPretty i (mbValPerm_Conj mb_ps)]]) >>>= - implFailM + use implStatePPInfo >>>= \ppinfo -> + implFailM $ InsufficientVariablesError $ + permPretty ppinfo (fmap ValPerm_Conj mb_ps) + ---------------------------------------------------------------------- @@ -8962,15 +9048,14 @@ proveExVarImpl _ mb_x mb_p@(mbMatch -> [nuMP| ValPerm_Conj [Perm_LLVMFrame _] |] getVarVarM memb >>>= \n' -> proveVarImplInt n' mb_p >>> pure n' Nothing -> - implFailMsgM "proveExVarImpl: No LLVM frame pointer in scope" + implFailM NoFrameInScopeError -- Otherwise we fail proveExVarImpl _ mb_x mb_p = - implTraceM (\i -> pretty "proveExVarImpl: existential variable" <+> - permPretty i mb_x <+> - pretty "not resolved when trying to prove:" <> softline <> - permPretty i mb_p) >>>= - implFailM + use implStatePPInfo >>>= \ppinfo -> + implFailM $ ExistentialError + (permPretty ppinfo mb_x) + (permPretty ppinfo mb_p) ---------------------------------------------------------------------- @@ -9115,14 +9200,10 @@ proveVarsImplAppendInt mb_ps = proveVarsImplAppendInt ps12 >>> implMoveUpM cur_perms (mbLift prxs1) x (mbLift prxs2) else - implTraceM - (\i -> - sep [PP.fillSep - [PP.pretty - "Could not determine enough variables to prove permissions:", - permPretty i mb_ps]]) >>>= - implFailM - + use implStatePPInfo >>>= \ppinfo -> + implFailM $ InsufficientVariablesError $ + permPretty ppinfo mb_ps + -- | Like 'proveVarsImplAppendInt' but re-associate the appends proveVarsImplAppendIntAssoc :: NuMatchingAny1 r => prx ps_in -> prx1 ps1 -> ExDistPerms vars ps -> @@ -9224,7 +9305,8 @@ implEndLifetimeRecM l = _ -> implTraceM (\i -> pretty "implEndLifetimeRecM: could not end lifetime: " <> - permPretty i l) >>>= implFailM + permPretty i l) >>> + implFailM (LifetimeError EndLifetimeError) -- | Prove a list of existentially-quantified distinguished permissions, adding -- those proofs to the top of the stack. In the case that a the variable itself @@ -9307,6 +9389,67 @@ proveVarImpl :: NuMatchingAny1 r => ExprVar a -> Mb vars (ValuePerm a) -> ImplM vars s r (ps :> a) ps () proveVarImpl x mb_p = proveVarsImplAppend $ fmap (distPerms1 x) mb_p +-- | Terminate the current proof branch with a failure +implFailM :: NuMatchingAny1 r => ImplError -> ImplM vars s r ps_any ps a +implFailM err = + use implStateFailPrefix >>>= \prefix -> + implTraceM (const $ pretty $ prefix <> ppError err) >>> + implApplyImpl1 (Impl1_Fail err) MNil + +-- | Terminate the current proof branch with a failure proving @x:p -o mb_p@ +implFailVarM :: NuMatchingAny1 r => String -> ExprVar tp -> ValuePerm tp -> + Mb vars (ValuePerm tp) -> ImplM vars s r ps_any ps a +implFailVarM f x p mb_p = + use implStatePPInfo >>>= \ppinfo -> + use implStateVars >>>= \ctx -> + findPermsContainingVar x >>>= \case + (Some distperms) -> + implFailM $ ImplVariableError + (ppImpl ppinfo x p mb_p) + f + (permPretty ppinfo x, x) + (permPretty ppinfo p, p) + ctx + distperms + +instance ErrorPretty ImplError where + ppError (GeneralError doc) = renderDoc doc + ppError NoFrameInScopeError = + "No LLVM frame in scope" + ppError ArrayStepError = + "Error proving array permissions" + ppError MuUnfoldError = + "Tried to unfold a mu on the left after unfolding on the right" + ppError FunctionPermissionError = + "Could not find function permission" + ppError (PartialSubstitutionError caller doc) = renderDoc $ + sep [ pretty ("Incomplete susbtitution in " ++ caller ++ " for: ") + , doc ] + ppError (LifetimeError EndLifetimeError) = + "implEndLifetimeM: lownedPermsToDistPerms" + ppError (LifetimeError ImplicationLifetimeError) = + "proveVarAtomicImpl: lownedPermsToDistPerms" + ppError (LifetimeError (LifetimeCurrentError doc)) = renderDoc $ + pretty "Could not prove lifetime is current:" <+> doc + ppError (MemBlockError doc) = renderDoc $ + pretty "Could not eliminate permission" <+> doc + -- permPretty pp (Perm_LLVMBlock bp) + ppError (EqualityProofError edoc mbedoc) = renderDoc $ + sep [ pretty "proveEq" <> colon <+> pretty "Could not prove" + , edoc <+> pretty "=" <+> mbedoc] + ppError (InsufficientVariablesError doc) = renderDoc $ + sep [PP.fillSep [PP.pretty + "Could not determine enough variables to prove permissions:", + doc]] + ppError (ExistentialError docx docp ) = renderDoc $ + pretty "proveExVarImpl: existential variable" <+> + docx <+> + pretty "not resolved when trying to prove:" <> softline <> + docp + ppError (ImplVariableError doc f _ev _vp _ctx _dp) = renderDoc $ + sep [ pretty f <> colon <+> pretty "Could not prove" + , doc ] + -- | Try to prove @x:p@, returning whether or not this was successful checkVarImpl :: PermSet ps_in -> diff --git a/heapster-saw/src/Verifier/SAW/Heapster/ImplicationError.hs b/heapster-saw/src/Verifier/SAW/Heapster/ImplicationError.hs new file mode 100644 index 0000000000..e69de29bb2 diff --git a/heapster-saw/src/Verifier/SAW/Heapster/JSONExport.hs b/heapster-saw/src/Verifier/SAW/Heapster/JSONExport.hs new file mode 100644 index 0000000000..b8a8e05ada --- /dev/null +++ b/heapster-saw/src/Verifier/SAW/Heapster/JSONExport.hs @@ -0,0 +1,211 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE OverloadedLists, OverloadedStrings #-} +{-# LANGUAGE ParallelListComp #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-orphans #-} -- hobbits instances for Value +module Verifier.SAW.Heapster.JSONExport + (JsonExport, JsonExport1, ppToJson) + where + +import Data.Aeson ( ToJSON(toJSON), Value(..), object ) +import Data.Binding.Hobbits +import Data.BitVector.Sized ( BV, asUnsigned ) +import Data.Kind (Type) +import Data.Parameterized.BoolRepr ( BoolRepr ) +import Data.Parameterized.Context ( Assignment ) +import Data.Parameterized.Nonce (Nonce, indexValue) +import Data.Parameterized.TraversableFC ( FoldableFC(toListFC) ) +import Data.Text (Text) +import Data.Traversable (for) +import Data.Type.RList ( mapToList ) +import GHC.Natural (Natural) +import Lang.Crucible.FunctionHandle ( FnHandle ) +import Lang.Crucible.LLVM.Bytes ( Bytes ) +import Lang.Crucible.LLVM.DataLayout (EndianForm) +import Lang.Crucible.Types +import qualified Language.Haskell.TH as TH +import qualified Language.Haskell.TH.Datatype as TH +import Verifier.SAW.Heapster.CruUtil ( CruCtx ) +import Verifier.SAW.Heapster.Implication +import Verifier.SAW.Heapster.Permissions +import Verifier.SAW.Name ( Ident ) +import What4.FunctionName ( FunctionName ) + +instance NuMatching Value where + nuMatchingProof = unsafeMbTypeRepr + +instance Liftable Value where + mbLift = unClosed . mbLift . fmap unsafeClose + +-- | Uniformly export the algebraic datatype structure +-- Heapster permissions. +ppToJson :: JsonExport a => PPInfo -> a -> Value +ppToJson ppi = let ?ppi = ppi in jsonExport + +-- | Class of types that can be uniformly exported as JSON +-- using the Heapster pretty-printing information for names +class JsonExport a where + jsonExport :: (?ppi::PPInfo) => a -> Value + default jsonExport :: ToJSON a => (?ppi::PPInfo) => a -> Value + jsonExport = toJSON + + +-- This code generates generic JSON generation instances for +-- algebraic data types. +-- +-- - All instances will generate an object. +-- - The object will have a @tag@ field containing the name +-- of the constructor used. +-- - Record constructors will add each record field to the +-- object using the field name +-- - Normal constructors with fields will have a field called +-- @contents@. If this constructor has more than one parameter +-- the @contents@ field will have a list. Otherwise it will +-- have a single element. +let fields :: String -> TH.ConstructorVariant -> [TH.ExpQ] -> TH.ExpQ + + -- Record constructor, use record field names as JSON field names + fields tag (TH.RecordConstructor fieldNames) xs = + TH.listE + $ [| ("tag", tag) |] + : [ [| (n, $x) |] | n <- TH.nameBase <$> fieldNames | x <- xs] + + -- No fields, so just report the constructor tag + fields tag _ [] = [| [("tag", tag)] |] + + -- One field, just report that field as @contents@ + fields tag _ [x] = [| [("tag", tag), ("contents", $x)] |] + + -- Multiple fields, report them as a list as @contents@ + fields tag _ xs = [| [("tag", tag), ("contents", Array $(TH.listE xs))] |] + + clauses :: TH.DatatypeInfo -> [TH.ClauseQ] + clauses info = + [do fieldVars <- for [0..length (TH.constructorFields con)-1] $ \i -> + TH.newName ("x" ++ show i) + TH.clause + [TH.conP (TH.constructorName con) (TH.varP <$> fieldVars)] + (TH.normalB [| + object + $(fields + (TH.nameBase (TH.constructorName con)) + (TH.constructorVariant con) + [ [| jsonExport $(TH.varE v) |] | v <- fieldVars ]) |]) + [] + | con <- TH.datatypeCons info ] + + generateJsonExport :: TH.Name -> TH.DecQ + generateJsonExport n = + do info <- TH.reifyDatatype n + let t = foldl TH.appT (TH.conT n) + $ zipWith (\c _ -> TH.varT (TH.mkName [c])) ['a'..] + $ TH.datatypeInstTypes info + TH.instanceD (TH.cxt []) [t|JsonExport $t|] + [TH.funD 'jsonExport (clauses info)] + + typesNeeded :: [TH.Name] + typesNeeded = + [''AtomicPerm, ''BaseTypeRepr, ''BoolRepr, ''BVFactor, ''BVProp, + ''BVRange, ''CruCtx, ''FloatInfoRepr, ''FloatPrecisionRepr, + ''FnHandle, ''FunPerm, ''LLVMArrayBorrow, + ''LLVMArrayIndex, ''LLVMArrayPerm, ''LLVMBlockPerm, ''LLVMFieldPerm, + ''LLVMFieldShape, ''NamedPermName, ''NamedShape, + ''NamedShapeBody, ''NameReachConstr, ''NameSortRepr, ''NatRepr, + ''PermExpr, ''PermOffset, ''StringInfoRepr, ''SymbolRepr, ''TypeRepr, + ''ValuePerm, ''RWModality, ''PermImpl1, ''Member, ''SimplImpl, + ''VarAndPerm, ''LocalPermImpl, ''LifetimeFunctor, ''NamedPerm, + ''RecPerm, ''OpaquePerm, ''DefinedPerm, ''ReachMethods, ''MbPermImpls, + ''ExprAndPerm, ''OrListDisj, ''EndianForm + ] + + in traverse generateJsonExport typesNeeded + +instance JsonExport (Name (t :: CrucibleType)) where + jsonExport = toJSON . permPrettyString ?ppi + +instance JsonExport1 f => JsonExport (Assignment f x) where + jsonExport = toJSON . toListFC jsonExport1 + +instance JsonExport1 f => JsonExport (RAssign f x) where + jsonExport = toJSON . mapToList jsonExport1 + + +instance JsonExport b => JsonExport (Mb (a :: RList CrucibleType) b) where + jsonExport mb = mbLift $ flip nuMultiWithElim1 mb $ \names body -> + let ?ppi = ppInfoAddExprNames "x" names ?ppi in + object [ + ("args", jsonExport names), + ("body", jsonExport body) + ] + +instance JsonExport (Nonce a b) where + jsonExport = toJSON . indexValue + +instance JsonExport Bytes where + jsonExport = toJSON . show -- Show instance is pretty + +instance JsonExport Ident where + jsonExport = toJSON . show -- Show instance is pretty + +instance JsonExport FunctionName where + jsonExport = toJSON . show -- Show instance is pretty + +instance JsonExport (EqProof a b) where + jsonExport _ = object [] + +instance JsonExport a => JsonExport (Maybe a) where + jsonExport = maybe Null jsonExport + +instance (JsonExport a, JsonExport b) => JsonExport (a,b) where + jsonExport (x,y) = toJSON (jsonExport x, jsonExport y) + +instance JsonExport a => JsonExport [a] where + jsonExport xs = toJSON (jsonExport <$> xs) + +instance JsonExport (BV n) where + jsonExport = toJSON . asUnsigned + +instance JsonExport (Proxy a) where + jsonExport _ = object [] + +instance JsonExport ImplError where + jsonExport = toJSON . ppError + +-- Custom instance avoids the polymorphic field on the Done case +instance JsonExport (PermImpl f ps) where + jsonExport (PermImpl_Done _eq) = + object [("tag", "PermImpl_Done")] + jsonExport (PermImpl_Step rs mb) = + object + [("tag", "PermImpl_Step"), + ("contents", Array + [jsonExport rs, + jsonExport mb])] + +instance JsonExport Natural +instance JsonExport Integer +instance JsonExport Int +instance JsonExport Bool +instance JsonExport Text +instance {-# OVERLAPPING #-} JsonExport String + +-- | 'JsonExport' lifted to work on types with higher kinds +class JsonExport1 f where + jsonExport1 :: (?ppi::PPInfo) => f a -> Value + default jsonExport1 :: JsonExport (f a) => (?ppi::PPInfo) => f a -> Value + jsonExport1 = jsonExport + +instance JsonExport1 BaseTypeRepr +instance JsonExport1 TypeRepr +instance JsonExport1 (Name :: CrucibleType -> Type) +instance JsonExport1 PermExpr +instance JsonExport1 ValuePerm +instance JsonExport1 VarAndPerm +instance JsonExport1 Proxy +instance JsonExport1 ExprAndPerm +instance JsonExport1 (OrListDisj ps a) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/NamedMb.hs b/heapster-saw/src/Verifier/SAW/Heapster/NamedMb.hs new file mode 100644 index 0000000000..27e1beecc7 --- /dev/null +++ b/heapster-saw/src/Verifier/SAW/Heapster/NamedMb.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeOperators #-} +module Verifier.SAW.Heapster.NamedMb where + +import Data.Binding.Hobbits +import Data.Binding.Hobbits.MonadBind +import Data.Type.RList +import Control.Lens + +-- | A constant type functor for 'String's +newtype StringF a = StringF { unStringF :: String } + +mkNuMatching [t| forall a. StringF a |] + +-- | An 'Mb' multi-binding where each bound 'Name' has an associated 'String' +-- for parsing and printing it +data NamedMb ctx a = NamedMb + { _mbNames :: RAssign StringF ctx + , _mbBinding :: Mb ctx a + } + deriving Functor + +-- | A 'Binding' of a single 'Name' with a 'String' +type NamedBinding c = NamedMb (RNil :> c) + +instance Liftable (StringF a) where + mbLift (mbMatch -> [nuMP| StringF x |]) = StringF (mbLift x) + +instance LiftableAny1 StringF where + mbLiftAny1 = mbLift + +mkNuMatching [t| forall ctx a. NuMatching a => NamedMb ctx a |] + +-- | Apply a binary function to the body of a 'NamedMb'; similar to 'mbMap2' +mbMap2Named :: (a -> b -> c) -> NamedMb ctx a -> NamedMb ctx b -> NamedMb ctx c +mbMap2Named f mb1 mb2 = + NamedMb (_mbNames mb1) (mbMap2 f (_mbBinding mb1) (_mbBinding mb2)) + +-- | A 'Lens' to get the binding ouf of a 'NamedMb' +mbBinding :: Lens (NamedMb ctx a) (NamedMb ctx b) (Mb ctx a) (Mb ctx b) +mbBinding f x = NamedMb (_mbNames x) <$> f (_mbBinding x) + +-- | Build a 'NamedMb' that binds multiple 'Name's with the given 'String's +nuMultiNamed :: RAssign StringF ctx -> (RAssign Name ctx -> b) -> NamedMb ctx b +nuMultiNamed tps f = NamedMb + { _mbNames = tps + , _mbBinding = nuMulti (mapRAssign (const Proxy) tps) f + } + +-- | A version of 'nuMultiWithElim1' for 'NamedMb' +nuMultiWithElim1Named :: (RAssign Name ctx -> arg -> b) -> + NamedMb ctx arg -> NamedMb ctx b +nuMultiWithElim1Named k = over mbBinding (nuMultiWithElim1 k) + +-- | Commute a 'NamedMb' inside a strong binding monad +strongMbMNamed :: MonadStrongBind m => NamedMb ctx (m a) -> m (NamedMb ctx a) +strongMbMNamed = traverseOf mbBinding strongMbM + +-- | Commute a 'NamedMb' inside a binding monad +mbMNamed :: (MonadBind m, NuMatching a) => NamedMb ctx (m a) -> m (NamedMb ctx a) +mbMNamed = traverseOf mbBinding mbM + +-- | Swap the order of two nested named bindings +mbSwapNamed :: RAssign Proxy ctx -> NamedMb ctx' (NamedMb ctx a) -> + NamedMb ctx (NamedMb ctx' a) +mbSwapNamed p (NamedMb names' body') = + NamedMb + { _mbNames = mbLift (_mbNames <$> body') + , _mbBinding = NamedMb names' <$> mbSwap p (_mbBinding <$> body') + } + +-- | Swap the order of a binding with 'String' names with one without +mbSink :: RAssign Proxy ctx -> Mb ctx' (NamedMb ctx a) -> NamedMb ctx (Mb ctx' a) +mbSink p m = + NamedMb + { _mbNames = mbLift (_mbNames <$> m) + , _mbBinding = mbSwap p (_mbBinding <$> m) + } + +-- | Lift a 'Liftable' value out of a 'NamedMb' +mbLiftNamed :: Liftable a => NamedMb ctx a -> a +mbLiftNamed = views mbBinding mbLift + +-- | Eliminate a 'NamedMb' that binds zero names +elimEmptyNamedMb :: NamedMb RNil a -> a +elimEmptyNamedMb = views mbBinding elimEmptyMb + +-- | Create a 'NamedMb' that binds zero names +emptyNamedMb :: a -> NamedMb RNil a +emptyNamedMb = NamedMb MNil . emptyMb diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs index c34ce7a47b..44926339bc 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs @@ -90,6 +90,7 @@ import Verifier.SAW.Term.Functor (ModuleName) import Verifier.SAW.Module import Verifier.SAW.SharedTerm hiding (Constant) import Verifier.SAW.OpenTerm +import Verifier.SAW.Heapster.NamedMb import Verifier.SAW.Heapster.CruUtil @@ -1145,9 +1146,6 @@ debugTraceTraceLvl = debugTrace traceDebugLevel debugTracePretty :: DebugLevel -> DebugLevel -> Doc ann -> a -> a debugTracePretty req dlevel d a = debugTrace req dlevel (renderDoc d) a --- | The constant string functor -newtype StringF a = StringF { unStringF :: String } - -- | Convert a type to a base name for printing variables of that type typeBaseName :: TypeRepr a -> String typeBaseName UnitRepr = "u" @@ -1184,16 +1182,24 @@ emptyPPInfo = PPInfo NameMap.empty Map.empty -- | Add an expression variable to a 'PPInfo' with the given base name ppInfoAddExprName :: String -> ExprVar a -> PPInfo -> PPInfo -ppInfoAddExprName base _ _ +ppInfoAddExprName base x ppi = + let (ppi', str) = ppInfoAllocateName base ppi in + ppInfoApplyName x str ppi' + +ppInfoApplyName :: Name (x :: CrucibleType) -> String -> PPInfo -> PPInfo +ppInfoApplyName x str ppi = + ppi { ppExprNames = NameMap.insert x (StringF str) (ppExprNames ppi) } + +ppInfoAllocateName :: String -> PPInfo -> (PPInfo, String) +ppInfoAllocateName base _ | length base == 0 || isDigit (last base) = error ("ppInfoAddExprName: invalid base name: " ++ base) -ppInfoAddExprName base x (PPInfo { .. }) = +ppInfoAllocateName base ppi = let (i',str) = - case Map.lookup base ppBaseNextInt of + case Map.lookup base (ppBaseNextInt ppi) of Just i -> (i+1, base ++ show i) Nothing -> (1, base) in - PPInfo { ppExprNames = NameMap.insert x (StringF str) ppExprNames, - ppBaseNextInt = Map.insert base i' ppBaseNextInt } + (ppi { ppBaseNextInt = Map.insert base i' (ppBaseNextInt ppi) }, str) -- | Add a sequence of variables to a 'PPInfo' with the given base name ppInfoAddExprNames :: String -> RAssign Name (tps :: RList CrucibleType) -> @@ -1202,12 +1208,33 @@ ppInfoAddExprNames _ MNil info = info ppInfoAddExprNames base (ns :>: n) info = ppInfoAddExprNames base ns $ ppInfoAddExprName base n info +-- | +ppInfoAllocateExprNames :: + String {- ^ base name -} -> + RAssign pxy (tps :: RList CrucibleType) -> + PPInfo -> + (PPInfo, RAssign StringF tps) +ppInfoAllocateExprNames _ MNil info = (info, MNil) +ppInfoAllocateExprNames base (ns :>: _) ppi = + case ppInfoAllocateName base ppi of + (ppi1, str) -> + case ppInfoAllocateExprNames base ns ppi1 of + (ppi2, ns') -> (ppi2, ns' :>: StringF str) + -- | Add a sequence of variables to a 'PPInfo' using their 'typeBaseName's ppInfoAddTypedExprNames :: CruCtx tps -> RAssign Name tps -> PPInfo -> PPInfo ppInfoAddTypedExprNames _ MNil info = info ppInfoAddTypedExprNames (CruCtxCons tps tp) (ns :>: n) info = ppInfoAddTypedExprNames tps ns $ ppInfoAddExprName (typeBaseName tp) n info +ppInfoApplyAllocation :: + RAssign Name (tps :: RList CrucibleType) -> + RAssign StringF tps -> + PPInfo -> + PPInfo +ppInfoApplyAllocation MNil MNil ppi = ppi +ppInfoApplyAllocation (ns :>: n) (ss :>: StringF s) ppi = + ppInfoApplyAllocation ns ss (ppInfoApplyName n s ppi) type PermPPM = Reader PPInfo @@ -1351,7 +1378,22 @@ permPrettyExprMb :: PermPretty a => Mb (ctx :: RList CrucibleType) a -> PermPPM (Doc ann) permPrettyExprMb f = permPrettyMb (\ns_pp a -> f ns_pp (permPrettyM a)) -instance PermPretty a => PermPretty (Mb (ctx :: RList CrucibleType) a) where + +-- | Pretty-print an expression-like construct in a name-binding using +-- a function that combines the pretty-printed names along with the +-- pretty-printed body of the name-binding, using the types of the +-- found names to generate their string names +permPrettyExprMbTyped :: PermPretty a => + CruCtx ctx -> + (RAssign (Constant (Doc ann)) ctx -> PermPPM (Doc ann) -> PermPPM (Doc ann)) -> + Mb (ctx :: RList CrucibleType) a -> PermPPM (Doc ann) +permPrettyExprMbTyped ctx f mb = + fmap mbLift $ strongMbM $ flip nuMultiWithElim1 mb $ \ns a -> + local (ppInfoAddTypedExprNames ctx ns) $ + do docs <- traverseRAssign (\n -> Constant <$> permPrettyM n) ns + f docs $ permPrettyM a + +instance (PermPretty a) => PermPretty (Mb (ctx :: RList CrucibleType) a) where permPrettyM = permPrettyExprMb $ \docs ppm -> (\pp -> ppEncList True (RL.toList docs) <> dot <> line <> pp) <$> ppm @@ -1748,7 +1790,7 @@ instance PermPretty (PermExpr a) where pp2 <- permPrettyM sh2 return $ nest 2 $ sep [pp1 <+> pretty "orsh", pp2] permPrettyM (PExpr_ExShape mb_sh) = - flip permPrettyExprMb mb_sh $ \(_ :>: Constant pp_n) ppm -> + flip (permPrettyExprMbTyped (CruCtxNil `CruCtxCons` knownRepr)) mb_sh $ \(_ :>: Constant pp_n) ppm -> do pp <- ppm return $ sep [pretty "exsh" <+> pp_n <> dot, pp] permPrettyM PExpr_FalseShape = return $ pretty "falsesh" @@ -3477,8 +3519,8 @@ instance PermPretty (ValuePerm a) where (\pp1 pp2 -> hang 2 (pp1 <> softline <> pretty "or" <+> pp2)) <$> permPrettyM p1 <*> permPrettyM p2 permPrettyM (ValPerm_Exists mb_p) = - flip permPrettyExprMb mb_p $ \(_ :>: Constant pp_n) ppm -> - (\pp -> pretty "exists" <+> pp_n <> dot <+> pp) <$> ppm + flip (permPrettyExprMbTyped (CruCtxNil `CruCtxCons` knownRepr)) mb_p $ \(_ :>: Constant pp_n) ppm -> + (\pp -> hang 2 (pretty "exists" <+> pp_n <> dot <+> pp)) <$> ppm permPrettyM (ValPerm_Named n args off) = do n_pp <- permPrettyM n args_pp <- permPrettyM args @@ -3687,7 +3729,6 @@ instance PermPretty (ExprAndPerm a) where instance PermPrettyF ExprAndPerm where permPrettyMF = permPrettyM - -- | Embed a 'ValuePerm' in a 'PermExpr' - like 'PExpr_ValPerm' but maps -- 'ValPerm_Var's to 'PExpr_Var's permToExpr :: ValuePerm a -> PermExpr (ValuePermType a) @@ -6722,6 +6763,27 @@ genSubstMb :: genSubstMb p s mbmb = mbM $ nuMulti p $ \ns -> genSubst (extSubstMulti s ns) (mbCombine p mbmb) + +instance {-# INCOHERENT #-} (Given (RAssign Proxy ctx), + Substable s a m, NuMatching a) => + Substable s (NamedMb ctx a) m where + genSubst = genSubstNamedMb given + +instance {-# INCOHERENT #-} (Substable s a m, NuMatching a) => + Substable s (NamedMb RNil a) m where + genSubst = genSubstNamedMb RL.typeCtxProxies + +instance {-# INCOHERENT #-} (Substable s a m, NuMatching a) => + Substable s (NamedBinding c a) m where + genSubst = genSubstNamedMb RL.typeCtxProxies + +genSubstNamedMb :: + Substable s a m => + NuMatching a => + RAssign Proxy ctx -> + s ctx' -> Mb ctx' (NamedMb ctx a) -> m (NamedMb ctx a) +genSubstNamedMb p s mbmb = mbMNamed (fmap (genSubst s) (mbSink p mbmb)) + instance SubstVar s m => Substable s (Member ctx a) m where genSubst _ mb_memb = return $ mbLift mb_memb @@ -6737,6 +6799,10 @@ instance (NuMatchingAny1 f, Substable1 s f m) => [nuMP| MNil |] -> return MNil [nuMP| xs :>: x |] -> (:>:) <$> genSubst s xs <*> genSubst1 s x +instance (NuMatchingAny1 f, Substable1 s f m) => + Substable1 s (RAssign f) m where + genSubst1 = genSubst + instance (NuMatchingAny1 f, Substable1 s f m) => Substable s (Assignment f ctx) m where genSubst s mb_assign = @@ -8431,7 +8497,7 @@ detVarsClauseAddLHSVar :: ExprVar a -> DetVarsClause -> DetVarsClause detVarsClauseAddLHSVar n (DetVarsClause lhs rhs) = DetVarsClause (NameSet.insert n lhs) rhs -newtype SeenDetVarsClauses :: CrucibleType -> * where +newtype SeenDetVarsClauses :: CrucibleType -> Type where SeenDetVarsClauses :: [DetVarsClause] -> SeenDetVarsClauses tp -- | Generic function to compute the 'DetVarsClause's for a permission diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 60e81c39aa..aad0829292 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -76,6 +76,7 @@ import Verifier.SAW.Heapster.CruUtil import Verifier.SAW.Heapster.Permissions import Verifier.SAW.Heapster.Implication import Verifier.SAW.Heapster.TypedCrucible +import Verifier.SAW.Heapster.NamedMb import GHC.Stack @@ -3294,7 +3295,6 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of m | otherwise -> fail "translateSimplImpl: SImpl_IntroLLVMBlockNamed, unknown named shape" - -- Elim for a recursive named shape applies the unfold function to the -- translations of the arguments plus the translations of the proofs of the -- permissions @@ -3657,7 +3657,8 @@ translatePermImpl1 :: ImplTranslateF r ext blocks tops rets => translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impls) of -- A failure translates to a call to the catch handler, which is the most recent -- Impl1_Catch, if one exists, or the SAW errorM function otherwise - ([nuMP| Impl1_Fail str |], _) -> pitmFail $ mbLift str + ([nuMP| Impl1_Fail err |], _) -> + tell ([mbLift (fmap ppError err)],HasFailures) >> mzero ([nuMP| Impl1_Catch |], [nuMP| (MbPermImpls_Cons _ (MbPermImpls_Cons _ _ mb_impl1) mb_impl2) |]) -> @@ -4497,8 +4498,7 @@ translateCallEntry nm entry_trans mb_tops_args mb_ghosts = withPermStackM (const $ RL.members ectx) (const $ typeTransF perms_trans $ transTerms stack) - (translate $ typedEntryBody entry) - + (translate $ _mbBinding $ typedEntryBody entry) instance PermCheckExtC ext exprExt => Translate (ImpTransInfo ext blocks tops rets ps) ctx @@ -4812,7 +4812,7 @@ instance PermCheckExtC ext exprExt => translate mb_x = case mbMatch mb_x of [nuMP| TypedImplStmt impl_seq |] -> translate impl_seq [nuMP| TypedConsStmt loc stmt pxys mb_seq |] -> - translateStmt (mbLift loc) stmt (translate $ mbCombine (mbLift pxys) mb_seq) + translateStmt (mbLift loc) stmt (translate $ mbCombine (mbLift pxys) (_mbBinding <$> mb_seq)) [nuMP| TypedTermStmt _ term_stmt |] -> translate term_stmt instance PermCheckExtC ext exprExt => @@ -4983,7 +4983,7 @@ translateEntryBody stack mapTrans entry = lambdaPermCtx (typedEntryPermsIn entry) $ \pctx -> do retType <- translateEntryRetType entry impTransM (RL.members pctx) pctx mapTrans stack retType $ - translate $ typedEntryBody entry + translate $ _mbBinding $ typedEntryBody entry -- | Translate all the entrypoints in a 'TypedBlockMap' that correspond to -- letrec-bound functions to SAW core functions as in 'translateEntryBody' @@ -5087,7 +5087,7 @@ data SomeCFGAndPerm ext where -- | An existentially quantified tuple of a 'TypedCFG', its 'GlobalSymbol', and -- a 'String' name we want to translate it to data SomeTypedCFG ext where - SomeTypedCFG :: GlobalSymbol -> String -> + SomeTypedCFG :: PermCheckExtC ext exprExt => GlobalSymbol -> String -> TypedCFG ext blocks ghosts inits gouts ret -> SomeTypedCFG ext @@ -5151,7 +5151,7 @@ frameTypeOpenTerm = dataTypeOpenTerm "Prelude.List1" [dataTypeOpenTerm tcTranslateAddCFGs :: HasPtrWidth w => SharedContext -> ModuleName -> PermEnv -> ChecksFlag -> EndianForm -> DebugLevel -> [SomeCFGAndPerm LLVM] -> - IO PermEnv + IO (PermEnv, [SomeTypedCFG LLVM]) tcTranslateAddCFGs sc mod_name env checks endianness dlevel cfgs_and_perms = withKnownNat ?ptrWidth $ do @@ -5235,7 +5235,7 @@ tcTranslateAddCFGs sc mod_name env checks endianness dlevel cfgs_and_perms = let perm = mkPtrFunPerm $ tpcfgFunPerm cfg return $ PermEnvGlobalEntry sym perm (Right [globalOpenTerm ident])) tcfgs fun_ixs - return $ permEnvAddGlobalSyms env new_entries + return (permEnvAddGlobalSyms env new_entries, tcfgs) ---------------------------------------------------------------------- diff --git a/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs b/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs index 4a5cb4ee26..d91c3d3e8d 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs @@ -52,7 +52,6 @@ import Prettyprinter as PP import qualified Data.Type.RList as RL import Data.Binding.Hobbits -import Data.Binding.Hobbits.MonadBind import Data.Binding.Hobbits.NameSet (NameSet, SomeName(..), SomeRAssign(..), namesListToNames, namesToNamesList, nameSetIsSubsetOf) @@ -82,6 +81,7 @@ import Verifier.SAW.Heapster.Implication import Verifier.SAW.Heapster.NamePropagation import Verifier.SAW.Heapster.Permissions import Verifier.SAW.Heapster.Widening +import Verifier.SAW.Heapster.NamedMb import GHC.Stack (HasCallStack) @@ -376,7 +376,6 @@ instance Closable (TypedCallSiteID blocks args vars) where instance Liftable (TypedCallSiteID blocks args vars) where mbLift = unClosed . mbLift . fmap toClosed - ---------------------------------------------------------------------- -- * Typed Crucible Statements ---------------------------------------------------------------------- @@ -767,7 +766,7 @@ data TypedStmtSeq ext blocks tops rets ps_in where TypedConsStmt :: !ProgramLoc -> !(TypedStmt ext stmt_rets ps_in ps_next) -> !(RAssign Proxy stmt_rets) -> - !(Mb stmt_rets (TypedStmtSeq ext blocks tops rets ps_next)) -> + !(NamedMb stmt_rets (TypedStmtSeq ext blocks tops rets ps_next)) -> TypedStmtSeq ext blocks tops rets ps_in -- | Typed version of 'TermStmt', which terminates the current block @@ -1208,11 +1207,12 @@ data TypedEntry phase ext blocks tops rets args ghosts = typedEntryPermsOut :: !(MbValuePerms (tops :++: rets)), -- | The type-checked body of the entrypoint typedEntryBody :: !(TransData phase - (Mb ((tops :++: args) :++: ghosts) + (NamedMb ((tops :++: args) :++: ghosts) (TypedStmtSeq ext blocks tops rets ((tops :++: args) :++: ghosts)))) } + -- | Test if an entrypoint has in-degree greater than 1 typedEntryHasMultiInDegree :: TypedEntry phase ext blocks tops rets args ghosts -> Bool @@ -1971,26 +1971,74 @@ runPermCheckM :: () ps_out r ((tops :++: args) :++: ghosts) ()) -> - TopPermCheckM ext cblocks blocks tops rets (Mb ((tops :++: args) :++: ghosts) r) + TopPermCheckM ext cblocks blocks tops rets (NamedMb ((tops :++: args) :++: ghosts) r) runPermCheckM names entryID args ghosts mb_perms_in m = get >>= \(TopPermCheckState {..}) -> let args_prxs = cruCtxProxies args - ghosts_prxs = cruCtxProxies ghosts in - liftInnerToTopM $ strongMbM $ - flip nuMultiWithElim1 (mbValuePermsToDistPerms mb_perms_in) $ \ns perms_in -> + ghosts_prxs = cruCtxProxies ghosts + (arg_names, local_names) = initialNames args names + (dbgs, ppi) = flip runState emptyPPInfo $ + do x <- state (allocateDebugNames (Just "top") (noNames' stTopCtx) stTopCtx) + y <- state (allocateDebugNames (Just "local") arg_names args) + z <- state (allocateDebugNames (Just "ghost") (noNames' ghosts) ghosts) + pure (x `rappend` y `rappend` z) + in + liftInnerToTopM $ strongMbMNamed $ + flip nuMultiWithElim1Named (NamedMb dbgs + (mbValuePermsToDistPerms mb_perms_in)) $ \ns perms_in -> let (tops_args, ghosts_ns) = RL.split Proxy ghosts_prxs ns (tops_ns, args_ns) = RL.split Proxy args_prxs tops_args - (arg_names, local_names) = initialNames args names - st = emptyPermCheckState (distPermSet perms_in) tops_ns entryID local_names in - + st1 = emptyPermCheckState (distPermSet perms_in) tops_ns entryID local_names + st = st1 { stPPInfo = ppi } in let go x = runGenStateContT x st (\_ () -> pure ()) in go $ - setVarTypes (Just "top") (noNames' stTopCtx) tops_ns stTopCtx >>> - setVarTypes (Just "local") arg_names args_ns args >>> - setVarTypes (Just "ghost") (noNames' ghosts) ghosts_ns ghosts >>> + setVarTypes tops_ns stTopCtx >>> + setVarTypes args_ns args >>> + setVarTypes ghosts_ns ghosts >>> + modify (\s->s{ stPPInfo = ppInfoApplyAllocation ns dbgs (stPPInfo st)}) >>> setInputExtState knownRepr ghosts ghosts_ns >>> m tops_ns args_ns ghosts_ns perms_in +{- +explore :: + forall tops args ghosts ext blocks cblocks ret ps r1 r2. + KnownRepr ExtRepr ext => + [Maybe String] -> + TypedEntryID blocks args -> + CruCtx tops -> + CruCtx args -> + CruCtx ghosts -> + MbValuePerms ((tops :++: args) :++: ghosts) -> + + (RAssign ExprVar tops -> RAssign ExprVar args -> RAssign ExprVar ghosts -> + DistPerms ((tops :++: args) :++: ghosts) -> + PermCheckM ext cblocks blocks tops ret r1 ps r2 ((tops :++: args) + :++: ghosts) ()) -> + + PermCheckM ext cblocks blocks tops ret r1 ps r2 ps () +explore names entryID topCtx argCtx ghostCtx mb_perms_in m = + let args_prxs = cruCtxProxies argCtx + ghosts_prxs = cruCtxProxies ghostCtx + (arg_names, local_names) = initialNames argCtx names in + + allocateDebugNamesM (Just "top") (noNames' topCtx) topCtx >>>= \topDbgs -> + allocateDebugNamesM (Just "local") arg_names argCtx >>>= \argDbgs -> + allocateDebugNamesM (Just "ghost") (noNames' ghostCtx) ghostCtx >>>= \ghostDbgs -> + gopenBinding (fmap _ . strongMbM) (mbValuePermsToDistPerms mb_perms_in) >>>= \(ns, perms_in) -> + let (tops_args, ghosts_ns) = RL.split Proxy ghosts_prxs ns + (tops_ns, args_ns) = RL.split Proxy args_prxs tops_args + st :: PermCheckState ext blocks tops ret ((tops :++: args) :++: ghosts) + st = emptyPermCheckState (distPermSet perms_in) tops_ns entryID local_names in + + setVarTypes tops_ns topCtx >>> + modify (\s->s{ stPPInfo = ppInfoApplyAllocation tops_ns topDbgs (stPPInfo st)}) >>> + modify (\s->s{ stPPInfo = ppInfoApplyAllocation args_ns argDbgs (stPPInfo st)}) >>> + modify (\s->s{ stPPInfo = ppInfoApplyAllocation ghosts_ns ghostDbgs (stPPInfo st)}) >>> + setInputExtState knownRepr ghostCtx ghosts_ns >>> + m tops_ns args_ns ghosts_ns perms_in + + -} + rassignLen :: RAssign f x -> Int rassignLen = go 0 where @@ -2159,11 +2207,8 @@ getAtomicOrWordLLVMPerms r = recombinePerm x p) >>> pure (Left e_word) _ -> - stmtFailM (\i -> - sep [pretty "getAtomicOrWordLLVMPerms:", - pretty "Needed atomic permissions for" <+> permPretty i r, - pretty "but found" <+> - permPretty i p]) + permGetPPInfo >>>= \ppinfo -> + stmtFailM $ AtomicPermError (permPretty ppinfo r) (permPretty ppinfo p) -- | Like 'getAtomicOrWordLLVMPerms', but fail if an equality permission to a @@ -2179,11 +2224,11 @@ getAtomicLLVMPerms r = case eith of Right ps -> pure ps Left e -> - stmtFailM (\i -> - sep [pretty "getAtomicLLVMPerms:", - pretty "Needed atomic permissions for" <+> permPretty i r, - pretty "but found" <+> - permPretty i (ValPerm_Eq $ PExpr_LLVMWord e)]) + permGetPPInfo >>>= \ppinfo -> + stmtFailM $ AtomicPermError + (permPretty ppinfo r) + (permPretty ppinfo (ValPerm_Eq $ PExpr_LLVMWord e)) + data SomeExprVarFrame where SomeExprVarFrame :: @@ -2262,39 +2307,55 @@ stmtHandleUnitVars ns = -- | Remember the type of a free variable, and ensure that it has a permission setVarType :: - Maybe String {- ^ The base name of the variable (e.g., "top", "arg", etc.) -} -> - Maybe String {- ^ The C name of the variable, if applicable -} -> - ExprVar a {- ^ The Hobbits variable itself -} -> - TypeRepr a {- ^ The type of the variable -} -> - PermCheckM ext cblocks blocks tops rets r ps r ps () -setVarType maybe_str dbg x tp = - (modify $ \st -> - st { stCurPerms = initVarPerm x (stCurPerms st), - stVarTypes = NameMap.insert x tp (stVarTypes st), - stPPInfo = ppInfoAddExprName (dbgStringPP maybe_str dbg tp) - x - (stPPInfo st) - }) + ExprVar a -> -- ^ The Hobbits variable itself + TypeRepr a -> -- ^ The type of the variable + PermCheckM ext cblocks blocks tops ret r ps r ps () +setVarType x tp = + modify $ \st -> + st { stCurPerms = initVarPerm x (stCurPerms st), + stVarTypes = NameMap.insert x tp (stVarTypes st) } -- | Remember the types of a sequence of free variables setVarTypes :: - Maybe String {- ^ The bsae name of the variable (e.g., "top", "arg", etc.) -} -> - RAssign (Constant (Maybe String)) tps -> RAssign Name tps -> CruCtx tps -> - PermCheckM ext cblocks blocks tops rets r ps r ps () -setVarTypes _ MNil MNil CruCtxNil = pure () -setVarTypes str (ds :>: Constant d) (ns :>: n) (CruCtxCons ts t) = - do setVarTypes str ds ns ts - setVarType str d n t - --- | Get the current 'PPInfo' -permGetPPInfo :: PermCheckM ext cblocks blocks tops rets r ps r ps PPInfo -permGetPPInfo = gets stPPInfo - --- | Get the current prefix string to give context to error messages -getErrorPrefix :: PermCheckM ext cblocks blocks tops rets r ps r ps (Doc ()) -getErrorPrefix = gets (fromMaybe emptyDoc . stErrPrefix) + PermCheckM ext cblocks blocks tops ret r ps r ps () +setVarTypes MNil CruCtxNil = pure () +setVarTypes (ns :>: n) (CruCtxCons ts t) = + do setVarTypes ns ts + setVarType n t + +allocateDebugNames :: + Maybe String -> -- ^ The base name of the variable (e.g., "top", "arg", etc.) + RAssign (Constant (Maybe String)) tps -> + CruCtx tps -> + PPInfo -> + (RAssign StringF tps, PPInfo) +allocateDebugNames _ MNil _ ppi = (MNil, ppi) +allocateDebugNames base (ds :>: Constant dbg) (CruCtxCons ts tp) ppi = + case allocateDebugNames base ds ts ppi of + (outs, ppi1) -> + case ppInfoAllocateName str ppi1 of + (ppi2, out) -> (outs :>: StringF out, ppi2) + where + str = + case (base,dbg) of + (_,Just d) -> "C[" ++ d ++ "]" + (Just b,_) -> b ++ "_" ++ typeBaseName tp + (Nothing,Nothing) -> typeBaseName tp + + +allocateDebugNamesM :: + Maybe String -> -- ^ The base name of the variable (e.g., "top", "arg", etc.) + RAssign (Constant (Maybe String)) tps -> + CruCtx tps -> + PermCheckM ext cblocks blocks tops ret r ps r ps + (RAssign StringF tps) +allocateDebugNamesM base ds tps = + do ppi <- permGetPPInfo + let (strs, ppi') = allocateDebugNames base ds tps ppi + gmodify $ \st -> st { stPPInfo = ppi' } + return strs -- | Emit debugging output at the given 'DebugLevel' stmtDebugM :: DebugLevel -> (PPInfo -> Doc ()) -> @@ -2315,16 +2376,6 @@ stmtVerbTraceM :: (PPInfo -> Doc ()) -> PermCheckM ext cblocks blocks tops ret r ps r ps String stmtVerbTraceM = stmtDebugM verboseDebugLevel --- | Failure in the statement permission-checking monad -stmtFailM :: (PPInfo -> Doc ()) -> PermCheckM ext cblocks blocks tops rets r1 ps1 - (TypedStmtSeq ext blocks tops rets ps2) ps2 a -stmtFailM msg = - getErrorPrefix >>>= \err_prefix -> - stmtTraceM (\i -> err_prefix <> line <> - pretty "Type-checking failure:" <> softline <> msg i) >>>= \str -> - gabortM (return $ TypedImplStmt $ AnnotPermImpl str $ - PermImpl_Step (Impl1_Fail "") MbPermImpls_Nil) - -- | FIXME HERE: Make 'ImplM' quantify over any underlying monad, so that we do -- not have to use 'traversePermImpl' after we run an 'ImplM' data WithImplState vars a ps ps' = @@ -2588,9 +2639,8 @@ convertRegType ext loc reg (LLVMPointerRepr w1) (LLVMPointerRepr w2) = convertRegType ext loc reg1 (BVRepr w1) (BVRepr w2) >>>= \reg2 -> convertRegType ext loc reg2 (BVRepr w2) (LLVMPointerRepr w2) convertRegType _ _ x tp1 tp2 = - stmtFailM (\i -> pretty "Could not cast" <+> permPretty i x - <+> pretty "from" <+> pretty (show tp1) - <+> pretty "to" <+> pretty (show tp2)) + permGetPPInfo >>>= \ppinfo -> + stmtFailM $ RegisterConversionError (permPretty ppinfo x) tp1 tp2 -- | Extract the bitvector of size @sz@ at offset @off@ from a larger bitvector @@ -2646,10 +2696,12 @@ emitStmt :: StmtPermCheckM ext cblocks blocks tops rets ps_out ps_in (RAssign Name stmt_rets) emitStmt tps names loc stmt = - gopenBinding - ((TypedConsStmt loc stmt (cruCtxProxies tps) <$>) . strongMbM) - (mbPure (cruCtxProxies tps) ()) >>>= \(ns, ()) -> - setVarTypes Nothing names ns tps >>> + let pxys = cruCtxProxies tps in + allocateDebugNamesM Nothing names tps >>>= \debugs -> + startNamedBinding debugs (fmap (TypedConsStmt loc stmt pxys) + . strongMbMNamed) >>>= \ns -> + modify (\st -> st { stPPInfo = ppInfoApplyAllocation ns debugs (stPPInfo st)}) >>> + setVarTypes ns tps >>> gmodify (modifySTCurPerms (applyTypedStmt stmt ns)) >>> gets (view distPerms . stCurPerms) >>>= \perms_out -> stmtVerbTraceM (\i -> @@ -3080,7 +3132,7 @@ tcEmitStmt' ctx loc (CallHandle _ret freg_untyped _args_ctx args_untyped) = _ -> pure []) >>>= \maybe_fun_perms -> (stmtEmbedImplM $ foldr1WithDefault (implCatchM "tcEmitStmt (fun perm)" $ typedRegVar freg) - (implFailMsgM "Could not find function permission") + (implFailM FunctionPermissionError) (mapMaybe (fmap pure) maybe_fun_perms)) >>>= \some_fun_perm -> case some_fun_perm of SomeFunPerm fun_perm -> @@ -3106,7 +3158,7 @@ tcEmitStmt' ctx loc (Assert reg msg) = let treg = tcReg ctx reg in getRegEqualsExpr treg >>= \case PExpr_Bool True -> pure ctx - PExpr_Bool False -> stmtFailM (\_ -> pretty "Failed assertion") + PExpr_Bool False -> stmtFailM FailedAssertionError _ -> ctx <$ emitStmt CruCtxNil MNil loc (TypedAssert (tcReg ctx reg) (tcReg ctx msg)) tcEmitStmt' _ _ _ = error "tcEmitStmt: unsupported statement" @@ -3132,8 +3184,9 @@ tcEmitLLVMSetExpr ctx loc (LLVM_PointerExpr w blk_reg off_reg) = emitLLVMStmt knownRepr name loc (ConstructLLVMWord toff_reg) >>>= \x -> stmtRecombinePerms >>> pure (addCtxName ctx x) - _ -> stmtFailM (\i -> pretty "LLVM_PointerExpr: Non-zero pointer block: " - <> permPretty i tblk_reg) + _ -> + permGetPPInfo >>>= \ppinfo -> + stmtFailM $ NonZeroPointerBlockError (permPretty ppinfo tblk_reg) -- Type-check the LLVM value destructor that gets the block value, by either -- proving a permission eq(llvmword e) and returning block 0 or proving @@ -3238,15 +3291,16 @@ tcEmitLLVMSetExpr ctx loc (LLVM_SideConditions _ tp conds reg) = foldr (\(LLVMSideCondition cond_reg ub) rest_m -> let tcond_reg = tcReg ctx cond_reg - err_str = renderDoc (pretty "Undefined behavior: " <> softline <> UB.explain ub) in + err_msg = pretty "Undefined behavior" <> softline <> UB.explain ub in + -- err_str = renderDoc (pretty "Undefined behavior: " <> softline <> UB.explain ub) in getRegEqualsExpr tcond_reg >>= \case PExpr_Bool True -> rest_m - PExpr_Bool False -> stmtFailM (\_ -> pretty err_str) + PExpr_Bool False -> stmtFailM $ UndefinedBehaviorError err_msg _ -> emitStmt knownRepr noNames loc (TypedSetRegPermExpr knownRepr $ - PExpr_String err_str) >>>= \(MNil :>: str_var) -> + PExpr_String (renderDoc err_msg)) >>>= \(_ :>: str_var) -> stmtRecombinePerms >>> emitStmt CruCtxNil MNil loc (TypedAssert tcond_reg $ @@ -3262,7 +3316,7 @@ tcEmitLLVMSetExpr ctx loc (LLVM_SideConditions _ tp conds reg) = pure (addCtxName ctx ret)) conds tcEmitLLVMSetExpr _ctx _loc X86Expr{} = - stmtFailM (\_ -> pretty "X86Expr not supported") + stmtFailM X86ExprError @@ -3445,14 +3499,15 @@ tcEmitLLVMStmt _arch ctx loc (LLVM_Alloca w _ sz_reg _ _) = stmtRecombinePerms >>> pure (addCtxName ctx y) (_, _, Nothing) -> - stmtFailM (\i -> pretty "LLVM_Alloca: non-constant size for" - <+> permPretty i sz_treg) + permGetPPInfo >>>= \ppinfo -> + stmtFailM $ AllocaError (AllocaNonConstantError $ permPretty ppinfo sz_treg) (Just fp, p, _) -> - stmtFailM (\i -> pretty "LLVM_Alloca: expected LLVM frame perm for " - <+> permPretty i fp <> pretty ", found perm" - <+> permPretty i p) + permGetPPInfo >>>= \ppinfo -> + stmtFailM $ AllocaError $ AllocaFramePermError + (permPretty ppinfo fp) + (permPretty ppinfo p) (Nothing, _, _) -> - stmtFailM (const $ pretty "LLVM_Alloca: no frame pointer set") + stmtFailM $ AllocaError AllocaFramePtrError -- Type-check a push frame instruction tcEmitLLVMStmt _arch ctx loc (LLVM_PushFrame _ _) = @@ -3483,7 +3538,7 @@ tcEmitLLVMStmt _arch ctx loc (LLVM_PopFrame _) = (TypedLLVMDeleteFrame fp fperms del_perms) >>>= \y -> modify (\st -> st { stExtState = PermCheckExtState_LLVM Nothing }) >>> pure (addCtxName ctx y) - _ -> stmtFailM (const $ pretty "LLVM_PopFrame: no frame perms") + _ -> stmtFailM $ PopFrameError -- Type-check a pointer offset instruction by emitting OffsetLLVMValue tcEmitLLVMStmt _arch ctx loc (LLVM_PtrAddOffset _w _ ptr off) = @@ -3515,7 +3570,7 @@ tcEmitLLVMStmt _arch ctx loc (LLVM_LoadHandle _ _ ptr args ret) = (TypedLLVMLoadHandle tptr tp p) >>>= \ret' -> stmtRecombinePerms >>> pure (addCtxName ctx ret') - _ -> stmtFailM (const $ pretty "LLVM_PopFrame: no function pointer perms") + _ -> stmtFailM LoadHandleError -- Type-check a ResolveGlobal instruction by looking up the global symbol tcEmitLLVMStmt _arch ctx loc (LLVM_ResolveGlobal w _ gsym) = @@ -3528,8 +3583,7 @@ tcEmitLLVMStmt _arch ctx loc (LLVM_ResolveGlobal w _ gsym) = stmtRecombinePerms >>> pure (addCtxName ctx ret) Nothing -> - stmtFailM (const $ pretty ("LLVM_ResolveGlobal: no perms for global " - ++ globalSymbolName gsym)) + stmtFailM $ ResolveGlobalError gsym {- tcEmitLLVMStmt _arch ctx loc (LLVM_PtrLe _ r1 r2) = @@ -3690,9 +3744,10 @@ tcEmitLLVMStmt _arch ctx loc (LLVM_PtrEq _ (r1 :: Reg ctx (LLVMPointerType wptr) -- If we don't know any relationship between the two registers, then we -- fail, because there is no way to compare pointers in the translation _ -> - stmtFailM (\i -> - sep [pretty "Could not compare LLVM pointer values", - permPretty i x1, pretty "and", permPretty i x2]) + permGetPPInfo >>>= \ppinfo -> + stmtFailM $ PointerComparisonError + (permPretty ppinfo x1) + (permPretty ppinfo x2) tcEmitLLVMStmt _arch ctx loc LLVM_Debug{} = -- let tptr = tcReg ctx ptr in @@ -4122,7 +4177,7 @@ tcBlockEntryBody :: Block ext cblocks ret args -> TypedEntry TCPhase ext blocks tops (gouts :> ret) (CtxToRList args) ghosts -> TopPermCheckM ext cblocks blocks tops (gouts :> ret) - (Mb ((tops :++: CtxToRList args) :++: ghosts) + (NamedMb ((tops :++: CtxToRList args) :++: ghosts) (TypedStmtSeq ext blocks tops (gouts :> ret) ((tops :++: CtxToRList args) :++: ghosts))) tcBlockEntryBody names blk entry@(TypedEntry {..}) = @@ -4146,6 +4201,9 @@ tcBlockEntryBody names blk entry@(TypedEntry {..}) = stmtRecombinePerms >>> tcEmitStmtSeq names ctx (blk ^. blockStmts) +rappend :: RAssign f x -> RAssign f y -> RAssign f (x :++: y) +rappend xs (ys :>: y) = rappend xs ys :>: y +rappend xs MNil = xs -- | Prove that the permissions held at a call site from the given source -- entrypoint imply the supplied input permissions of the current entrypoint @@ -4159,7 +4217,7 @@ proveCallSiteImpl :: ((tops :++: args) :++: vars) tops args ghosts) proveCallSiteImpl srcID destID args ghosts vars mb_perms_in mb_perms_out = - fmap CallSiteImpl $ runPermCheckM [] srcID args vars mb_perms_in $ + fmap (CallSiteImpl . _mbBinding) $ runPermCheckM [] srcID args vars mb_perms_in $ \tops_ns args_ns _ perms_in -> let ns = RL.append tops_ns args_ns perms_out = @@ -4219,12 +4277,14 @@ widenEntry dlevel env (TypedEntry {..}) = debugTraceTraceLvl dlevel ("Widening entrypoint: " ++ show typedEntryID) $ case foldl1' (widen dlevel env typedEntryTops typedEntryArgs) $ map (fmapF typedCallSiteArgVarPerms) typedEntryCallers of - Some (ArgVarPerms ghosts perms_in) -> + Some (ArgVarPerms (ghosts :: CruCtx x) perms_in) -> let callers = - map (fmapF (callSiteSetGhosts ghosts)) typedEntryCallers in + map (fmapF (callSiteSetGhosts ghosts)) typedEntryCallers + in Some $ TypedEntry { typedEntryCallers = callers, typedEntryGhosts = ghosts, - typedEntryPermsIn = perms_in, typedEntryBody = Nothing, .. } + typedEntryPermsIn = perms_in, typedEntryBody = Nothing, + .. } -- | Visit an entrypoint, by first proving the required implications at each -- call site, meaning that the permissions held at the call site imply the input @@ -4277,7 +4337,8 @@ visitEntry names can_widen blk entry = else do body <- maybe (tcBlockEntryBody names blk entry) return (typedEntryBody entry) return $ Some $ entry { typedEntryCallers = callers, - typedEntryBody = Just body } + typedEntryBody = Just body + } -- | Visit a block by visiting all its entrypoints @@ -4368,3 +4429,82 @@ tcCFG w env endianness dlevel fun_perm cfg = (visitBlock (rem_iters > 0) >=> assign (stBlockMap . member memb))) >> main_loop (rem_iters - 1) nodes + +-------------------------------------------------------------------------------- +-- Error handling and logging + +data StmtError where + AtomicPermError :: Doc ann -> Doc ann -> StmtError + RegisterConversionError + :: (Show tp1, Show tp2) + => Doc ann -> tp1 -> tp2 -> StmtError + FailedAssertionError :: StmtError + NonZeroPointerBlockError :: Doc ann -> StmtError + UndefinedBehaviorError :: Doc () -> StmtError + X86ExprError :: StmtError + AllocaError :: AllocaErrorType -> StmtError + PopFrameError :: StmtError + LoadHandleError :: StmtError + ResolveGlobalError :: GlobalSymbol -> StmtError + PointerComparisonError :: Doc ann -> Doc ann -> StmtError + +data AllocaErrorType where + AllocaNonConstantError :: Doc ann -> AllocaErrorType + AllocaFramePermError :: Doc ann -> Doc ann -> AllocaErrorType + AllocaFramePtrError :: AllocaErrorType + +instance ErrorPretty StmtError where + ppError (AtomicPermError r p) = renderDoc $ + sep [pretty "getAtomicOrWordLLVMPerms:", + pretty "Needed atomic permissions for" <+> r, + pretty "but found" <+> p] + ppError (RegisterConversionError docx tp1 tp2) = renderDoc $ + pretty "Could not cast" <+> docx <+> + pretty "from" <+> pretty (show tp1) <+> + pretty "to" <+> pretty (show tp2) + ppError FailedAssertionError = + "Failed assertion" + ppError (NonZeroPointerBlockError tblk_reg) = renderDoc $ + pretty "LLVM_PointerExpr: Non-zero pointer block: " <> tblk_reg + ppError (UndefinedBehaviorError doc) = + renderDoc doc + ppError X86ExprError = + "X86Expr not supported" + ppError (AllocaError (AllocaNonConstantError sz_treg)) = renderDoc $ + pretty "LLVM_Alloca: non-constant size for" <+> + sz_treg + ppError (AllocaError (AllocaFramePermError fp p)) = renderDoc $ + pretty "LLVM_Alloca: expected LLVM frame perm for " <+> + fp <> pretty ", found perm" <+> p + ppError (AllocaError AllocaFramePtrError) = + "LLVM_Alloca: no frame pointer set" + ppError PopFrameError = + "LLVM_PopFrame: no frame perms" + ppError LoadHandleError = + "LLVM_LoadHandle: no function pointer perms" + ppError (ResolveGlobalError gsym) = + "LLVM_ResolveGlobal: no perms for global " ++ + globalSymbolName gsym + ppError (PointerComparisonError x1 x2) = renderDoc $ + sep [ pretty "Could not compare LLVM pointer values" + , x1, pretty "and", x2 ] + + +-- | Get the current 'PPInfo' +permGetPPInfo :: PermCheckM ext cblocks blocks tops ret r ps r ps PPInfo +permGetPPInfo = gets stPPInfo + +-- | Get the current prefix string to give context to error messages +getErrorPrefix :: PermCheckM ext cblocks blocks tops ret r ps r ps (Doc ()) +getErrorPrefix = gets (fromMaybe emptyDoc . stErrPrefix) + +-- | Failure in the statement permission-checking monad +stmtFailM :: StmtError -> PermCheckM ext cblocks blocks tops ret r1 ps1 + (TypedStmtSeq ext blocks tops ret ps2) ps2 a +stmtFailM err = + getErrorPrefix >>>= \err_prefix -> + stmtTraceM (const $ err_prefix <> line <> + pretty "Type-checking failure:" <> softline <> + pretty (ppError err)) >>>= \str -> + gabortM (return $ TypedImplStmt $ AnnotPermImpl str $ + PermImpl_Step (Impl1_Fail $ GeneralError (pretty "")) MbPermImpls_Nil) diff --git a/src/SAWScript/HeapsterBuiltins.hs b/src/SAWScript/HeapsterBuiltins.hs index fb754319e2..8b3b40db8d 100644 --- a/src/SAWScript/HeapsterBuiltins.hs +++ b/src/SAWScript/HeapsterBuiltins.hs @@ -54,6 +54,7 @@ module SAWScript.HeapsterBuiltins , heapster_print_fun_trans , heapster_export_coq , heapster_parse_test + , heapster_dump_ide_info , heapster_set_debug_level , heapster_set_translation_checks ) where @@ -124,6 +125,7 @@ import Verifier.SAW.Heapster.SAWTranslation import Verifier.SAW.Heapster.IRTTranslation import Verifier.SAW.Heapster.PermParser import Verifier.SAW.Heapster.ParsedCtx +import qualified Verifier.SAW.Heapster.IDESupport as HIDE import Verifier.SAW.Heapster.LLVMGlobalConst import SAWScript.Prover.Exporter @@ -304,12 +306,14 @@ mkHeapsterEnv dlevel saw_mod_name llvm_mods@(Some first_mod:_) = env_ref <- liftIO $ newIORef env dlevel_ref <- liftIO $ newIORef dlevel checks_ref <- liftIO $ newIORef doChecks + tcfg_ref <- liftIO $ newIORef [] return $ HeapsterEnv { heapsterEnvSAWModule = saw_mod_name, heapsterEnvPermEnvRef = env_ref, heapsterEnvLLVMModules = llvm_mods, heapsterEnvDebugLevel = dlevel_ref, - heapsterEnvChecksFlag = checks_ref + heapsterEnvChecksFlag = checks_ref, + heapsterEnvTCFGs = tcfg_ref } mkHeapsterEnv _ _ [] = fail "mkHeapsterEnv: empty list of LLVM modules!" @@ -390,8 +394,6 @@ heapster_init_env_for_files_debug _bic _opts mod_filename llvm_filenames = heapster_init_env_for_files_gen _bic _opts traceDebugLevel mod_filename llvm_filenames - - -- | Look up the CFG associated with a symbol name in a Heapster environment heapster_get_cfg :: BuiltinContext -> Options -> HeapsterEnv -> String -> TopLevel SAW_CFG @@ -432,7 +434,7 @@ heapster_define_recursive_perm _bic _opts henv Some args_ctx <- parseParsedCtxString "argument types" env args_str let args = parsedCtxCtx args_ctx Some tp <- parseTypeString "permission type" env tp_str - trans_tp <- liftIO $ + trans_tp <- liftIO $ translateCompleteTypeInCtx sc env args (nus (cruCtxProxies args) $ const $ ValuePermRepr tp) trans_ident <- parseAndInsDef henv nm trans_tp trans_str @@ -1132,7 +1134,7 @@ heapster_typecheck_mut_funs :: BuiltinContext -> Options -> HeapsterEnv -> [(String, String)] -> TopLevel () heapster_typecheck_mut_funs bic opts henv = heapster_typecheck_mut_funs_rename bic opts henv . - map (\(nm, perms_string) -> (nm, nm, perms_string)) + map (\(nm, perms_string) -> (nm, nm, perms_string)) heapster_typecheck_mut_funs_rename :: BuiltinContext -> Options -> HeapsterEnv -> @@ -1176,11 +1178,12 @@ heapster_typecheck_mut_funs_rename _bic _opts henv fn_names_and_perms = env <- liftIO $ readIORef $ heapsterEnvPermEnvRef henv sc <- getSharedContext let saw_modname = heapsterEnvSAWModule henv - env' <- liftIO $ + (env', tcfgs) <- liftIO $ let ?ptrWidth = w in tcTranslateAddCFGs sc saw_modname env checks endianness dlevel some_cfgs_and_perms liftIO $ writeIORef (heapsterEnvPermEnvRef henv) env' + liftIO $ modifyIORef (heapsterEnvTCFGs henv) (\old -> map Some tcfgs ++ old) heapster_typecheck_fun :: BuiltinContext -> Options -> HeapsterEnv -> @@ -1198,7 +1201,7 @@ heapster_typecheck_fun_rename bic opts henv fn_name fn_name_to perms_string = heapster_typecheck_fun_rs :: BuiltinContext -> Options -> HeapsterEnv -> String -> String -> TopLevel () heapster_typecheck_fun_rs bic opts henv fn_name perms_string = - heapster_typecheck_fun bic opts henv + heapster_typecheck_fun bic opts henv heapster_typecheck_fun_rename_rs :: BuiltinContext -> Options -> HeapsterEnv -> String -> String -> String -> TopLevel () @@ -1267,3 +1270,10 @@ heapster_parse_test _bic _opts _some_lm@(Some lm) fn_name perms_string = SomeFunPerm fun_perm <- parseFunPermString "permissions" env args ret perms_string liftIO $ putStrLn $ permPrettyString emptyPPInfo fun_perm + +heapster_dump_ide_info :: BuiltinContext -> Options -> HeapsterEnv -> String -> TopLevel () +heapster_dump_ide_info _bic _opts henv filename = do + -- heapster_typecheck_mut_funs bic opts henv [(fnName, perms)] + penv <- io $ readIORef (heapsterEnvPermEnvRef henv) + tcfgs <- io $ readIORef (heapsterEnvTCFGs henv) + io $ HIDE.printIDEInfo penv tcfgs filename emptyPPInfo diff --git a/src/SAWScript/Interpreter.hs b/src/SAWScript/Interpreter.hs index f2e4a8bd73..e4cb1dede8 100644 --- a/src/SAWScript/Interpreter.hs +++ b/src/SAWScript/Interpreter.hs @@ -4160,6 +4160,13 @@ primitives = Map.fromList [ "Parse and print back a set of Heapster permissions for a function" ] + , prim "heapster_dump_ide_info" + "HeapsterEnv -> String -> TopLevel ()" + (bicVal heapster_dump_ide_info) + Experimental + [ "Dump environment info to a JSON file for IDE integration." + ] + --------------------------------------------------------------------- , prim "sharpSAT" "Term -> TopLevel Integer" diff --git a/src/SAWScript/Value.hs b/src/SAWScript/Value.hs index 5da9c83644..d7c018d980 100644 --- a/src/SAWScript/Value.hs +++ b/src/SAWScript/Value.hs @@ -116,7 +116,7 @@ import Lang.Crucible.LLVM.ArraySizeProfile import What4.ProgramLoc (ProgramLoc(..)) import Verifier.SAW.Heapster.Permissions -import Verifier.SAW.Heapster.SAWTranslation (ChecksFlag) +import Verifier.SAW.Heapster.SAWTranslation (ChecksFlag,SomeTypedCFG(..)) -- Values ---------------------------------------------------------------------- @@ -195,6 +195,8 @@ data HeapsterEnv = HeapsterEnv { -- ^ The current permissions environment heapsterEnvLLVMModules :: [Some CMSLLVM.LLVMModule], -- ^ The list of underlying 'LLVMModule's that we are translating + heapsterEnvTCFGs :: IORef [Some SomeTypedCFG], + -- ^ The typed CFGs for output debugging/IDE info heapsterEnvDebugLevel :: IORef DebugLevel, -- ^ The current debug level heapsterEnvChecksFlag :: IORef ChecksFlag From af4dc592831cfec8e9ca08040b7f4aaa0f09b4ce Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Tue, 7 Mar 2023 08:38:42 -0500 Subject: [PATCH 02/27] CI: Use modern version of action-docker-layer-caching (#1835) Fixes #1833. --- .github/workflows/ci.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 9159120fd6..91f4971cfb 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -561,7 +561,7 @@ jobs: docker-compose pull grep -h '^FROM' docker/*.dockerfile | sort -u | awk '{print $2}' | xargs -n1 -P8 docker pull - - uses: satackey/action-docker-layer-caching@v0.0.11 + - uses: jpribyl/action-docker-layer-caching@v0.1.1 continue-on-error: true - shell: bash @@ -594,7 +594,7 @@ jobs: name: "${{ runner.os }}-bins" path: ./exercises/bin - - uses: satackey/action-docker-layer-caching@v0.0.11 + - uses: jpribyl/action-docker-layer-caching@v0.1.1 continue-on-error: true - shell: bash From 93ecec5048573544e7a6558c3084c725c84de62a Mon Sep 17 00:00:00 2001 From: Yan Peng <112029182+pennyannn@users.noreply.github.com> Date: Wed, 8 Mar 2023 12:09:19 -0800 Subject: [PATCH 03/27] Speed up propsSubset through stAppIndex check (#1829) --- src/SAWScript/Proof.hs | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/src/SAWScript/Proof.hs b/src/SAWScript/Proof.hs index 906fcb29e5..b77bec0a40 100644 --- a/src/SAWScript/Proof.hs +++ b/src/SAWScript/Proof.hs @@ -1334,7 +1334,17 @@ psStats = _psStats -- forall x in ps1, exists y in ps2 where x == y propsSubset :: SharedContext -> [Prop] -> [Prop] -> IO Bool propsSubset sc ps1 ps2 = - and <$> sequence [ propsElem sc x ps2 | x <- ps1 ] + -- For each x, check if x exists in ps2 by checking term identity using stAppIndex + -- If the check succeeds, return True. Otherwise use propsElem to do the more expensive + -- convertibility check. + and <$> sequence [ if idSubset (unProp x) then pure True else propsElem sc x ps2 | x <- ps1 ] + where + ps2Ids = foldr (\x idents -> case (unProp x) of + STApp{ stAppIndex = ident } -> Set.insert ident idents + _ -> idents) + Set.empty ps2 + idSubset STApp{ stAppIndex = ident } = Set.member ident ps2Ids + idSubset _ = False -- exists y in ps where x == y propsElem :: SharedContext -> Prop -> [Prop] -> IO Bool From 8eaf10e5858d26d86d06de7ca67d9edf0c42096f Mon Sep 17 00:00:00 2001 From: Sam Breese Date: Wed, 8 Mar 2023 23:41:15 -0500 Subject: [PATCH 04/27] Fix bugs in several Yosys cell implementations (#1817) * Fix bugs in some Yosys cell implementations * Fix warning --- src/SAWScript/Yosys/Cell.hs | 348 ++++++++++++++++++++++-------------- 1 file changed, 211 insertions(+), 137 deletions(-) diff --git a/src/SAWScript/Yosys/Cell.hs b/src/SAWScript/Yosys/Cell.hs index 31407af968..c7eb9c38fc 100644 --- a/src/SAWScript/Yosys/Cell.hs +++ b/src/SAWScript/Yosys/Cell.hs @@ -6,13 +6,8 @@ Maintainer : sbreese Stability : experimental -} -{-# Language TemplateHaskell #-} {-# Language OverloadedStrings #-} -{-# Language RecordWildCards #-} -{-# Language ViewPatterns #-} -{-# Language LambdaCase #-} {-# Language MultiWayIf #-} -{-# Language TupleSections #-} {-# Language ScopedTypeVariables #-} module SAWScript.Yosys.Cell where @@ -37,6 +32,87 @@ import SAWScript.Panic (panic) import SAWScript.Yosys.Utils import SAWScript.Yosys.IR +-- | A SAWCore bitvector term along with its width and whether it should be interpreted as signed. +data CellTerm = CellTerm + { cellTermTerm :: SC.Term + , cellTermWidth :: Natural + , cellTermSigned :: Bool + } + +cellTermNat :: forall m. MonadIO m => SC.SharedContext -> CellTerm -> m SC.Term +cellTermNat sc (CellTerm { cellTermTerm = t, cellTermWidth = w }) = liftIO $ SC.scBvToNat sc w t + +-- | Reverse the bits in the given bitvector. +-- Note that Yosys arithmetic cells treat bitvectors as "little-bit-endian", i.e. the 0-index bit is +-- least significant. SAWCore has the opposite convention, so it's important to reverse bitvectors +-- before and after each arithmetic operation in order to match Yosys' semantics. +flipEndianness :: forall m. MonadIO m => SC.SharedContext -> CellTerm -> m CellTerm +flipEndianness sc (CellTerm { cellTermTerm = t, cellTermWidth = w, cellTermSigned = s}) = do + wt <- liftIO $ SC.scNat sc w + bool <- liftIO $ SC.scBoolType sc + res <- liftIO $ SC.scGlobalApply sc "Prelude.reverse" [wt, bool, t] + pure $ CellTerm res w s + +-- | Apply the appropriate (possibly signed) extension or truncation to make the given bitvector +-- match the given width. +extTrunc :: forall m. MonadIO m => SC.SharedContext -> Natural -> CellTerm -> m CellTerm +extTrunc sc width (CellTerm { cellTermTerm = t, cellTermWidth = bvw, cellTermSigned = signed}) = do + wterm <- liftIO $ SC.scNat sc width + bvwterm <- liftIO $ SC.scNat sc bvw + res <- if + | bvw > width -> do + diffterm <- liftIO . SC.scNat sc $ bvw - width + liftIO $ SC.scBvTrunc sc diffterm wterm t + | width > bvw && signed -> do + bvwpredterm <- liftIO . SC.scNat sc $ bvw - 1 + diffterm <- liftIO . SC.scNat sc $ width - bvw + liftIO $ SC.scBvSExt sc diffterm bvwpredterm t + | width > bvw && not signed -> do + diffterm <- liftIO . SC.scNat sc $ width - bvw + liftIO $ SC.scBvUExt sc diffterm bvwterm t + | otherwise -> pure t + pure $ CellTerm res width signed + +-- | Given two bitvectors, extend the narrower bitvector to match the wider. +extMax :: forall m. MonadIO m => SC.SharedContext -> CellTerm -> CellTerm -> m (CellTerm, CellTerm) +extMax sc c1 c2 = do + let + w1 = cellTermWidth c1 + w2 = cellTermWidth c2 + w = max w1 w2 + res1 <- extTrunc sc w c1 + res2 <- extTrunc sc w c2 + pure (res1, res2) + +liftUnary :: forall m. + MonadIO m => + SC.SharedContext -> + (SC.Term -> SC.Term -> IO SC.Term) -> -- (w : Nat) -> [w] -> [w] + CellTerm -> m CellTerm +liftUnary sc f c@(CellTerm { cellTermTerm = t }) = do + wt <- liftIO . SC.scNat sc $ cellTermWidth c + res <- liftIO $ f wt t + pure $ c { cellTermTerm = res } + +liftBinary :: forall m. + MonadIO m => + SC.SharedContext -> + (SC.Term -> SC.Term -> SC.Term -> IO SC.Term) -> -- (w : Nat) -> [w] -> [w] -> [w] + CellTerm -> CellTerm -> m CellTerm +liftBinary sc f c1@(CellTerm { cellTermTerm = t1 }) (CellTerm { cellTermTerm = t2 }) = do + wt <- liftIO . SC.scNat sc $ cellTermWidth c1 + res <- liftIO $ f wt t1 t2 + pure $ c1 { cellTermTerm = res } + +liftBinaryCmp :: forall m. + MonadIO m => + SC.SharedContext -> + (SC.Term -> SC.Term -> SC.Term -> IO SC.Term) -> -- (w : Nat) -> [w] -> [w] -> Bool + CellTerm -> CellTerm -> m SC.Term +liftBinaryCmp sc f c1@(CellTerm { cellTermTerm = t1 }) (CellTerm { cellTermTerm = t2 }) = do + wt <- liftIO . SC.scNat sc $ cellTermWidth c1 + liftIO $ f wt t1 t2 + -- | Given a primitive Yosys cell and a map of terms for its arguments, construct a record term representing the output. -- If the provided cell is not a primitive, return Nothing. primCellToTerm :: @@ -47,15 +123,15 @@ primCellToTerm :: Map Text SC.Term {- ^ Mapping of input names to input terms -} -> m (Maybe SC.Term) primCellToTerm sc c args = traverse (validateTerm sc typeCheckMsg) =<< case c ^. cellType of - "$not" -> bvUnaryOp $ SC.scBvNot sc + "$not" -> bvUnaryOp . liftUnary sc $ SC.scBvNot sc "$pos" -> do res <- input "A" output res - "$neg" -> bvUnaryOp $ SC.scBvNeg sc - "$and" -> bvBinaryOp $ SC.scBvAnd sc - "$or" -> bvBinaryOp $ SC.scBvOr sc - "$xor" -> bvBinaryOp $ SC.scBvXor sc - "$xnor" -> bvBinaryOp $ \w x y -> do + "$neg" -> bvUnaryOp . liftUnary sc $ SC.scBvNeg sc + "$and" -> bvBinaryOp . liftBinary sc $ SC.scBvAnd sc + "$or" -> bvBinaryOp . liftBinary sc $ SC.scBvOr sc + "$xor" -> bvBinaryOp . liftBinary sc $ SC.scBvXor sc + "$xnor" -> bvBinaryOp . liftBinary sc $ \w x y -> do r <- SC.scBvXor sc w x y SC.scBvNot sc w r "$reduce_and" -> bvReduce True =<< do @@ -76,81 +152,120 @@ primCellToTerm sc c args = traverse (validateTerm sc typeCheckMsg) =<< case c ^. "$reduce_bool" -> bvReduce False =<< do liftIO . SC.scLookupDef sc $ SC.mkIdent SC.preludeName "or" "$shl" -> do - ta <- input "A" - nb <- inputNat "B" + ta <- fmap cellTermTerm . flipEndianness sc =<< input "A" + nb <- cellTermNat sc =<< flipEndianness sc =<< input "B" w <- outputWidth res <- liftIO $ SC.scBvShl sc w ta nb - output res + output =<< flipEndianness sc (CellTerm res (connWidthNat "A") (connSigned "A")) "$shr" -> do - ta <- input "A" - nb <- inputNat "B" + ta <- fmap cellTermTerm . flipEndianness sc =<< input "A" + nb <- cellTermNat sc =<< flipEndianness sc =<< input "B" w <- outputWidth res <- liftIO $ SC.scBvShr sc w ta nb - output res + output =<< flipEndianness sc (CellTerm res (connWidthNat "A") (connSigned "A")) "$sshl" -> do - ta <- input "A" - nb <- inputNat "B" + ta <- fmap cellTermTerm . flipEndianness sc =<< input "A" + nb <- cellTermNat sc =<< flipEndianness sc =<< input "B" w <- outputWidth res <- liftIO $ SC.scBvShl sc w ta nb - output res + output =<< flipEndianness sc (CellTerm res (connWidthNat "A") (connSigned "A")) "$sshr" -> do - ta <- input "A" - nb <- inputNat "B" + ta <- fmap cellTermTerm . flipEndianness sc =<< input "A" + nb <- cellTermNat sc =<< flipEndianness sc =<< input "B" w <- outputWidth res <- liftIO $ SC.scBvSShr sc w ta nb - output res + output =<< flipEndianness sc (CellTerm res (connWidthNat "A") (connSigned "A")) -- "$shift" -> _ - -- "$shiftx" -> _ - "$lt" -> bvBinaryCmp $ SC.scBvULt sc - "$le" -> bvBinaryCmp $ SC.scBvULe sc - "$gt" -> bvBinaryCmp $ SC.scBvUGt sc - "$ge" -> bvBinaryCmp $ SC.scBvUGe sc - "$eq" -> bvBinaryCmp $ SC.scBvEq sc - "$ne" -> bvBinaryCmp $ \w x y -> do + "$shiftx" -> do + let w = max (connWidthNat "A") (connWidthNat "B") + wt <- liftIO $ SC.scNat sc w + CellTerm ta _ _ <- extTrunc sc w =<< flipEndianness sc =<< input "A" + CellTerm tb _ _ <- extTrunc sc w =<< flipEndianness sc =<< input "B" + zero <- liftIO $ SC.scBvConst sc w 0 + tbn <- liftIO $ SC.scBvToNat sc w tb + tbneg <- liftIO $ SC.scBvNeg sc wt tb + tbnegn <- liftIO $ SC.scBvToNat sc w tbneg + cond <- liftIO $ SC.scBvSGe sc wt tb zero + tcase <- liftIO $ SC.scBvShr sc wt ta tbn + ecase <- liftIO $ SC.scBvShl sc wt ta tbnegn + ty <- liftIO . SC.scBitvector sc $ connWidthNat "A" + res <- if connSigned "B" + then liftIO $ SC.scIte sc ty cond tcase ecase + else pure tcase + output =<< flipEndianness sc (CellTerm res (connWidthNat "A") (connSigned "A")) + "$lt" -> bvBinaryCmp . liftBinaryCmp sc $ SC.scBvULt sc + "$le" -> bvBinaryCmp . liftBinaryCmp sc $ SC.scBvULe sc + "$gt" -> bvBinaryCmp . liftBinaryCmp sc $ SC.scBvUGt sc + "$ge" -> bvBinaryCmp . liftBinaryCmp sc $ SC.scBvUGe sc + "$eq" -> bvBinaryCmp . liftBinaryCmp sc $ SC.scBvEq sc + "$ne" -> bvBinaryCmp . liftBinaryCmp sc $ \w x y -> do r <- SC.scBvEq sc w x y SC.scNot sc r - "$eqx" -> bvBinaryCmp $ SC.scBvEq sc - "$nex" -> bvBinaryCmp $ \w x y -> do + "$eqx" -> bvBinaryCmp . liftBinaryCmp sc $ SC.scBvEq sc + "$nex" -> bvBinaryCmp . liftBinaryCmp sc $ \w x y -> do r <- SC.scBvEq sc w x y SC.scNot sc r - "$add" -> bvBinaryArithOp $ SC.scBvAdd sc - "$sub" -> bvBinaryArithOp $ SC.scBvSub sc - "$mul" -> bvBinaryArithOp $ SC.scBvMul sc - "$div" -> bvBinaryArithOp $ SC.scBvUDiv sc - "$mod" -> bvBinaryArithOp $ SC.scBvURem sc + "$add" -> bvBinaryOp . liftBinary sc $ SC.scBvAdd sc + "$sub" -> bvBinaryOp . liftBinary sc $ SC.scBvSub sc + "$mul" -> bvBinaryOp . liftBinary sc $ SC.scBvMul sc + "$div" -> bvBinaryOp . liftBinary sc $ SC.scBvUDiv sc + "$mod" -> bvBinaryOp . liftBinary sc $ SC.scBvURem sc -- "$modfloor" -> _ "$logic_not" -> do - w <- outputWidth - ta <- input "A" + w <- connWidth "A" + ta <- cellTermTerm <$> input "A" anz <- liftIO $ SC.scBvNonzero sc w ta res <- liftIO $ SC.scNot sc anz outputBit res - "$logic_and" -> do - w <- outputWidth - ta <- inputRaw "A" - tb <- inputRaw "B" - anz <- liftIO $ SC.scBvNonzero sc w ta - bnz <- liftIO $ SC.scBvNonzero sc w tb - res <- liftIO $ SC.scAnd sc anz bnz - outputBit res - "$logic_or" -> do - w <- outputWidth - ta <- input "A" - tb <- input "B" - anz <- liftIO $ SC.scBvNonzero sc w ta - bnz <- liftIO $ SC.scBvNonzero sc w tb - res <- liftIO $ SC.scOr sc anz bnz - outputBit res + "$logic_and" -> bvBinaryCmp . liftBinaryCmp sc $ \w x y -> do + xnz <- liftIO $ SC.scBvNonzero sc w x + ynz <- liftIO $ SC.scBvNonzero sc w y + liftIO $ SC.scAnd sc xnz ynz + "$logic_or" -> bvBinaryCmp . liftBinaryCmp sc $ \w x y -> do + xnz <- liftIO $ SC.scBvNonzero sc w x + ynz <- liftIO $ SC.scBvNonzero sc w y + liftIO $ SC.scOr sc xnz ynz "$mux" -> do - ta <- input "A" - tb <- input "B" - ts <- inputRaw "S" + ta <- cellTermTerm <$> input "A" + tb <- cellTermTerm <$> input "B" + ts <- cellTermTerm <$> input "S" swidth <- connWidth "S" snz <- liftIO $ SC.scBvNonzero sc swidth ts - ty <- liftIO $ SC.scBitvector sc outputWidthNat + let width = connWidthNat "Y" + ty <- liftIO $ SC.scBitvector sc width res <- liftIO $ SC.scIte sc ty snz tb ta - output res - "$pmux" -> throw YosysErrorUnsupportedPmux + output $ CellTerm res (connWidthNat "A") (connSigned "A") + "$pmux" -> do + ta <- cellTermTerm <$> input "A" + tb <- cellTermTerm <$> input "B" + ts <- cellTermTerm <$> input "S" + + width <- connWidth "A" + widthBv <- liftIO . SC.scBitvector sc $ connWidthNat "A" + swidth <- connWidth "S" + bool <- liftIO $ SC.scBoolType sc + nat <- liftIO $ SC.scNatType sc + splitb <- liftIO $ SC.scSplit sc swidth width bool tb + zero <- liftIO $ SC.scNat sc 0 + accTy <- liftIO $ SC.scPairType sc nat widthBv + defaultAcc <- liftIO $ SC.scPairValue sc zero ta + + bitEC <- liftIO $ SC.scFreshEC sc "bit" bool + accEC <- liftIO $ SC.scFreshEC sc "acc" accTy + fun <- liftIO . SC.scAbstractExts sc [bitEC, accEC] =<< do + bit <- liftIO $ SC.scExtCns sc bitEC + acc <- liftIO $ SC.scExtCns sc accEC + idx <- liftIO $ SC.scPairLeft sc acc + aval <- liftIO $ SC.scPairRight sc acc + bval <- liftIO $ SC.scAtWithDefault sc swidth widthBv aval splitb idx + newidx <- liftIO $ SC.scAddNat sc idx width + newval <- liftIO $ SC.scIte sc widthBv bit bval aval + liftIO $ SC.scPairValue sc newidx newval + + scFoldr <- liftIO . SC.scLookupDef sc $ SC.mkIdent SC.preludeName "foldr" + resPair <- liftIO $ SC.scApplyAll sc scFoldr [bool, accTy, swidth, fun, defaultAcc, ts] + res <- liftIO $ SC.scPairRight sc resPair + output $ CellTerm res (connWidthNat "A") (connSigned "Y") "$adff" -> throw $ YosysErrorUnsupportedFF "$adff" "$sdff" -> throw $ YosysErrorUnsupportedFF "$sdff" "$aldff" -> throw $ YosysErrorUnsupportedFF "$aldff" @@ -173,6 +288,7 @@ primCellToTerm sc c args = traverse (validateTerm sc typeCheckMsg) =<< case c ^. typeCheckMsg = mconcat [ "translating a cell with type \"", nm, "\"" ] + textBinNat :: Text -> Natural textBinNat = fromIntegral . Text.foldl' (\a x -> digitToInt x + a * 2) 0 connSigned :: Text -> Bool @@ -187,55 +303,22 @@ primCellToTerm sc c args = traverse (validateTerm sc typeCheckMsg) =<< case c ^. Just bits -> fromIntegral $ length bits connWidth :: Text -> m SC.Term connWidth onm = liftIO . SC.scNat sc $ connWidthNat onm - outputWidthNat = connWidthNat "Y" outputWidth = connWidth "Y" - extTrunc :: Text -> SC.Term -> m SC.Term - extTrunc onm t = do - let bvw = connWidthNat onm - let width = outputWidthNat - let signed = connSigned onm - if - | bvw > width -> do - wterm <- liftIO $ SC.scNat sc width - diffterm <- liftIO . SC.scNat sc $ bvw - width - liftIO $ SC.scBvTrunc sc diffterm wterm t - | width > bvw && signed -> do - bvwpredterm <- liftIO . SC.scNat sc $ bvw - 1 - diffterm <- liftIO . SC.scNat sc $ width - bvw - liftIO $ SC.scBvSExt sc diffterm bvwpredterm t - | width > bvw && not signed -> do - bvwterm <- liftIO $ SC.scNat sc bvw - diffterm <- liftIO . SC.scNat sc $ width - bvw - liftIO $ SC.scBvUExt sc diffterm bvwterm t - | otherwise -> pure t - inputRaw :: Text -> m SC.Term - inputRaw inpNm = - case Map.lookup inpNm args of - Nothing -> panic "cellToTerm" [Text.unpack $ mconcat [nm, " missing input ", inpNm]] - Just a -> pure a - input :: Text -> m SC.Term - input inpNm = extTrunc inpNm =<< inputRaw inpNm - inputRev :: Text -> m SC.Term - inputRev inpNm = do - raw <- inputRaw inpNm - w <- connWidth inpNm - bool <- liftIO $ SC.scBoolType sc - rev <- liftIO $ SC.scGlobalApply sc "Prelude.reverse" [w, bool, raw] - extTrunc inpNm rev - inputNat :: Text -> m SC.Term - inputNat inpNm = do - raw <- inputRaw inpNm - w <- connWidth inpNm - bool <- liftIO $ SC.scBoolType sc - rev <- liftIO $ SC.scGlobalApply sc "Prelude.reverse" [w, bool, raw] - -- note bvToNat is big-endian while yosys shifts expect little-endian - liftIO $ SC.scGlobalApply sc "Prelude.bvToNat" [w, rev] - output :: SC.Term -> m (Maybe SC.Term) - output res = do - eres <- extTrunc "Y" res + + input :: Text -> m CellTerm + input inpNm = case Map.lookup inpNm args of + Nothing -> panic "cellToTerm" [Text.unpack $ mconcat [nm, " missing input ", inpNm]] + Just a -> pure $ CellTerm a (connWidthNat inpNm) (connSigned inpNm) + + output :: CellTerm -> m (Maybe SC.Term) + output (CellTerm ct cw _) = do + let res = CellTerm ct cw (connSigned "Y") + eres <- extTrunc sc (connWidthNat "Y") =<< flipEndianness sc res + CellTerm t _ _ <- flipEndianness sc eres fmap Just . cryptolRecord sc $ Map.fromList - [ ("Y", eres) + [ ("Y", t) ] + outputBit :: SC.Term -> m (Maybe SC.Term) outputBit res = do bool <- liftIO $ SC.scBoolType sc @@ -243,41 +326,32 @@ primCellToTerm sc c args = traverse (validateTerm sc typeCheckMsg) =<< case c ^. fmap Just . cryptolRecord sc $ Map.fromList [ ("Y", vres) ] - bvUnaryOp :: (SC.Term -> SC.Term -> IO SC.Term) -> m (Maybe SC.Term) + + -- convert input to big endian + bvUnaryOp :: (CellTerm -> m CellTerm) -> m (Maybe SC.Term) bvUnaryOp f = do - t <- input "A" - w <- outputWidth - res <- liftIO $ f w t - output res - bvBinaryOp :: (SC.Term -> SC.Term -> SC.Term -> IO SC.Term) -> m (Maybe SC.Term) + t <- flipEndianness sc =<< input "A" + res <- f t + output =<< flipEndianness sc res + -- convert inputs to big endian and extend inputs to output width + bvBinaryOp :: (CellTerm -> CellTerm -> m CellTerm) -> m (Maybe SC.Term) bvBinaryOp f = do - w <- outputWidth - ta <- input "A" - tb <- input "B" - res <- liftIO $ f w ta tb - output res - bvBinaryArithOp :: (SC.Term -> SC.Term -> SC.Term -> IO SC.Term) -> m (Maybe SC.Term) - bvBinaryArithOp f = do - w <- outputWidth - bool <- liftIO $ SC.scBoolType sc - ta <- inputRev "A" - tb <- inputRev "B" - res <- liftIO $ f w ta tb - revres <- liftIO $ SC.scGlobalApply sc "Prelude.reverse" [w, bool, res] - output revres - bvBinaryCmp :: (SC.Term -> SC.Term -> SC.Term -> IO SC.Term) -> m (Maybe SC.Term) + let w = connWidthNat "Y" + ta <- extTrunc sc w =<< flipEndianness sc =<< input "A" + tb <- extTrunc sc w =<< flipEndianness sc =<< input "B" + res <- f ta tb + output =<< flipEndianness sc res + -- convert inputs to big endian and extend inputs to max input width, output is a single bit + bvBinaryCmp :: (CellTerm -> CellTerm -> m SC.Term) -> m (Maybe SC.Term) bvBinaryCmp f = do - ta <- inputRaw "A" - tb <- inputRaw "B" - w <- connWidth "A" - bit <- liftIO $ f w ta tb - boolty <- liftIO $ SC.scBoolType sc - res <- liftIO $ SC.scSingle sc boolty bit - output res + ta <- flipEndianness sc =<< input "A" + tb <- flipEndianness sc =<< input "B" + res <- uncurry f =<< extMax sc ta tb + outputBit res bvReduce :: Bool -> SC.Term -> m (Maybe SC.Term) bvReduce boolIdentity boolFun = do - t <- input "A" - w <- outputWidth + CellTerm t _ _ <- input "A" + w <- connWidth "A" boolTy <- liftIO $ SC.scBoolType sc identity <- liftIO $ SC.scBool sc boolIdentity scFoldr <- liftIO . SC.scLookupDef sc $ SC.mkIdent SC.preludeName "foldr" From 66875f5b59d52c44b0faa772fc257ea552c8afab Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Mon, 6 Mar 2023 10:03:23 -0500 Subject: [PATCH 05/27] write_aig: Normalize symmetry in multiplication This bumps the `aig` submodule to bring in the changes from GaloisInc/aig#14, which changes how `aig` performs multiplication to swap the order of arguments if the second argument is a constant. This has two benefits: * This ensures that `write_aig` will produce the same networks for `X * C` and `C * X`, where `C` is a constant and `X` is a variable. * The algorithm that `mul` uses to compute multiplication is biased in its order of arguments, and having the first argument be a constant tends to produce networks that ABC has an easier time verifying. (The FFS example under `doc/tutorial/code/ffs.c` is a notable example of this.) I have added a test case to check to see if the test case from #1828 now produces identical AIGs regardless of the order of arguments. Fixes #1828. --- deps/aig | 2 +- intTests/test1828/.gitignore | 2 ++ intTests/test1828/test.saw | 2 ++ intTests/test1828/test.sh | 9 +++++++++ 4 files changed, 14 insertions(+), 1 deletion(-) create mode 100644 intTests/test1828/.gitignore create mode 100644 intTests/test1828/test.saw create mode 100755 intTests/test1828/test.sh diff --git a/deps/aig b/deps/aig index 00f138637d..31da58c944 160000 --- a/deps/aig +++ b/deps/aig @@ -1 +1 @@ -Subproject commit 00f138637d8936566534103878ca895613b7f714 +Subproject commit 31da58c944358bdd7267ed95d1ea85ee375ff491 diff --git a/intTests/test1828/.gitignore b/intTests/test1828/.gitignore new file mode 100644 index 0000000000..2e31392fa5 --- /dev/null +++ b/intTests/test1828/.gitignore @@ -0,0 +1,2 @@ +left.aig +right.aig diff --git a/intTests/test1828/test.saw b/intTests/test1828/test.saw new file mode 100644 index 0000000000..f839820e50 --- /dev/null +++ b/intTests/test1828/test.saw @@ -0,0 +1,2 @@ +write_aig "left.aig" {{ \x -> x * 0x12345678 }}; +write_aig "right.aig" {{ \x -> 0x12345678 * x }}; diff --git a/intTests/test1828/test.sh b/intTests/test1828/test.sh new file mode 100755 index 0000000000..a914d55337 --- /dev/null +++ b/intTests/test1828/test.sh @@ -0,0 +1,9 @@ +set -e + +# This test case uses `write_aiger` to produce AIG files for two nearly +# identical functions, where the only difference is the order of arguments (one +# symbolic and one concrete) in a bitvector multiplication. If the `aig` library +# does its job correctly, these should produce identical AIG files, so check +# this using `diff`. +$SAW test.saw +diff -ru left.aig right.aig From 5c837724d8f1435583a8c49e8a5601418a0c271a Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Thu, 9 Mar 2023 10:06:17 -0500 Subject: [PATCH 06/27] Add test case for #1788 The fix for #1828 also addresses many of the symptoms of #1788, so let's add a test case to ensure that those symptoms remain cured. --- intTests/test1788/Makefile | 17 +++++++++++++++++ intTests/test1788/test.bc | Bin 0 -> 2788 bytes intTests/test1788/test.c | 5 +++++ intTests/test1788/test.saw | 13 +++++++++++++ intTests/test1788/test.sh | 3 +++ 5 files changed, 38 insertions(+) create mode 100644 intTests/test1788/Makefile create mode 100644 intTests/test1788/test.bc create mode 100644 intTests/test1788/test.c create mode 100644 intTests/test1788/test.saw create mode 100755 intTests/test1788/test.sh diff --git a/intTests/test1788/Makefile b/intTests/test1788/Makefile new file mode 100644 index 0000000000..1a3bb3f6a4 --- /dev/null +++ b/intTests/test1788/Makefile @@ -0,0 +1,17 @@ +CC = clang +CFLAGS = -g -frecord-command-line -O0 + +all: test.bc test.exe + +test.bc: test.c + $(CC) $(CFLAGS) -c -emit-llvm $< -o $@ + +test.o: test.c + $(CC) $(CFLAGS) -c $< -o $@ + +test.exe: test.o + $(CC) $(CFLAGS) $< -o $@ + +.PHONY: clean +clean: + rm -f test.bc test.exe diff --git a/intTests/test1788/test.bc b/intTests/test1788/test.bc new file mode 100644 index 0000000000000000000000000000000000000000..8d2870d93b7a92c94964b81896792265dac28789 GIT binary patch literal 2788 zcma)8ZA@F&89tY5I1ZR=^P$8f*UoiFBCCz@#U#YUumPqmS(yS^wPji-Y>dHfz}UY2 z!pWvi_cNG(F82%!N5zyDj`|J~5H|8f09MW5J10ZpesC{%(_ zMTrhUhjv26vHJ5J3$o*7DpSh^Dxo+~DzDSZ-X0KDFO_s&sOU_nOtogY`qgq%XR_Nn zr>pO(mQt#Y3nhaK@~gF+_2ne@A!X`Js9(^(kZwFX_4;{kZUN-J#UTX8A=5tj4sP&G zSZ?MiPmRzofN#&-!KYtAp}c5^ zp5_!uUj&b*CBGU+ZPHm6Jsy#wUhLOnzl-*F<1^hbmYOqCB#omkS`ejXm*maj0Ltsw zWxIBf;udt8Egd@-(=1L_KG3nZW11BkI~&u$DiY*4l#%>ME~F)|O9GjZh!pVRs2-0a zvWMc9C)q8#b_HoSC)s%rHOa0_vul%@*%St*>Bnr})0 z4oBNDV$iJS-el$N8BHFf5ebzmI`#pjc`igAj!4bDQq+YbE;=g5KAYsv;Ax^N99m>w z)v>Gpi#;O+%s5)r&B-X~E=8*nswKuQBLdEm%D}!$Jh} zly)Tx&etwcyyUe><9aM!ftKhK<_ibeq_7-EpC`a_R!$P?o2a^-3Zf?fh~toJ1P3(} zwoXV_RCADM{It}PjW>&u4+06{yn@fV;(}L-F5AlQFO@yYVraKH97Z_GV}BM493DkV zzZd%oV?r!$fPmX@Ad5rocr?vGOQuU@TOx+U^l><{RQ6cJQ56mq84Ih|RM;=#-8zN4 zCvo_T*>pJv8WJT*k)smz$*NvTCX!j9w4>@hvU8vAKxi;V2xU-B+Ki&EswbV=aqyLS znRUXiPwdmjtI<`k_vf(QBp2Dab#|zhYD-$piCn5vgdD*_#;4dq%10{ZiO4i5I>FPB z5$q6OTG$rflc(DjtZgZ}Egwk%IL^rNc(>#Qlz8b-MDlV{UA~HWm}b^_rH5B;Y%|-v zOp|I(a}OY>)6CknL;PEo58{?3Ys+=I^@Dh8g0|$hYeP1C#)Xd(*x{oh$rP^*hx9n~ zv=qdKMX6sd`P7gv(s(9z= zn%QVqu5-*ou!7TTR%f)c9opM~yqI=%4KiKxDWx4!_nD`x$1cS!`QH6s8v=P3!I4Z~ z&y%#0ctHDxcG1p0&}r_?XnstQ`y;Q@Y}?CTdoym%=PXm!HgL$7v#py}OA@BJ)bGo| zQYj4jK>h-VGqKkik(+_g;kiGc~V|{Pgl_2?{ucK!d~R8XI*Q{eojG z5HNO)IfA23Pe3qs+a0Ifo?+;P)6S6*qhJpk1c%@44H(^?z-z!N7>R(!qh_;X#O@j9 zLQcQn9`kUGd;@%j!@+@|ClGApy25t<5cl2UYL{~$ILsaQ42?abgdHxszh7`ioyMTx zH;%Xmj3XnVQ9~nd9B_M#McIa7&M@S6I>!8i2FKXwsNFMY7;$@?oZ$q|862F!IqD7= z2p?CpiZhHAM*|L2FBkansudb2v+boSIpS$PC#pVF#7`b- zQl!r3Rf;B=l#(6P?`m%TZSyYE)uwl@{-&?wU_F_>bK~f*j@>ZrYPvCX?bm%j!RJoe z9oJ3^$Ln7d-rI8^T|Gc%b!SeWt`O=SuL>{jIgml`1McBzMHS`nMuy?aIpxh*+W;0* z)|RE*#1=abFJcFQ`<6~q%+sBRH*Cx&y^#LOO#%YtC%w!QqVh+o;vIwYt(W7LO8_dm zEgNqIfTeTfAH&We^gZZnWF3cKYvJmW9dT=R{~e*f@CaFew(pgNbe}eP9EPZi<=)8h z6dDbV1PXC*dmJOdL8mcdZtibBOq?Bz7=}GT2ns}A2n<3N7=qAv8eF7nGWGvIjDc~l zQ)qDY_dnwadIa~d$2rJ>j0i%%yqtR<4Xfi+J5ssP8YOm=+9r&~gS!j&Et=|($NA+hxu`}P)v=E+=@cdC)Gl>RqMmB1LblZG6ji05 z`2jEDeArKLi6PKLp(f4RjO8oWz^J ereSbkxM9! + +uint32_t mult(uint32_t x) { + return x * 0x85EBCA77U; +} diff --git a/intTests/test1788/test.saw b/intTests/test1788/test.saw new file mode 100644 index 0000000000..ceb9626201 --- /dev/null +++ b/intTests/test1788/test.saw @@ -0,0 +1,13 @@ +// This test case ensures that ABC can prove that a C implementation of the +// `mult` function is equivalent to a direct Cryptol implementation of the +// same function. + +let +{{ +cryptol_mult : [32] -> [32] +cryptol_mult x = x * 0x85EBCA77 +}}; + +m <- llvm_load_module "test.bc"; +llvm_mult <- llvm_extract m "mult"; +prove abc {{ \x -> llvm_mult x == cryptol_mult x }}; diff --git a/intTests/test1788/test.sh b/intTests/test1788/test.sh new file mode 100755 index 0000000000..2315cc233c --- /dev/null +++ b/intTests/test1788/test.sh @@ -0,0 +1,3 @@ +set -e + +$SAW test.saw From 6331e5577da24b78e6420695555d260c3de9bf19 Mon Sep 17 00:00:00 2001 From: Brett Boston Date: Sun, 12 Mar 2023 15:40:41 -0700 Subject: [PATCH 07/27] Expand help text for `llvm_compositional_extract` to cover arguments This change adds a description of every argument that `llvm_compositional_extract` expects to the `:h` text for the command. --- src/SAWScript/Interpreter.hs | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/src/SAWScript/Interpreter.hs b/src/SAWScript/Interpreter.hs index e4cb1dede8..742ded7b74 100644 --- a/src/SAWScript/Interpreter.hs +++ b/src/SAWScript/Interpreter.hs @@ -2744,7 +2744,20 @@ primitives = Map.fromList , "`llvm_points_to`). The Term is the tuple consisting of the" , "output parameters of the LLVM function: the return parameter, then" , "the parameters passed by reference (in the order given by" - , "`llvm_points_to`). For more flexibility, see `llvm_verify`." + , "`llvm_points_to`)." + , "" + , "In order, the arguments to `llvm_compositional_extract` are:" + , " 1. The LLVM module containing the function to extract." + , " 2. The name of the function to extract." + , " 3. The name of the `Term` to generate." + , " 4. A list of overrides to use in the memory safety proof in the 7th" + , " argument." + , " 5. Whether to perform path satisfiability checks." + , " 6. Memory layout specification for the extracted function." + , " 7. Proof that the extracted function satisfies the memory" + , " specification in the 6th argument." + , "" + , "For more flexibility, see `llvm_verify`." ] , prim "crucible_llvm_compositional_extract" "LLVMModule -> String -> String -> [LLVMSpec] -> Bool -> LLVMSetup () -> ProofScript () -> TopLevel LLVMSpec" From 7582a4b20321d069e51a680b0ff2f16544727cec Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Fri, 10 Mar 2023 11:39:43 -0500 Subject: [PATCH 08/27] Bump crucible, language-sally, what4 submodules --- deps/crucible | 2 +- deps/language-sally | 2 +- deps/what4 | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/deps/crucible b/deps/crucible index 7501d6b62b..a946dc99b6 160000 --- a/deps/crucible +++ b/deps/crucible @@ -1 +1 @@ -Subproject commit 7501d6b62be53fec0a1da4d92749c300c19da23a +Subproject commit a946dc99b68baf0e24ad87bd187847cc2e0ead89 diff --git a/deps/language-sally b/deps/language-sally index de4f979032..a217a9f661 160000 --- a/deps/language-sally +++ b/deps/language-sally @@ -1 +1 @@ -Subproject commit de4f979032396b2c8fa1b5d05603c47dd96874e2 +Subproject commit a217a9f661caabd7858a17c2b556217fc39a946e diff --git a/deps/what4 b/deps/what4 index 4af08d1762..6f5e0fe9be 160000 --- a/deps/what4 +++ b/deps/what4 @@ -1 +1 @@ -Subproject commit 4af08d1762a60ff4d36adf6a98481fe5910a72d6 +Subproject commit 6f5e0fe9bef58234603ccf6914c32ea1ba2f9766 From 9bc0a22d0206ebaa66cf324972e35fe8b53bebeb Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Fri, 10 Mar 2023 11:49:39 -0500 Subject: [PATCH 09/27] Bump crucible submodule to bring in crucible-mir changes This bumps the `crucible` submodule to bring in the changes from GaloisInc/crucible#1066, which splits out `crucible-mir` from `crux-mir`. --- cabal.project | 1 + crux-mir-comp/crux-mir-comp.cabal | 1 + deps/crucible | 2 +- 3 files changed, 3 insertions(+), 1 deletion(-) diff --git a/cabal.project b/cabal.project index 8a20405818..2b62235786 100644 --- a/cabal.project +++ b/cabal.project @@ -23,6 +23,7 @@ packages: deps/crucible/crucible-concurrency deps/crucible/crucible-jvm deps/crucible/crucible-llvm + deps/crucible/crucible-mir deps/crucible/crucible-symio deps/crucible/crucible-syntax deps/crucible/crux diff --git a/crux-mir-comp/crux-mir-comp.cabal b/crux-mir-comp/crux-mir-comp.cabal index fbb95ec9f9..945462b3b2 100644 --- a/crux-mir-comp/crux-mir-comp.cabal +++ b/crux-mir-comp/crux-mir-comp.cabal @@ -37,6 +37,7 @@ library bv-sized, bytestring, crux, + crucible-mir, crux-mir, template-haskell, saw-core, diff --git a/deps/crucible b/deps/crucible index a946dc99b6..4b8e481f98 160000 --- a/deps/crucible +++ b/deps/crucible @@ -1 +1 @@ -Subproject commit a946dc99b68baf0e24ad87bd187847cc2e0ead89 +Subproject commit 4b8e481f986e2ba2125032edf05dda407dbb57b8 From b2c4bb12b77067d4d46465380ba7e6ba36446776 Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Fri, 10 Mar 2023 12:16:25 -0500 Subject: [PATCH 10/27] Split out crucible-mir-comp from crux-mir-comp For the most part, most code was moved wholesale from `crux-mir-comp` with only minor changes. This fixes #1839. This also adds basic `README` and `LICENSE` files for `crucible-mir-comp` and `crux-mir-comp`, thereby fixing #1616. --- cabal.project | 1 + crucible-mir-comp/LICENSE | 30 ++++++++++++ crucible-mir-comp/README.md | 4 ++ crucible-mir-comp/crucible-mir-comp.cabal | 47 +++++++++++++++++++ .../src/Mir/Compositional/Builder.hs | 0 .../src/Mir/Compositional/Clobber.hs | 0 .../src/Mir/Compositional/Convert.hs | 0 .../src/Mir/Compositional/MethodSpec.hs | 0 .../src/Mir/Compositional/Override.hs | 0 crux-mir-comp/LICENSE | 30 ++++++++++++ crux-mir-comp/README.md | 4 ++ crux-mir-comp/crux-mir-comp.cabal | 21 ++------- 12 files changed, 119 insertions(+), 18 deletions(-) create mode 100644 crucible-mir-comp/LICENSE create mode 100644 crucible-mir-comp/README.md create mode 100644 crucible-mir-comp/crucible-mir-comp.cabal rename {crux-mir-comp => crucible-mir-comp}/src/Mir/Compositional/Builder.hs (100%) rename {crux-mir-comp => crucible-mir-comp}/src/Mir/Compositional/Clobber.hs (100%) rename {crux-mir-comp => crucible-mir-comp}/src/Mir/Compositional/Convert.hs (100%) rename {crux-mir-comp => crucible-mir-comp}/src/Mir/Compositional/MethodSpec.hs (100%) rename {crux-mir-comp => crucible-mir-comp}/src/Mir/Compositional/Override.hs (100%) create mode 100644 crux-mir-comp/LICENSE create mode 100644 crux-mir-comp/README.md diff --git a/cabal.project b/cabal.project index 2b62235786..7ed7119a69 100644 --- a/cabal.project +++ b/cabal.project @@ -1,6 +1,7 @@ packages: saw-script.cabal saw-remote-api + crucible-mir-comp crux-mir-comp cryptol-saw-core rme diff --git a/crucible-mir-comp/LICENSE b/crucible-mir-comp/LICENSE new file mode 100644 index 0000000000..e8f247d2ce --- /dev/null +++ b/crucible-mir-comp/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2017-2023 Galois, Inc. + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of the authors nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/crucible-mir-comp/README.md b/crucible-mir-comp/README.md new file mode 100644 index 0000000000..299ab18dd0 --- /dev/null +++ b/crucible-mir-comp/README.md @@ -0,0 +1,4 @@ +# crucible-mir-comp + +This package implements support for compositional verification in +[`crucible-mir`](https://github.com/GaloisInc/crucible/blob/master/crucible-mir). diff --git a/crucible-mir-comp/crucible-mir-comp.cabal b/crucible-mir-comp/crucible-mir-comp.cabal new file mode 100644 index 0000000000..6e4220cce1 --- /dev/null +++ b/crucible-mir-comp/crucible-mir-comp.cabal @@ -0,0 +1,47 @@ +name: crucible-mir-comp +version: 0.1 +-- synopsis: +-- description: +homepage: https://github.com/GaloisInc/saw-script/blob/master/crucible-mir-comp/README.md +license: BSD3 +license-file: LICENSE +author: Joshua Gancher, + Rob Dockins, + Andrey Chudnov, + Stephanie Weirich, + Stuart Pernsteiner +maintainer: spernsteiner@galois.com +copyright: 2017-2023 Galois, Inc. +category: Web +build-type: Simple +cabal-version: >=1.10 +extra-source-files: README.md + +library + default-language: Haskell2010 + build-depends: base >= 4.9 && < 5, + text, + prettyprinter >= 1.7.0, + crucible, + parameterized-utils >= 1.0.8, + containers, + lens, + vector, + mtl, + what4, + bv-sized, + bytestring, + crucible-mir, + saw-core, + saw-core-what4, + cryptol-saw-core, + saw-script + + hs-source-dirs: src + exposed-modules: Mir.Compositional.Builder + Mir.Compositional.Clobber + Mir.Compositional.Convert + Mir.Compositional.MethodSpec + Mir.Compositional.Override + + ghc-options: -Wall -Wno-name-shadowing diff --git a/crux-mir-comp/src/Mir/Compositional/Builder.hs b/crucible-mir-comp/src/Mir/Compositional/Builder.hs similarity index 100% rename from crux-mir-comp/src/Mir/Compositional/Builder.hs rename to crucible-mir-comp/src/Mir/Compositional/Builder.hs diff --git a/crux-mir-comp/src/Mir/Compositional/Clobber.hs b/crucible-mir-comp/src/Mir/Compositional/Clobber.hs similarity index 100% rename from crux-mir-comp/src/Mir/Compositional/Clobber.hs rename to crucible-mir-comp/src/Mir/Compositional/Clobber.hs diff --git a/crux-mir-comp/src/Mir/Compositional/Convert.hs b/crucible-mir-comp/src/Mir/Compositional/Convert.hs similarity index 100% rename from crux-mir-comp/src/Mir/Compositional/Convert.hs rename to crucible-mir-comp/src/Mir/Compositional/Convert.hs diff --git a/crux-mir-comp/src/Mir/Compositional/MethodSpec.hs b/crucible-mir-comp/src/Mir/Compositional/MethodSpec.hs similarity index 100% rename from crux-mir-comp/src/Mir/Compositional/MethodSpec.hs rename to crucible-mir-comp/src/Mir/Compositional/MethodSpec.hs diff --git a/crux-mir-comp/src/Mir/Compositional/Override.hs b/crucible-mir-comp/src/Mir/Compositional/Override.hs similarity index 100% rename from crux-mir-comp/src/Mir/Compositional/Override.hs rename to crucible-mir-comp/src/Mir/Compositional/Override.hs diff --git a/crux-mir-comp/LICENSE b/crux-mir-comp/LICENSE new file mode 100644 index 0000000000..e8f247d2ce --- /dev/null +++ b/crux-mir-comp/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2017-2023 Galois, Inc. + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of the authors nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/crux-mir-comp/README.md b/crux-mir-comp/README.md new file mode 100644 index 0000000000..80533c947b --- /dev/null +++ b/crux-mir-comp/README.md @@ -0,0 +1,4 @@ +# crux-mir-comp + +This package implements a Crux frontend for +[`crucible-mir-comp`](https://github.com/GaloisInc/saw-script/blob/master/crux-mir-comp). diff --git a/crux-mir-comp/crux-mir-comp.cabal b/crux-mir-comp/crux-mir-comp.cabal index 945462b3b2..ce6056da60 100644 --- a/crux-mir-comp/crux-mir-comp.cabal +++ b/crux-mir-comp/crux-mir-comp.cabal @@ -11,7 +11,7 @@ author: Joshua Gancher, Stephanie Weirich, Stuart Pernsteiner maintainer: spernsteiner@galois.com -copyright: 2017-2020 Galois, Inc. +copyright: 2017-2023 Galois, Inc. category: Web build-type: Simple cabal-version: >=1.10 @@ -21,38 +21,23 @@ library default-language: Haskell2010 build-depends: base >= 4.9 && < 5, text, - prettyprinter >= 1.7.0, crucible, parameterized-utils >= 1.0.8, containers, lens, - vector, - mtl, - transformers, what4, - tasty >= 0.10, - tasty-hunit >= 0.10, - tasty-quickcheck >= 0.8, - tasty-golden >= 2.3, - bv-sized, bytestring, crux, crucible-mir, + crucible-mir-comp, crux-mir, - template-haskell, saw-core, saw-core-what4, cryptol, - cryptol-saw-core, - saw-script + cryptol-saw-core hs-source-dirs: src exposed-modules: Mir.Compositional - Mir.Compositional.Builder - Mir.Compositional.Clobber - Mir.Compositional.Convert - Mir.Compositional.MethodSpec - Mir.Compositional.Override Mir.Cryptol ghc-options: -Wall -Wno-name-shadowing From cda0117152b77c3150aa0862d16333af4b1fd101 Mon Sep 17 00:00:00 2001 From: Brett Boston Date: Tue, 14 Mar 2023 15:16:01 -0700 Subject: [PATCH 11/27] Name arguments and clarify that 7th argument is a proof *strategy* --- src/SAWScript/Interpreter.hs | 21 +++++++++++---------- 1 file changed, 11 insertions(+), 10 deletions(-) diff --git a/src/SAWScript/Interpreter.hs b/src/SAWScript/Interpreter.hs index 742ded7b74..005b97a2b3 100644 --- a/src/SAWScript/Interpreter.hs +++ b/src/SAWScript/Interpreter.hs @@ -2746,16 +2746,17 @@ primitives = Map.fromList , "the parameters passed by reference (in the order given by" , "`llvm_points_to`)." , "" - , "In order, the arguments to `llvm_compositional_extract` are:" - , " 1. The LLVM module containing the function to extract." - , " 2. The name of the function to extract." - , " 3. The name of the `Term` to generate." - , " 4. A list of overrides to use in the memory safety proof in the 7th" - , " argument." - , " 5. Whether to perform path satisfiability checks." - , " 6. Memory layout specification for the extracted function." - , " 7. Proof that the extracted function satisfies the memory" - , " specification in the 6th argument." + , "When invoking `llvm_compositional_extract mod fn_name term_name ovs" + , "check_path_sat spec strat`, the arguments represent the following:" + , " 1. `mod`: The LLVM module containing the function to extract." + , " 2. `fn_name`: The name of the function to extract." + , " 3. `term_name`: The name of the `Term` to generate." + , " 4. `ovs`: A list of overrides to use in the proof that the extracted" + , " function satisifies `spec`." + , " 5. `check_path_sat`: Whether to perform path satisfiability checks." + , " 6. `spec`: SAW specification for the extracted function." + , " 7. `strat`: Proof strategy to use when verifying that the extracted" + , " function satisfies `spec`." , "" , "For more flexibility, see `llvm_verify`." ] From 4fb3fd215d4614c3d3cb23fb1222fb8ed0a15bac Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Fri, 10 Mar 2023 13:02:36 -0500 Subject: [PATCH 12/27] Bump elf-edit, macaw submodules --- deps/elf-edit | 2 +- deps/macaw | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/deps/elf-edit b/deps/elf-edit index d6d26540ed..dc5eabec3c 160000 --- a/deps/elf-edit +++ b/deps/elf-edit @@ -1 +1 @@ -Subproject commit d6d26540ed50348a597720b0015357bde34d504d +Subproject commit dc5eabec3c00df530962ec41391356dc491cb0dc diff --git a/deps/macaw b/deps/macaw index d9525554ca..97c61e471a 160000 --- a/deps/macaw +++ b/deps/macaw @@ -1 +1 @@ -Subproject commit d9525554ca3d6414e20a9f7571e38758ea5a3c3f +Subproject commit 97c61e471aa60a48393bb6496260db416c4dca55 From e74a79a7ea09c0a9813ef10c3dcdb08c5805885e Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Fri, 10 Mar 2023 13:46:20 -0500 Subject: [PATCH 13/27] Adapt to changes in GaloisInc/macaw#327 MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This mostly involves consolidating various `macaw` memory model–related options into a `MemModelConfig` value. Apart from the API changes, there should be no user-visible changes in behavior. --- deps/macaw | 2 +- src/SAWScript/Crucible/LLVM/X86.hs | 15 ++++++++++----- src/SAWScript/X86.hs | 12 +++++++++++- 3 files changed, 22 insertions(+), 7 deletions(-) diff --git a/deps/macaw b/deps/macaw index 97c61e471a..88d024990b 160000 --- a/deps/macaw +++ b/deps/macaw @@ -1 +1 @@ -Subproject commit 97c61e471aa60a48393bb6496260db416c4dca55 +Subproject commit 88d024990b97292f4d3d0fe0bf9c08e75c12c3ce diff --git a/src/SAWScript/Crucible/LLVM/X86.hs b/src/SAWScript/Crucible/LLVM/X86.hs index 76c15dd351..5c2e738a84 100644 --- a/src/SAWScript/Crucible/LLVM/X86.hs +++ b/src/SAWScript/Crucible/LLVM/X86.hs @@ -475,13 +475,18 @@ llvm_verify_x86_common (Some (llvmModule :: LLVMModule x)) path nm globsyms chec archEvalFns = Macaw.x86_64MacawEvalFn sfs Macaw.defaultMacawArchStmtExtensionOverride lookupSyscall = Macaw.unsupportedSyscalls "saw-script" noExtraValidityPred _ _ _ _ = return Nothing + mmConf = Macaw.MemModelConfig + { Macaw.globalMemMap = mkGlobalMap . Map.singleton 0 $ preState ^. x86GlobalBase + , Macaw.lookupFunctionHandle = funcLookup + , Macaw.lookupSyscallHandle = lookupSyscall + , Macaw.mkGlobalPointerValidityAssertion = noExtraValidityPred + , Macaw.resolvePointer = pure + , Macaw.concreteImmutableGlobalRead = \_ _ -> pure Nothing + , Macaw.lazilyPopulateGlobalMem = \_ _ -> pure + } defaultMacawExtensions_x86_64 = Macaw.macawExtensions - archEvalFns mvar - (mkGlobalMap . Map.singleton 0 $ preState ^. x86GlobalBase) - funcLookup - lookupSyscall - noExtraValidityPred + archEvalFns mvar mmConf sawMacawExtensions = defaultMacawExtensions_x86_64 { C.extensionExec = \s0 st -> case s0 of Macaw.PtrLt w x y -> doPtrCmp W4.bvUlt st mvar w x y diff --git a/src/SAWScript/X86.hs b/src/SAWScript/X86.hs index 0718323463..e61a44b0dd 100644 --- a/src/SAWScript/X86.hs +++ b/src/SAWScript/X86.hs @@ -106,6 +106,7 @@ import Data.Macaw.Symbolic( ArchRegStruct , GlobalMap , MacawSimulatorState(..) , macawExtensions + , MemModelConfig(..) , unsupportedSyscalls , defaultMacawArchStmtExtensionOverride ) @@ -491,13 +492,22 @@ doSim opts elf sfs name (globs,overs) st checkPost = let noExtraValidityPred _ _ _ _ = return Nothing let archEvalFns = x86_64MacawEvalFn sfs defaultMacawArchStmtExtensionOverride let lookupSyscall = unsupportedSyscalls "saw-script" + let mmConf = MemModelConfig + { globalMemMap = globs + , lookupFunctionHandle = callHandler overs sym + , lookupSyscallHandle = lookupSyscall + , mkGlobalPointerValidityAssertion = noExtraValidityPred + , resolvePointer = pure + , concreteImmutableGlobalRead = \_ _ -> pure Nothing + , lazilyPopulateGlobalMem = \_ _ -> pure + } let ctx :: SimContext (MacawSimulatorState Sym) Sym (MacawExt X86_64) ctx = SimContext { _ctxBackend = backend opts , ctxSolverProof = \a -> a , ctxIntrinsicTypes = llvmIntrinsicTypes , simHandleAllocator = allocator opts , printHandle = stdout - , extensionImpl = macawExtensions archEvalFns mvar globs (callHandler overs sym) lookupSyscall noExtraValidityPred + , extensionImpl = macawExtensions archEvalFns mvar mmConf , _functionBindings = FnBindings $ insertHandleMap (cfgHandle cfg) (UseCFG cfg (postdomInfo cfg)) emptyHandleMap , _cruciblePersonality = MacawSimulatorState From bee96b924b5ddf913dfc0c88fae4a22db5d694b2 Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Sat, 9 Jul 2022 12:37:46 -0400 Subject: [PATCH 14/27] Support GHC 9.2 This contains a variety of minor changes needed to make `saw` and its supporting libraries compile with GHC 9.2: * One place in `heapster-saw` matches on a GADT using a `let` binding, which no longer typechecks in GHC 9.2. While somewhat mysterious, using `let` bindings to match on GADTs is fragile anyway, so I opted to simply replace this with a monadic `do` match, which does not exhibit the same fragility. * GHC now includes `-Wincomplete-uni-patterns` in `-Wall` as of 9.2, so much of this patch is dedicated to silencing these sorts of warnings, usually by adding explicit fall-through cases for partial pattern matches. * GHC now inclues `-Wnoncanonical-monad-instances` in `-Wall` as of 9.2, so I had to refactor some `Applicative`/`Monad` instances to fix these warnings. * GHC 9.2 now defines `readBin` in `Numeric`, which clashes with a function of the same name in `SAWScript.Lexer`. Using explicit imports avoids this. * GHC's pattern-match coverage checker is smarter in 9.2 (see [here](https://gitlab.haskell.org/ghc/ghc/-/wikis/migration/9.2?version_id=63085dd8a5b56370571bda428848e7098765f7f8#improved-pattern-match-coverage-checker)), so I had to use `EmptyCase` to silence some of the new `-Wincomplete-patterns` warnings that were uncovered in `heapster-saw`. --- README.md | 2 +- heapster-saw/heapster-saw.cabal | 2 +- .../src/Verifier/SAW/Heapster/CruUtil.hs | 2 + .../src/Verifier/SAW/Heapster/Permissions.hs | 4 ++ .../Verifier/SAW/Heapster/SAWTranslation.hs | 2 +- .../src/Verifier/SAW/Heapster/Widening.hs | 6 +- .../Verifier/SAW/Translation/Coq/SAWModule.hs | 15 ++++- saw-core-sbv/saw-core-sbv.cabal | 2 +- saw-core/saw-core.cabal | 2 +- saw-core/src/Verifier/SAW/Change.hs | 21 +++---- saw-core/src/Verifier/SAW/Conversion.hs | 4 +- saw-core/src/Verifier/SAW/Rewriter.hs | 17 ++++-- saw-core/src/Verifier/SAW/TermNet.hs | 6 +- saw-core/src/Verifier/SAW/UnionFind.hs | 55 +++++++++++++------ saw-remote-api/saw-remote-api.cabal | 4 +- saw-remote-api/src/SAWServer/Yosys.hs | 5 +- saw-script.cabal | 6 +- saw/SAWScript/REPL/Command.hs | 2 + saw/SAWScript/REPL/Monad.hs | 4 +- src/SAWScript/Crucible/LLVM/Builtins.hs | 5 +- src/SAWScript/Interpreter.hs | 6 +- src/SAWScript/Lexer.x | 2 +- src/SAWScript/MGU.hs | 26 +++++++++ src/SAWScript/Prover/MRSolver/Monad.hs | 37 +++++++++++-- src/SAWScript/Prover/MRSolver/Solver.hs | 22 ++++---- src/SAWScript/SBVParser.hs | 10 +++- src/SAWScript/VerificationSummary.hs | 4 +- src/SAWScript/X86Spec.hs | 19 +++++-- 28 files changed, 208 insertions(+), 84 deletions(-) diff --git a/README.md b/README.md index 9aed46475a..b701a747e6 100644 --- a/README.md +++ b/README.md @@ -42,7 +42,7 @@ To build SAWScript and related utilities from source: * Ensure that you have the `cabal` and `ghc` executables in your `PATH`. If you don't already have them, we recommend using `ghcup` to install them: . We recommend - Cabal 3.4 or newer, and GHC 8.8, 8.10, or 9.0. + Cabal 3.4 or newer, and GHC 8.8, 8.10, 9.0, or 9.2. * Ensure that you have the C libraries and header files for `terminfo`, which generally comes as part of `ncurses` on most diff --git a/heapster-saw/heapster-saw.cabal b/heapster-saw/heapster-saw.cabal index de796b54d1..613f7dd0a9 100644 --- a/heapster-saw/heapster-saw.cabal +++ b/heapster-saw/heapster-saw.cabal @@ -38,7 +38,7 @@ library filepath, language-rust, hobbits ^>= 1.4, - aeson ^>= 1.5, + aeson >= 1.5 && < 2.1, th-abstraction, template-haskell, extra diff --git a/heapster-saw/src/Verifier/SAW/Heapster/CruUtil.hs b/heapster-saw/src/Verifier/SAW/Heapster/CruUtil.hs index a864a538d7..a5941f520e 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/CruUtil.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/CruUtil.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE EmptyCase #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} @@ -731,6 +732,7 @@ cruCtxLen (CruCtxCons ctx _) = 1 + cruCtxLen ctx -- | Look up a type in a 'CruCtx' cruCtxLookup :: CruCtx ctx -> Member ctx a -> TypeRepr a +cruCtxLookup CruCtxNil m = case m of {} cruCtxLookup (CruCtxCons _ tp) Member_Base = tp cruCtxLookup (CruCtxCons ctx _) (Member_Step memb) = cruCtxLookup ctx memb diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs index 44926339bc..3925b582a0 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs @@ -3115,6 +3115,7 @@ addPermOffsets (LLVMPermOffset off1) (LLVMPermOffset off2) = -- | Get the @n@th expression in a 'PermExprs' list nthPermExpr :: PermExprs args -> Member args a -> PermExpr a +nthPermExpr PExprs_Nil m = case m of {} nthPermExpr (PExprs_Cons _ arg) Member_Base = arg nthPermExpr (PExprs_Cons args _) (Member_Step memb) = nthPermExpr args memb @@ -3122,6 +3123,8 @@ nthPermExpr (PExprs_Cons args _) (Member_Step memb) = -- | Set the @n@th expression in a 'PermExprs' list setNthPermExpr :: PermExprs args -> Member args a -> PermExpr a -> PermExprs args +setNthPermExpr PExprs_Nil m _ = + case m of {} setNthPermExpr (PExprs_Cons args _) Member_Base a = PExprs_Cons args a setNthPermExpr (PExprs_Cons args arg) (Member_Step memb) a = @@ -7204,6 +7207,7 @@ permVarSubstToNames PermVarSubst_Nil = MNil permVarSubstToNames (PermVarSubst_Cons s n) = permVarSubstToNames s :>: n varSubstLookup :: PermVarSubst ctx -> Member ctx a -> ExprVar a +varSubstLookup PermVarSubst_Nil m = case m of {} varSubstLookup (PermVarSubst_Cons _ x) Member_Base = x varSubstLookup (PermVarSubst_Cons s _) (Member_Step memb) = varSubstLookup s memb diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index aad0829292..2377d8cd09 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -3109,7 +3109,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of let prxs2 = mbRAssignProxies ps2 let prxs_in = RL.append prxs1 prxs2 :>: Proxy pctx <- itiPermStack <$> ask - let (pctx_ps, pctx12 :>: ptrans_l) = RL.split ps0 prxs_in pctx + (pctx_ps, pctx12 :>: ptrans_l) <- pure $ RL.split ps0 prxs_in pctx let (pctx1, pctx2) = RL.split prxs1 prxs2 pctx12 -- Also split out the input variables and replace them with the ps_out vars diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Widening.hs b/heapster-saw/src/Verifier/SAW/Heapster/Widening.hs index 9e0b12bec2..0e61cea46c 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Widening.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Widening.hs @@ -128,11 +128,11 @@ instance Functor (PolyContT r m) where fmap f m = m >>= return . f instance Applicative (PolyContT r m) where - pure = return + pure x = PolyContT $ \k -> k x (<*>) = ap instance Monad (PolyContT r m) where - return x = PolyContT $ \k -> k x + return = pure (PolyContT m) >>= f = PolyContT $ \k -> m $ \a -> runPolyContT (f a) k @@ -480,7 +480,7 @@ widenExprs (CruCtxCons tps tp) (es1 :>: e1) (es2 :>: e2) = -- | Widen two bitvector offsets by trying to widen them additively --- ('widenBVsAddy'), or if that is not possible, by widening them +-- ('widenBVsAddy'), or if that is not possible, by widening them -- multiplicatively ('widenBVsMulty') widenOffsets :: (1 <= w, KnownNat w) => TypeRepr (BVType w) -> PermOffset (LLVMPointerType w) -> diff --git a/saw-core-coq/src/Verifier/SAW/Translation/Coq/SAWModule.hs b/saw-core-coq/src/Verifier/SAW/Translation/Coq/SAWModule.hs index e41414db15..60c7c617c9 100644 --- a/saw-core-coq/src/Verifier/SAW/Translation/Coq/SAWModule.hs +++ b/saw-core-coq/src/Verifier/SAW/Translation/Coq/SAWModule.hs @@ -96,7 +96,20 @@ translateDataType (DataType {..}) = liftTermTranslationMonad $ do ps <- TermTranslation.translateParams dtParams ixs <- TermTranslation.translateParams dtIndices - return (ps, map (\(Coq.Binder s (Just t)) -> Coq.PiBinder (Just s) t) ixs) + -- Translating the indices of a data type should never yield + -- Inhabited constraints, so the result of calling + -- `translateParams dtIndices` above should only return Binders and not + -- any ImplicitBinders. Moreover, `translateParams` always returns + -- Binders where the second field is `Just t`, where `t` is the type. + let errorBecause msg = error $ "translateDataType.translateNamed: " ++ msg + let bs = map (\case Coq.Binder s (Just t) -> + Coq.PiBinder (Just s) t + Coq.Binder _ Nothing -> + errorBecause "encountered a Binder without a Type" + Coq.ImplicitBinder{} -> + errorBecause "encountered an implicit binder") + ixs + return (ps, bs) let inductiveSort = TermTranslation.translateSort dtSort inductiveConstructors <- mapM (translateCtor inductiveParameters) dtCtors return $ Coq.InductiveDecl $ Coq.Inductive diff --git a/saw-core-sbv/saw-core-sbv.cabal b/saw-core-sbv/saw-core-sbv.cabal index bc2cb9c205..1cc5448ab4 100644 --- a/saw-core-sbv/saw-core-sbv.cabal +++ b/saw-core-sbv/saw-core-sbv.cabal @@ -20,7 +20,7 @@ library lens, mtl, saw-core, - sbv >= 8.10 && < 8.16, + sbv >= 8.10 && < 9.1, text, transformers, vector diff --git a/saw-core/saw-core.cabal b/saw-core/saw-core.cabal index 82b90875a7..9e6d9d77d9 100644 --- a/saw-core/saw-core.cabal +++ b/saw-core/saw-core.cabal @@ -24,7 +24,7 @@ library happy >= 1.9.6 build-depends: - base == 4.*, + base >= 4.8, array, bytestring, containers, diff --git a/saw-core/src/Verifier/SAW/Change.hs b/saw-core/src/Verifier/SAW/Change.hs index aa7a4e51bb..d2af8fb388 100644 --- a/saw-core/src/Verifier/SAW/Change.hs +++ b/saw-core/src/Verifier/SAW/Change.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -25,10 +24,8 @@ module Verifier.SAW.Change , flatten ) where -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif -import Control.Monad (liftM, liftM2) +import Control.Applicative (liftA2) +import Control.Monad (liftM) import Control.Monad.Trans ---------------------------------------------------------------------- @@ -84,7 +81,7 @@ instance Applicative Change where Modified f <*> Modified x = Modified (f x) instance Monad Change where - return x = Original x + return = pure Original x >>= k = k x Modified x >>= k = taint (k x) @@ -108,15 +105,15 @@ commitChange (Modified x) = x newtype ChangeT m a = ChangeT { runChangeT :: m (Change a) } -instance Monad m => Functor (ChangeT m) where - fmap f (ChangeT m) = ChangeT (liftM (fmap f) m) +instance Functor m => Functor (ChangeT m) where + fmap f (ChangeT m) = ChangeT (fmap (fmap f) m) -instance Monad m => Applicative (ChangeT m) where - pure x = ChangeT (return (Original x)) - ChangeT m1 <*> ChangeT m2 = ChangeT (liftM2 (<*>) m1 m2) +instance Applicative m => Applicative (ChangeT m) where + pure x = ChangeT (pure (Original x)) + ChangeT m1 <*> ChangeT m2 = ChangeT (liftA2 (<*>) m1 m2) instance Monad m => Monad (ChangeT m) where - return x = ChangeT (return (Original x)) + return = pure ChangeT m >>= k = ChangeT (m >>= f) where f (Original x) = runChangeT (k x) f (Modified x) = runChangeT (k x) >>= (return . taint) diff --git a/saw-core/src/Verifier/SAW/Conversion.hs b/saw-core/src/Verifier/SAW/Conversion.hs index 2d6e2615d4..c8b647c83c 100644 --- a/saw-core/src/Verifier/SAW/Conversion.hs +++ b/saw-core/src/Verifier/SAW/Conversion.hs @@ -361,13 +361,13 @@ instance Monad TermBuilder where m >>= h = TermBuilder $ \mg mk -> do r <- runTermBuilder m mg mk runTermBuilder (h r) mg mk - return v = TermBuilder $ \_ _ -> return v + return = pure instance Functor TermBuilder where fmap = liftM instance Applicative TermBuilder where - pure = return + pure v = TermBuilder $ \_ _ -> pure v (<*>) = ap mkTermF :: TermF Term -> TermBuilder Term diff --git a/saw-core/src/Verifier/SAW/Rewriter.hs b/saw-core/src/Verifier/SAW/Rewriter.hs index c21d5f12e9..dff781e9e4 100644 --- a/saw-core/src/Verifier/SAW/Rewriter.hs +++ b/saw-core/src/Verifier/SAW/Rewriter.hs @@ -260,7 +260,11 @@ scMatch sc pat term = guard (fvy `unionBitSets` fvj == fvj) let fixVar t (nm, ty) = do v <- scFreshGlobal sc nm ty - let Just ec = R.asExtCns v + -- asExtCns should always return Just here because + -- scFreshGlobal always returns an ExtCns. + ec <- case R.asExtCns v of + Just ec -> pure ec + Nothing -> error "scMatch.match: impossible" t' <- instantiateVar sc 0 v t return (t', ec) let fixVars t [] = return (t, []) @@ -975,10 +979,13 @@ doHoistIfs sc ss hoistCache itePat = go top :: Term -> TermF Term -> IO (HoistIfs s) top t tf | Just inst <- first_order_match itePat t = do - let Just branch_tp = Map.lookup 0 inst - let Just cond = Map.lookup 1 inst - let Just then_branch = Map.lookup 2 inst - let Just else_branch = Map.lookup 3 inst + -- All of these Map lookups should be safe due to the term + -- structure of an if-then-else expression. + let err = error "doHoistIfs.top: impossible" + let branch_tp = Map.findWithDefault err 0 inst + let cond = Map.findWithDefault err 1 inst + let then_branch = Map.findWithDefault err 2 inst + let else_branch = Map.findWithDefault err 3 inst (then_branch',conds1) <- go then_branch (else_branch',conds2) <- go else_branch diff --git a/saw-core/src/Verifier/SAW/TermNet.hs b/saw-core/src/Verifier/SAW/TermNet.hs index 3c7a6dd101..50e112ff73 100644 --- a/saw-core/src/Verifier/SAW/TermNet.hs +++ b/saw-core/src/Verifier/SAW/TermNet.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} @@ -250,8 +251,11 @@ matching unif = match Var -> nets App t1 t2 -> foldr (match t2) nets (rands t1 comb []) +{- Invariant: Each list entry must be a Leaf. -} extract_leaves :: [Net a] -> [a] -extract_leaves = concatMap (\(Leaf xs) -> xs) +extract_leaves = concatMap $ \case + Leaf xs -> xs + Net{} -> error "extract_leaves: Unexpected Net node" {-return items whose key could match t, WHICH MUST BE BETA-ETA NORMAL-} match_term :: Pattern t => Net a -> t -> [a] diff --git a/saw-core/src/Verifier/SAW/UnionFind.hs b/saw-core/src/Verifier/SAW/UnionFind.hs index 1615bf1da5..6ab5da2589 100644 --- a/saw-core/src/Verifier/SAW/UnionFind.hs +++ b/saw-core/src/Verifier/SAW/UnionFind.hs @@ -85,6 +85,26 @@ classRep (Class r) = UF $ do return (Class i) impl r [] +-- | Look up an equivalence class in a union find structure's map. This checks +-- the invariant that the index of the class exists in the map and is associated +-- with a 'Rep', not a 'NonRep'. If this invariant is violated, this function +-- will throw an error. +lookupClassRep :: Class d -> UnionFind d -> ([ClassIndex], Int, d) +lookupClassRep (Class rC) uf = + case Map.lookup rC (ufsMap uf) of + Just (Rep ne sz d) -> + (ne, sz, d) + Just (NonRep i) -> + errorBecause $ unlines + [ "not associated with a class representative," + , "but rather an element with index " ++ show i + ] + Nothing -> + errorBecause "not found in map" + where + errorBecause msg = error $ + "lookupClassRep: Equivalence class index " ++ show rC ++ " " ++ msg + -- | Creates a new class with the given descriptor. freshClass :: d -> Action d (Class d) freshClass d = UF $ do @@ -118,14 +138,14 @@ setEqual :: Class d -> d -- ^ Descriptor for union class. -> Action d AssertResult setEqual x y d = do - Class xr <- classRep x - Class yr <- classRep y + xc@(Class xr) <- classRep x + yc@(Class yr) <- classRep y if xr == yr then return AssertRedundant else do - m <- UF $ gets ufsMap - let Rep xne xsz _xd = m Map.! xr - let Rep yne ysz _yd = m Map.! yr + uf <- UF get + let (xne, xsz, _xd) = lookupClassRep xc uf + let (yne, ysz, _yd) = lookupClassRep yc uf xElts <- fmap (map toClassIdx) $ mapM classRep (map Class xne) yElts <- fmap (map toClassIdx) $ mapM classRep (map Class yne) if xr `elem` yElts || yr `elem` xElts @@ -151,14 +171,14 @@ setEqual x y d = do -- previously set equal. setUnequal :: Class d -> Class d -> Action d AssertResult setUnequal x y = do - Class xr <- classRep x - Class yr <- classRep y + xc@(Class xr) <- classRep x + yc@(Class yr) <- classRep y if xr == yr then return AssertFailed else do - m <- UF $ gets ufsMap - let Rep xne xsz xd = m Map.! xr - let Rep yne _ _ = m Map.! yr + uf <- UF get + let (xne, xsz, xd) = lookupClassRep xc uf + let (yne, _, _) = lookupClassRep yc uf xElts <- fmap (map toClassIdx) $ mapM classRep (map Class xne) yElts <- fmap (map toClassIdx) $ mapM classRep (map Class yne) if xr `elem` yElts || yr `elem` xElts @@ -172,24 +192,23 @@ setUnequal x y = do -- | Get a class description readClassDesc :: Class d -> Action d d readClassDesc c = do - Class rC <- classRep c - m <- UF $ gets ufsMap - let Rep _ _ desc = m Map.! rC + rCls <- classRep c + s <- UF get + let (_, _, desc) = lookupClassRep rCls s return desc -- | Set a class description writeClassDesc :: Class d -> d -> Action d () writeClassDesc c d = do - Class rC <- classRep c + rCls@(Class rC) <- classRep c UF $ modify $ \s -> - let Rep dis sz _ = (ufsMap s) Map.! rC + let (dis, sz, _) = lookupClassRep rCls s in s { ufsMap = Map.insert rC (Rep dis sz d) (ufsMap s) } -- | Modify a class description modifyClassDesc :: Class d -> (d -> d) -> Action d () modifyClassDesc c fn = do - Class rC <- classRep c + rCls@(Class rC) <- classRep c UF $ modify $ \s -> - let Rep dis sz desc = (ufsMap s) Map.! rC + let (dis, sz, desc) = lookupClassRep rCls s in s { ufsMap = Map.insert rC (Rep dis sz (fn desc)) (ufsMap s) } - diff --git a/saw-remote-api/saw-remote-api.cabal b/saw-remote-api/saw-remote-api.cabal index a903c5b63f..7cdf6084f3 100644 --- a/saw-remote-api/saw-remote-api.cabal +++ b/saw-remote-api/saw-remote-api.cabal @@ -34,8 +34,8 @@ common errors -Werror=overlapping-patterns common deps - build-depends: base >=4.11.1.0 && <4.16, - aeson >= 1.4.2 && < 2.0, + build-depends: base >=4.11.1.0 && <4.17, + aeson >= 1.4.2 && < 2.1, aig, argo, base64-bytestring, diff --git a/saw-remote-api/src/SAWServer/Yosys.hs b/saw-remote-api/src/SAWServer/Yosys.hs index f227c8fbf1..7f54632690 100644 --- a/saw-remote-api/src/SAWServer/Yosys.hs +++ b/saw-remote-api/src/SAWServer/Yosys.hs @@ -110,7 +110,10 @@ yosysVerify params = do [] -> do fileReader <- Argo.getFileReader YosysImport imp <- getYosysImport $ yosysVerifyImport params - let Just modTerm = Map.lookup (yosysVerifyModule params) imp + let modu = yosysVerifyModule params + modTerm <- case Map.lookup modu imp of + Just modTerm -> pure modTerm + Nothing -> error $ "Module " ++ show modu ++ " not found" lemmas <- mapM getYosysTheorem $ yosysVerifyLemmas params proofScript <- interpretProofScript $ yosysVerifyScript params cexp <- getCryptolExpr $ yosysVerifySpec params diff --git a/saw-script.cabal b/saw-script.cabal index 5f739f5146..c3e726c100 100644 --- a/saw-script.cabal +++ b/saw-script.cabal @@ -22,8 +22,8 @@ custom-setup library default-language: Haskell2010 build-depends: - base >= 4 - , aeson >= 1.4.2 && < 2.0 + base >= 4.9 + , aeson >= 2.0 && < 2.1 , aig , array , binary @@ -80,7 +80,7 @@ library , saw-core-coq , saw-core-sbv , saw-core-what4 - , sbv >= 8.10 && < 8.16 + , sbv >= 8.10 && < 9.1 , split , temporary , template-haskell diff --git a/saw/SAWScript/REPL/Command.hs b/saw/SAWScript/REPL/Command.hs index 2c6c6413c4..31aff23112 100644 --- a/saw/SAWScript/REPL/Command.hs +++ b/saw/SAWScript/REPL/Command.hs @@ -8,6 +8,8 @@ Stability : provisional {-# LANGUAGE CPP, PatternGuards, FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} +-- TODO RGS: Do better (or at least comment why we do this) +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} module SAWScript.REPL.Command ( -- * Commands diff --git a/saw/SAWScript/REPL/Monad.hs b/saw/SAWScript/REPL/Monad.hs index 74e5b03638..294ea88e60 100644 --- a/saw/SAWScript/REPL/Monad.hs +++ b/saw/SAWScript/REPL/Monad.hs @@ -193,7 +193,7 @@ instance Functor REPL where instance Monad REPL where {-# INLINE return #-} - return x = REPL (\_ -> return x) + return = pure {-# INLINE (>>=) #-} m >>= f = REPL $ \ref -> do @@ -210,7 +210,7 @@ instance Fail.MonadFail REPL where instance Applicative REPL where {-# INLINE pure #-} - pure = return + pure x = REPL (\_ -> pure x) {-# INLINE (<*>) #-} (<*>) = ap diff --git a/src/SAWScript/Crucible/LLVM/Builtins.hs b/src/SAWScript/Crucible/LLVM/Builtins.hs index 732401b9f8..aa8591b13a 100644 --- a/src/SAWScript/Crucible/LLVM/Builtins.hs +++ b/src/SAWScript/Crucible/LLVM/Builtins.hs @@ -945,7 +945,10 @@ verifyPrestate opts cc mspec globals = liftIO $ W4.setCurrentProgramLoc sym prestateLoc let lvar = Crucible.llvmMemVar (ccLLVMContext cc) - let Just mem = Crucible.lookupGlobal lvar globals + mem <- + case Crucible.lookupGlobal lvar globals of + Nothing -> fail "internal error: LLVM Memory global not found" + Just mem -> pure mem -- Allocate LLVM memory for each 'llvm_alloc' (env, mem') <- runStateT diff --git a/src/SAWScript/Interpreter.hs b/src/SAWScript/Interpreter.hs index 005b97a2b3..9304a0da5c 100644 --- a/src/SAWScript/Interpreter.hs +++ b/src/SAWScript/Interpreter.hs @@ -20,6 +20,8 @@ Stability : provisional {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE NondecreasingIndentation #-} +-- See Note [-Wincomplete-uni-patterns and irrefutable patterns] in SAWScript.MGU +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module SAWScript.Interpreter ( interpretStmt @@ -390,10 +392,10 @@ interpretStmt printBinds stmt = putTopLevelRW $ addTypedef (getVal name) ty rw interpretFile :: FilePath -> Bool {- ^ run main? -} -> TopLevel () -interpretFile file runMain = +interpretFile file runMain = bracketTopLevel (io getCurrentDirectory) (io . setCurrentDirectory) (const interp) where - interp = + interp = do opts <- getOptions io $ setCurrentDirectory (takeDirectory file) stmts <- io $ SAWScript.Import.loadFile opts file diff --git a/src/SAWScript/Lexer.x b/src/SAWScript/Lexer.x index a0814e8a43..23a02cc3f4 100644 --- a/src/SAWScript/Lexer.x +++ b/src/SAWScript/Lexer.x @@ -17,7 +17,7 @@ import SAWScript.Token import SAWScript.Position import SAWScript.Utils -import Numeric +import Numeric (readInt) import Data.List } diff --git a/src/SAWScript/MGU.hs b/src/SAWScript/MGU.hs index 74130f878f..47ab549f28 100644 --- a/src/SAWScript/MGU.hs +++ b/src/SAWScript/MGU.hs @@ -11,6 +11,8 @@ Stability : provisional {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TupleSections #-} +-- See Note [-Wincomplete-uni-patterns and irrefutable patterns] +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module SAWScript.MGU ( checkDecl @@ -682,3 +684,27 @@ runTIWithEnv env tenv pos m = (a, subst rw, errors rw) (a,rw) = runState m' emptyRW -- }}} + +{- +Note [-Wincomplete-uni-patterns and irrefutable patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Various parts of SAW use irrefutable patterns in functions that assume that +their arguments have particular shapes. For example, inferDecl in this module +matches on ~[(e1,s)] with an irrefutable pattern because it assumes the +invariant that the list will have exactly one element. This lets inferDecl be +slightly lazier when evaluated. + +Unfortunately, this use of irrefutable patterns is at odds with the +-Wincomplete-uni-patterns warning. At present, -Wincomplete-uni-patterns will +produce a warning for any irrefutable pattern that does not cover all possible +data constructors. While we could rewrite functions like `inferDecl` to +explicitly provide a fall-through case, that would change its strictness +properties. As a result, we simply disable -Wincomplete-uni-patterns warnings +in each part of SAW that uses irrefutable patterns. + +Arguably, -Wincomplete-uni-patterns shouldn't be producing warnings for +irrefutable patterns at all. GHC issue #14800 +(https://gitlab.haskell.org/ghc/ghc/-/issues/14800) proposes this idea. +If that issue is fixed in the future, we may want to reconsider whether we want +to disable -Wincomplete-uni-patterns. +-} diff --git a/src/SAWScript/Prover/MRSolver/Monad.hs b/src/SAWScript/Prover/MRSolver/Monad.hs index 7ead557815..f025f2b724 100644 --- a/src/SAWScript/Prover/MRSolver/Monad.hs +++ b/src/SAWScript/Prover/MRSolver/Monad.hs @@ -92,7 +92,7 @@ pattern TermsNotEq t1 t2 = TermsNotRel False t1 t2 pattern TypesNotEq :: Type -> Type -> MRFailure pattern TypesNotEq t1 t2 = TypesNotRel False t1 t2 --- | Remove the context from a 'MRFailure', i.e. remove all applications of the +-- | Remove the context from a 'MRFailure', i.e. remove all applications of the -- 'MRFailureLocalVar' and 'MRFailureCtx' constructors mrFailureWithoutCtx :: MRFailure -> MRFailure mrFailureWithoutCtx (MRFailureLocalVar x err) = @@ -265,7 +265,7 @@ coIndHypWithVar (CoIndHyp ctx f1 f2 args1 args2 invar1 invar2) nm tp = let ctx' = mrVarCtxAppend (singletonMRVarCtx nm tp) ctx (args1', args2') <- liftTermLike 0 1 (args1, args2) return (CoIndHyp ctx' f1 f2 args1' args2' invar1 invar2, var) - + -- | A map from pairs of function names to co-inductive hypotheses over those -- names type CoIndHyps = Map (FunName, FunName) CoIndHyp @@ -292,7 +292,7 @@ data DataTypeAssump deriving (Generic, Show, TermLike) instance PrettyInCtx DataTypeAssump where - prettyInCtx (IsLeft x) = prettyInCtx x >>= ppWithPrefix "Left _ _" + prettyInCtx (IsLeft x) = prettyInCtx x >>= ppWithPrefix "Left _ _" prettyInCtx (IsRight x) = prettyInCtx x >>= ppWithPrefix "Right _ _" prettyInCtx (IsNum x) = prettyInCtx x >>= ppWithPrefix "TCNum" prettyInCtx IsInf = return "TCInf" @@ -485,14 +485,14 @@ mrErrorTerm a str = liftSC2 scGlobalApply "Prelude.error" [a, err_str] -- | Create a term representing an application of @Prelude.genBVVecFromVec@, --- where the default value argument is @Prelude.error@ of the given 'T.Text' +-- where the default value argument is @Prelude.error@ of the given 'T.Text' mrGenBVVecFromVec :: Term -> Term -> Term -> T.Text -> Term -> Term -> MRM Term mrGenBVVecFromVec m a v def_err_str n len = do err_tm <- mrErrorTerm a def_err_str liftSC2 scGlobalApply "Prelude.genBVVecFromVec" [m, a, v, err_tm, n, len] -- | Create a term representing an application of @Prelude.genFromBVVec@, --- where the default value argument is @Prelude.error@ of the given 'T.Text' +-- where the default value argument is @Prelude.error@ of the given 'T.Text' mrGenFromBVVec :: Term -> Term -> Term -> Term -> T.Text -> Term -> MRM Term mrGenFromBVVec n len a v def_err_str m = do err_tm <- mrErrorTerm a def_err_str @@ -629,11 +629,36 @@ mrLambdaLift ctx t f = t' <- liftTermLike 0 (length ctx) t f vars t' >>= liftSC2 scLambdaList ctx' +-- Specialized versions of mrLambdaLift that expect a certain number of Term +-- arguments. As an alternative, we could change the type of mrLambdaLift to +-- take a length-indexed vector instead (thereby avoiding partial pattern +-- matches), but that is probably overkill for our needs. + +-- | Call 'mrLambdaLift' with exactly one 'Term' argument. +mrLambdaLift1 :: TermLike tm => (LocalName,Term) -> tm -> + (Term -> tm -> MRM Term) -> MRM Term +mrLambdaLift1 ctx t f = + mrLambdaLift [ctx] t $ \vars t' -> + case vars of + [v] -> f v t' + _ -> error "mrLambdaLift1: Expected exactly one Term argument" + +-- | Call 'mrLambdaLift' with exactly two 'Term' arguments. +mrLambdaLift2 :: TermLike tm => (LocalName,Term) -> (LocalName,Term) -> tm -> + (Term -> Term -> tm -> MRM Term) -> MRM Term +mrLambdaLift2 ctx1 ctx2 t f = + mrLambdaLift [ctx1, ctx2] t $ \vars t' -> + case vars of + [v1, v2] -> f v1 v2 t' + _ -> error "mrLambdaLift2: Expected exactly two Term arguments" + -- | Run a MR Solver computation in a context extended with a universal -- variable, which is passed as a 'Term' to the sub-computation. Note that any -- assumptions made in the sub-computation will be lost when it completes. withUVar :: LocalName -> Type -> (Term -> MRM a) -> MRM a -withUVar nm tp m = withUVars (singletonMRVarCtx nm tp) (\[v] -> m v) +withUVar nm tp m = withUVars (singletonMRVarCtx nm tp) $ \case + [v] -> m v + _ -> error "withUVar: impossible" -- | Run a MR Solver computation in a context extended with a universal variable -- and pass it the lifting (in the sense of 'incVars') of an MR Solver term diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index 8531409d70..9b976ddeda 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -422,7 +422,7 @@ normComp (CompTerm t) = -- Always unfold recursors applied to constructors (asRecursorApp -> Just (rc, crec, _, arg), args) | Just (c, _, cargs) <- asCtorParams arg -> - do hd' <- liftSC4 scReduceRecursor rc crec c cargs + do hd' <- liftSC4 scReduceRecursor rc crec c cargs >>= liftSC1 betaNormalize t' <- mrApplyAll hd' args normCompTerm t' @@ -521,13 +521,13 @@ compFunToTerm (CompFunComp f g) = -- we explicitly unfold @Prelude.composeM@ here so @mrApplyAll@ will -- beta-reduce let nm = maybe "ret_val" id (compFunVarName f) in - mrLambdaLift [(nm, a)] (b, c, f', g') $ \[arg] (b', c', f'', g'') -> + mrLambdaLift1 (nm, a) (b, c, f', g') $ \arg (b', c', f'', g'') -> do app <- mrApplyAll f'' [arg] liftSC2 scGlobalApply "Prelude.bindS" (specMParamsArgs params ++ [b', c', app, g'']) _ -> error "compFunToTerm: type(s) not of the form: a -> SpecM b" compFunToTerm (CompFunReturn params (Type a)) = - mrLambdaLift [("ret_val", a)] a $ \[ret_val] (a') -> + mrLambdaLift1 ("ret_val", a) a $ \ret_val a' -> liftSC2 scGlobalApply "Prelude.retS" (specMParamsArgs params ++ [a', ret_val]) {- @@ -715,7 +715,7 @@ generalizeCoIndHyp hyp all_specs@(arg_spec_0:arg_specs) = -- we need to do is find a @tp@ (and appropriate conversions) such that the -- following diagram holds for all @i@ and @j@ (using the names from the -- previous comment): - -- + -- -- > arg_tp_i arg_tp_0 arg_tp_j -- > ^ ^ ^ ^ -- > \ / \ / @@ -723,7 +723,7 @@ generalizeCoIndHyp hyp all_specs@(arg_spec_0:arg_specs) = -- > ^ ^ -- > \ / -- > tp - -- + -- -- To do this, we simply need to call 'findInjConvs' iteratively as we fold -- through @eq_specs@, and compose the injective conversions appropriately. -- Each step of this iteration is @cbnConvs@, which can be pictured as: @@ -737,7 +737,7 @@ generalizeCoIndHyp hyp all_specs@(arg_spec_0:arg_specs) = -- > c1 \ / c2 -- > \ / -- > tp' - -- + -- -- where @c1@, @c2@, and @tp'@ come from 'findInjConvs' on @tp@ and @tp_i@, -- and the @tp@ and @c_0@ to use for the next (@i+1@th) iteration are @tp'@ -- and @c_0 <> c1@. @@ -940,7 +940,7 @@ mrRefines' m1 (OrS m2 m2') = mrOr (mrRefines m1 m2) (mrRefines m1 m2') mrRefines' (OrS m1 m1') m2 = mrRefines m1 m2 >> mrRefines m1' m2 - + -- FIXME: the following cases don't work unless we either allow evars to be set -- to NormComps or we can turn NormComps back into terms mrRefines' m1@(FunBind (EVarFunName _) _ _) m2 = @@ -1140,8 +1140,8 @@ mrRefinesFun tp1 f1 tp2 f2 = mrDebugPPPrefixSep 1 "mrRefinesFun" f1' "|=" f2' let nm1 = maybe "call_ret_val" id (compFunVarName f1) nm2 = maybe "call_ret_val" id (compFunVarName f2) - f1'' <- mrLambdaLift [(nm1, tp1)] f1' $ \[var] -> flip mrApply var - f2'' <- mrLambdaLift [(nm2, tp2)] f2' $ \[var] -> flip mrApply var + f1'' <- mrLambdaLift1 (nm1, tp1) f1' $ flip mrApply + f2'' <- mrLambdaLift1 (nm2, tp2) f2' $ flip mrApply piTp1 <- mrTypeOf f1'' piTp2 <- mrTypeOf f2'' mrRefinesFunH mrRefines [] piTp1 f1'' piTp2 f2'' @@ -1182,9 +1182,9 @@ mrRefinesFunH k vars piTp1 t1 (asPi -> Just (nm2, tp2@(asEq -> Just (asBoolType -- of an evar with a non-projected value, e.g. evar.1 == val) mrRefinesFunH k vars (asPi -> Just (nm1, asPairType -> Just (tpL1, tpR1), _)) t1 (asPi -> Just (nm2, asPairType -> Just (tpL2, tpR2), _)) t2 = - do t1'' <- mrLambdaLift [(nm1, tpL1), (nm1, tpR1)] t1 $ \[prj1, prj2] t1' -> + do t1'' <- mrLambdaLift2 (nm1, tpL1) (nm1, tpR1) t1 $ \prj1 prj2 t1' -> liftSC2 scPairValue prj1 prj2 >>= mrApply t1' - t2'' <- mrLambdaLift [(nm2, tpL2), (nm2, tpR2)] t2 $ \[prj1, prj2] t2' -> + t2'' <- mrLambdaLift2 (nm2, tpL2) (nm2, tpR2) t2 $ \prj1 prj2 t2' -> liftSC2 scPairValue prj1 prj2 >>= mrApply t2' piTp1' <- mrTypeOf t1'' piTp2' <- mrTypeOf t2'' diff --git a/src/SAWScript/SBVParser.hs b/src/SAWScript/SBVParser.hs index 8f16083c79..3aef0a3277 100644 --- a/src/SAWScript/SBVParser.hs +++ b/src/SAWScript/SBVParser.hs @@ -131,7 +131,10 @@ parseSBVExpr opts sc unint nodes size (SBV.SBVApp operator sbvs) = scGlobalDef sc (mkIdent preludeName (Text.pack name)) args <- mapM (parseSBV sc nodes) sbvs let inSizes = map fst args - (TFun inTyp outTyp) = typ + (inTyp, outTyp) <- + case typ of + TFun inTyp outTyp -> pure (inTyp, outTyp) + _ -> fail "parseSBVExpr: expected function type" unless (sum (typSizes inTyp) == sum (map fromIntegral inSizes)) $ do printOutLn opts Error ("ERROR parseSBVPgm: input size mismatch in " ++ name) printOutFn opts Error (show inTyp) @@ -333,7 +336,10 @@ combineOutputs sc ty xs0 = parseSBVPgm :: Options -> SharedContext -> UnintMap -> SBV.SBVPgm -> IO Term parseSBVPgm opts sc unint (SBV.SBVPgm (_version, irtype, revcmds, _vcs, _warnings, _uninterps)) = - do let (TFun inTyp outTyp) = parseIRType irtype + do (inTyp, outTyp) <- + case parseIRType irtype of + TFun inTyp outTyp -> pure (inTyp, outTyp) + _ -> fail "parseSBVPgm: expected function type" let cmds = reverse revcmds let (assigns, inputs, outputs) = partitionSBVCommands cmds let inSizes = [ size | SBVInput size _ <- inputs ] diff --git a/src/SAWScript/VerificationSummary.hs b/src/SAWScript/VerificationSummary.hs index 7a687f1396..0caae341e7 100644 --- a/src/SAWScript/VerificationSummary.hs +++ b/src/SAWScript/VerificationSummary.hs @@ -18,10 +18,10 @@ module SAWScript.VerificationSummary import Control.Lens ((^.)) import qualified Data.Map as Map import qualified Data.Set as Set -import Data.Text (Text) import Data.String import Prettyprinter import Data.Aeson (encode, (.=), Value(..), object, toJSON) +import Data.Aeson.Key (Key) import qualified Data.ByteString.Lazy.UTF8 as BLU import Data.Parameterized.Nonce @@ -111,7 +111,7 @@ thmToJSON thm = object ([ Just ploc -> [("ploc" .= plocToJSON ploc)] ) -theoremStatus :: TheoremSummary -> [(Text,Value)] +theoremStatus :: TheoremSummary -> [(Key,Value)] theoremStatus summary = case summary of ProvedTheorem stats -> [ ("status" .= ("verified" :: String)) diff --git a/src/SAWScript/X86Spec.hs b/src/SAWScript/X86Spec.hs index d11e3ef2ae..e066fd3569 100644 --- a/src/SAWScript/X86Spec.hs +++ b/src/SAWScript/X86Spec.hs @@ -1107,7 +1107,9 @@ setupGlobals opts gs fs s let alignment = noAlignment -- default to byte-aligned (FIXME, see #338) (p,mem) <- doMalloc bak GlobalAlloc Immutable "Globals" (stateMem s) sz alignment - let Just base = asNat (fst (llvmPointerView p)) + base <- case asNat (fst (llvmPointerView p)) of + Just base -> pure base + Nothing -> error "[setupGlobals] Expected concrete block number from doMalloc" mem1 <- foldM (writeGlob p) mem gs let gMap = mkGlobalMap (Map.singleton 0 p) @@ -1194,7 +1196,9 @@ debugPPReg :: (ToCrucibleType mt ~ LLVMPointerType w) => X86Reg mt -> State -> IO () debugPPReg r s = - do let Just (RV v) = lookupX86Reg r (stateRegs s) + do RV v <- case lookupX86Reg r (stateRegs s) of + Just rv -> pure rv + Nothing -> error $ "[debugPPReg] Could not find register: " ++ show r putStrLn (show r ++ " = " ++ show (ppPtr v)) _debugDumpGoals :: Opts -> IO () @@ -1282,9 +1286,16 @@ overrideMode spec opts s = -- of the stack, as it shold be, so we don't know the correct value. -- It looks like things work, if keep the orignal value instead. - let Just ip0 = lookupX86Reg X86_IP (stateRegs s) - let Just finalRegs = updateX86Reg X86_IP (const ip0) (stateRegs sf) + ip0 <- case lookupX86Reg X86_IP (stateRegs s) of + Just ip0 -> pure ip0 + Nothing -> noIPError + finalRegs <- case updateX86Reg X86_IP (const ip0) (stateRegs sf) of + Just finalRegs -> pure finalRegs + Nothing -> noIPError return sf { stateRegs = finalRegs } + where + noIPError :: a + noIPError = error "[overrideMode] Could not find instruction pointer" From 2ee9159c1a8cd41dfbc692d66724b8afc2498ebc Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 13 Mar 2023 15:01:47 -0700 Subject: [PATCH 15/27] fixed some pattern-matching coverage failures --- .../src/Verifier/SAW/Heapster/Implication.hs | 125 +++++++++++------- 1 file changed, 79 insertions(+), 46 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs b/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs index 392120d423..91ded9fe38 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs @@ -3700,6 +3700,16 @@ getDistPermsProxies = rlToProxies <$> getDistPerms getTopDistPerm :: ExprVar a -> ImplM vars s r (ps :> a) (ps :> a) (ValuePerm a) getTopDistPerm x = use (implStatePerms . topDistPerm x) +-- | Get the top permission in the stack, which is expected to be a conjuction, +-- and return its conjuncts. If it is not a conjunction, raise an 'error', using +-- the supplied 'String' as the caller in the error message. +getTopDistConj :: String -> ExprVar a -> + ImplM vars s r (ps :> a) (ps :> a) [AtomicPerm a] +getTopDistConj caller x = + use (implStatePerms . topDistPerm x) >>>= \case + ValPerm_Conj ps -> return ps + _ -> error (caller ++ ": unexpected non-conjunctive permission") + -- | Get a sequence of the top @N@ permissions on the stack getTopDistPerms :: prx1 ps1 -> RAssign prx2 ps2 -> ImplM vars s r (ps1 :++: ps2) (ps1 :++: ps2) (DistPerms ps2) @@ -4209,8 +4219,10 @@ implIntroStructAllFields :: ImplM vars s r (ps :> StructType ctx) (ps :++: CtxToRList ctx :> StructType ctx) () implIntroStructAllFields x = - getTopDistPerm x >>>= \(ValPerm_Conj1 (Perm_Struct ps)) -> - implIntroStructFields x ps (RL.members ps) + getTopDistPerm x >>>= \case + (ValPerm_Conj1 (Perm_Struct ps)) -> + implIntroStructFields x ps (RL.members ps) + _ -> error "implIntroStructAllFields: malformed input permission" -- | Eliminate a permission @x:ptr((rw,off) |-> p)@ into permissions -- @x:ptr((rw,off) |-> eq(y))@ and @y:p@ for a fresh variable @y@, returning the @@ -6468,10 +6480,12 @@ proveNeededPerm _ (NeededEq eq_perm) = return (Some MNil) proveNeededPerm vars (NeededRange x rng@(MbRangeForLLVMType _ _ _ _)) = proveSomeMbPerm x (someMbPermForRange vars rng) >>> - getTopDistPerm x >>>= \(ValPerm_LLVMBlock bp) -> - case NameSet.toRAssign (findEqVarFieldsInShape (llvmBlockShape bp)) of - NameSet.SomeRAssign ns -> - Some <$> traverseRAssign (\n -> VarAndPerm n <$> getPerm n) ns + getTopDistPerm x >>>= \case + (ValPerm_LLVMBlock bp) -> + case NameSet.toRAssign (findEqVarFieldsInShape (llvmBlockShape bp)) of + NameSet.SomeRAssign ns -> + Some <$> traverseRAssign (\n -> VarAndPerm n <$> getPerm n) ns + _ -> error "proveNeededPerm: expected block permission" -- | Prove the permissions represented by a sequence of 'NeededPerms', returning -- zero or more auxiliary permissions that are also needed @@ -6732,7 +6746,7 @@ proveVarLLVMFieldH2 x (Perm_LLVMField fp) off mb_fp let mb_fp1 = fmap (flip llvmFieldSetContents (ValPerm_Eq (PExpr_Var y))) mb_fp in proveVarLLVMFieldH x (Perm_LLVMField fp') off mb_fp1 >>> - getTopDistPerm x >>>= \(ValPerm_LLVMField fp1) -> + getTopDistPerm x >>>= \p_top1 -> -- Next, prove the rest of mb_fp, at offset off+sz_bytes and with contents -- equal to some variable z @@ -6744,13 +6758,18 @@ proveVarLLVMFieldH2 x (Perm_LLVMField fp) off mb_fp llvmFieldContents = ValPerm_Eq (PExpr_Var z) }) mb_fp in withExtVarsM (proveVarImplInt x $ mbValPerm_LLVMField mb_fp2) >>> - getTopDistPerm x >>>= \(ValPerm_LLVMField fp2) -> + getTopDistPerm x >>>= \p_top2 -> -- Finally, combine these two pieces of mb_fp into a single permission, and -- use this permission to prove the one we needed to begin with - implLLVMFieldConcat x fp1 fp2 >>> - getTopDistPerm x >>>= \(ValPerm_LLVMField fp_concat) -> - proveVarLLVMFieldH x (Perm_LLVMField fp_concat) off mb_fp + case (p_top1, p_top2) of + (ValPerm_LLVMField fp1, ValPerm_LLVMField fp2) -> + implLLVMFieldConcat x fp1 fp2 >>> + getTopDistPerm x >>>= \case + (ValPerm_LLVMField fp_concat) -> + proveVarLLVMFieldH x (Perm_LLVMField fp_concat) off mb_fp + _ -> error "proveVarLLVMFieldH2: expected field permission" + _ -> error "proveVarLLVMFieldH2: expected field permissions" -- If we have a field permission that contains the correct offset but doesn't -- start at it, then split it and recurse @@ -7504,7 +7523,7 @@ proveVarLLVMBlocks1 x ps psubst (mb_bp:mb_bps) -- Recursively prove the remaining perms proveVarLLVMBlocks x ps' psubst mb_bps >>> - getTopDistPerm x >>>= \(ValPerm_Conj ps_out) -> + getTopDistConj "proveVarLLVMBlocks1" x >>>= \ps_out -> -- Finally, combine the one memblock perm we chose with the rest of them implInsertConjM x (Perm_LLVMBlock bp') ps_out 0 @@ -7579,7 +7598,7 @@ proveVarLLVMBlocks1 x ps psubst mb_bps_in@(mb_bp:_) else bvSub off (llvmBlockOffset bp) in implSimplM Proxy (SImpl_SplitLLVMBlockEmpty x bp len1) >>> - getTopDistPerm x >>>= \(ValPerm_Conj ps') -> + getTopDistConj "proveVarLLVMBlocks1" x >>>= \ps' -> implAppendConjsM x (deleteNth i ps) ps' >>> proveVarLLVMBlocks x (deleteNth i ps ++ ps') psubst mb_bps_in @@ -7627,7 +7646,7 @@ proveVarLLVMBlocks2 x ps psubst mb_bp [nuMP| PExpr_EmptyShape |] mb_bps -- Do the recursive call without the empty shape and remember what -- permissions it proved proveVarLLVMBlocks x ps psubst mb_bps >>> - getTopDistPerm x >>>= \(ValPerm_Conj ps_out) -> + getTopDistConj "proveVarLLVMBlocks2" x >>>= \ps_out -> -- Substitute into the required block perm and prove it with -- SImpl_IntroLLVMBlockEmpty @@ -7652,7 +7671,7 @@ proveVarLLVMBlocks2 x ps psubst mb_bp [nuMP| PExpr_EmptyShape |] mb_bps = proveVarLLVMBlocksExt1 x ps psubst mb_bp' mb_bps >>> -- Extract out the block perm we proved and coerce it to the empty shape - getTopDistPerm x >>>= \(ValPerm_Conj ps_out) -> + getTopDistConj "proveVarLLVMBlocks2" x >>>= \ps_out -> let (Perm_LLVMBlock bp : ps_out') = ps_out in implSplitSwapConjsM x ps_out 1 >>> implSimplM Proxy (SImpl_CoerceLLVMBlockEmpty x bp) >>> @@ -7687,7 +7706,7 @@ proveVarLLVMBlocks2 x ps psubst mb_bp _ mb_bps -- Move the correctly-sized perm + the empty shape one to the top of the -- stack and sequence them, and then eliminate the empty shape at the end - getTopDistPerm x >>>= \(ValPerm_Conj ps') -> + getTopDistConj "proveVarLLVMBlocks2" x >>>= \ps' -> let (Perm_LLVMBlock bp1 : Perm_LLVMBlock bp2 : ps'') = ps' len2 = llvmBlockLen bp2 bp_out = bp1 { llvmBlockLen = bvAdd (llvmBlockLen bp1) len2 } in @@ -7721,7 +7740,7 @@ proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps proveVarLLVMBlocks x ps psubst (mb_bp' : mb_bps) >>> -- Extract out the block perm we proved - getTopDistPerm x >>>= \(ValPerm_Conj ps_out) -> + getTopDistConj "proveVarLLVMBlocks2" x >>>= \ps_out -> let (_ : ps_out') = ps_out in implSplitSwapConjsM x ps_out 1 >>> @@ -7766,7 +7785,7 @@ proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps proveVarLLVMBlocks x ps psubst (mb_bp' : mb_bps) >>> -- Extract out the block perm we proved - getTopDistPerm x >>>= \(ValPerm_Conj ps_out) -> + getTopDistConj "proveVarLLVMBlocks2" x >>>= \ps_out -> let (Perm_LLVMBlock bp : ps_out') = ps_out in implSplitSwapConjsM x ps_out 1 >>> @@ -7825,7 +7844,7 @@ proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps proveVarLLVMBlocksExt1 x ps psubst mb_bp' mb_bps >>> -- Extract out the block perm we proved - getTopDistPerm x >>>= \(ValPerm_Conj ps_out) -> + getTopDistConj "proveVarLLVMBlocks2" x >>>= \ps_out -> let (Perm_LLVMBlock bp : ps_out') = ps_out in implSplitSwapConjsM x ps_out 1 >>> @@ -7868,7 +7887,7 @@ proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps proveVarLLVMBlocks x ps psubst (mb_bp':mb_bps) >>> -- Move the pointer permission we proved to the top of the stack - getTopDistPerm x >>>= \(ValPerm_Conj ps') -> + getTopDistConj "proveVarLLVMBlocks2" x >>>= \ps' -> implExtractSwapConjM x ps' 0 >>> -- Use the SImpl_IntroLLVMBlockPtr rule to prove the required memblock perm @@ -7897,15 +7916,16 @@ proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps -- Recursively prove the remaining block permissions proveVarLLVMBlocks x ps psubst mb_bps >>> - getTopDistPerm x >>>= \(ValPerm_Conj ps') -> + getTopDistConj "proveVarLLVMBlocks2" x >>>= \ps' -> -- Prove the corresponding field permission proveVarImplInt x (mbValPerm_LLVMField mb_fp) >>> - getTopDistPerm x >>>= \(ValPerm_LLVMField fp) -> - - -- Finally, convert the field perm to a block and move it into position - implSimplM Proxy (SImpl_IntroLLVMBlockField x fp) >>> - implSwapInsertConjM x (Perm_LLVMBlock $ llvmFieldPermToBlock fp) ps' 0 + getTopDistPerm x >>>= \case + (ValPerm_LLVMField fp) -> + -- Finally, convert the field perm to a block and move it into position + implSimplM Proxy (SImpl_IntroLLVMBlockField x fp) >>> + implSwapInsertConjM x (Perm_LLVMBlock $ llvmFieldPermToBlock fp) ps' 0 + _ -> error "proveVarLLVMBlocks2: expected field permission" -- If proving an array shape, prove the remaining blocks and then prove the @@ -7916,18 +7936,18 @@ proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps | [nuMP| PExpr_ArrayShape _ _ _ |] <- mb_sh = -- Recursively prove the remaining block permissions proveVarLLVMBlocks x ps psubst mb_bps >>> - getTopDistPerm x >>>= \(ValPerm_Conj ps') -> + getTopDistConj "proveVarLLVMBlocks2" x >>>= \ps' -> -- Prove the corresponding array permission proveVarImplInt x (mbMapCl $(mkClosed [| ValPerm_LLVMArray . fromJust . llvmBlockPermToArray |]) mb_bp) >>> - getTopDistPerm x >>>= \(ValPerm_LLVMArray ap) -> - - -- Finally, convert the array perm to a block and move it into position - implSimplM Proxy (SImpl_IntroLLVMBlockArray x ap) >>> - implSwapInsertConjM x (Perm_LLVMBlock $ fromJust $ - llvmArrayPermToBlock ap) ps' 0 - + getTopDistPerm x >>>= \case + ValPerm_LLVMArray ap -> + -- Finally, convert the array perm to a block and move it into position + implSimplM Proxy (SImpl_IntroLLVMBlockArray x ap) >>> + implSwapInsertConjM x (Perm_LLVMBlock $ fromJust $ + llvmArrayPermToBlock ap) ps' 0 + _ -> error "proveVarLLVMBlocks2: expected array permission" -- If proving a sequence shape with an unneeded empty shape, i.e., of the form -- sh1;emptysh where the length of sh1 equals the entire length of the required @@ -7948,7 +7968,7 @@ proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps -- Extract the sh1 permission from the top of the stack and sequence an -- empty shape onto the end of it - getTopDistPerm x >>>= \(ValPerm_Conj ps') -> + getTopDistConj "proveVarLLVMBlocks2" x >>>= \ps' -> implExtractSwapConjM x ps' 0 >>> let Perm_LLVMBlock bp = head ps' sh1 = llvmBlockShape bp in @@ -7971,8 +7991,10 @@ proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps let mb_bps12 = mbMapCl $(mkClosed [| \bp -> - let PExpr_SeqShape sh1 sh2 = llvmBlockShape bp in - let Just len1 = llvmShapeLength sh1 in + let (sh1,sh2) = case llvmBlockShape bp of + PExpr_SeqShape sh1_ sh2_ -> (sh1_,sh2_) + _ -> error "proveVarLLVMBlocks2: expected seq shape" in + let len1 = fromJust (llvmShapeLength sh1) in [bp { llvmBlockLen = len1, llvmBlockShape = sh1 }, bp { llvmBlockOffset = bvAdd (llvmBlockOffset bp) len1, llvmBlockLen = bvSub (llvmBlockLen bp) len1, @@ -7981,8 +8003,12 @@ proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps proveVarLLVMBlocks x ps psubst (mbList mb_bps12 ++ mb_bps) >>> -- Move the block permissions we proved to the top of the stack - getTopDistPerm x >>>= \(ValPerm_Conj ps') -> - let (Perm_LLVMBlock bp1 : Perm_LLVMBlock bp2 : ps'') = ps' + getTopDistConj "proveVarLLVMBlocks2" x >>>= \ps' -> + let (bp1,bp2,ps'') = + (case ps' of + (Perm_LLVMBlock bp1_ : Perm_LLVMBlock bp2_ : ps''_) -> + (bp1_,bp2_,ps''_) + _ -> error "proveVarLLVMBlocks2: expected 2 block permissions") len2 = llvmBlockLen bp2 sh2 = llvmBlockShape bp2 in implSplitSwapConjsM x ps' 2 >>> @@ -8039,7 +8065,7 @@ proveVarLLVMBlocks2 x ps psubst mb_bp _ mb_bps : mb_bps) >>> -- Move the block permission with shape mb_sh to the top of the stack - getTopDistPerm x >>>= \(ValPerm_Conj ps'') -> + getTopDistConj "proveVarLLVMBlocks2" x >>>= \ps'' -> implExtractSwapConjM x ps'' 0 >>> -- Finally, weaken the block permission to be the desired tagged union @@ -8064,12 +8090,14 @@ proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps proveVarLLVMBlocks x ps psubst (mb_bp' : mb_bps) >>> -- Move the block permission we proved to the top of the stack - getTopDistPerm x >>>= \(ValPerm_Conj ps') -> + getTopDistConj "proveVarLLVMBlocks2" x >>>= \ps' -> implSplitSwapConjsM x ps' 1 >>> -- Prove the disjunction of the two memblock permissions partialSubstForceM mb_bp "proveVarLLVMBlock" >>>= \bp -> - let PExpr_OrShape sh1 sh2 = llvmBlockShape bp in + let (sh1, sh2) = case llvmBlockShape bp of + PExpr_OrShape sh1' sh2' -> (sh1',sh2') + _ -> error "proveVarLLVMBlocks2: expected or shape" in let introM = if is_case1 then introOrLM else introOrRM in introM x (ValPerm_LLVMBlock $ bp { llvmBlockShape = sh1 }) (ValPerm_LLVMBlock $ bp { llvmBlockShape = sh2 }) >>> @@ -8092,7 +8120,7 @@ proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps proveVarLLVMBlocksExt1 x ps psubst mb_bp' mb_bps >>>= \e -> -- Move the block permission we proved to the top of the stack - getTopDistPerm x >>>= \(ValPerm_Conj ps') -> + getTopDistConj "proveVarLLVMBlocks2" x >>>= \ps' -> implSplitSwapConjsM x ps' 1 >>> -- Prove an existential around the memblock permission we proved @@ -8250,9 +8278,14 @@ proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps proveVarLLVMBlocksExt2 x ps psubst mb_bps12 mb_bps >>> -- Move the two block permissions we proved to the top of the stack - getTopDistPerm x >>>= \(ValPerm_Conj ps_ret) -> - let (Perm_LLVMBlock bp1 : Perm_LLVMBlock bp2 : ps_ret') = ps_ret - len2 = llvmBlockLen bp2 + getTopDistPerm x >>>= \p_top -> + (case p_top of + ValPerm_Conj + ps_ret@(Perm_LLVMBlock bp1 : Perm_LLVMBlock bp2 : ps_ret') -> + return (ps_ret, bp1, bp2, ps_ret') + _ -> error "proveVarLLVMBlocks2: unexpected permission on top of the stack") + >>>= \(ps_ret, bp1, bp2, ps_ret') -> + let len2 = llvmBlockLen bp2 sh2 = llvmBlockShape bp2 in implSplitSwapConjsM x ps_ret 2 >>> implSplitConjsM x (map Perm_LLVMBlock [bp1,bp2]) 1 >>> From c69f0e1d8f94eb58610be1cfb3698d3d9fb83424 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 13 Mar 2023 17:23:12 -0700 Subject: [PATCH 16/27] removed pattern-matching coverage failures in Implication.hs --- .../src/Verifier/SAW/Heapster/Implication.hs | 76 +++++++++++++------ 1 file changed, 52 insertions(+), 24 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs b/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs index 91ded9fe38..91785e5a40 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs @@ -5137,10 +5137,12 @@ implLLVMFieldSplit x fp sz_bytes (Impl1_SplitLLVMWordField x (llvmFieldSetEqWord fp e) sz endianness) (MNil :>: Impl1Cont (const $ return ())) >>> getDistPerms >>>= - \(_ :>: VarAndPerm _ (ValPerm_Conj1 p1) :>: - VarAndPerm _ (ValPerm_Conj1 p2) :>: - VarAndPerm y p_y :>: VarAndPerm z p_z) -> - recombinePerm z p_z >>> recombinePerm y p_y >>> return (p1,p2) + \case + (_ :>: VarAndPerm _ (ValPerm_Conj1 p1) :>: + VarAndPerm _ (ValPerm_Conj1 p2) :>: + VarAndPerm y p_y :>: VarAndPerm z p_z) -> + recombinePerm z p_z >>> recombinePerm y p_y >>> return (p1,p2) + _ -> error "implLLVMFieldSplit: unexpected permission stack" Nothing -> implSimplM Proxy (SImpl_SplitLLVMTrueField x (llvmFieldSetTrue fp fp) sz fp_m_sz) >>> @@ -5175,8 +5177,10 @@ implLLVMFieldTruncate x fp sz' (Impl1_TruncateLLVMWordField x (llvmFieldSetEqWord fp e) sz' endianness) (MNil :>: Impl1Cont (const $ return ())) >>> getDistPerms >>>= - \(_ :>: VarAndPerm _ (ValPerm_Conj1 p) :>: VarAndPerm y p_y) -> - recombinePerm y p_y >>> return p + \case + (_ :>: VarAndPerm _ (ValPerm_Conj1 p) :>: VarAndPerm y p_y) -> + recombinePerm y p_y >>> return p + _ -> error "implLLVMFieldTruncate: unexpected permission stack" Nothing -> implSimplM Proxy (SImpl_TruncateLLVMTrueField x (llvmFieldSetTrue fp fp) sz') >>> @@ -5365,10 +5369,11 @@ implLLVMArrayReturnBorrow :: :> LLVMPointerType w) () implLLVMArrayReturnBorrow x ap (FieldBorrow cell) = implLLVMArrayCellReturn x ap cell -implLLVMArrayReturnBorrow x ap b@(RangeBorrow _) = - let ValPerm_Conj1 (Perm_LLVMArray ap_ret) = permForLLVMArrayBorrow ap b in - implLLVMArrayReturn x ap ap_ret >>> - pure () +implLLVMArrayReturnBorrow x ap b@(RangeBorrow _) + | ValPerm_Conj1 (Perm_LLVMArray ap_ret) <- permForLLVMArrayBorrow ap b = + implLLVMArrayReturn x ap ap_ret >>> + pure () +implLLVMArrayReturnBorrow _ _ _ = error "implLLVMArrayReturnBorrow" -- | Append to array permissions, assuming one ends where the other begins and @@ -7672,7 +7677,10 @@ proveVarLLVMBlocks2 x ps psubst mb_bp [nuMP| PExpr_EmptyShape |] mb_bps = -- Extract out the block perm we proved and coerce it to the empty shape getTopDistConj "proveVarLLVMBlocks2" x >>>= \ps_out -> - let (Perm_LLVMBlock bp : ps_out') = ps_out in + let ps_out' = tail ps_out + bp = case head ps_out of + Perm_LLVMBlock bp_ -> bp_ + _ -> error "proveVarLLVMBlocks2: expected block permission" in implSplitSwapConjsM x ps_out 1 >>> implSimplM Proxy (SImpl_CoerceLLVMBlockEmpty x bp) >>> @@ -7707,7 +7715,10 @@ proveVarLLVMBlocks2 x ps psubst mb_bp _ mb_bps -- Move the correctly-sized perm + the empty shape one to the top of the -- stack and sequence them, and then eliminate the empty shape at the end getTopDistConj "proveVarLLVMBlocks2" x >>>= \ps' -> - let (Perm_LLVMBlock bp1 : Perm_LLVMBlock bp2 : ps'') = ps' + let (bp1,bp2,ps'') = case ps' of + (Perm_LLVMBlock bp1_ : Perm_LLVMBlock bp2_ : ps''_) -> + (bp1_,bp2_,ps''_) + _ -> error "proveVarLLVMBlocks2: expected two block permissions" len2 = llvmBlockLen bp2 bp_out = bp1 { llvmBlockLen = bvAdd (llvmBlockLen bp1) len2 } in implSplitSwapConjsM x ps' 2 >>> @@ -7741,7 +7752,7 @@ proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps -- Extract out the block perm we proved getTopDistConj "proveVarLLVMBlocks2" x >>>= \ps_out -> - let (_ : ps_out') = ps_out in + let ps_out' = tail ps_out in implSplitSwapConjsM x ps_out 1 >>> -- Introduce the modalities @@ -7786,7 +7797,10 @@ proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps -- Extract out the block perm we proved getTopDistConj "proveVarLLVMBlocks2" x >>>= \ps_out -> - let (Perm_LLVMBlock bp : ps_out') = ps_out in + let ps_out' = tail ps_out + bp = case head ps_out of + Perm_LLVMBlock bp_ -> bp_ + _ -> error "proveVarLLVMBlocks2: expected block permission" in implSplitSwapConjsM x ps_out 1 >>> -- Fold the named shape @@ -7821,9 +7835,12 @@ proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps | [nuMP| PExpr_EqShape _ (PExpr_Var mb_z) |] <- mb_sh , Left memb <- mbNameBoundP mb_z , Just blk <- psubstLookup psubst memb = - let mb_bp' = fmap (\bp -> - let PExpr_EqShape len _ = llvmBlockShape bp in - bp { llvmBlockShape = PExpr_EqShape len blk }) mb_bp in + let mb_bp' = + fmap (\bp -> + case llvmBlockShape bp of + PExpr_EqShape len _ -> + bp { llvmBlockShape = PExpr_EqShape len blk } + _ -> error "proveVarLLVMBlocks2: expected eq shape") mb_bp in proveVarLLVMBlocks x ps psubst (mb_bp' : mb_bps) @@ -7845,7 +7862,10 @@ proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps -- Extract out the block perm we proved getTopDistConj "proveVarLLVMBlocks2" x >>>= \ps_out -> - let (Perm_LLVMBlock bp : ps_out') = ps_out in + let ps_out' = tail ps_out + bp = case head ps_out of + Perm_LLVMBlock bp_ -> bp_ + _ -> error "proveVarLLVMBlocks2: expected block perm" in implSplitSwapConjsM x ps_out 1 >>> -- Eliminate that block perm to have an equality shape, and set z to the @@ -7956,21 +7976,29 @@ proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps | [nuMP| PExpr_SeqShape _ PExpr_EmptyShape |] <- mb_sh , mbLift $ mbMapCl $(mkClosed [| \bp -> - let PExpr_SeqShape sh1 _ = llvmBlockShape bp in - bvEq (llvmBlockLen bp) (fromJust $ - llvmShapeLength sh1) |]) mb_bp = + case llvmBlockShape bp of + PExpr_SeqShape sh1 _ -> + bvEq (llvmBlockLen bp) (fromJust $ + llvmShapeLength sh1) + _ -> error "proveVarLLVMBlocks2: expected seq shape" + |]) mb_bp = -- Recursively call proveVarLLVMBlocks with sh1 in place of sh1;emptysh let mb_bp' = mbMapCl $(mkClosed [| \bp -> - let PExpr_SeqShape sh1 _ = llvmBlockShape bp in - bp { llvmBlockShape = sh1 } |]) mb_bp in + case llvmBlockShape bp of + PExpr_SeqShape sh1 _ -> + bp { llvmBlockShape = sh1 } + _ -> error "proveVarLLVMBlocks2: expected seq shape" + |]) mb_bp in proveVarLLVMBlocks x ps psubst (mb_bp':mb_bps) >>> -- Extract the sh1 permission from the top of the stack and sequence an -- empty shape onto the end of it getTopDistConj "proveVarLLVMBlocks2" x >>>= \ps' -> implExtractSwapConjM x ps' 0 >>> - let Perm_LLVMBlock bp = head ps' + let bp = case head ps' of + Perm_LLVMBlock bp_ -> bp_ + _ -> error "proveVarLLVMBlocks2: expected block permission" sh1 = llvmBlockShape bp in implSimplM Proxy (SImpl_IntroLLVMBlockSeqEmpty x bp) >>> From 6eb90298adc884156f7a2cf1330d252235b5da6b Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 13 Mar 2023 17:37:46 -0700 Subject: [PATCH 17/27] Fixed remaining pattern-match coverage failures in heapster-saw --- .../src/Verifier/SAW/Heapster/HintExtract.hs | 2 +- .../Verifier/SAW/Heapster/SAWTranslation.hs | 66 ++++++++++++------- 2 files changed, 45 insertions(+), 23 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/HintExtract.hs b/heapster-saw/src/Verifier/SAW/Heapster/HintExtract.hs index f61929c8e0..4a299e2b73 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/HintExtract.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/HintExtract.hs @@ -173,7 +173,7 @@ extractHintFromSequence who env globals tops blockIns sz s = -- The first two arguments are the ghost/spec strings. -- we can't "demote" their contexts to block args since they're globals -- and hence loaded in this block - let ~_:_:args = toListFC Some actuals in + let args = tail $ tail $ toListFC Some actuals in -- "demote" the context of each reg to the block input context, -- proving that each arg is in fact defined in a previous block -- (and is thus valid for use in this spec) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 2377d8cd09..fdde3649b3 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -130,11 +130,15 @@ instance Applicative TypeTrans where -- | Build a 'TypeTrans' represented by 0 SAW types mkTypeTrans0 :: tr -> TypeTrans tr -mkTypeTrans0 tr = TypeTrans [] (\[] -> tr) +mkTypeTrans0 tr = TypeTrans [] $ \case + [] -> tr + _ -> error "mkTypeTrans0: incorrect number of terms" -- | Build a 'TypeTrans' represented by 1 SAW type mkTypeTrans1 :: OpenTerm -> (OpenTerm -> tr) -> TypeTrans tr -mkTypeTrans1 tp f = TypeTrans [tp] (\[t] -> f t) +mkTypeTrans1 tp f = TypeTrans [tp] $ \case + [t] -> f t + _ -> error "mkTypeTrans1: incorrect number of terms" -- | Build a 'TypeTrans' for an 'OpenTerm' of a given type openTermTypeTrans :: OpenTerm -> TypeTrans OpenTerm @@ -186,8 +190,11 @@ tupleTypeTrans :: TypeTrans tr -> TypeTrans tr tupleTypeTrans ttrans = let tps = typeTransTypes ttrans in TypeTrans [tupleOfTypes tps] - (\[t] -> typeTransF ttrans $ map (\i -> projTupleOfTypes tps i t) $ - take (length $ typeTransTypes ttrans) [0..]) + (\case + [t] -> + typeTransF ttrans $ map (\i -> projTupleOfTypes tps i t) $ + take (length $ typeTransTypes ttrans) [0..] + _ -> error "tupleTypeTrans: incorrect number of terms") -- | Convert a 'TypeTrans' over 0 or more types to one over 1 type of the form -- @#(tp1, #(tp2, ... #(tpn, #()) ...))@. This is "strict" in the sense that @@ -195,8 +202,11 @@ tupleTypeTrans ttrans = strictTupleTypeTrans :: TypeTrans tr -> TypeTrans tr strictTupleTypeTrans ttrans = TypeTrans [tupleTypeOpenTerm $ typeTransTypes ttrans] - (\[t] -> typeTransF ttrans $ map (\i -> projTupleOpenTerm i t) $ - take (length $ typeTransTypes ttrans) [0..]) + (\case + [t] -> + typeTransF ttrans $ map (\i -> projTupleOpenTerm i t) $ + take (length $ typeTransTypes ttrans) [0..] + _ -> error "strictTupleTypeTrans: incorrect number of terms") -- | Build a type translation for a list of translations listTypeTrans :: [TypeTrans tr] -> TypeTrans [tr] @@ -1663,7 +1673,8 @@ getLLVMArrayTransSlice arr_trans sub_arr_tp rng_trans prop_transs = v_tm = llvmArrayTransTerm arr_trans off_tm = transTerm1 $ bvRangeTransOff rng_trans len'_tm = transTerm1 $ bvRangeTransLen rng_trans - p1_trans:p2_trans:_ = prop_transs + p1_trans = head prop_transs + p2_trans = head (tail prop_transs) BVPropTrans _ p1_tm = p1_trans BVPropTrans _ p2_tm = p2_trans in typeTransF sub_arr_tp @@ -1893,8 +1904,10 @@ instance TransInfo info => -- To translate P@off as an atomic permission, we translate it as a -- normal permission and map the resulting PermTrans to an AtomicPermTrans do ptrans <- translate $ mbMap2 (ValPerm_Named $ mbLift npn) args off - return $ fmap (\(PTrans_Term _ t) -> - APTrans_NamedConj (mbLift npn) args off t) ptrans + return $ fmap (\case + (PTrans_Term _ t) -> + APTrans_NamedConj (mbLift npn) args off t + _ -> error "translateSimplImpl: Perm_NamedConj") ptrans [nuMP| Perm_LLVMFrame fp |] -> return $ mkTypeTrans0 $ APTrans_LLVMFrame fp [nuMP| Perm_LOwned ls tps_in tps_out ps_in ps_out |] -> @@ -2657,9 +2670,11 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of [nuMP| SImpl_IntroStructField _ _ memb _ |] -> do tptrans <- translateSimplImplOutHead mb_simpl withPermStackM RL.tail - (\(pctx :>: PTrans_Conj [APTrans_Struct pctx_str] :>: ptrans) -> - pctx :>: typeTransF tptrans (transTerms $ - RL.set (mbLift memb) ptrans pctx_str)) + (\case + (pctx :>: PTrans_Conj [APTrans_Struct pctx_str] :>: ptrans) -> + pctx :>: typeTransF tptrans (transTerms $ + RL.set (mbLift memb) ptrans pctx_str) + _ -> error "translateSimplImpl: SImpl_IntroStructField") m [nuMP| SImpl_ConstFunPerm _ _ _ ident |] -> @@ -2845,8 +2860,11 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of do (w_term, len1_tm, elem_tp, _) <- translateLLVMArrayPerm mb_ap1 (_, len2_tm, _, _) <- translateLLVMArrayPerm mb_ap2 tp_trans <- translateSimplImplOutHead mb_simpl - len3_tm <- translate1 $ fmap (\(ValPerm_LLVMArray ap) -> - llvmArrayLen ap) $ + len3_tm <- + translate1 $ + fmap (\case + (ValPerm_LLVMArray ap) -> llvmArrayLen ap + _ -> error "translateSimplImpl: SImpl_LLVMArrayAppend") $ fmap distPermsHeadPerm $ mbSimplImplOut mb_simpl (_ :>: ptrans1 :>: ptrans2) <- itiPermStack <$> ask arr_out_comp_tm <- @@ -3783,10 +3801,13 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl PExpr_Var y) x inExtTransM etrans_y $ withPermStackM (:>: Member_Base) - (\(pctx :>: PTrans_Conj [APTrans_Struct pctx_str]) -> - pctx :>: PTrans_Conj [APTrans_Struct $ - RL.set (mbLift memb) (PTrans_Eq mb_y) pctx_str] - :>: RL.get (mbLift memb) pctx_str) + (\case + (pctx :>: PTrans_Conj [APTrans_Struct pctx_str]) -> + pctx :>: PTrans_Conj [APTrans_Struct $ + RL.set (mbLift memb) (PTrans_Eq mb_y) pctx_str] + :>: RL.get (mbLift memb) pctx_str + _ -> + error "translatePermImpl1: Impl1_ElimStructField") m ([nuMP| Impl1_ElimLLVMFieldContents _ mb_fld |], _) -> @@ -4719,11 +4740,12 @@ translateLLVMStmt mb_stmt m = case mbMatch mb_stmt of [nuMP| TypedLLVMLoadHandle _ tp _ |] -> inExtTransM ETrans_Fun $ withPermStackM ((:>: Member_Base) . RL.tail) - (\(pctx :>: PTrans_Conj [APTrans_LLVMFunPtr tp' ptrans]) -> - case testEquality (mbLift tp) tp' of - Just Refl -> pctx :>: ptrans + (\case + (pctx :>: PTrans_Conj [APTrans_LLVMFunPtr tp' ptrans]) + | Just Refl <- testEquality (mbLift tp) tp' -> + pctx :>: ptrans _ -> error ("translateLLVMStmt: TypedLLVMLoadHandle: " - ++ "unexpected function permission type")) + ++ "unexpected permission stack")) m [nuMP| TypedLLVMResolveGlobal gsym (p :: ValuePerm (LLVMPointerType w))|] -> From 54b883f9543c8ccb1a6bf8f4b1390c96b50240ad Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Tue, 14 Mar 2023 12:54:04 -0400 Subject: [PATCH 18/27] heapster-saw: Replace head/tail with more specific functions --- heapster-saw/heapster-saw.cabal | 2 + .../src/Verifier/SAW/Heapster/HintExtract.hs | 93 ++++++------- .../src/Verifier/SAW/Heapster/Implication.hs | 129 ++++++++++-------- .../Verifier/SAW/Heapster/PatternMatchUtil.hs | 20 +++ .../Verifier/SAW/Heapster/SAWTranslation.hs | 9 +- 5 files changed, 143 insertions(+), 110 deletions(-) create mode 100644 heapster-saw/src/Verifier/SAW/Heapster/PatternMatchUtil.hs diff --git a/heapster-saw/heapster-saw.cabal b/heapster-saw/heapster-saw.cabal index 613f7dd0a9..46a91108dc 100644 --- a/heapster-saw/heapster-saw.cabal +++ b/heapster-saw/heapster-saw.cabal @@ -70,6 +70,8 @@ library Verifier.SAW.Heapster.TypedCrucible Verifier.SAW.Heapster.UntypedAST Verifier.SAW.Heapster.Widening + other-modules: + Verifier.SAW.Heapster.PatternMatchUtil GHC-options: -Wall default-language: Haskell2010 diff --git a/heapster-saw/src/Verifier/SAW/Heapster/HintExtract.hs b/heapster-saw/src/Verifier/SAW/Heapster/HintExtract.hs index 4a299e2b73..d60397df21 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/HintExtract.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/HintExtract.hs @@ -28,7 +28,7 @@ import Lang.Crucible.CFG.Core ( Some(Some) , CtxRepr , CFG(..) , Reg(..) - + , Block(..) , blockStmts , StmtSeq(..) @@ -36,6 +36,7 @@ import Lang.Crucible.CFG.Core ( Some(Some) import Verifier.SAW.Heapster.CruUtil import Verifier.SAW.Heapster.ParsedCtx +import Verifier.SAW.Heapster.PatternMatchUtil import Verifier.SAW.Heapster.Permissions import Verifier.SAW.Heapster.PermParser @@ -51,7 +52,7 @@ extractHints :: PermEnv -> [L.Module] {- ^ The original source modules: used for finding constant values (i.e. spec strings) -} -> FunPerm ghosts args outs ret {- ^ The FunPerm corresponding to the CFG we are scanning -} -> - CFG LLVM blocks init ret {- ^ The Crucible CFG for which to build the block hint map -} -> + CFG LLVM blocks init ret {- ^ The Crucible CFG for which to build the block hint map -} -> Either String (Ctx.Assignment (Constant (Maybe Hint)) blocks) extractHints env modules perm cfg = runExcept $ traverseFC extractHint (cfgBlockMap cfg) @@ -78,20 +79,20 @@ extractHints env modules perm cfg = -- | Packs up the ghosts in a parsed hint permission spec data SomeHintSpec tops ctx where - SomeHintSpec :: + SomeHintSpec :: CruCtx ghosts -> - MbValuePerms ((tops :++: CtxToRList ctx) :++: ghosts) -> + MbValuePerms ((tops :++: CtxToRList ctx) :++: ghosts) -> SomeHintSpec tops ctx -- | Try to find a hint in a Block extractBlockHints :: forall blocks ret ctx tops. - PermEnv -> + PermEnv -> Map.Map L.Symbol String {- ^ Globals map -} -> CruCtx tops {- ^ top context derived from current function's perm -} -> Block LLVM blocks ret ctx -> ExtractM (Maybe (SomeHintSpec tops ctx)) -extractBlockHints env globals tops block = +extractBlockHints env globals tops block = extractStmtsHint who env globals tops inputs stmts where stmts = block ^. blockStmts @@ -103,15 +104,15 @@ extractBlockHints env globals tops block = extractStmtsHint :: forall blocks ret ctx tops. String -> - PermEnv -> + PermEnv -> Map.Map L.Symbol String {- ^ globals -} -> CruCtx tops {- ^ top context derived from current function's perm -} -> CtxRepr ctx {- ^ block arguments -} -> - StmtSeq LLVM blocks ret ctx -> + StmtSeq LLVM blocks ret ctx -> ExtractM (Maybe (SomeHintSpec tops ctx)) -extractStmtsHint who env globals tops inputs = loop Ctx.zeroSize +extractStmtsHint who env globals tops inputs = loop Ctx.zeroSize where - loop :: + loop :: forall rest. Ctx.Size rest -> StmtSeq LLVM blocks ret (ctx Ctx.<+> rest) -> @@ -122,41 +123,41 @@ extractStmtsHint who env globals tops inputs = loop Ctx.zeroSize _ | ConsStmt _ s' rest <- s -> let inc_rest :: forall tp. Ctx.Size (rest Ctx.::> tp) inc_rest = Ctx.incSize sz_rest in - case s' of - SetReg{} -> loop inc_rest rest - ExtendAssign{} -> loop inc_rest rest - CallHandle{} -> loop inc_rest rest + case s' of + SetReg{} -> loop inc_rest rest + ExtendAssign{} -> loop inc_rest rest + CallHandle{} -> loop inc_rest rest Print{} -> loop sz_rest rest - ReadGlobal{} -> loop inc_rest rest - WriteGlobal{} -> loop sz_rest rest - FreshConstant {} -> loop inc_rest rest - FreshFloat {} -> loop inc_rest rest - FreshNat {} -> loop inc_rest rest - NewRefCell {} -> loop inc_rest rest - NewEmptyRefCell {} -> loop inc_rest rest - ReadRefCell {} -> loop inc_rest rest - WriteRefCell {} -> loop sz_rest rest - DropRefCell {} -> loop sz_rest rest - Assert {} -> loop sz_rest rest - Assume {} -> loop sz_rest rest + ReadGlobal{} -> loop inc_rest rest + WriteGlobal{} -> loop sz_rest rest + FreshConstant {} -> loop inc_rest rest + FreshFloat {} -> loop inc_rest rest + FreshNat {} -> loop inc_rest rest + NewRefCell {} -> loop inc_rest rest + NewEmptyRefCell {} -> loop inc_rest rest + ReadRefCell {} -> loop inc_rest rest + WriteRefCell {} -> loop sz_rest rest + DropRefCell {} -> loop sz_rest rest + Assert {} -> loop sz_rest rest + Assume {} -> loop sz_rest rest _ -> return Nothing -- | Try to recognize the sequence of Crucible instructions leading up to -- a call to heapster.require. If found, build a hint by parsing the provided --- (global) ghost context string and spec string by looking them up +-- (global) ghost context string and spec string by looking them up -- in the global map. -- --- Will throw an error if the `require` is malformed (malformed spec strings --- or references out-of-scope values) -extractHintFromSequence :: +-- Will throw an error if the `require` is malformed (malformed spec strings +-- or references out-of-scope values) +extractHintFromSequence :: forall tops ctx rest blocks ret. String -> - PermEnv -> + PermEnv -> Map.Map L.Symbol String {- ^ globals -} -> CruCtx tops {- ^ toplevel context -} -> CtxRepr ctx {- ^ block arguments -} -> Ctx.Size rest {- ^ keeps track of how deep we are into the current block -} -> - StmtSeq LLVM blocks ret (ctx Ctx.<+> rest) -> + StmtSeq LLVM blocks ret (ctx Ctx.<+> rest) -> ExtractM (Maybe (SomeHintSpec tops ctx)) extractHintFromSequence who env globals tops blockIns sz s = case s of @@ -168,13 +169,13 @@ extractHintFromSequence who env globals tops blockIns sz s = | globalSymbolName f == heapsterRequireName , Just Refl <- testEquality ptr fnPtrReg , Just Refl <- testEquality fh fnHdlReg - , Just ghosts_str <- Map.lookup (fromString (globalSymbolName ghosts)) globals + , Just ghosts_str <- Map.lookup (fromString (globalSymbolName ghosts)) globals , Just spec_str <- Map.lookup (fromString (globalSymbolName spec)) globals -> - -- The first two arguments are the ghost/spec strings. + -- The first two arguments are the ghost/spec strings. -- we can't "demote" their contexts to block args since they're globals -- and hence loaded in this block - let args = tail $ tail $ toListFC Some actuals in - -- "demote" the context of each reg to the block input context, + let (_, _, args) = expectLengthAtLeastTwo $ toListFC Some actuals in + -- "demote" the context of each reg to the block input context, -- proving that each arg is in fact defined in a previous block -- (and is thus valid for use in this spec) case sequence (toBlockArg (Ctx.size blockIns) sizeAtCall <$> args) of @@ -195,10 +196,10 @@ extractHintFromSequence who env globals tops blockIns sz s = sizeAtCall :: forall a b c d. Ctx.Size (rest Ctx.::> a Ctx.::> b Ctx.::> c Ctx.::> d) sizeAtCall = Ctx.incSize (Ctx.incSize (Ctx.incSize (Ctx.incSize sz))) --- | Assemble a Hint +-- | Assemble a Hint -- --- Will throw an error if the `require` is malformed (malformed spec strings --- or references out-of-scope values) +-- Will throw an error if the `require` is malformed (malformed spec strings +-- or references out-of-scope values) requireArgsToHint :: String {-^ A string representing the block in which this call appears (for errors) -} -> PermEnv -> @@ -211,10 +212,10 @@ requireArgsToHint :: requireArgsToHint who env blockIns tops args ghostString specString = case parseParsedCtxString who env ghostString of Just (Some ghost_ctx) -> - let full_ctx = appendParsedCtx (appendParsedCtx top_ctx ctx_rename) ghost_ctx + let full_ctx = appendParsedCtx (appendParsedCtx top_ctx ctx_rename) ghost_ctx sub = buildHintSub blockIns args ctx = mkArgsParsedCtx (mkCruCtx blockIns) - top_ctx = mkTopParsedCtx tops + top_ctx = mkTopParsedCtx tops ctx_rename = renameParsedCtx sub ctx in maybe (throwError (who ++ ": error parsing permissions")) (return . SomeHintSpec (parsedCtxCtx ghost_ctx)) @@ -225,7 +226,7 @@ requireArgsToHint who env blockIns tops args ghostString specString = -- | Apply a substitution to the names in a ParsedCtx renameParsedCtx :: [(String, String)] -> ParsedCtx ctx -> ParsedCtx ctx renameParsedCtx sub ctx = ctx { parsedCtxNames = renamed } - where + where renamed = mapRAssign (\(Constant x) -> Constant (substNames x)) (parsedCtxNames ctx) substNames x = fromMaybe x (lookup x sub) @@ -234,7 +235,7 @@ renameParsedCtx sub ctx = ctx { parsedCtxNames = renamed } -- provided to a `requires` call, i.e. given -- -- heapster.require(..., ..., %11, %50) --- if %11 corresponds to block argument 1 and %50 to block argument 0, with block arg 2 +-- if %11 corresponds to block argument 1 and %50 to block argument 0, with block arg 2 -- unused, -- then return the substitution [("arg1", "arg0"), ("arg1, arg0"), ("arg2", "arg2")] buildHintSub :: @@ -243,7 +244,7 @@ buildHintSub :: [Some (Reg block_args)] -> [(String, String)] buildHintSub blockArgs args = usedSub - where + where argNames = someRegName <$> args unusedNames = argNamei <$> [length argNames .. (Ctx.sizeInt (Ctx.size blockArgs))] usedSub = [ (a, argNamei i) | i <- [0..] | a <- argNames ++ unusedNames ] @@ -253,7 +254,7 @@ buildHintSub blockArgs args = usedSub toBlockArg :: Ctx.Size block_args -> Ctx.Size rest -> - Some (Reg (block_args Ctx.<+> rest)) -> + Some (Reg (block_args Ctx.<+> rest)) -> Maybe (Some (Reg block_args)) toBlockArg argsSz _restSz reg = case reg of @@ -269,7 +270,7 @@ mkBlockEntryHint :: CruCtx top_args -> CruCtx ghosts -> MbValuePerms ((top_args :++: CtxToRList args) :++: ghosts) -> - Hint + Hint mkBlockEntryHint cfg blockId tops ghosts valPerms = Hint_Block $ BlockHint h blocks blockId entryHint where diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs b/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs index 91785e5a40..4aded72cb8 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs @@ -62,6 +62,7 @@ import Lang.Crucible.LLVM.Bytes import Data.Binding.Hobbits import Verifier.SAW.Heapster.CruUtil +import Verifier.SAW.Heapster.PatternMatchUtil import Verifier.SAW.Heapster.Permissions import Verifier.SAW.Heapster.GenMonad @@ -371,9 +372,9 @@ data ImplError where EqualityProofError :: Doc ann -> Doc ann -> ImplError InsufficientVariablesError :: Doc ann -> ImplError ExistentialError :: Doc ann -> Doc ann -> ImplError - ImplVariableError - :: Doc ann -> String - -> (Doc ann, ExprVar tp) -> (Doc ann, ValuePerm tp) -> CruCtx vars + ImplVariableError + :: Doc ann -> String + -> (Doc ann, ExprVar tp) -> (Doc ann, ValuePerm tp) -> CruCtx vars -> DistPerms ps -> ImplError @@ -396,34 +397,34 @@ instance Liftable LifetimeErrorType where instance SubstVar PermVarSubst m => Substable PermVarSubst ImplError m where genSubst s mb_impl = case mbMatch mb_impl of - [nuMP| GeneralError doc |] -> + [nuMP| GeneralError doc |] -> return $ GeneralError $ mbLift doc - [nuMP| NoFrameInScopeError |] -> + [nuMP| NoFrameInScopeError |] -> return NoFrameInScopeError - [nuMP| ArrayStepError |] -> + [nuMP| ArrayStepError |] -> return ArrayStepError - [nuMP| MuUnfoldError |] -> + [nuMP| MuUnfoldError |] -> return MuUnfoldError - [nuMP| FunctionPermissionError |] -> + [nuMP| FunctionPermissionError |] -> return FunctionPermissionError - [nuMP| PartialSubstitutionError str doc |] -> + [nuMP| PartialSubstitutionError str doc |] -> return $ PartialSubstitutionError (mbLift str) (mbLift doc) - [nuMP| LifetimeError le |] -> + [nuMP| LifetimeError le |] -> return $ LifetimeError $ mbLift le - [nuMP| MemBlockError doc |] -> + [nuMP| MemBlockError doc |] -> return $ MemBlockError (mbLift doc) - [nuMP| EqualityProofError docl docr |] -> + [nuMP| EqualityProofError docl docr |] -> return $ EqualityProofError (mbLift docl) (mbLift docr) - [nuMP| InsufficientVariablesError doc |] -> + [nuMP| InsufficientVariablesError doc |] -> return $ InsufficientVariablesError $ mbLift doc - [nuMP| ExistentialError doc1 doc2 |] -> + [nuMP| ExistentialError doc1 doc2 |] -> return $ ExistentialError (mbLift doc1) (mbLift doc2) [nuMP| ImplVariableError doc f (xdoc, x) (pdoc, p) ctx mb_dp |] -> do x' <- genSubst s x p' <- genSubst s p dp <- genSubst s mb_dp return $ ImplVariableError (mbLift doc) (mbLift f) (mbLift xdoc, x') (mbLift pdoc, p') (mbLift ctx) dp - + -- The reason this isn't just Show is to sort of future-proof things. For -- instance, we may want to dump a limited amount of information to stdout, but -- something more comprehensive to a log for an IDE. @@ -1826,8 +1827,8 @@ permImplCatch pimpl (PermImpl_Step (Impl1_Fail _) _) | pruneFailingBranches = pimpl permImplCatch (PermImpl_Step (Impl1_Fail str1) _) (PermImpl_Step (Impl1_Fail str2) mb_impls) = - PermImpl_Step (Impl1_Fail $ GeneralError $ - pretty (ppError str1 ++ "\n\n--------------------\n\n" ++ ppError str2)) + PermImpl_Step (Impl1_Fail $ GeneralError $ + pretty (ppError str1 ++ "\n\n--------------------\n\n" ++ ppError str2)) mb_impls permImplCatch pimpl1@(PermImpl_Step (Impl1_Fail _) _) pimpl2 = permImplCatch pimpl2 pimpl1 @@ -3703,7 +3704,8 @@ getTopDistPerm x = use (implStatePerms . topDistPerm x) -- | Get the top permission in the stack, which is expected to be a conjuction, -- and return its conjuncts. If it is not a conjunction, raise an 'error', using -- the supplied 'String' as the caller in the error message. -getTopDistConj :: String -> ExprVar a -> +getTopDistConj :: HasCallStack => + String -> ExprVar a -> ImplM vars s r (ps :> a) (ps :> a) [AtomicPerm a] getTopDistConj caller x = use (implStatePerms . topDistPerm x) >>>= \case @@ -3804,11 +3806,11 @@ implSetNameTypes (ns :>: n) (CruCtxCons tps tp) = implSetNameTypes ns tps -- | TODO: Move this in to Hobbits -nameMapFind - :: (forall tp. f tp -> Bool) - -> NameMap f +nameMapFind + :: (forall tp. f tp -> Bool) + -> NameMap f -> Maybe (Some (Product Name f)) -nameMapFind predicate nm = +nameMapFind predicate nm = case find (\(NameAndElem _ f) -> predicate f) $ NameMap.assocs nm of Just (NameAndElem name f) -> Just $ Some $ Pair name f Nothing -> Nothing @@ -3824,13 +3826,13 @@ permContainsVar x p = NameSet.member x (freeVars p) -- FIXME: what is the purpose of this? Don't we want all permissions recursively -- containing @x@? findPermsContainingVar :: ExprVar tp -> ImplM vars s r ps ps (Some DistPerms) -findPermsContainingVar x = +findPermsContainingVar x = getPerms >>>= \perms -> case nameMapFind (permContainsVar x) (view varPermMap perms) of Just (Some (Pair y p)) -> findPermsContainingVar y >>>= \(Some dps) -> return $ Some $ DistPermsCons dps y p Nothing -> return $ Some DistPermsNil - + -- | When adding a new existential unit-typed variable, instantiate it with the -- underlying global unit if available; if not, update the global unit variable -- with a fresh variable @@ -5678,7 +5680,7 @@ implGetLLVMPermForOffset :: (1 <= w, KnownNat w, NuMatchingAny1 r) => ExprVar (LLVMPointerType w) {- ^ the variable @x@ -} -> [AtomicPerm (LLVMPointerType w)] {- ^ the permissions held for @x@ -} -> - Bool {- ^ whether imprecise matches are allowed -} -> + Bool {- ^ whether imprecise matches are allowed -} -> Bool {- ^ whether block permissions should be eliminated -} -> PermExpr (BVType w) {- ^ the offset we are looking for -} -> Mb vars (ValuePerm (LLVMPointerType w)) {- ^ the perm we want to prove -} -> @@ -6087,10 +6089,10 @@ instance ProveEq (LLVMFramePerm w) where do eqp1 <- proveEq e mb_e eqp2 <- proveEq fperms mb_fperms pure (liftA2 (\x y -> (x,i):y) eqp1 eqp2) - proveEq perms mb = + proveEq perms mb = use implStatePPInfo >>>= \ppinfo -> - implFailM $ EqualityProofError - (permPretty ppinfo perms) + implFailM $ EqualityProofError + (permPretty ppinfo perms) (permPretty ppinfo mb) instance ProveEq (LLVMBlockPerm w) where @@ -6178,9 +6180,9 @@ proveEqH psubst e mb_e = case (e, mbMatch mb_e) of Just _ -> proveEqH psubst e mb_e Nothing -> getVarEqPerm y >>= \case Just _ -> proveEqH psubst e mb_e - Nothing -> + Nothing -> use implStatePPInfo >>>= \ppinfo -> - implFailM $ EqualityProofError + implFailM $ EqualityProofError (permPretty ppinfo e) (permPretty ppinfo mb_e) @@ -6210,7 +6212,7 @@ proveEqH psubst e mb_e = case (e, mbMatch mb_e) of pure (someEqProofTrans (someEqProof1 x e' True) eqp2) Nothing -> use implStatePPInfo >>>= \ppinfo -> - implFailM $ EqualityProofError + implFailM $ EqualityProofError (permPretty ppinfo e) (permPretty ppinfo mb_e) @@ -6225,7 +6227,7 @@ proveEqH psubst e mb_e = case (e, mbMatch mb_e) of pure (someEqProofTrans eqp (someEqProof1 x e' False)) Nothing -> use implStatePPInfo >>>= \ppinfo -> - implFailM $ EqualityProofError + implFailM $ EqualityProofError (permPretty ppinfo e) (permPretty ppinfo mb_e) @@ -6252,7 +6254,7 @@ proveEqH psubst e mb_e = case (e, mbMatch mb_e) of -- Otherwise give up! _ -> use implStatePPInfo >>>= \ppinfo -> - implFailM $ EqualityProofError + implFailM $ EqualityProofError (permPretty ppinfo e) (permPretty ppinfo mb_e) @@ -6934,10 +6936,12 @@ borrowedLLVMArrayForArray lhs rhs = , llvmArrayOffset = o' }) where - rs = llvmArrayAbsBorrowRange rhs <$> bs + rs = llvmArrayAbsBorrowRange rhs <$> bs + (r', rs') = expectLengthAtLeastOne rs + bs' = chopBorrows [] bs (llvmArrayBorrows rhs) ++ llvmArrayBorrows rhs - o' = bvRangeOffset (head rs) - v = bvRangeOffset (last rs) `bvAdd` bvRangeLength (last rs) + o' = bvRangeOffset r' + v = bvRangeOffset rs' `bvAdd` bvRangeLength rs' len' = matchLLVMArrayCell rhs v _ -> Nothing @@ -7677,8 +7681,8 @@ proveVarLLVMBlocks2 x ps psubst mb_bp [nuMP| PExpr_EmptyShape |] mb_bps = -- Extract out the block perm we proved and coerce it to the empty shape getTopDistConj "proveVarLLVMBlocks2" x >>>= \ps_out -> - let ps_out' = tail ps_out - bp = case head ps_out of + let (ps_out_hd, ps_out') = expectLengthAtLeastOne ps_out + bp = case ps_out_hd of Perm_LLVMBlock bp_ -> bp_ _ -> error "proveVarLLVMBlocks2: expected block permission" in implSplitSwapConjsM x ps_out 1 >>> @@ -7752,7 +7756,7 @@ proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps -- Extract out the block perm we proved getTopDistConj "proveVarLLVMBlocks2" x >>>= \ps_out -> - let ps_out' = tail ps_out in + let (_, ps_out') = expectLengthAtLeastOne ps_out in implSplitSwapConjsM x ps_out 1 >>> -- Introduce the modalities @@ -7797,8 +7801,8 @@ proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps -- Extract out the block perm we proved getTopDistConj "proveVarLLVMBlocks2" x >>>= \ps_out -> - let ps_out' = tail ps_out - bp = case head ps_out of + let (ps_out_hd, ps_out') = expectLengthAtLeastOne ps_out + bp = case ps_out_hd of Perm_LLVMBlock bp_ -> bp_ _ -> error "proveVarLLVMBlocks2: expected block permission" in implSplitSwapConjsM x ps_out 1 >>> @@ -7862,8 +7866,8 @@ proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps -- Extract out the block perm we proved getTopDistConj "proveVarLLVMBlocks2" x >>>= \ps_out -> - let ps_out' = tail ps_out - bp = case head ps_out of + let (ps_out_hd, ps_out') = expectLengthAtLeastOne ps_out + bp = case ps_out_hd of Perm_LLVMBlock bp_ -> bp_ _ -> error "proveVarLLVMBlocks2: expected block perm" in implSplitSwapConjsM x ps_out 1 >>> @@ -7915,7 +7919,8 @@ proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps implSimplM Proxy (SImpl_IntroLLVMBlockPtr x bp) >>> -- Finally, move the memblock perm we proved back into position - implSwapInsertConjM x (Perm_LLVMBlock bp) (tail ps') 0 + let (_, ps'') = expectLengthAtLeastOne ps' in + implSwapInsertConjM x (Perm_LLVMBlock bp) ps'' 0 -- If proving a field shape, prove the remaining blocks and then prove the @@ -7996,7 +8001,8 @@ proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps -- empty shape onto the end of it getTopDistConj "proveVarLLVMBlocks2" x >>>= \ps' -> implExtractSwapConjM x ps' 0 >>> - let bp = case head ps' of + let (ps_hd', ps'') = expectLengthAtLeastOne ps' + bp = case ps_hd' of Perm_LLVMBlock bp_ -> bp_ _ -> error "proveVarLLVMBlocks2: expected block permission" sh1 = llvmBlockShape bp in @@ -8006,7 +8012,7 @@ proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps implSwapInsertConjM x (Perm_LLVMBlock (bp { llvmBlockShape = PExpr_SeqShape sh1 PExpr_EmptyShape })) - (tail ps') 0 + ps'' 0 -- If proving a sequence shape otherwise, prove the two shapes and combine them; @@ -8098,10 +8104,11 @@ proveVarLLVMBlocks2 x ps psubst mb_bp _ mb_bps -- Finally, weaken the block permission to be the desired tagged union -- shape, and move it back into position + let (_, ps''') = expectLengthAtLeastOne ps'' in partialSubstForceM mb_shs "proveVarLLVMBlock" >>>= \shs -> partialSubstForceM mb_bp "proveVarLLVMBlock" >>>= \bp -> implIntroOrShapeMultiM x bp shs i >>> - implSwapInsertConjM x (Perm_LLVMBlock bp) (tail ps'') 0 + implSwapInsertConjM x (Perm_LLVMBlock bp) ps''' 0 -- If proving a disjunctive shape, try to prove one of the disjuncts @@ -8132,9 +8139,10 @@ proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps -- Now coerce the disjunctive permission on top of the stack to an or shape, -- and move it back into position + let (_, ps'') = expectLengthAtLeastOne ps' in implSimplM Proxy (SImpl_IntroLLVMBlockOr x (bp { llvmBlockShape = sh1 }) sh2) >>> - implSwapInsertConjM x (Perm_LLVMBlock bp) (tail ps') 0 + implSwapInsertConjM x (Perm_LLVMBlock bp) ps'' 0 -- If proving an existential shape, introduce an evar and recurse @@ -8157,8 +8165,9 @@ proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps -- Now coerce the existential permission on top of the stack to a memblock -- perm with existential shape, and move it back into position + let (_, ps'') = expectLengthAtLeastOne ps' in implSimplM Proxy (SImpl_IntroLLVMBlockEx x bp_out) >>> - implSwapInsertConjM x (Perm_LLVMBlock bp_out) (tail ps') 0 + implSwapInsertConjM x (Perm_LLVMBlock bp_out) ps'' 0 -- If proving an evar shape that has already been set, substitute and recurse @@ -8785,7 +8794,7 @@ proveVarConjImpl x ps_lhs mb_ps = implInsertConjM x p ps' i [nuMP| Nothing |] -> use implStatePPInfo >>>= \ppinfo -> - implFailM $ InsufficientVariablesError $ + implFailM $ InsufficientVariablesError $ permPretty ppinfo (fmap ValPerm_Conj mb_ps) @@ -9114,7 +9123,7 @@ proveExVarImpl _ mb_x mb_p@(mbMatch -> [nuMP| ValPerm_Conj [Perm_LLVMFrame _] |] -- Otherwise we fail proveExVarImpl _ mb_x mb_p = use implStatePPInfo >>>= \ppinfo -> - implFailM $ ExistentialError + implFailM $ ExistentialError (permPretty ppinfo mb_x) (permPretty ppinfo mb_p) @@ -9264,7 +9273,7 @@ proveVarsImplAppendInt mb_ps = use implStatePPInfo >>>= \ppinfo -> implFailM $ InsufficientVariablesError $ permPretty ppinfo mb_ps - + -- | Like 'proveVarsImplAppendInt' but re-associate the appends proveVarsImplAppendIntAssoc :: NuMatchingAny1 r => prx ps_in -> prx1 ps1 -> ExDistPerms vars ps -> @@ -9454,7 +9463,7 @@ proveVarImpl x mb_p = proveVarsImplAppend $ fmap (distPerms1 x) mb_p implFailM :: NuMatchingAny1 r => ImplError -> ImplM vars s r ps_any ps a implFailM err = use implStateFailPrefix >>>= \prefix -> - implTraceM (const $ pretty $ prefix <> ppError err) >>> + implTraceM (const $ pretty $ prefix <> ppError err) >>> implApplyImpl1 (Impl1_Fail err) MNil -- | Terminate the current proof branch with a failure proving @x:p -o mb_p@ @@ -9465,19 +9474,19 @@ implFailVarM f x p mb_p = use implStateVars >>>= \ctx -> findPermsContainingVar x >>>= \case (Some distperms) -> - implFailM $ ImplVariableError - (ppImpl ppinfo x p mb_p) - f - (permPretty ppinfo x, x) + implFailM $ ImplVariableError + (ppImpl ppinfo x p mb_p) + f + (permPretty ppinfo x, x) (permPretty ppinfo p, p) - ctx + ctx distperms instance ErrorPretty ImplError where ppError (GeneralError doc) = renderDoc doc - ppError NoFrameInScopeError = + ppError NoFrameInScopeError = "No LLVM frame in scope" - ppError ArrayStepError = + ppError ArrayStepError = "Error proving array permissions" ppError MuUnfoldError = "Tried to unfold a mu on the left after unfolding on the right" diff --git a/heapster-saw/src/Verifier/SAW/Heapster/PatternMatchUtil.hs b/heapster-saw/src/Verifier/SAW/Heapster/PatternMatchUtil.hs new file mode 100644 index 0000000000..21c20de41d --- /dev/null +++ b/heapster-saw/src/Verifier/SAW/Heapster/PatternMatchUtil.hs @@ -0,0 +1,20 @@ +-- | Pattern-matching utilities used within @heapster-saw@. +module Verifier.SAW.Heapster.PatternMatchUtil + ( expectLengthAtLeastOne + , expectLengthAtLeastTwo + ) where + +import GHC.Stack + +-- | Use this in places where you maintain the invariant that the list argument +-- has at least one element. +expectLengthAtLeastOne :: HasCallStack => [a] -> (a, [a]) +expectLengthAtLeastOne (x:xs) = (x, xs) +expectLengthAtLeastOne [] = error "expectLengthAtLeastOne: Unexpected empty list" + +-- | Use this in places where you maintain the invariant that the list argument +-- has at least two elements. +expectLengthAtLeastTwo :: HasCallStack => [a] -> (a, a, [a]) +expectLengthAtLeastTwo (x1:x2:xs) = (x1, x2, xs) +expectLengthAtLeastTwo [_] = error "expectLengthAtLeastTwo: Unexpected singleton list" +expectLengthAtLeastTwo [] = error "expectLengthAtLeastTwo: Unexpected empty list" diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index fdde3649b3..7369ccecc6 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -73,6 +73,7 @@ import Verifier.SAW.Term.Functor import Verifier.SAW.SharedTerm import Verifier.SAW.Heapster.CruUtil +import Verifier.SAW.Heapster.PatternMatchUtil import Verifier.SAW.Heapster.Permissions import Verifier.SAW.Heapster.Implication import Verifier.SAW.Heapster.TypedCrucible @@ -1673,8 +1674,7 @@ getLLVMArrayTransSlice arr_trans sub_arr_tp rng_trans prop_transs = v_tm = llvmArrayTransTerm arr_trans off_tm = transTerm1 $ bvRangeTransOff rng_trans len'_tm = transTerm1 $ bvRangeTransLen rng_trans - p1_trans = head prop_transs - p2_trans = head (tail prop_transs) + (p1_trans, p2_trans, _) = expectLengthAtLeastTwo prop_transs BVPropTrans _ p1_tm = p1_trans BVPropTrans _ p2_tm = p2_trans in typeTransF sub_arr_tp @@ -5201,8 +5201,9 @@ tcTranslateAddCFGs sc mod_name env checks endianness dlevel cfgs_and_perms = let (fun_ixs, lrtss) = unzip $ gen_lrts_ixs 0 tcfgs let lrts = concat lrtss frame_tm <- completeNormOpenTerm sc $ lrtsOpenTerm lrts + let (cfg_and_perm, _) = expectLengthAtLeastOne cfgs_and_perms let frame_ident = - mkSafeIdent mod_name (someCFGAndPermToName (head cfgs_and_perms) + mkSafeIdent mod_name (someCFGAndPermToName cfg_and_perm ++ "__frame") frame_tp <- completeNormOpenTerm sc frameTypeOpenTerm scInsertDef sc mod_name frame_ident frame_tp frame_tm @@ -5231,7 +5232,7 @@ tcTranslateAddCFGs sc mod_name env checks endianness dlevel cfgs_and_perms = -- Add a named definition for bodies_tm let bodies_ident = - mkSafeIdent mod_name (someCFGAndPermToName (head cfgs_and_perms) + mkSafeIdent mod_name (someCFGAndPermToName cfg_and_perm ++ "__bodies") bodies_tp <- completeNormOpenTerm sc $ From 979c5b3f510c21b874854b85764c96b14520f92c Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Tue, 14 Mar 2023 13:16:48 -0400 Subject: [PATCH 19/27] Regenerate cabal.GHC-*.config files --- cabal.GHC-8.10.7.config | 216 ++++++++++++++++++++------------------- cabal.GHC-8.8.4.config | 216 ++++++++++++++++++++------------------- cabal.GHC-9.0.2.config | 220 +++++++++++++++++++++------------------- 3 files changed, 341 insertions(+), 311 deletions(-) diff --git a/cabal.GHC-8.10.7.config b/cabal.GHC-8.10.7.config index e859dc2c14..606ffdc455 100644 --- a/cabal.GHC-8.10.7.config +++ b/cabal.GHC-8.10.7.config @@ -5,26 +5,26 @@ constraints: any.Cabal ==3.2.1.0, GraphSCC -use-maps, any.HUnit ==1.6.2.0, any.IfElse ==0.85, - any.IntervalMap ==0.6.1.2, + any.IntervalMap ==0.6.2.0, any.MemoTrie ==0.6.10, MemoTrie -examples, - any.MonadRandom ==0.5.3, + any.MonadRandom ==0.6, any.OneTuple ==0.3.1, any.Only ==0.1, any.QuickCheck ==2.14.2, QuickCheck -old-random +templatehaskell, any.StateVar ==1.2.2, - any.adjunctions ==4.4.1, - any.aeson ==1.5.6.0, - aeson -bytestring-builder -cffi -developer -fast, - any.aeson-typescript ==0.4.0.0, + any.adjunctions ==4.4.2, + any.aeson ==2.0.3.0, + aeson -cffi +ordered-keymap, + any.aeson-typescript ==0.4.2.0, any.alex ==3.2.7.1, - any.ansi-terminal ==0.11.3, + any.ansi-terminal ==0.11.4, ansi-terminal -example, any.ansi-wl-pprint ==0.6.9, ansi-wl-pprint -example, any.appar ==0.1.8, - any.arithmoi ==0.12.0.1, + any.arithmoi ==0.12.0.2, any.array ==0.5.4.0, any.asn1-encoding ==0.9.6, any.asn1-parse ==0.9.5, @@ -35,36 +35,38 @@ constraints: any.Cabal ==3.2.1.0, any.attoparsec ==0.14.4, attoparsec -developer, any.auto-update ==0.1.6, - any.barbies ==2.0.3.1, + any.barbies ==2.0.4.0, any.base ==4.14.3.0, - any.base-compat ==0.12.1, - any.base-compat-batteries ==0.12.1, - any.base-orphans ==0.8.6, + any.base-compat ==0.12.2, + any.base-compat-batteries ==0.12.2, + any.base-orphans ==0.8.8.2, any.base16-bytestring ==1.0.2.0, any.base64-bytestring ==1.2.1.0, - any.basement ==0.0.14, - any.bifunctors ==5.5.12, + any.basement ==0.0.15, + any.bifunctors ==5.5.15, bifunctors +semigroups +tagged, any.bimap ==0.5.0, any.binary ==0.8.8.0, - any.binary-orphans ==1.0.2, + any.binary-orphans ==1.0.4.1, + any.bitvec ==1.1.3.0, + bitvec -libgmp, any.bitwise ==1.0.0.1, any.blaze-builder ==0.4.2.2, any.blaze-html ==0.9.1.2, any.blaze-markup ==0.8.2.8, - any.boomerang ==1.4.8, + any.boomerang ==1.4.8.1, any.bsb-http-chunked ==0.0.0.4, - any.bv-sized ==1.0.4, + any.bv-sized ==1.0.5, any.byteorder ==1.0.4, any.bytestring ==0.10.12.0, any.cabal-doctest ==1.0.9, any.call-stack ==0.4.0, any.case-insensitive ==1.2.1.0, - any.cassava ==0.5.2.0, + any.cassava ==0.5.3.0, cassava -bytestring--lt-0_10_4, - any.cereal ==0.5.8.2, + any.cereal ==0.5.8.3, cereal -bytestring-builder, - any.chimera ==0.3.2.0, + any.chimera ==0.3.3.0, chimera +representable, any.clock ==0.8.3, clock -llvm, @@ -73,67 +75,67 @@ constraints: any.Cabal ==3.2.1.0, any.comonad ==5.0.8, comonad +containers +distributive +indexed-traversable, any.concurrent-extra ==0.7.0.12, - any.concurrent-output ==1.10.16, - any.conduit ==1.3.4.2, + any.concurrent-output ==1.10.17, + any.conduit ==1.3.4.3, any.conduit-extra ==1.3.6, - any.config-schema ==1.2.2.0, - any.config-value ==0.8.2.1, + any.config-schema ==1.3.0.0, + any.config-value ==0.8.3, any.constraints ==0.13.4, any.containers ==0.6.5.1, any.contravariant ==1.5.5, contravariant +semigroups +statevar +tagged, - any.cookie ==0.4.5, - any.criterion ==1.5.13.0, + any.cookie ==0.4.6, + any.criterion ==1.6.0.0, criterion -embed-data-files -fast, - any.criterion-measurement ==0.1.3.0, + any.criterion-measurement ==0.2.1.0, criterion-measurement -fast, crucible +unsafe-operations, any.cryptohash-md5 ==0.11.101.0, any.cryptohash-sha1 ==0.11.101.0, - cryptol +relocatable -static, + cryptol +ffi +relocatable -static, cryptol-remote-api -notthreaded -static, any.cryptonite ==0.30, cryptonite -check_alignment +integer-gmp -old_toolchain_inliner +support_aesni +support_deepseq -support_pclmuldq +support_rdrand -support_sse +use_target_attributes, any.cryptonite-conduit ==0.2.2, - any.data-accessor ==0.2.3, + any.data-accessor ==0.2.3.1, data-accessor +category +monadfail +splitbase, + any.data-array-byte ==0.1.0.1, any.data-default-class ==0.1.2.0, any.data-fix ==0.3.2, any.data-inttrie ==0.1.4, - any.data-ref ==0.0.2, + any.data-ref ==0.1, any.deepseq ==1.4.4.0, any.dense-linear-algebra ==0.1.0.0, - any.deriving-compat ==0.6.1, + any.deriving-compat ==0.6.3, deriving-compat +base-4-9 +new-functor-classes +template-haskell-2-11, any.directory ==1.3.6.0, any.distributive ==0.6.2.1, distributive +semigroups +tagged, any.dlist ==1.0, dlist -werror, - any.doctest ==0.20.0, + any.doctest ==0.20.1, any.dotgen ==0.4.3, dotgen -devel, any.easy-file ==0.2.2, any.either ==5.0.2, - any.entropy ==0.4.1.7, - entropy -halvm, + any.entropy ==0.4.1.10, + entropy -donotgetentropy, any.erf ==2.0.0.0, any.exact-pi ==0.5.0.2, any.exceptions ==0.10.4, any.executable-path ==0.0.3.1, any.extensible-exceptions ==0.1.1.4, - any.extra ==1.7.10, - any.fail ==4.9.0.0, - any.fast-logger ==3.1.1, - any.fgl ==5.7.0.3, + any.extra ==1.7.12, + any.fast-logger ==3.2.1, + any.fgl ==5.8.1.1, fgl +containers042, any.fgl-visualize ==0.1.0.1, any.filelock ==0.1.1.5, any.filemanip ==0.3.6.3, any.filepath ==1.4.2.1, any.fingertree ==0.1.5.0, - any.free ==5.1.9, - any.generic-deriving ==1.14.1, + any.free ==5.1.10, + any.generic-deriving ==1.14.3, generic-deriving +base-4-9, any.generic-lens ==2.2.1.0, any.generic-lens-core ==2.2.1.0, @@ -146,47 +148,49 @@ constraints: any.Cabal ==3.2.1.0, any.ghc-paths ==0.1.0.12, any.ghc-prim ==0.6.1, any.ghci ==8.10.7, - any.githash ==0.1.6.2, + any.githash ==0.1.6.3, any.gitrev ==1.3.1, any.graphviz ==2999.20.1.0, graphviz -test-parsing, - any.happy ==1.20.0, + any.happy ==1.20.1.1, any.hashable ==1.3.5.0, hashable +integer-gmp -random-initial-seed, any.hashtables ==1.2.4.2, hashtables -bounds-checking -debug -detailed-profiling -portable -sse42 +unsafe-tricks, any.haskeline ==0.8.2, - any.haskell-lexer ==1.1, + any.haskell-lexer ==1.1.1, any.haskell-src-exts ==1.23.1, - any.haskell-src-meta ==0.8.10, - any.hedgehog ==1.1.1, - any.hedgehog-classes ==0.2.5.3, + any.haskell-src-meta ==0.8.11, + any.hedgehog ==1.2, + any.hedgehog-classes ==0.2.5.4, hedgehog-classes +aeson +comonad +primitive +semirings +vector, any.heredoc ==0.2.0.0, + any.hgmp ==0.1.2.1, any.hobbits ==1.4, any.hostname ==1.0, any.hourglass ==0.2.12, any.hpc ==0.6.1.0, - any.hsc2hs ==0.68.8, + any.hsc2hs ==0.68.9, hsc2hs -in-ghc-tree, - any.hspec ==2.10.0, - any.hspec-core ==2.10.0, - any.hspec-discover ==2.10.0, + any.hspec ==2.10.10, + any.hspec-core ==2.10.10, + any.hspec-discover ==2.10.10, any.hspec-expectations ==0.8.2, any.http-date ==0.0.11, any.http-types ==0.12.3, - any.http2 ==3.0.3, + any.http2 ==4.0.0, http2 -devel -doc -h2spec, + any.ieee754 ==0.8.0, any.indexed-profunctors ==0.1.1, - any.indexed-traversable ==0.1.2, - any.indexed-traversable-instances ==0.1.1, + any.indexed-traversable ==0.1.2.1, + any.indexed-traversable-instances ==0.1.1.2, any.integer-gmp ==1.0.3.0, any.integer-logarithms ==1.0.3.1, integer-logarithms -check-bounds +integer-gmp, any.integer-roots ==1.0.2.0, any.interpolate ==0.2.1, - any.invariant ==0.5.6, - any.io-streams ==1.5.2.1, + any.invariant ==0.6.1, + any.io-streams ==1.5.2.2, io-streams +network -nointeractivetests +zlib, any.iproute ==1.7.12, any.itanium-abi ==0.1.1.1, @@ -194,29 +198,34 @@ constraints: any.Cabal ==3.2.1.0, any.json ==0.10, json +generic -mapdict +parsec +pretty +split-base, any.kan-extensions ==5.2.5, - any.kvitable ==1.0.1.0, + any.kvitable ==1.0.2.0, + any.language-c99 ==0.2.0, + any.language-c99-simple ==0.2.2, + any.language-c99-util ==0.2.0, language-rust +enablequasiquotes +usebytestrings, any.lens ==5.1.1, lens -benchmark-uniplate -dump-splices +inlining -j +test-hunit +test-properties +test-templates +trustworthy, - any.libBF ==0.6.3, + any.libBF ==0.6.5.1, libBF -system-libbf, + any.libffi ==0.2.1, + libffi +ghc-bundled-libffi, any.libyaml ==0.1.2, libyaml -no-unicode -system-libyaml, - any.lifted-async ==0.10.2.2, + any.lifted-async ==0.10.2.3, any.lifted-base ==0.2.3.12, llvm-pretty-bc-parser -fuzz -regressions, any.logict ==0.8.0.0, any.lucid ==2.11.1, - any.lumberjack ==1.0.1.0, + any.lumberjack ==1.0.2.0, any.math-functions ==0.3.4.2, math-functions +system-erf +system-expm1, any.megaparsec ==9.0.1, megaparsec -dev, - any.memory ==0.17.0, + any.memory ==0.18.0, memory +support_bytestring +support_deepseq, - any.microlens ==0.4.13.0, - any.microlens-th ==0.4.3.10, - any.microstache ==1.0.2.1, + any.microlens ==0.4.13.1, + any.microlens-th ==0.4.3.11, + any.microstache ==1.0.2.3, any.mmorph ==1.2.0, any.mod ==0.1.2.2, mod +semirings +vector, @@ -227,9 +236,7 @@ constraints: any.Cabal ==3.2.1.0, any.mono-traversable ==1.0.15.3, any.mtl ==2.2.2, any.mwc-random ==0.15.0.2, - any.nats ==1.1.2, - nats +binary +hashable +template-haskell, - any.network ==3.1.2.7, + any.network ==3.1.2.8, network -devel, any.network-byte-order ==0.1.6, any.network-info ==0.2.1, @@ -259,12 +266,13 @@ constraints: any.Cabal ==3.2.1.0, any.process ==1.6.13.2, any.profunctors ==5.6.2, any.psqueues ==0.2.7.3, - any.quickcheck-instances ==0.3.27, + any.quickcheck-instances ==0.3.29.1, quickcheck-instances -bytestring-builder, any.quickcheck-io ==0.2.0, any.random ==1.2.1.1, any.raw-strings-qq ==1.1, - any.reflection ==2.1.6, + any.recv ==0.1.0, + any.reflection ==2.1.7, reflection -slow +template-haskell, any.regex-base ==0.94.0.2, any.regex-compat ==0.95.2.1, @@ -272,13 +280,16 @@ constraints: any.Cabal ==3.2.1.0, regex-posix -_regex-posix-clib, any.resourcet ==1.2.6, any.rts ==1.0.1, - any.s-cargot ==0.1.4.0, + any.s-cargot ==0.1.5.0, s-cargot -build-example, any.safe ==0.3.19, - any.sbv ==8.15, + any.safe-exceptions ==0.1.7.3, + any.sbv ==9.0, any.scientific ==0.3.7.0, scientific -bytestring-builder -integer-simple, - any.scotty ==0.12, + any.scotty ==0.12.1, + any.semialign ==1.2.0.1, + semialign +semigroupoids, any.semigroupoids ==5.3.7, semigroupoids +comonad +containers +contravariant +distributive +tagged +unordered-containers, any.semigroups ==0.20, @@ -286,39 +297,39 @@ constraints: any.Cabal ==3.2.1.0, any.semirings ==0.6, semirings +containers +unordered-containers, any.setenv ==0.1.1.3, - any.silently ==1.2.5.2, + any.silently ==1.2.5.3, any.simple-get-opt ==0.4, any.simple-sendfile ==0.2.30, simple-sendfile +allow-bsd, any.simple-smt ==0.9.7, any.smallcheck ==1.2.1, - any.split ==0.2.3.4, + any.split ==0.2.3.5, any.splitmix ==0.1.0.4, splitmix -optimised-mixer, - any.statistics ==0.16.1.0, + any.statistics ==0.16.1.2, any.stm ==2.5.0.1, - any.streaming-commons ==0.2.2.4, + any.streaming-commons ==0.2.2.5, streaming-commons -use-bytestring-builder, any.strict ==0.4.0.1, strict +assoc, - any.string-interpolate ==0.3.1.2, + any.string-interpolate ==0.3.2.0, string-interpolate -bytestring-builder -extended-benchmarks -text-builder, - any.syb ==0.7.2.1, - any.tagged ==0.8.6.1, + any.syb ==0.7.2.2, + any.tagged ==0.8.7, tagged +deepseq +transformers, - any.tasty ==1.4.2.3, - tasty +clock +unix, + any.tasty ==1.4.3, + tasty +unix, any.tasty-ant-xml ==1.1.8, - any.tasty-checklist ==1.0.3.0, + any.tasty-checklist ==1.0.5.0, any.tasty-expected-failure ==0.12.3, any.tasty-golden ==2.3.5, tasty-golden -build-example, - any.tasty-hedgehog ==1.2.0.0, - any.tasty-hspec ==1.2.0.1, + any.tasty-hedgehog ==1.4.0.0, + any.tasty-hspec ==1.2.0.3, any.tasty-hunit ==0.10.0.3, any.tasty-quickcheck ==0.10.2, any.tasty-smallcheck ==0.8.2, - any.tasty-sugar ==1.3.0.1, + any.tasty-sugar ==1.3.0.2, any.template-haskell ==2.16.0.0, any.temporary ==1.3, any.terminal-size ==0.3.3, @@ -331,12 +342,12 @@ constraints: any.Cabal ==3.2.1.0, any.text-short ==0.1.5, text-short -asserts, any.tf-random ==0.5, - any.th-abstraction ==0.4.3.0, - any.th-compat ==0.1.3, - any.th-expand-syns ==0.4.9.0, - any.th-lift ==0.8.2, - any.th-lift-instances ==0.1.19, - any.th-orphans ==0.13.13, + any.th-abstraction ==0.4.5.0, + any.th-compat ==0.1.4, + any.th-expand-syns ==0.4.11.0, + any.th-lift ==0.8.3, + any.th-lift-instances ==0.1.20, + any.th-orphans ==0.13.14, any.th-reify-many ==0.1.10, any.these ==1.1.1.1, these +assoc, @@ -353,15 +364,15 @@ constraints: any.Cabal ==3.2.1.0, any.transformers-compat ==0.7.2, transformers-compat -five +five-three -four +generic-deriving +mtl -three -two, any.type-equality ==1, - any.typed-process ==0.2.10.1, + any.typed-process ==0.2.11.0, any.unbounded-delays ==0.1.1.1, any.uniplate ==1.6.13, any.unix ==2.7.2.2, any.unix-compat ==0.6, unix-compat -old-time, - any.unix-time ==0.4.7, - any.unliftio ==0.2.22.0, - any.unliftio-core ==0.2.0.1, + any.unix-time ==0.4.8, + any.unliftio ==0.2.24.0, + any.unliftio-core ==0.2.1.0, any.unordered-containers ==0.2.19.1, unordered-containers -debug, any.utf8-string ==1.0.2, @@ -371,24 +382,23 @@ constraints: any.Cabal ==3.2.1.0, vault +useghc, any.vector ==0.12.3.1, vector +boundschecks -internalchecks -unsafechecks -wall, - any.vector-algorithms ==0.8.0.4, + any.vector-algorithms ==0.9.0.1, vector-algorithms +bench +boundschecks -internalchecks -llvm +properties -unsafechecks, any.vector-binary-instances ==0.2.5.2, any.vector-th-unbox ==0.2.2, - any.versions ==5.0.3, + any.versions ==5.0.4, any.void ==0.7.3, void -safe, any.wai ==3.2.3, - any.wai-extra ==3.1.12.1, + any.wai-extra ==3.1.13.0, wai-extra -build-example, any.wai-logger ==2.4.0, - any.warp ==3.3.21, + any.warp ==3.3.24, warp +allow-sendfilefd -network-bytestring -warp-debug +x509, - any.warp-tls ==3.3.2, - any.wcwidth ==0.0.2, - wcwidth -cli +split-base, + any.warp-tls ==3.3.5, any.weigh ==0.0.16, what4 -drealtestdisable -solvertests -stptestdisable, + any.witherable ==0.4.2, any.wl-pprint-annotated ==0.1.0.1, any.wl-pprint-text ==1.2.0.2, any.word8 ==0.1.3, @@ -396,10 +406,10 @@ constraints: any.Cabal ==3.2.1.0, any.x509-store ==1.6.9, any.x509-validation ==1.6.12, any.xml ==1.3.14, - any.yaml ==0.11.8.0, + any.yaml ==0.11.11.0, yaml +no-examples +no-exe, any.zenc ==0.1.2, any.zlib ==0.6.3.0, zlib -bundled-c-zlib -non-blocking-ffi -pkg-config, any.zlib-bindings ==0.1.1.5 -index-state: hackage.haskell.org 2022-06-30T19:50:05Z +index-state: hackage.haskell.org 2023-03-13T12:18:58Z diff --git a/cabal.GHC-8.8.4.config b/cabal.GHC-8.8.4.config index 5adc7218e7..316e457bfd 100644 --- a/cabal.GHC-8.8.4.config +++ b/cabal.GHC-8.8.4.config @@ -5,26 +5,26 @@ constraints: any.Cabal ==3.0.1.0, GraphSCC -use-maps, any.HUnit ==1.6.2.0, any.IfElse ==0.85, - any.IntervalMap ==0.6.1.2, + any.IntervalMap ==0.6.2.0, any.MemoTrie ==0.6.10, MemoTrie -examples, - any.MonadRandom ==0.5.3, + any.MonadRandom ==0.6, any.OneTuple ==0.3.1, any.Only ==0.1, any.QuickCheck ==2.14.2, QuickCheck -old-random +templatehaskell, any.StateVar ==1.2.2, - any.adjunctions ==4.4.1, - any.aeson ==1.5.6.0, - aeson -bytestring-builder -cffi -developer -fast, - any.aeson-typescript ==0.4.0.0, + any.adjunctions ==4.4.2, + any.aeson ==2.0.3.0, + aeson -cffi +ordered-keymap, + any.aeson-typescript ==0.4.2.0, any.alex ==3.2.7.1, - any.ansi-terminal ==0.11.3, + any.ansi-terminal ==0.11.4, ansi-terminal -example, any.ansi-wl-pprint ==0.6.9, ansi-wl-pprint -example, any.appar ==0.1.8, - any.arithmoi ==0.12.0.1, + any.arithmoi ==0.12.0.2, any.array ==0.5.4.0, any.asn1-encoding ==0.9.6, any.asn1-parse ==0.9.5, @@ -35,36 +35,38 @@ constraints: any.Cabal ==3.0.1.0, any.attoparsec ==0.14.4, attoparsec -developer, any.auto-update ==0.1.6, - any.barbies ==2.0.3.1, + any.barbies ==2.0.4.0, any.base ==4.13.0.0, - any.base-compat ==0.12.1, - any.base-compat-batteries ==0.12.1, - any.base-orphans ==0.8.6, + any.base-compat ==0.12.2, + any.base-compat-batteries ==0.12.2, + any.base-orphans ==0.8.8.2, any.base16-bytestring ==1.0.2.0, any.base64-bytestring ==1.2.1.0, any.basement ==0.0.14, - any.bifunctors ==5.5.12, + any.bifunctors ==5.5.15, bifunctors +semigroups +tagged, any.bimap ==0.5.0, any.binary ==0.8.7.0, - any.binary-orphans ==1.0.2, + any.binary-orphans ==1.0.4.1, + any.bitvec ==1.1.3.0, + bitvec -libgmp, any.bitwise ==1.0.0.1, any.blaze-builder ==0.4.2.2, any.blaze-html ==0.9.1.2, any.blaze-markup ==0.8.2.8, - any.boomerang ==1.4.8, + any.boomerang ==1.4.8.1, any.bsb-http-chunked ==0.0.0.4, - any.bv-sized ==1.0.4, + any.bv-sized ==1.0.5, any.byteorder ==1.0.4, any.bytestring ==0.10.10.1, any.cabal-doctest ==1.0.9, any.call-stack ==0.4.0, any.case-insensitive ==1.2.1.0, - any.cassava ==0.5.2.0, + any.cassava ==0.5.3.0, cassava -bytestring--lt-0_10_4, - any.cereal ==0.5.8.2, + any.cereal ==0.5.8.3, cereal -bytestring-builder, - any.chimera ==0.3.2.0, + any.chimera ==0.3.3.0, chimera +representable, any.clock ==0.8.3, clock -llvm, @@ -73,68 +75,68 @@ constraints: any.Cabal ==3.0.1.0, any.comonad ==5.0.8, comonad +containers +distributive +indexed-traversable, any.concurrent-extra ==0.7.0.12, - any.concurrent-output ==1.10.16, - any.conduit ==1.3.4.2, + any.concurrent-output ==1.10.17, + any.conduit ==1.3.4.3, any.conduit-extra ==1.3.6, - any.config-schema ==1.2.2.0, - any.config-value ==0.8.2.1, + any.config-schema ==1.3.0.0, + any.config-value ==0.8.3, any.constraints ==0.13.4, any.containers ==0.6.2.1, any.contravariant ==1.5.5, contravariant +semigroups +statevar +tagged, - any.cookie ==0.4.5, - any.criterion ==1.5.13.0, + any.cookie ==0.4.6, + any.criterion ==1.6.0.0, criterion -embed-data-files -fast, - any.criterion-measurement ==0.1.3.0, + any.criterion-measurement ==0.2.1.0, criterion-measurement -fast, crucible +unsafe-operations, any.cryptohash-md5 ==0.11.101.0, any.cryptohash-sha1 ==0.11.101.0, - cryptol +relocatable -static, + cryptol +ffi +relocatable -static, cryptol-remote-api -notthreaded -static, any.cryptonite ==0.30, cryptonite -check_alignment +integer-gmp -old_toolchain_inliner +support_aesni +support_deepseq -support_pclmuldq +support_rdrand -support_sse +use_target_attributes, any.cryptonite-conduit ==0.2.2, - any.data-accessor ==0.2.3, + any.data-accessor ==0.2.3.1, data-accessor +category +monadfail +splitbase, + any.data-array-byte ==0.1.0.1, any.data-default-class ==0.1.2.0, any.data-fix ==0.3.2, any.data-inttrie ==0.1.4, - any.data-ref ==0.0.2, + any.data-ref ==0.1, any.deepseq ==1.4.4.0, any.dense-linear-algebra ==0.1.0.0, - any.deriving-compat ==0.6.1, + any.deriving-compat ==0.6.3, deriving-compat +base-4-9 +new-functor-classes +template-haskell-2-11, any.directory ==1.3.6.0, any.distributive ==0.6.2.1, distributive +semigroups +tagged, any.dlist ==1.0, dlist -werror, - any.doctest ==0.20.0, + any.doctest ==0.20.1, any.dotgen ==0.4.3, dotgen -devel, any.easy-file ==0.2.2, any.either ==5.0.2, - any.entropy ==0.4.1.7, - entropy -halvm, + any.entropy ==0.4.1.10, + entropy -donotgetentropy, any.erf ==2.0.0.0, any.exact-pi ==0.5.0.2, - any.exceptions ==0.10.5, + any.exceptions ==0.10.7, exceptions +transformers-0-4, any.executable-path ==0.0.3.1, any.extensible-exceptions ==0.1.1.4, - any.extra ==1.7.10, - any.fail ==4.9.0.0, - any.fast-logger ==3.1.1, - any.fgl ==5.7.0.3, + any.extra ==1.7.12, + any.fast-logger ==3.2.1, + any.fgl ==5.8.1.1, fgl +containers042, any.fgl-visualize ==0.1.0.1, any.filelock ==0.1.1.5, any.filemanip ==0.3.6.3, any.filepath ==1.4.2.1, any.fingertree ==0.1.5.0, - any.free ==5.1.9, - any.generic-deriving ==1.14.1, + any.free ==5.1.10, + any.generic-deriving ==1.14.3, generic-deriving +base-4-9, any.generic-lens ==2.2.1.0, any.generic-lens-core ==2.2.1.0, @@ -147,47 +149,49 @@ constraints: any.Cabal ==3.0.1.0, any.ghc-paths ==0.1.0.12, any.ghc-prim ==0.5.3, any.ghci ==8.8.4, - any.githash ==0.1.6.2, + any.githash ==0.1.6.3, any.gitrev ==1.3.1, any.graphviz ==2999.20.1.0, graphviz -test-parsing, - any.happy ==1.20.0, + any.happy ==1.20.1.1, any.hashable ==1.3.5.0, hashable +integer-gmp -random-initial-seed, any.hashtables ==1.2.4.2, hashtables -bounds-checking -debug -detailed-profiling -portable -sse42 +unsafe-tricks, any.haskeline ==0.7.5.0, - any.haskell-lexer ==1.1, + any.haskell-lexer ==1.1.1, any.haskell-src-exts ==1.23.1, - any.haskell-src-meta ==0.8.10, - any.hedgehog ==1.1.1, - any.hedgehog-classes ==0.2.5.3, + any.haskell-src-meta ==0.8.11, + any.hedgehog ==1.2, + any.hedgehog-classes ==0.2.5.4, hedgehog-classes +aeson +comonad +primitive +semirings +vector, any.heredoc ==0.2.0.0, + any.hgmp ==0.1.2.1, any.hobbits ==1.4, any.hostname ==1.0, any.hourglass ==0.2.12, any.hpc ==0.6.0.3, - any.hsc2hs ==0.68.8, + any.hsc2hs ==0.68.9, hsc2hs -in-ghc-tree, - any.hspec ==2.10.0, - any.hspec-core ==2.10.0, - any.hspec-discover ==2.10.0, + any.hspec ==2.10.10, + any.hspec-core ==2.10.10, + any.hspec-discover ==2.10.10, any.hspec-expectations ==0.8.2, any.http-date ==0.0.11, any.http-types ==0.12.3, - any.http2 ==3.0.3, + any.http2 ==4.0.0, http2 -devel -doc -h2spec, + any.ieee754 ==0.8.0, any.indexed-profunctors ==0.1.1, - any.indexed-traversable ==0.1.2, - any.indexed-traversable-instances ==0.1.1, + any.indexed-traversable ==0.1.2.1, + any.indexed-traversable-instances ==0.1.1.2, any.integer-gmp ==1.0.2.0, any.integer-logarithms ==1.0.3.1, integer-logarithms -check-bounds +integer-gmp, any.integer-roots ==1.0.2.0, any.interpolate ==0.2.1, - any.invariant ==0.5.6, - any.io-streams ==1.5.2.1, + any.invariant ==0.6.1, + any.io-streams ==1.5.2.2, io-streams +network -nointeractivetests +zlib, any.iproute ==1.7.12, any.itanium-abi ==0.1.1.1, @@ -195,29 +199,34 @@ constraints: any.Cabal ==3.0.1.0, any.json ==0.10, json +generic -mapdict +parsec +pretty +split-base, any.kan-extensions ==5.2.5, - any.kvitable ==1.0.1.0, + any.kvitable ==1.0.2.0, + any.language-c99 ==0.2.0, + any.language-c99-simple ==0.2.2, + any.language-c99-util ==0.2.0, language-rust +enablequasiquotes +usebytestrings, any.lens ==5.1.1, lens -benchmark-uniplate -dump-splices +inlining -j +test-hunit +test-properties +test-templates +trustworthy, - any.libBF ==0.6.3, + any.libBF ==0.6.5.1, libBF -system-libbf, + any.libffi ==0.2.1, + libffi +ghc-bundled-libffi, any.libyaml ==0.1.2, libyaml -no-unicode -system-libyaml, - any.lifted-async ==0.10.2.2, + any.lifted-async ==0.10.2.3, any.lifted-base ==0.2.3.12, llvm-pretty-bc-parser -fuzz -regressions, any.logict ==0.8.0.0, any.lucid ==2.11.1, - any.lumberjack ==1.0.1.0, + any.lumberjack ==1.0.2.0, any.math-functions ==0.3.4.2, math-functions +system-erf +system-expm1, any.megaparsec ==9.0.1, megaparsec -dev, - any.memory ==0.17.0, + any.memory ==0.18.0, memory +support_bytestring +support_deepseq, - any.microlens ==0.4.13.0, - any.microlens-th ==0.4.3.10, - any.microstache ==1.0.2.1, + any.microlens ==0.4.13.1, + any.microlens-th ==0.4.3.11, + any.microstache ==1.0.2.3, any.mmorph ==1.2.0, any.mod ==0.1.2.2, mod +semirings +vector, @@ -228,9 +237,7 @@ constraints: any.Cabal ==3.0.1.0, any.mono-traversable ==1.0.15.3, any.mtl ==2.2.2, any.mwc-random ==0.15.0.2, - any.nats ==1.1.2, - nats +binary +hashable +template-haskell, - any.network ==3.1.2.7, + any.network ==3.1.2.8, network -devel, any.network-byte-order ==0.1.6, any.network-info ==0.2.1, @@ -260,12 +267,13 @@ constraints: any.Cabal ==3.0.1.0, any.process ==1.6.9.0, any.profunctors ==5.6.2, any.psqueues ==0.2.7.3, - any.quickcheck-instances ==0.3.27, + any.quickcheck-instances ==0.3.29.1, quickcheck-instances -bytestring-builder, any.quickcheck-io ==0.2.0, any.random ==1.2.1.1, any.raw-strings-qq ==1.1, - any.reflection ==2.1.6, + any.recv ==0.1.0, + any.reflection ==2.1.7, reflection -slow +template-haskell, any.regex-base ==0.94.0.2, any.regex-compat ==0.95.2.1, @@ -273,13 +281,16 @@ constraints: any.Cabal ==3.0.1.0, regex-posix -_regex-posix-clib, any.resourcet ==1.2.6, any.rts ==1.0, - any.s-cargot ==0.1.4.0, + any.s-cargot ==0.1.5.0, s-cargot -build-example, any.safe ==0.3.19, - any.sbv ==8.15, + any.safe-exceptions ==0.1.7.3, + any.sbv ==9.0, any.scientific ==0.3.7.0, scientific -bytestring-builder -integer-simple, - any.scotty ==0.12, + any.scotty ==0.12.1, + any.semialign ==1.2.0.1, + semialign +semigroupoids, any.semigroupoids ==5.3.7, semigroupoids +comonad +containers +contravariant +distributive +tagged +unordered-containers, any.semigroups ==0.20, @@ -287,39 +298,39 @@ constraints: any.Cabal ==3.0.1.0, any.semirings ==0.6, semirings +containers +unordered-containers, any.setenv ==0.1.1.3, - any.silently ==1.2.5.2, + any.silently ==1.2.5.3, any.simple-get-opt ==0.4, any.simple-sendfile ==0.2.30, simple-sendfile +allow-bsd, any.simple-smt ==0.9.7, any.smallcheck ==1.2.1, - any.split ==0.2.3.4, + any.split ==0.2.3.5, any.splitmix ==0.1.0.4, splitmix -optimised-mixer, - any.statistics ==0.16.1.0, + any.statistics ==0.16.1.2, any.stm ==2.5.0.0, - any.streaming-commons ==0.2.2.4, + any.streaming-commons ==0.2.2.5, streaming-commons -use-bytestring-builder, any.strict ==0.4.0.1, strict +assoc, - any.string-interpolate ==0.3.1.2, + any.string-interpolate ==0.3.2.0, string-interpolate -bytestring-builder -extended-benchmarks -text-builder, - any.syb ==0.7.2.1, - any.tagged ==0.8.6.1, + any.syb ==0.7.2.2, + any.tagged ==0.8.7, tagged +deepseq +transformers, - any.tasty ==1.4.2.3, - tasty +clock +unix, + any.tasty ==1.4.3, + tasty +unix, any.tasty-ant-xml ==1.1.8, - any.tasty-checklist ==1.0.3.0, + any.tasty-checklist ==1.0.5.0, any.tasty-expected-failure ==0.12.3, any.tasty-golden ==2.3.5, tasty-golden -build-example, - any.tasty-hedgehog ==1.2.0.0, - any.tasty-hspec ==1.2.0.1, + any.tasty-hedgehog ==1.4.0.0, + any.tasty-hspec ==1.2.0.3, any.tasty-hunit ==0.10.0.3, any.tasty-quickcheck ==0.10.2, any.tasty-smallcheck ==0.8.2, - any.tasty-sugar ==1.3.0.1, + any.tasty-sugar ==1.3.0.2, any.template-haskell ==2.15.0.0, any.temporary ==1.3, any.terminal-size ==0.3.3, @@ -332,12 +343,12 @@ constraints: any.Cabal ==3.0.1.0, any.text-short ==0.1.5, text-short -asserts, any.tf-random ==0.5, - any.th-abstraction ==0.4.3.0, - any.th-compat ==0.1.3, - any.th-expand-syns ==0.4.9.0, - any.th-lift ==0.8.2, - any.th-lift-instances ==0.1.19, - any.th-orphans ==0.13.13, + any.th-abstraction ==0.4.5.0, + any.th-compat ==0.1.4, + any.th-expand-syns ==0.4.11.0, + any.th-lift ==0.8.3, + any.th-lift-instances ==0.1.20, + any.th-orphans ==0.13.14, any.th-reify-many ==0.1.10, any.these ==1.1.1.1, these +assoc, @@ -354,15 +365,15 @@ constraints: any.Cabal ==3.0.1.0, any.transformers-compat ==0.7.2, transformers-compat -five +five-three -four +generic-deriving +mtl -three -two, any.type-equality ==1, - any.typed-process ==0.2.10.1, + any.typed-process ==0.2.11.0, any.unbounded-delays ==0.1.1.1, any.uniplate ==1.6.13, any.unix ==2.7.2.2, any.unix-compat ==0.6, unix-compat -old-time, - any.unix-time ==0.4.7, - any.unliftio ==0.2.22.0, - any.unliftio-core ==0.2.0.1, + any.unix-time ==0.4.8, + any.unliftio ==0.2.24.0, + any.unliftio-core ==0.2.1.0, any.unordered-containers ==0.2.19.1, unordered-containers -debug, any.utf8-string ==1.0.2, @@ -372,24 +383,23 @@ constraints: any.Cabal ==3.0.1.0, vault +useghc, any.vector ==0.12.3.1, vector +boundschecks -internalchecks -unsafechecks -wall, - any.vector-algorithms ==0.8.0.4, + any.vector-algorithms ==0.9.0.1, vector-algorithms +bench +boundschecks -internalchecks -llvm +properties -unsafechecks, any.vector-binary-instances ==0.2.5.2, any.vector-th-unbox ==0.2.2, - any.versions ==5.0.3, + any.versions ==5.0.4, any.void ==0.7.3, void -safe, any.wai ==3.2.3, - any.wai-extra ==3.1.12.1, + any.wai-extra ==3.1.13.0, wai-extra -build-example, any.wai-logger ==2.4.0, - any.warp ==3.3.21, + any.warp ==3.3.24, warp +allow-sendfilefd -network-bytestring -warp-debug +x509, - any.warp-tls ==3.3.2, - any.wcwidth ==0.0.2, - wcwidth -cli +split-base, + any.warp-tls ==3.3.5, any.weigh ==0.0.16, what4 -drealtestdisable -solvertests -stptestdisable, + any.witherable ==0.4.2, any.wl-pprint-annotated ==0.1.0.1, any.wl-pprint-text ==1.2.0.2, any.word8 ==0.1.3, @@ -397,10 +407,10 @@ constraints: any.Cabal ==3.0.1.0, any.x509-store ==1.6.9, any.x509-validation ==1.6.12, any.xml ==1.3.14, - any.yaml ==0.11.8.0, + any.yaml ==0.11.11.0, yaml +no-examples +no-exe, any.zenc ==0.1.2, any.zlib ==0.6.3.0, zlib -bundled-c-zlib -non-blocking-ffi -pkg-config, any.zlib-bindings ==0.1.1.5 -index-state: hackage.haskell.org 2022-06-30T19:50:05Z +index-state: hackage.haskell.org 2023-03-13T12:18:58Z diff --git a/cabal.GHC-9.0.2.config b/cabal.GHC-9.0.2.config index d8354f8fef..2986fb4594 100644 --- a/cabal.GHC-9.0.2.config +++ b/cabal.GHC-9.0.2.config @@ -5,26 +5,26 @@ constraints: any.Cabal ==3.4.1.0, GraphSCC -use-maps, any.HUnit ==1.6.2.0, any.IfElse ==0.85, - any.IntervalMap ==0.6.1.2, + any.IntervalMap ==0.6.2.0, any.MemoTrie ==0.6.10, MemoTrie -examples, - any.MonadRandom ==0.5.3, + any.MonadRandom ==0.6, any.OneTuple ==0.3.1, any.Only ==0.1, any.QuickCheck ==2.14.2, QuickCheck -old-random +templatehaskell, any.StateVar ==1.2.2, - any.adjunctions ==4.4.1, - any.aeson ==1.5.6.0, - aeson -bytestring-builder -cffi -developer -fast, - any.aeson-typescript ==0.4.0.0, + any.adjunctions ==4.4.2, + any.aeson ==2.0.3.0, + aeson -cffi +ordered-keymap, + any.aeson-typescript ==0.4.2.0, any.alex ==3.2.7.1, - any.ansi-terminal ==0.11.3, + any.ansi-terminal ==0.11.4, ansi-terminal -example, any.ansi-wl-pprint ==0.6.9, ansi-wl-pprint -example, any.appar ==0.1.8, - any.arithmoi ==0.12.0.1, + any.arithmoi ==0.12.0.2, any.array ==0.5.4.0, any.asn1-encoding ==0.9.6, any.asn1-parse ==0.9.5, @@ -35,36 +35,38 @@ constraints: any.Cabal ==3.4.1.0, any.attoparsec ==0.14.4, attoparsec -developer, any.auto-update ==0.1.6, - any.barbies ==2.0.3.1, + any.barbies ==2.0.4.0, any.base ==4.15.1.0, - any.base-compat ==0.12.1, - any.base-compat-batteries ==0.12.1, - any.base-orphans ==0.8.6, + any.base-compat ==0.12.2, + any.base-compat-batteries ==0.12.2, + any.base-orphans ==0.8.8.2, any.base16-bytestring ==1.0.2.0, any.base64-bytestring ==1.2.1.0, - any.basement ==0.0.14, - any.bifunctors ==5.5.12, + any.basement ==0.0.15, + any.bifunctors ==5.5.15, bifunctors +semigroups +tagged, any.bimap ==0.5.0, any.binary ==0.8.8.0, - any.binary-orphans ==1.0.2, + any.binary-orphans ==1.0.4.1, + any.bitvec ==1.1.3.0, + bitvec -libgmp, any.bitwise ==1.0.0.1, any.blaze-builder ==0.4.2.2, any.blaze-html ==0.9.1.2, any.blaze-markup ==0.8.2.8, - any.boomerang ==1.4.8, + any.boomerang ==1.4.8.1, any.bsb-http-chunked ==0.0.0.4, - any.bv-sized ==1.0.4, + any.bv-sized ==1.0.5, any.byteorder ==1.0.4, any.bytestring ==0.10.12.1, any.cabal-doctest ==1.0.9, any.call-stack ==0.4.0, any.case-insensitive ==1.2.1.0, - any.cassava ==0.5.2.0, + any.cassava ==0.5.3.0, cassava -bytestring--lt-0_10_4, - any.cereal ==0.5.8.2, + any.cereal ==0.5.8.3, cereal -bytestring-builder, - any.chimera ==0.3.2.0, + any.chimera ==0.3.3.0, chimera +representable, any.clock ==0.8.3, clock -llvm, @@ -73,67 +75,67 @@ constraints: any.Cabal ==3.4.1.0, any.comonad ==5.0.8, comonad +containers +distributive +indexed-traversable, any.concurrent-extra ==0.7.0.12, - any.concurrent-output ==1.10.16, - any.conduit ==1.3.4.2, + any.concurrent-output ==1.10.17, + any.conduit ==1.3.4.3, any.conduit-extra ==1.3.6, - any.config-schema ==1.2.2.0, - any.config-value ==0.8.2.1, + any.config-schema ==1.3.0.0, + any.config-value ==0.8.3, any.constraints ==0.13.4, any.containers ==0.6.4.1, any.contravariant ==1.5.5, contravariant +semigroups +statevar +tagged, - any.cookie ==0.4.5, - any.criterion ==1.5.13.0, + any.cookie ==0.4.6, + any.criterion ==1.6.0.0, criterion -embed-data-files -fast, - any.criterion-measurement ==0.1.3.0, + any.criterion-measurement ==0.2.1.0, criterion-measurement -fast, crucible +unsafe-operations, any.cryptohash-md5 ==0.11.101.0, any.cryptohash-sha1 ==0.11.101.0, - cryptol +relocatable -static, + cryptol +ffi +relocatable -static, cryptol-remote-api -notthreaded -static, any.cryptonite ==0.30, cryptonite -check_alignment +integer-gmp -old_toolchain_inliner +support_aesni +support_deepseq -support_pclmuldq +support_rdrand -support_sse +use_target_attributes, any.cryptonite-conduit ==0.2.2, - any.data-accessor ==0.2.3, + any.data-accessor ==0.2.3.1, data-accessor +category +monadfail +splitbase, + any.data-array-byte ==0.1.0.1, any.data-default-class ==0.1.2.0, any.data-fix ==0.3.2, any.data-inttrie ==0.1.4, - any.data-ref ==0.0.2, + any.data-ref ==0.1, any.deepseq ==1.4.5.0, any.dense-linear-algebra ==0.1.0.0, - any.deriving-compat ==0.6.1, + any.deriving-compat ==0.6.3, deriving-compat +base-4-9 +new-functor-classes +template-haskell-2-11, any.directory ==1.3.6.2, any.distributive ==0.6.2.1, distributive +semigroups +tagged, any.dlist ==1.0, dlist -werror, - any.doctest ==0.20.0, + any.doctest ==0.20.1, any.dotgen ==0.4.3, dotgen -devel, any.easy-file ==0.2.2, any.either ==5.0.2, - any.entropy ==0.4.1.7, - entropy -halvm, + any.entropy ==0.4.1.10, + entropy -donotgetentropy, any.erf ==2.0.0.0, any.exact-pi ==0.5.0.2, any.exceptions ==0.10.4, any.executable-path ==0.0.3.1, any.extensible-exceptions ==0.1.1.4, - any.extra ==1.7.10, - any.fail ==4.9.0.0, - any.fast-logger ==3.1.1, - any.fgl ==5.7.0.3, + any.extra ==1.7.12, + any.fast-logger ==3.2.1, + any.fgl ==5.8.1.1, fgl +containers042, any.fgl-visualize ==0.1.0.1, any.filelock ==0.1.1.5, any.filemanip ==0.3.6.3, any.filepath ==1.4.2.1, any.fingertree ==0.1.5.0, - any.free ==5.1.9, - any.generic-deriving ==1.14.1, + any.free ==5.1.10, + any.generic-deriving ==1.14.3, generic-deriving +base-4-9, any.generic-lens ==2.2.1.0, any.generic-lens-core ==2.2.1.0, @@ -147,47 +149,49 @@ constraints: any.Cabal ==3.4.1.0, any.ghc-paths ==0.1.0.12, any.ghc-prim ==0.7.0, any.ghci ==9.0.2, - any.githash ==0.1.6.2, + any.githash ==0.1.6.3, any.gitrev ==1.3.1, any.graphviz ==2999.20.1.0, graphviz -test-parsing, - any.happy ==1.20.0, + any.happy ==1.20.1.1, any.hashable ==1.3.5.0, hashable +integer-gmp -random-initial-seed, any.hashtables ==1.2.4.2, hashtables -bounds-checking -debug -detailed-profiling -portable -sse42 +unsafe-tricks, any.haskeline ==0.8.2, - any.haskell-lexer ==1.1, + any.haskell-lexer ==1.1.1, any.haskell-src-exts ==1.23.1, - any.haskell-src-meta ==0.8.10, - any.hedgehog ==1.1.1, - any.hedgehog-classes ==0.2.5.3, + any.haskell-src-meta ==0.8.11, + any.hedgehog ==1.2, + any.hedgehog-classes ==0.2.5.4, hedgehog-classes +aeson +comonad +primitive +semirings +vector, any.heredoc ==0.2.0.0, + any.hgmp ==0.1.2.1, any.hobbits ==1.4, any.hostname ==1.0, any.hourglass ==0.2.12, any.hpc ==0.6.1.0, - any.hsc2hs ==0.68.8, + any.hsc2hs ==0.68.9, hsc2hs -in-ghc-tree, - any.hspec ==2.10.0, - any.hspec-core ==2.10.0, - any.hspec-discover ==2.10.0, + any.hspec ==2.10.10, + any.hspec-core ==2.10.10, + any.hspec-discover ==2.10.10, any.hspec-expectations ==0.8.2, any.http-date ==0.0.11, any.http-types ==0.12.3, - any.http2 ==3.0.3, + any.http2 ==4.0.0, http2 -devel -doc -h2spec, + any.ieee754 ==0.8.0, any.indexed-profunctors ==0.1.1, - any.indexed-traversable ==0.1.2, - any.indexed-traversable-instances ==0.1.1, + any.indexed-traversable ==0.1.2.1, + any.indexed-traversable-instances ==0.1.1.2, any.integer-gmp ==1.1, any.integer-logarithms ==1.0.3.1, integer-logarithms -check-bounds +integer-gmp, any.integer-roots ==1.0.2.0, any.interpolate ==0.2.1, - any.invariant ==0.5.6, - any.io-streams ==1.5.2.1, + any.invariant ==0.6.1, + any.io-streams ==1.5.2.2, io-streams +network -nointeractivetests +zlib, any.iproute ==1.7.12, any.itanium-abi ==0.1.1.1, @@ -195,42 +199,45 @@ constraints: any.Cabal ==3.4.1.0, any.json ==0.10, json +generic -mapdict +parsec +pretty +split-base, any.kan-extensions ==5.2.5, - any.kvitable ==1.0.1.0, + any.kvitable ==1.0.2.0, + any.language-c99 ==0.2.0, + any.language-c99-simple ==0.2.2, + any.language-c99-util ==0.2.0, language-rust +enablequasiquotes +usebytestrings, any.lens ==5.1.1, lens -benchmark-uniplate -dump-splices +inlining -j +test-hunit +test-properties +test-templates +trustworthy, - any.libBF ==0.6.3, + any.libBF ==0.6.5.1, libBF -system-libbf, + any.libffi ==0.2.1, + libffi +ghc-bundled-libffi, any.libyaml ==0.1.2, libyaml -no-unicode -system-libyaml, - any.lifted-async ==0.10.2.2, + any.lifted-async ==0.10.2.3, any.lifted-base ==0.2.3.12, llvm-pretty-bc-parser -fuzz -regressions, any.logict ==0.8.0.0, any.lucid ==2.11.1, - any.lumberjack ==1.0.1.0, + any.lumberjack ==1.0.2.0, any.math-functions ==0.3.4.2, math-functions +system-erf +system-expm1, any.megaparsec ==9.0.1, megaparsec -dev, - any.memory ==0.17.0, + any.memory ==0.18.0, memory +support_bytestring +support_deepseq, - any.microlens ==0.4.13.0, - any.microlens-th ==0.4.3.10, - any.microstache ==1.0.2.1, + any.microlens ==0.4.13.1, + any.microlens-th ==0.4.3.11, + any.microstache ==1.0.2.3, any.mmorph ==1.2.0, - any.mod ==0.1.2.2, + any.mod ==0.2.0.1, mod +semirings +vector, - any.modern-uri ==0.3.4.4, + any.modern-uri ==0.3.6.0, modern-uri -dev, any.monad-control ==1.0.3.1, any.monadLib ==3.10.1, any.mono-traversable ==1.0.15.3, any.mtl ==2.2.2, any.mwc-random ==0.15.0.2, - any.nats ==1.1.2, - nats +binary +hashable +template-haskell, - any.network ==3.1.2.7, + any.network ==3.1.2.8, network -devel, any.network-byte-order ==0.1.6, any.network-info ==0.2.1, @@ -260,12 +267,13 @@ constraints: any.Cabal ==3.4.1.0, any.process ==1.6.13.2, any.profunctors ==5.6.2, any.psqueues ==0.2.7.3, - any.quickcheck-instances ==0.3.27, + any.quickcheck-instances ==0.3.29.1, quickcheck-instances -bytestring-builder, any.quickcheck-io ==0.2.0, any.random ==1.2.1.1, any.raw-strings-qq ==1.1, - any.reflection ==2.1.6, + any.recv ==0.1.0, + any.reflection ==2.1.7, reflection -slow +template-haskell, any.regex-base ==0.94.0.2, any.regex-compat ==0.95.2.1, @@ -273,13 +281,16 @@ constraints: any.Cabal ==3.4.1.0, regex-posix -_regex-posix-clib, any.resourcet ==1.2.6, any.rts ==1.0.2, - any.s-cargot ==0.1.4.0, + any.s-cargot ==0.1.5.0, s-cargot -build-example, any.safe ==0.3.19, - any.sbv ==8.15, + any.safe-exceptions ==0.1.7.3, + any.sbv ==9.0, any.scientific ==0.3.7.0, scientific -bytestring-builder -integer-simple, - any.scotty ==0.12, + any.scotty ==0.12.1, + any.semialign ==1.2.0.1, + semialign +semigroupoids, any.semigroupoids ==5.3.7, semigroupoids +comonad +containers +contravariant +distributive +tagged +unordered-containers, any.semigroups ==0.20, @@ -287,39 +298,39 @@ constraints: any.Cabal ==3.4.1.0, any.semirings ==0.6, semirings +containers +unordered-containers, any.setenv ==0.1.1.3, - any.silently ==1.2.5.2, + any.silently ==1.2.5.3, any.simple-get-opt ==0.4, any.simple-sendfile ==0.2.30, simple-sendfile +allow-bsd, any.simple-smt ==0.9.7, any.smallcheck ==1.2.1, - any.split ==0.2.3.4, + any.split ==0.2.3.5, any.splitmix ==0.1.0.4, splitmix -optimised-mixer, - any.statistics ==0.16.1.0, + any.statistics ==0.16.1.2, any.stm ==2.5.0.0, - any.streaming-commons ==0.2.2.4, + any.streaming-commons ==0.2.2.5, streaming-commons -use-bytestring-builder, any.strict ==0.4.0.1, strict +assoc, - any.string-interpolate ==0.3.1.2, + any.string-interpolate ==0.3.2.0, string-interpolate -bytestring-builder -extended-benchmarks -text-builder, - any.syb ==0.7.2.1, - any.tagged ==0.8.6.1, + any.syb ==0.7.2.2, + any.tagged ==0.8.7, tagged +deepseq +transformers, - any.tasty ==1.4.2.3, - tasty +clock +unix, + any.tasty ==1.4.3, + tasty +unix, any.tasty-ant-xml ==1.1.8, - any.tasty-checklist ==1.0.3.0, + any.tasty-checklist ==1.0.5.0, any.tasty-expected-failure ==0.12.3, any.tasty-golden ==2.3.5, tasty-golden -build-example, - any.tasty-hedgehog ==1.2.0.0, - any.tasty-hspec ==1.2.0.1, + any.tasty-hedgehog ==1.4.0.0, + any.tasty-hspec ==1.2.0.3, any.tasty-hunit ==0.10.0.3, any.tasty-quickcheck ==0.10.2, any.tasty-smallcheck ==0.8.2, - any.tasty-sugar ==1.3.0.1, + any.tasty-sugar ==1.3.0.2, any.template-haskell ==2.17.0.0, any.temporary ==1.3, any.terminal-size ==0.3.3, @@ -332,12 +343,12 @@ constraints: any.Cabal ==3.4.1.0, any.text-short ==0.1.5, text-short -asserts, any.tf-random ==0.5, - any.th-abstraction ==0.4.3.0, - any.th-compat ==0.1.3, - any.th-expand-syns ==0.4.9.0, - any.th-lift ==0.8.2, - any.th-lift-instances ==0.1.19, - any.th-orphans ==0.13.13, + any.th-abstraction ==0.4.5.0, + any.th-compat ==0.1.4, + any.th-expand-syns ==0.4.11.0, + any.th-lift ==0.8.3, + any.th-lift-instances ==0.1.20, + any.th-orphans ==0.13.14, any.th-reify-many ==0.1.10, any.these ==1.1.1.1, these +assoc, @@ -354,15 +365,15 @@ constraints: any.Cabal ==3.4.1.0, any.transformers-compat ==0.7.2, transformers-compat -five +five-three -four +generic-deriving +mtl -three -two, any.type-equality ==1, - any.typed-process ==0.2.10.1, + any.typed-process ==0.2.11.0, any.unbounded-delays ==0.1.1.1, any.uniplate ==1.6.13, any.unix ==2.7.2.2, any.unix-compat ==0.6, unix-compat -old-time, - any.unix-time ==0.4.7, - any.unliftio ==0.2.22.0, - any.unliftio-core ==0.2.0.1, + any.unix-time ==0.4.8, + any.unliftio ==0.2.24.0, + any.unliftio-core ==0.2.1.0, any.unordered-containers ==0.2.19.1, unordered-containers -debug, any.utf8-string ==1.0.2, @@ -372,24 +383,23 @@ constraints: any.Cabal ==3.4.1.0, vault +useghc, any.vector ==0.12.3.1, vector +boundschecks -internalchecks -unsafechecks -wall, - any.vector-algorithms ==0.8.0.4, + any.vector-algorithms ==0.9.0.1, vector-algorithms +bench +boundschecks -internalchecks -llvm +properties -unsafechecks, any.vector-binary-instances ==0.2.5.2, any.vector-th-unbox ==0.2.2, - any.versions ==5.0.3, + any.versions ==5.0.4, any.void ==0.7.3, void -safe, any.wai ==3.2.3, - any.wai-extra ==3.1.12.1, + any.wai-extra ==3.1.13.0, wai-extra -build-example, any.wai-logger ==2.4.0, - any.warp ==3.3.21, + any.warp ==3.3.24, warp +allow-sendfilefd -network-bytestring -warp-debug +x509, - any.warp-tls ==3.3.2, - any.wcwidth ==0.0.2, - wcwidth -cli +split-base, + any.warp-tls ==3.3.5, any.weigh ==0.0.16, what4 -drealtestdisable -solvertests -stptestdisable, + any.witherable ==0.4.2, any.wl-pprint-annotated ==0.1.0.1, any.wl-pprint-text ==1.2.0.2, any.word8 ==0.1.3, @@ -397,10 +407,10 @@ constraints: any.Cabal ==3.4.1.0, any.x509-store ==1.6.9, any.x509-validation ==1.6.12, any.xml ==1.3.14, - any.yaml ==0.11.8.0, + any.yaml ==0.11.11.0, yaml +no-examples +no-exe, any.zenc ==0.1.2, any.zlib ==0.6.3.0, zlib -bundled-c-zlib -non-blocking-ffi -pkg-config, any.zlib-bindings ==0.1.1.5 -index-state: hackage.haskell.org 2022-06-30T19:50:05Z +index-state: hackage.haskell.org 2023-03-13T12:18:58Z From f68e0b9db3a5eaddbeeeb8dd95ea83aae08e8ac0 Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Tue, 14 Mar 2023 13:20:36 -0400 Subject: [PATCH 20/27] CI: Test GHC 9.2.7, drop 9.0.2 --- .github/workflows/ci.yml | 11 ++---- README.md | 2 +- ...GHC-9.0.2.config => cabal.GHC-9.2.7.config | 38 +++++++++---------- 3 files changed, 24 insertions(+), 27 deletions(-) rename cabal.GHC-9.0.2.config => cabal.GHC-9.2.7.config (96%) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 91f4971cfb..c3636d3011 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -68,9 +68,12 @@ jobs: fail-fast: false matrix: os: [ubuntu-22.04, macos-12, windows-latest] - ghc: ["8.8.4", "8.10.7", "9.0.2"] + ghc: ["8.8.4", "8.10.7", "9.2.7"] run-tests: [true] include: + # We include one job from an older Ubuntu LTS release to increase our + # coverage of possible Linux configurations. Since we already run the + # tests with the newest LTS release, we won't bother testing this one. - os: ubuntu-20.04 ghc: "8.10.7" run-tests: false @@ -83,12 +86,6 @@ jobs: - os: windows-latest ghc: "8.8.4" run-tests: true - # Exclude 9.0 on Windows for now until - # https://github.com/commercialhaskell/stackage/issues/6400 - # is resolved - - os: windows-latest - ghc: "9.0.2" - run-tests: false outputs: cabal-test-suites-json: ${{ steps.cabal-test-suites.outputs.targets-json }} steps: diff --git a/README.md b/README.md index b701a747e6..6bd97dbba6 100644 --- a/README.md +++ b/README.md @@ -42,7 +42,7 @@ To build SAWScript and related utilities from source: * Ensure that you have the `cabal` and `ghc` executables in your `PATH`. If you don't already have them, we recommend using `ghcup` to install them: . We recommend - Cabal 3.4 or newer, and GHC 8.8, 8.10, 9.0, or 9.2. + Cabal 3.4 or newer, and GHC 8.8, 8.10, or 9.2. * Ensure that you have the C libraries and header files for `terminfo`, which generally comes as part of `ncurses` on most diff --git a/cabal.GHC-9.0.2.config b/cabal.GHC-9.2.7.config similarity index 96% rename from cabal.GHC-9.0.2.config rename to cabal.GHC-9.2.7.config index 2986fb4594..738ac74284 100644 --- a/cabal.GHC-9.0.2.config +++ b/cabal.GHC-9.2.7.config @@ -1,5 +1,5 @@ active-repositories: hackage.haskell.org:merge -constraints: any.Cabal ==3.4.1.0, +constraints: any.Cabal ==3.6.3.0, any.Glob ==0.10.2, any.GraphSCC ==1.0.4, GraphSCC -use-maps, @@ -36,7 +36,7 @@ constraints: any.Cabal ==3.4.1.0, attoparsec -developer, any.auto-update ==0.1.6, any.barbies ==2.0.4.0, - any.base ==4.15.1.0, + any.base ==4.16.4.0, any.base-compat ==0.12.2, any.base-compat-batteries ==0.12.2, any.base-orphans ==0.8.8.2, @@ -46,7 +46,7 @@ constraints: any.Cabal ==3.4.1.0, any.bifunctors ==5.5.15, bifunctors +semigroups +tagged, any.bimap ==0.5.0, - any.binary ==0.8.8.0, + any.binary ==0.8.9.0, any.binary-orphans ==1.0.4.1, any.bitvec ==1.1.3.0, bitvec -libgmp, @@ -58,7 +58,7 @@ constraints: any.Cabal ==3.4.1.0, any.bsb-http-chunked ==0.0.0.4, any.bv-sized ==1.0.5, any.byteorder ==1.0.4, - any.bytestring ==0.10.12.1, + any.bytestring ==0.11.4.0, any.cabal-doctest ==1.0.9, any.call-stack ==0.4.0, any.case-insensitive ==1.2.1.0, @@ -81,7 +81,7 @@ constraints: any.Cabal ==3.4.1.0, any.config-schema ==1.3.0.0, any.config-value ==0.8.3, any.constraints ==0.13.4, - any.containers ==0.6.4.1, + any.containers ==0.6.5.1, any.contravariant ==1.5.5, contravariant +semigroups +statevar +tagged, any.cookie ==0.4.6, @@ -104,7 +104,7 @@ constraints: any.Cabal ==3.4.1.0, any.data-fix ==0.3.2, any.data-inttrie ==0.1.4, any.data-ref ==0.1, - any.deepseq ==1.4.5.0, + any.deepseq ==1.4.6.1, any.dense-linear-algebra ==0.1.0.0, any.deriving-compat ==0.6.3, deriving-compat +base-4-9 +new-functor-classes +template-haskell-2-11, @@ -132,7 +132,7 @@ constraints: any.Cabal ==3.4.1.0, any.fgl-visualize ==0.1.0.1, any.filelock ==0.1.1.5, any.filemanip ==0.3.6.3, - any.filepath ==1.4.2.1, + any.filepath ==1.4.2.2, any.fingertree ==0.1.5.0, any.free ==5.1.10, any.generic-deriving ==1.14.3, @@ -141,14 +141,14 @@ constraints: any.Cabal ==3.4.1.0, any.generic-lens-core ==2.2.1.0, any.generic-random ==1.5.0.1, generic-random -enable-inspect, - any.ghc ==9.0.2, - any.ghc-bignum ==1.1, - any.ghc-boot ==9.0.2, - any.ghc-boot-th ==9.0.2, - any.ghc-heap ==9.0.2, + any.ghc ==9.2.7, + any.ghc-bignum ==1.2, + any.ghc-boot ==9.2.7, + any.ghc-boot-th ==9.2.7, + any.ghc-heap ==9.2.7, any.ghc-paths ==0.1.0.12, - any.ghc-prim ==0.7.0, - any.ghci ==9.0.2, + any.ghc-prim ==0.8.0, + any.ghci ==9.2.7, any.githash ==0.1.6.3, any.gitrev ==1.3.1, any.graphviz ==2999.20.1.0, @@ -252,7 +252,7 @@ constraints: any.Cabal ==3.4.1.0, any.panic ==0.4.0.1, any.parallel ==3.2.2.0, parameterized-utils +unsafe-operations, - any.parsec ==3.1.14.0, + any.parsec ==3.1.15.0, any.parser-combinators ==1.3.0, parser-combinators -dev, any.pem ==0.2.4, @@ -264,7 +264,7 @@ constraints: any.Cabal ==3.4.1.0, prettyprinter -buildreadme +text, any.prettyprinter-ansi-terminal ==1.1.3, any.primitive ==0.7.4.0, - any.process ==1.6.13.2, + any.process ==1.6.16.0, any.profunctors ==5.6.2, any.psqueues ==0.2.7.3, any.quickcheck-instances ==0.3.29.1, @@ -308,7 +308,7 @@ constraints: any.Cabal ==3.4.1.0, any.splitmix ==0.1.0.4, splitmix -optimised-mixer, any.statistics ==0.16.1.2, - any.stm ==2.5.0.0, + any.stm ==2.5.0.2, any.streaming-commons ==0.2.2.5, streaming-commons -use-bytestring-builder, any.strict ==0.4.0.1, @@ -331,7 +331,7 @@ constraints: any.Cabal ==3.4.1.0, any.tasty-quickcheck ==0.10.2, any.tasty-smallcheck ==0.8.2, any.tasty-sugar ==1.3.0.2, - any.template-haskell ==2.17.0.0, + any.template-haskell ==2.18.0.0, any.temporary ==1.3, any.terminal-size ==0.3.3, any.terminfo ==0.4.1.5, @@ -352,7 +352,7 @@ constraints: any.Cabal ==3.4.1.0, any.th-reify-many ==0.1.10, any.these ==1.1.1.1, these +assoc, - any.time ==1.9.3, + any.time ==1.11.1.1, any.time-compat ==1.9.6.1, time-compat -old-locale, any.time-manager ==0.0.0, From 3bc898162ff403cd3ab975eb9d8e97592c074215 Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Wed, 15 Mar 2023 13:01:23 -0400 Subject: [PATCH 21/27] CI: Always save cache, even on failure --- .github/workflows/ci.yml | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index c3636d3011..ad419ddfdc 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -119,8 +119,8 @@ jobs: env: BUILD_TARGET_OS: ${{ matrix.os }} - - uses: actions/cache@v2 - name: Cache cabal store + - uses: actions/cache/restore@v3 + name: Restore cabal store cache with: path: | ${{ steps.setup-haskell.outputs.cabal-store }} @@ -210,6 +210,16 @@ jobs: path: dist/bin name: ${{ runner.os }}-bins + - uses: actions/cache/save@v3 + name: Save cabal store cache + if: always() + with: + path: | + ${{ steps.setup-haskell.outputs.cabal-store }} + dist-newstyle + key: ${{ env.CACHE_VERSION }}-cabal-${{ matrix.os }}-${{ matrix.ghc }}-${{ hashFiles(format('cabal.GHC-{0}.config', matrix.ghc)) }}-${{ github.sha }} + ${{ env.CACHE_VERSION }}-cabal-${{ matrix.os }}-${{ matrix.ghc }}-${{ hashFiles(format('cabal.GHC-{0}.config', matrix.ghc)) }}- + mr-solver-tests: needs: [build] strategy: From bdddd9f6b4004211d1e35086a225cfccec0bbf37 Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Wed, 15 Mar 2023 12:02:32 -0400 Subject: [PATCH 22/27] CI: Use cabal-collect-actions@v1.1.1 This version does not need to install `cabal-plan`, which avoids build plan issues. --- .github/workflows/ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index ad419ddfdc..38d9b89b6e 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -146,7 +146,7 @@ jobs: RELEASE: ${{ needs.config.outputs.release }} run: .github/ci.sh build_cryptol - - uses: GaloisInc/.github/actions/cabal-collect-bins@v1 + - uses: GaloisInc/.github/actions/cabal-collect-bins@v1.1.1 id: cabal-test-suites with: targets: | From 57d0775a41bb034a62fcfb309c5313b93a1d8b0b Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Wed, 15 Mar 2023 15:22:36 -0400 Subject: [PATCH 23/27] CI: Explicitly pin cabal 3.8.1.0 Not only is pinning the `cabal` version good practice, but `cabal` 3.8.1.0 in particular likely contains a bugfix needed to make `cabal list-bin` work as expected. --- .github/workflows/ci.yml | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 38d9b89b6e..5b8dd32c2d 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -68,6 +68,7 @@ jobs: fail-fast: false matrix: os: [ubuntu-22.04, macos-12, windows-latest] + cabal: ["3.8.1.0"] ghc: ["8.8.4", "8.10.7", "9.2.7"] run-tests: [true] include: @@ -76,15 +77,18 @@ jobs: # tests with the newest LTS release, we won't bother testing this one. - os: ubuntu-20.04 ghc: "8.10.7" + cabal: "3.8.1.0" run-tests: false exclude: # Exclude 8.8 on macOS 12 due to # https://gitlab.haskell.org/ghc/ghc/-/issues/18446 - os: macos-12 ghc: "8.8.4" + cabal: "3.8.1.0" run-tests: true - os: windows-latest ghc: "8.8.4" + cabal: "3.8.1.0" run-tests: true outputs: cabal-test-suites-json: ${{ steps.cabal-test-suites.outputs.targets-json }} @@ -105,6 +109,7 @@ jobs: id: setup-haskell with: ghc-version: ${{ matrix.ghc }} + cabal-version: ${{ matrix.cabal }} - name: Post-GHC installation fixups on Windows shell: bash From c120306476357b867eaca98fe2d99f6d91b47dc6 Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Sun, 19 Mar 2023 20:43:03 -0400 Subject: [PATCH 24/27] Bump submodules in preparation for supporting CVC5 The main payload of this commit is to bump the `what4` submodule to bring in the changes from GaloisInc/what4#204. This also brings in a variety of other submodule changes to accommodate this: * GaloisIns/crucible#1068, which ensures that everything can build against `tasty-sugar >= 2.0` (the version of the library that `what4-1.4` depends on). * GaloisInc/cryptol#1504, which adapts Cryptol to CVC5. This adjusts the lower and upper version bounds on SBV in Cryptol, so I do the same here in `saw-core.sbv.cabal` and `saw-script.cabal`. * GaloisInc/language-sally#12, which performs a similar `what4` adaptation. * GaloisInc/macaw#328, which performs a similar `what4` adaptation. --- deps/crucible | 2 +- deps/cryptol | 2 +- deps/language-sally | 2 +- deps/macaw | 2 +- deps/what4 | 2 +- saw-core-sbv/saw-core-sbv.cabal | 2 +- saw-script.cabal | 2 +- 7 files changed, 7 insertions(+), 7 deletions(-) diff --git a/deps/crucible b/deps/crucible index 4b8e481f98..f4145fbed9 160000 --- a/deps/crucible +++ b/deps/crucible @@ -1 +1 @@ -Subproject commit 4b8e481f986e2ba2125032edf05dda407dbb57b8 +Subproject commit f4145fbed96245f385a91ef3a32e6737df1075ff diff --git a/deps/cryptol b/deps/cryptol index 4b89554988..9382d52754 160000 --- a/deps/cryptol +++ b/deps/cryptol @@ -1 +1 @@ -Subproject commit 4b89554988e1f755b6d8f49e6be08027aadbaacf +Subproject commit 9382d527543db70068b71fe3a327cd07fe0b36c8 diff --git a/deps/language-sally b/deps/language-sally index a217a9f661..24d53a963c 160000 --- a/deps/language-sally +++ b/deps/language-sally @@ -1 +1 @@ -Subproject commit a217a9f661caabd7858a17c2b556217fc39a946e +Subproject commit 24d53a963c2a2d11a118cfaa98956a69f5c8c6d5 diff --git a/deps/macaw b/deps/macaw index 88d024990b..0686e5d86b 160000 --- a/deps/macaw +++ b/deps/macaw @@ -1 +1 @@ -Subproject commit 88d024990b97292f4d3d0fe0bf9c08e75c12c3ce +Subproject commit 0686e5d86bfd802e04dd94cf8836127127232f8f diff --git a/deps/what4 b/deps/what4 index 6f5e0fe9be..6c462cd46e 160000 --- a/deps/what4 +++ b/deps/what4 @@ -1 +1 @@ -Subproject commit 6f5e0fe9bef58234603ccf6914c32ea1ba2f9766 +Subproject commit 6c462cd46e0ea9ebbfbd6b6ea237984eeb3dc72a diff --git a/saw-core-sbv/saw-core-sbv.cabal b/saw-core-sbv/saw-core-sbv.cabal index 1cc5448ab4..386a740dde 100644 --- a/saw-core-sbv/saw-core-sbv.cabal +++ b/saw-core-sbv/saw-core-sbv.cabal @@ -20,7 +20,7 @@ library lens, mtl, saw-core, - sbv >= 8.10 && < 9.1, + sbv >= 9.1 && < 9.3, text, transformers, vector diff --git a/saw-script.cabal b/saw-script.cabal index c3e726c100..cff9ea9dc1 100644 --- a/saw-script.cabal +++ b/saw-script.cabal @@ -80,7 +80,7 @@ library , saw-core-coq , saw-core-sbv , saw-core-what4 - , sbv >= 8.10 && < 9.1 + , sbv >= 9.1 && < 9.3 , split , temporary , template-haskell From 5167b2959094212785069d2658b7fd7fe03fef2f Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Sun, 19 Mar 2023 22:21:07 -0400 Subject: [PATCH 25/27] Add support for CVC5 This adds basic support for the CVC5 SMT solver by adding `cvc5` and related proof scripts. I hae added a `test_cvc5` integration test to kick the tires. This addresses one part of #1706. --- .github/ci.sh | 3 +- CHANGES.md | 5 +++ doc/manual/manual.md | 8 +++- doc/tutorial/tutorial.md | 2 +- intTests/test_cvc5/test.saw | 9 +++++ intTests/test_cvc5/test.sh | 3 ++ .../python/saw_client/proofscript.py | 11 ++++++ saw-remote-api/src/SAWServer/ProofScript.hs | 7 ++++ src/SAWScript/Builtins.hs | 16 ++++++++ src/SAWScript/Interpreter.hs | 38 +++++++++++++++++++ src/SAWScript/Prover/SBV.hs | 2 +- src/SAWScript/Prover/What4.hs | 8 +++- 12 files changed, 106 insertions(+), 6 deletions(-) create mode 100644 intTests/test_cvc5/test.saw create mode 100755 intTests/test_cvc5/test.sh diff --git a/.github/ci.sh b/.github/ci.sh index fb6acf2018..6d86bb867d 100755 --- a/.github/ci.sh +++ b/.github/ci.sh @@ -80,7 +80,7 @@ install_system_deps() { cp $BIN/yices_smt2$EXT $BIN/yices-smt2$EXT export PATH="$BIN:$PATH" echo "$BIN" >> "$GITHUB_PATH" - is_exe "$BIN" z3 && is_exe "$BIN" cvc4 && is_exe "$BIN" yices + is_exe "$BIN" z3 && is_exe "$BIN" cvc4 && is_exe "$BIN" cvc5 && is_exe "$BIN" yices } build_cryptol() { @@ -127,6 +127,7 @@ zip_dist_with_solvers() { # dependencies) as the SAW binaries. cp "$BIN/abc" dist/bin/ cp "$BIN/cvc4" dist/bin/ + cp "$BIN/cvc5" dist/bin/ cp "$BIN/yices" dist/bin/ cp "$BIN/yices-smt2" dist/bin/ # Z3 4.8.14 has been known to nondeterministically time out with the AWSLC diff --git a/CHANGES.md b/CHANGES.md index 686d137c21..9717a5fa5a 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -90,6 +90,11 @@ allows verification certain kinds of simple loops by using a user-provided loop invariant. +* Add a `cvc5` family of proof scripts that use the CVC5 SMT solver. + (Note that the `sbv_cvc5` and `sbv_unint_cvc5` are non-functional + on Windows at this time due to a downstream issue with CVC5 1.0.4 and + earlier.) + # Version 0.9 ## New Features diff --git a/doc/manual/manual.md b/doc/manual/manual.md index 967b438949..beb6047c2c 100644 --- a/doc/manual/manual.md +++ b/doc/manual/manual.md @@ -1131,7 +1131,7 @@ sawscript> sat_print abc {{ \(x:[8]) -> x+x == x*2 }} Sat: [x = 0] ~~~~ -In addition to these, the `boolector`, `cvc4`, `mathsat`, and `yices` +In addition to these, the `boolector`, `cvc4`, `cvc5`, `mathsat`, and `yices` provers are available. The internal decision procedure `rme`, short for Reed-Muller Expansion, is an automated prover that works particularly well on the Galois field operations that show up, for example, in AES. @@ -1199,6 +1199,8 @@ named subterms should be represented as uninterpreted functions. * `unint_cvc4 : [String] -> ProofScript ()` +* `unint_cvc5 : [String] -> ProofScript ()` + * `unint_yices : [String] -> ProofScript ()` * `unint_z3 : [String] -> ProofScript ()` @@ -1218,6 +1220,8 @@ library to represent and solve SMT queries: * `sbv_unint_cvc4 : [String] -> ProofScript ()` +* `sbv_unint_cvc5 : [String] -> ProofScript ()` + * `sbv_unint_yices : [String] -> ProofScript ()` * `sbv_unint_z3 : [String] -> ProofScript ()` @@ -1226,6 +1230,8 @@ The `w4_`-prefixed tactics make use of the What4 library instead of SBV: * `w4_unint_cvc4 : [String] -> ProofScript ()` +* `w4_unint_cvc5 : [String] -> ProofScript ()` + * `w4_unint_yices : [String] -> ProofScript ()` * `w4_unint_z3 : [String] -> ProofScript ()` diff --git a/doc/tutorial/tutorial.md b/doc/tutorial/tutorial.md index 9580829897..62412f7ee2 100644 --- a/doc/tutorial/tutorial.md +++ b/doc/tutorial/tutorial.md @@ -296,7 +296,7 @@ passes the given term through unchanged, because it might be used for either satisfiability or validity checking. The SMT-Lib export capabilities in SAWScript make use of the Haskell -SBV package, and support ABC, Boolector, CVC4, MathSAT, Yices, and Z3. +SBV package, and support ABC, Boolector, CVC4, CVC5, MathSAT, Yices, and Z3. \newpage diff --git a/intTests/test_cvc5/test.saw b/intTests/test_cvc5/test.saw new file mode 100644 index 0000000000..58d54ea3fa --- /dev/null +++ b/intTests/test_cvc5/test.saw @@ -0,0 +1,9 @@ +let +{{ +add_mul_lemma : Integer -> Integer -> Integer -> Integer -> Bit +add_mul_lemma m n p q = + (0 <= m /\ 0 <= n /\ 0 <= p /\ 0 <= q /\ n < q /\ p < m) ==> + (m * n + p < m * q) +}}; + +prove (w4_unint_cvc5 []) {{ add_mul_lemma }}; diff --git a/intTests/test_cvc5/test.sh b/intTests/test_cvc5/test.sh new file mode 100755 index 0000000000..2315cc233c --- /dev/null +++ b/intTests/test_cvc5/test.sh @@ -0,0 +1,3 @@ +set -e + +$SAW test.saw diff --git a/saw-remote-api/python/saw_client/proofscript.py b/saw-remote-api/python/saw_client/proofscript.py index 960e31bdbb..853cee7d32 100644 --- a/saw-remote-api/python/saw_client/proofscript.py +++ b/saw-remote-api/python/saw_client/proofscript.py @@ -45,6 +45,10 @@ class CVC4(UnintProver): def __init__(self, unints : List[str]) -> None: super().__init__("w4-cvc4", unints) +class CVC5(UnintProver): + def __init__(self, unints : List[str]) -> None: + super().__init__("w4-cvc5", unints) + class Yices(UnintProver): def __init__(self, unints : List[str]) -> None: super().__init__("w4-yices", unints) @@ -57,6 +61,10 @@ class CVC4_SBV(UnintProver): def __init__(self, unints : List[str]) -> None: super().__init__("sbv-cvc4", unints) +class CVC5_SBV(UnintProver): + def __init__(self, unints : List[str]) -> None: + super().__init__("sbv-cvc5", unints) + class Yices_SBV(UnintProver): def __init__(self, unints : List[str]) -> None: super().__init__("sbv-yices", unints) @@ -121,6 +129,9 @@ def to_json(self) -> Any: def cvc4(unints : List[str]) -> ProofTactic: return UseProver(CVC4(unints)) +def cvc5(unints : List[str]) -> ProofTactic: + return UseProver(CVC5(unints)) + def yices(unints : List[str]) -> ProofTactic: return UseProver(Yices(unints)) diff --git a/saw-remote-api/src/SAWServer/ProofScript.hs b/saw-remote-api/src/SAWServer/ProofScript.hs index dd570ec031..be68202fb9 100644 --- a/saw-remote-api/src/SAWServer/ProofScript.hs +++ b/saw-remote-api/src/SAWServer/ProofScript.hs @@ -57,6 +57,7 @@ data Prover | SBV_ABC_SMTLib | SBV_Boolector [String] | SBV_CVC4 [String] + | SBV_CVC5 [String] | SBV_MathSAT [String] | SBV_Yices [String] | SBV_Z3 [String] @@ -64,6 +65,7 @@ data Prover | W4_ABC_Verilog | W4_Boolector [String] | W4_CVC4 [String] + | W4_CVC5 [String] | W4_Yices [String] | W4_Z3 [String] @@ -87,11 +89,13 @@ instance FromJSON Prover where "abc" -> pure W4_ABC_SMTLib "boolector" -> SBV_Boolector <$> unints "cvc4" -> SBV_CVC4 <$> unints + "cvc5" -> SBV_CVC5 <$> unints "mathsat" -> SBV_MathSAT <$> unints "rme" -> pure RME "sbv-abc" -> pure SBV_ABC_SMTLib "sbv-boolector" -> SBV_Boolector <$> unints "sbv-cvc4" -> SBV_CVC4 <$> unints + "sbv-cvc5" -> SBV_CVC5 <$> unints "sbv-mathsat" -> SBV_MathSAT <$> unints "sbv-yices" -> SBV_Yices <$> unints "sbv-z3" -> SBV_Z3 <$> unints @@ -99,6 +103,7 @@ instance FromJSON Prover where "w4-abc-verilog" -> pure W4_ABC_Verilog "w4-boolector" -> W4_Boolector <$> unints "w4-cvc4" -> W4_CVC4 <$> unints + "w4-cvc5" -> W4_CVC5 <$> unints "w4-yices" -> W4_Yices <$> unints "w4-z3" -> W4_Z3 <$> unints "yices" -> SBV_Yices <$> unints @@ -273,6 +278,7 @@ interpretProofScript (ProofScript ts) = go ts SBV_ABC_SMTLib -> return $ SB.proveABC_SBV SBV_Boolector unints -> return $ SB.proveUnintBoolector unints SBV_CVC4 unints -> return $ SB.proveUnintCVC4 unints + SBV_CVC5 unints -> return $ SB.proveUnintCVC5 unints SBV_MathSAT unints -> return $ SB.proveUnintMathSAT unints SBV_Yices unints -> return $ SB.proveUnintYices unints SBV_Z3 unints -> return $ SB.proveUnintZ3 unints @@ -280,6 +286,7 @@ interpretProofScript (ProofScript ts) = go ts W4_ABC_Verilog -> return $ SB.w4_abc_verilog W4_Boolector unints -> return $ SB.w4_unint_boolector unints W4_CVC4 unints -> return $ SB.w4_unint_cvc4 unints + W4_CVC5 unints -> return $ SB.w4_unint_cvc5 unints W4_Yices unints -> return $ SB.w4_unint_yices unints W4_Z3 unints -> return $ SB.w4_unint_z3 unints go [Trivial] = return $ SB.trivial diff --git a/src/SAWScript/Builtins.hs b/src/SAWScript/Builtins.hs index 224debfd04..005214fcae 100644 --- a/src/SAWScript/Builtins.hs +++ b/src/SAWScript/Builtins.hs @@ -1005,6 +1005,9 @@ proveZ3 = proveSBV SBV.z3 proveCVC4 :: ProofScript () proveCVC4 = proveSBV SBV.cvc4 +proveCVC5 :: ProofScript () +proveCVC5 = proveSBV SBV.cvc5 + proveMathSAT :: ProofScript () proveMathSAT = proveSBV SBV.mathSAT @@ -1020,6 +1023,9 @@ proveUnintZ3 = proveUnintSBV SBV.z3 proveUnintCVC4 :: [String] -> ProofScript () proveUnintCVC4 = proveUnintSBV SBV.cvc4 +proveUnintCVC5 :: [String] -> ProofScript () +proveUnintCVC5 = proveUnintSBV SBV.cvc5 + proveUnintMathSAT :: [String] -> ProofScript () proveUnintMathSAT = proveUnintSBV SBV.mathSAT @@ -1040,6 +1046,9 @@ w4_z3 = wrapW4Prover Prover.proveWhat4_z3 [] w4_cvc4 :: ProofScript () w4_cvc4 = wrapW4Prover Prover.proveWhat4_cvc4 [] +w4_cvc5 :: ProofScript () +w4_cvc5 = wrapW4Prover Prover.proveWhat4_cvc5 [] + w4_yices :: ProofScript () w4_yices = wrapW4Prover Prover.proveWhat4_yices [] @@ -1055,6 +1064,9 @@ w4_unint_z3_using tactic = wrapW4Prover (Prover.proveWhat4_z3_using tactic) w4_unint_cvc4 :: [String] -> ProofScript () w4_unint_cvc4 = wrapW4Prover Prover.proveWhat4_cvc4 +w4_unint_cvc5 :: [String] -> ProofScript () +w4_unint_cvc5 = wrapW4Prover Prover.proveWhat4_cvc5 + w4_unint_yices :: [String] -> ProofScript () w4_unint_yices = wrapW4Prover Prover.proveWhat4_yices @@ -1066,6 +1078,10 @@ offline_w4_unint_cvc4 :: [String] -> String -> ProofScript () offline_w4_unint_cvc4 unints path = wrapW4ProveExporter Prover.proveExportWhat4_cvc4 unints path ".smt2" +offline_w4_unint_cvc5 :: [String] -> String -> ProofScript () +offline_w4_unint_cvc5 unints path = + wrapW4ProveExporter Prover.proveExportWhat4_cvc5 unints path ".smt2" + offline_w4_unint_yices :: [String] -> String -> ProofScript () offline_w4_unint_yices unints path = wrapW4ProveExporter Prover.proveExportWhat4_yices unints path ".smt2" diff --git a/src/SAWScript/Interpreter.hs b/src/SAWScript/Interpreter.hs index 9304a0da5c..d13357be39 100644 --- a/src/SAWScript/Interpreter.hs +++ b/src/SAWScript/Interpreter.hs @@ -1918,6 +1918,11 @@ primitives = Map.fromList Current [ "Use the CVC4 theorem prover to prove the current goal." ] + , prim "cvc5" "ProofScript ()" + (pureVal proveCVC5) + Current + [ "Use the CVC5 theorem prover to prove the current goal." ] + , prim "z3" "ProofScript ()" (pureVal proveZ3) Current @@ -1947,6 +1952,13 @@ primitives = Map.fromList , "given list of names as uninterpreted." ] + , prim "unint_cvc5" "[String] -> ProofScript ()" + (pureVal proveUnintCVC5) + Current + [ "Use the CVC5 theorem prover to prove the current goal. Leave the" + , "given list of names as uninterpreted." + ] + , prim "unint_yices" "[String] -> ProofScript ()" (pureVal proveUnintYices) Current @@ -1964,6 +1976,11 @@ primitives = Map.fromList Current [ "Use the CVC4 theorem prover to prove the current goal." ] + , prim "sbv_cvc5" "ProofScript ()" + (pureVal proveCVC5) + Current + [ "Use the CVC5 theorem prover to prove the current goal." ] + , prim "sbv_z3" "ProofScript ()" (pureVal proveZ3) Current @@ -1993,6 +2010,13 @@ primitives = Map.fromList , "given list of names as uninterpreted." ] + , prim "sbv_unint_cvc5" "[String] -> ProofScript ()" + (pureVal proveUnintCVC5) + Current + [ "Use the CVC5 theorem prover to prove the current goal. Leave the" + , "given list of names as uninterpreted." + ] + , prim "sbv_unint_yices" "[String] -> ProofScript ()" (pureVal proveUnintYices) Current @@ -2116,6 +2140,13 @@ primitives = Map.fromList , "given list of names as uninterpreted." ] + , prim "w4_unint_cvc5" "[String] -> ProofScript ()" + (pureVal w4_unint_cvc5) + Current + [ "Prove the current goal using What4 (CVC5 backend). Leave the" + , "given list of names as uninterpreted." + ] + , prim "w4_abc_aiger" "ProofScript ()" (pureVal w4_abc_aiger) Current @@ -2161,6 +2192,13 @@ primitives = Map.fromList ," SMT-Lib2 format. Leave the given list of names as uninterpreted." ] + , prim "offline_w4_unint_cvc5" "[String] -> String -> ProofScript ()" + (pureVal offline_w4_unint_cvc5) + Current + [ "Write the current goal to the given file using What4 (CVC5 backend) in" + ," SMT-Lib2 format. Leave the given list of names as uninterpreted." + ] + , prim "split_goal" "ProofScript ()" (pureVal split_goal) Experimental diff --git a/src/SAWScript/Prover/SBV.hs b/src/SAWScript/Prover/SBV.hs index c401330348..3e4d6114ba 100644 --- a/src/SAWScript/Prover/SBV.hs +++ b/src/SAWScript/Prover/SBV.hs @@ -2,7 +2,7 @@ module SAWScript.Prover.SBV ( proveUnintSBV , proveUnintSBVIO , SBV.SMTConfig - , SBV.z3, SBV.cvc4, SBV.yices, SBV.mathSAT, SBV.boolector + , SBV.z3, SBV.cvc4, SBV.cvc5, SBV.yices, SBV.mathSAT, SBV.boolector , prepNegatedSBV ) where diff --git a/src/SAWScript/Prover/What4.hs b/src/SAWScript/Prover/What4.hs index 2ee794f40a..73c4e11047 100644 --- a/src/SAWScript/Prover/What4.hs +++ b/src/SAWScript/Prover/What4.hs @@ -111,7 +111,8 @@ proveExportWhat4_sym solver un hashConsing outFilePath t = -- Assume unsat return (Nothing, stats) -proveWhat4_z3, proveWhat4_boolector, proveWhat4_cvc4, +proveWhat4_z3, proveWhat4_boolector, + proveWhat4_cvc4, proveWhat4_cvc5, proveWhat4_dreal, proveWhat4_stp, proveWhat4_yices, proveWhat4_abc :: Set VarIndex {- ^ Uninterpreted functions -} -> @@ -122,6 +123,7 @@ proveWhat4_z3, proveWhat4_boolector, proveWhat4_cvc4, proveWhat4_z3 = proveWhat4_sym z3Adapter proveWhat4_boolector = proveWhat4_sym boolectorAdapter proveWhat4_cvc4 = proveWhat4_sym cvc4Adapter +proveWhat4_cvc5 = proveWhat4_sym cvc5Adapter proveWhat4_dreal = proveWhat4_sym drealAdapter proveWhat4_stp = proveWhat4_sym stpAdapter proveWhat4_yices = proveWhat4_sym yicesAdapter @@ -141,7 +143,8 @@ proveWhat4_z3_using tactic un hashConsing t = _ <- setOpt z3TacticSetting $ Text.pack tactic return () -proveExportWhat4_z3, proveExportWhat4_boolector, proveExportWhat4_cvc4, +proveExportWhat4_z3, proveExportWhat4_boolector, + proveExportWhat4_cvc4, proveExportWhat4_cvc5, proveExportWhat4_dreal, proveExportWhat4_stp, proveExportWhat4_yices :: Set VarIndex {- ^ Uninterpreted functions -} -> Bool {- ^ Hash-consing of ExportWhat4 terms -}-> @@ -152,6 +155,7 @@ proveExportWhat4_z3, proveExportWhat4_boolector, proveExportWhat4_cvc4, proveExportWhat4_z3 = proveExportWhat4_sym z3Adapter proveExportWhat4_boolector = proveExportWhat4_sym boolectorAdapter proveExportWhat4_cvc4 = proveExportWhat4_sym cvc4Adapter +proveExportWhat4_cvc5 = proveExportWhat4_sym cvc5Adapter proveExportWhat4_dreal = proveExportWhat4_sym drealAdapter proveExportWhat4_stp = proveExportWhat4_sym stpAdapter proveExportWhat4_yices = proveExportWhat4_sym yicesAdapter From 4d3412958a001ee41637040363037af40eac6c95 Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Wed, 22 Mar 2023 10:32:22 -0400 Subject: [PATCH 26/27] Regenerate cabal.GHC-*.config files --- cabal.GHC-8.10.7.config | 8 +++++--- cabal.GHC-8.8.4.config | 8 +++++--- cabal.GHC-9.2.7.config | 8 +++++--- 3 files changed, 15 insertions(+), 9 deletions(-) diff --git a/cabal.GHC-8.10.7.config b/cabal.GHC-8.10.7.config index 606ffdc455..84f07b3765 100644 --- a/cabal.GHC-8.10.7.config +++ b/cabal.GHC-8.10.7.config @@ -1,5 +1,6 @@ active-repositories: hackage.haskell.org:merge -constraints: any.Cabal ==3.2.1.0, +constraints: any.BoundedChan ==1.0.3.0, + any.Cabal ==3.2.1.0, any.Glob ==0.10.2, any.GraphSCC ==1.0.4, GraphSCC -use-maps, @@ -248,6 +249,7 @@ constraints: any.Cabal ==3.2.1.0, optparse-applicative +process, any.optparse-simple ==0.1.1.4, optparse-simple -build-example, + any.ordered-containers ==0.2.3, any.panic ==0.4.0.1, any.parallel ==3.2.2.0, parameterized-utils +unsafe-operations, @@ -284,7 +286,7 @@ constraints: any.Cabal ==3.2.1.0, s-cargot -build-example, any.safe ==0.3.19, any.safe-exceptions ==0.1.7.3, - any.sbv ==9.0, + any.sbv ==9.2, any.scientific ==0.3.7.0, scientific -bytestring-builder -integer-simple, any.scotty ==0.12.1, @@ -329,7 +331,7 @@ constraints: any.Cabal ==3.2.1.0, any.tasty-hunit ==0.10.0.3, any.tasty-quickcheck ==0.10.2, any.tasty-smallcheck ==0.8.2, - any.tasty-sugar ==1.3.0.2, + any.tasty-sugar ==2.0.1.0, any.template-haskell ==2.16.0.0, any.temporary ==1.3, any.terminal-size ==0.3.3, diff --git a/cabal.GHC-8.8.4.config b/cabal.GHC-8.8.4.config index 316e457bfd..e2415ba6fc 100644 --- a/cabal.GHC-8.8.4.config +++ b/cabal.GHC-8.8.4.config @@ -1,5 +1,6 @@ active-repositories: hackage.haskell.org:merge -constraints: any.Cabal ==3.0.1.0, +constraints: any.BoundedChan ==1.0.3.0, + any.Cabal ==3.0.1.0, any.Glob ==0.10.2, any.GraphSCC ==1.0.4, GraphSCC -use-maps, @@ -249,6 +250,7 @@ constraints: any.Cabal ==3.0.1.0, optparse-applicative +process, any.optparse-simple ==0.1.1.4, optparse-simple -build-example, + any.ordered-containers ==0.2.3, any.panic ==0.4.0.1, any.parallel ==3.2.2.0, parameterized-utils +unsafe-operations, @@ -285,7 +287,7 @@ constraints: any.Cabal ==3.0.1.0, s-cargot -build-example, any.safe ==0.3.19, any.safe-exceptions ==0.1.7.3, - any.sbv ==9.0, + any.sbv ==9.2, any.scientific ==0.3.7.0, scientific -bytestring-builder -integer-simple, any.scotty ==0.12.1, @@ -330,7 +332,7 @@ constraints: any.Cabal ==3.0.1.0, any.tasty-hunit ==0.10.0.3, any.tasty-quickcheck ==0.10.2, any.tasty-smallcheck ==0.8.2, - any.tasty-sugar ==1.3.0.2, + any.tasty-sugar ==2.0.1.0, any.template-haskell ==2.15.0.0, any.temporary ==1.3, any.terminal-size ==0.3.3, diff --git a/cabal.GHC-9.2.7.config b/cabal.GHC-9.2.7.config index 738ac74284..461fe2cb89 100644 --- a/cabal.GHC-9.2.7.config +++ b/cabal.GHC-9.2.7.config @@ -1,5 +1,6 @@ active-repositories: hackage.haskell.org:merge -constraints: any.Cabal ==3.6.3.0, +constraints: any.BoundedChan ==1.0.3.0, + any.Cabal ==3.6.3.0, any.Glob ==0.10.2, any.GraphSCC ==1.0.4, GraphSCC -use-maps, @@ -249,6 +250,7 @@ constraints: any.Cabal ==3.6.3.0, optparse-applicative +process, any.optparse-simple ==0.1.1.4, optparse-simple -build-example, + any.ordered-containers ==0.2.3, any.panic ==0.4.0.1, any.parallel ==3.2.2.0, parameterized-utils +unsafe-operations, @@ -285,7 +287,7 @@ constraints: any.Cabal ==3.6.3.0, s-cargot -build-example, any.safe ==0.3.19, any.safe-exceptions ==0.1.7.3, - any.sbv ==9.0, + any.sbv ==9.2, any.scientific ==0.3.7.0, scientific -bytestring-builder -integer-simple, any.scotty ==0.12.1, @@ -330,7 +332,7 @@ constraints: any.Cabal ==3.6.3.0, any.tasty-hunit ==0.10.0.3, any.tasty-quickcheck ==0.10.2, any.tasty-smallcheck ==0.8.2, - any.tasty-sugar ==1.3.0.2, + any.tasty-sugar ==2.0.1.0, any.template-haskell ==2.18.0.0, any.temporary ==1.3, any.terminal-size ==0.3.3, From b508d121b7e72792b076780cc0a6406456e11e1e Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Thu, 23 Mar 2023 17:08:20 -0400 Subject: [PATCH 27/27] CI: Remove action-docker-layer-caching step Sadly, this action is timing out very frequently. I am going to remove it for the sake of getting CI to work. Fixes #1834. --- .github/workflows/ci.yml | 6 ------ 1 file changed, 6 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 5b8dd32c2d..8ad4f84484 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -573,9 +573,6 @@ jobs: docker-compose pull grep -h '^FROM' docker/*.dockerfile | sort -u | awk '{print $2}' | xargs -n1 -P8 docker pull - - uses: jpribyl/action-docker-layer-caching@v0.1.1 - continue-on-error: true - - shell: bash name: "make s2n" working-directory: s2nTests @@ -606,9 +603,6 @@ jobs: name: "${{ runner.os }}-bins" path: ./exercises/bin - - uses: jpribyl/action-docker-layer-caching@v0.1.1 - continue-on-error: true - - shell: bash name: "make exercises container" working-directory: exercises