From 3a9c13b4b25009f2b94de66e82aa2e3b5df6f75b Mon Sep 17 00:00:00 2001 From: Karl Smeltzer Date: Mon, 28 Jun 2021 13:35:45 -0700 Subject: [PATCH 01/28] add basic IDE logging, start error cleanup --- heapster-saw/heapster-saw.cabal | 2 + .../src/Verifier/SAW/Heapster/IDESupport.hs | 253 ++++++++++++++ .../src/Verifier/SAW/Heapster/Implication.hs | 111 +++--- .../Verifier/SAW/Heapster/SAWTranslation.hs | 322 +++++++++--------- .../Verifier/SAW/Heapster/TypedCrucible.hs | 18 +- src/SAWScript/HeapsterBuiltins.hs | 20 +- src/SAWScript/Interpreter.hs | 7 + src/SAWScript/Value.hs | 5 +- 8 files changed, 531 insertions(+), 207 deletions(-) create mode 100644 heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs diff --git a/heapster-saw/heapster-saw.cabal b/heapster-saw/heapster-saw.cabal index 7c904aa5ff..939a25b3a9 100644 --- a/heapster-saw/heapster-saw.cabal +++ b/heapster-saw/heapster-saw.cabal @@ -37,6 +37,7 @@ library filepath, language-rust, hobbits ^>= 1.4, + aeson ^>= 1.5 hs-source-dirs: src build-tool-depends: alex:alex, @@ -44,6 +45,7 @@ library exposed-modules: Verifier.SAW.Heapster.CruUtil Verifier.SAW.Heapster.GenMonad + Verifier.SAW.Heapster.IDESupport Verifier.SAW.Heapster.Implication Verifier.SAW.Heapster.IRTTranslation Verifier.SAW.Heapster.Lexer 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..f68a644e36 --- /dev/null +++ b/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs @@ -0,0 +1,253 @@ +{-# 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 #-} + +module Verifier.SAW.Heapster.IDESupport where + +import Control.Monad.Reader +import Data.Aeson ( encodeFile, ToJSON ) +import Data.Bifunctor +import Data.Binding.Hobbits +import Data.Binding.Hobbits.MonadBind +import Data.Maybe +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.Types +import What4.FunctionName ( FunctionName(functionName) ) +import What4.ProgramLoc + ( Position(InternalPos, SourcePos, BinaryPos, OtherPos), + ProgramLoc(..) ) + +import Verifier.SAW.Heapster.CruUtil +import Verifier.SAW.Heapster.Implication +import Verifier.SAW.Heapster.Permissions +import Verifier.SAW.Heapster.TypedCrucible + +import Debug.Trace + + +-- | 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 = Reader (PPInfo, ProgramLoc) + +-- | 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 + , lePermissions :: String + } + | LogError + { lerrLocation :: String + , lerrError :: 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 x y |] -> LogEntry (mbLift x) (mbLift y) + [nuMP| LogError x y |] -> LogError (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 [LogEntry] + +instance (PermCheckExtC ext) + => ExtractLogEntries + (TypedEntry TransPhase ext blocks tops ret args ghosts) where + extractLogEntries te = do + let loc = trace "typed entry loc" (mbLift $ fmap getFirstProgramLocTS (typedEntryBody te)) + errors <- withLoc loc $ + mbExtractLogEntries undefined (typedEntryBody te) + entryEntries <- mbExtractLogEntries undefined (typedEntryPermsIn te) + return $ trace "te entries" entryEntries <> trace "errors" errors + +instance ExtractLogEntries (ValuePerms ctx) where + extractLogEntries vps = do + (ppi, loc) <- ask + return $ foldValuePerms (handlePerm ppi (snd $ ppLoc loc)) [] vps + where + handlePerm + :: PPInfo -> String -> [LogEntry] -> ValuePerm ctx' -> [LogEntry] + handlePerm ppi loc rest perm = + let permStr = permPrettyString ppi perm + in LogEntry loc permStr : rest + +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 $ mbExtractLogEntries undefined rest + extractLogEntries (TypedTermStmt _ _) = return [] + +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) = + -- The error message is available further up the stack, so we just leave it + -- empty here + reader $ \(_, loc) -> [LogError (snd $ ppLoc loc) err] + extractLogEntries _ = return [] + +instance ExtractLogEntries + (MbPermImpls (TypedStmtSeq ext blocks tops ret) ps_outs) where + extractLogEntries (MbPermImpls_Cons ctx mbpis pis) = do + pisEntries <- mbExtractLogEntries ctx pis + mbpisEntries <- extractLogEntries mbpis + return $ pisEntries <> mbpisEntries + extractLogEntries MbPermImpls_Nil = return [] + +instance (PermCheckExtC ext) + => ExtractLogEntries (TypedCFG ext blocks ghosts inits ret) where + extractLogEntries tcfg = extractLogEntries $ tpcfgBlockMap tcfg + +instance (PermCheckExtC ext) + => ExtractLogEntries (TypedBlockMap TransPhase ext blocks tops ret) where + extractLogEntries tbm = + fmap concat $ sequence $ RL.mapToList extractLogEntries tbm + +instance (PermCheckExtC ext) + => ExtractLogEntries (TypedBlock TransPhase ext blocks tops ret args) where + extractLogEntries tb = fmap concat $ mapM helper $ _typedBlockEntries tb + where + helper + :: (PermCheckExtC ext) + => Some (TypedEntry TransPhase ext blocks tops ret args) + -> ExtractionM [LogEntry] + helper ste = case ste of + Some te -> extractLogEntries te + +mbExtractLogEntries + :: ExtractLogEntries a => CruCtx ctx -> Mb ctx a -> ExtractionM [LogEntry] +mbExtractLogEntries ctx mb_a = + fmap mbLift $ strongMbM $ flip nuMultiWithElim1 mb_a $ \ns a -> + local (first $ ppInfoAddTypedExprNames ctx ns) $ + extractLogEntries a + +ppInfoAddTypedExprNames + :: CruCtx ctx + -> RAssign Name (tps :: RList CrucibleType) + -> PPInfo + -> PPInfo +ppInfoAddTypedExprNames _ = ppInfoAddExprNames "x" + +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, _) -> (ppinfo, loc)) + +setErrorMsg :: String -> LogEntry -> LogEntry +setErrorMsg msg le@LogError {} = le { lerrError = msg } +setErrorMsg msg le@LogEntry {} = + LogError { lerrError = msg, lerrLocation = leLocation le} + + +runWithLoc :: PPInfo -> [Some SomeTypedCFG] -> [LogEntry] +runWithLoc ppi = + trace "runWithLoc" + concatMap (runWithLocHelper ppi) + where + runWithLocHelper :: PPInfo -> Some SomeTypedCFG -> [LogEntry] + runWithLocHelper ppi' sstcfg = case trace "runWith Helper Case" sstcfg of + Some (SomeTypedCFG tcfg) -> do + let env = trace "runWithLocHelper" (ppi', getFirstProgramLoc tcfg) + runReader (trace "calling extract" extractLogEntries tcfg) env + +getFirstProgramLoc + :: PermCheckExtC ext + => TypedCFG ext blocks ghosts inits ret -> ProgramLoc +getFirstProgramLoc tcfg = + case trace "getFirstProgramLoc" listToMaybe $ catMaybes $ + RL.mapToList getFirstProgramLocBM $ tpcfgBlockMap tcfg of + Just pl -> pl + _ -> error "Unable to get initial program location" + +getFirstProgramLocBM + :: PermCheckExtC ext + => TypedBlock TransPhase ext blocks tops ret ctx + -> Maybe ProgramLoc +getFirstProgramLocBM block = + listToMaybe $ mapMaybe helper (_typedBlockEntries block) + where + helper + :: PermCheckExtC ext + => Some (TypedEntry TransPhase ext blocks tops ret ctx) + -> Maybe ProgramLoc + helper ste = case ste of + Some TypedEntry { typedEntryBody = stmts } -> + Just $ mbLift $ 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 + => TypedStmtSeq ext blocks tops ret ctx + -> ProgramLoc +getFirstProgramLocTS (TypedImplStmt (AnnotPermImpl _ pis)) = + getFirstProgramLocPI pis +getFirstProgramLocTS (TypedConsStmt loc _ _ _) = loc +getFirstProgramLocTS (TypedTermStmt loc _) = loc + +getFirstProgramLocPI + :: PermCheckExtC ext + => PermImpl (TypedStmtSeq ext blocks tops ret) ctx + -> ProgramLoc +getFirstProgramLocPI (PermImpl_Done stmts) = getFirstProgramLocTS stmts +getFirstProgramLocPI (PermImpl_Step _ mbps) = getFirstProgramLocMBPI mbps + +getFirstProgramLocMBPI + :: PermCheckExtC ext + => 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 875647acc9..833c59c693 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs @@ -2714,9 +2714,10 @@ partialSubstForceM mb_e caller = case partialSubst psubst mb_e of Just e -> pure e Nothing -> - implTraceM (\i -> sep [pretty ("Incomplete susbtitution in " ++ caller - ++ " for:"), - permPretty i mb_e]) >>= implFailM + implFailM' $ PartialSubstitutionError + (\i -> sep [pretty ("Incomplete susbtitution in " ++ caller ++ + " for: "), + permPretty i mb_e]) -- | Modify the current partial substitution modifyPSubst :: (PartialSubst vars -> PartialSubst vars) -> @@ -2782,7 +2783,7 @@ implRecFlagCaseM 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 @@ -2791,7 +2792,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 @@ -2962,18 +2963,6 @@ implApplyImpl1 impl1 mb_ms = implSetNameTypes ns ctx >>> f ns) --- | Emit debugging output using the current 'PPInfo' if the 'implStateDoTrace' --- flag is set -implTraceM :: (PPInfo -> PP.Doc ann) -> ImplM vars s r ps ps String -implTraceM f = - do do_trace <- use implStateDoTrace - doc <- uses implStatePPInfo f - let str = renderDoc doc - fn do_trace str (pure str) - where - fn True = trace - fn False = const id - -- | Run an 'ImplM' computation with 'implStateDoTrace' temporarily disabled implWithoutTracingM :: ImplM vars s r ps_out ps_in a -> ImplM vars s r ps_out ps_in a @@ -2984,18 +2973,6 @@ implWithoutTracingM m = (implStateDoTrace .= 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 @@ -3004,15 +2981,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. If 'pruneFailingBranches' is set, -- failing branches are pruned. @@ -4600,7 +4568,7 @@ solveForPermListImpl ps_l mb_ps = case mbMatch mb_ps of pure (Some MNil) concatSomeRAssign :: [Some (RAssign f)] -> Some (RAssign f) -concatSomeRAssign = foldl apSomeRAssign (Some MNil) +concatSomeRAssign = foldl apSomeRAssign (Some MNil) -- foldl is intentional, appending RAssign matches on the second argument apSomeRAssign :: Some (RAssign f) -> Some (RAssign f) -> Some (RAssign f) @@ -5054,7 +5022,7 @@ proveVarLLVMArray_ArrayStep x ps ap i ap_lhs -- Otherwise we don't know what to do so we fail proveVarLLVMArray_ArrayStep _x _ps _ap _i _ap_lhs = - implFailMsgM "proveVarLLVMArray_ArrayStep" + implFailM' ArrayStepError ---------------------------------------------------------------------- @@ -6457,7 +6425,7 @@ 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 = @@ -6619,6 +6587,8 @@ proveVarsImplAppendInt ps = proveVarsImplAppendInt (mbMap2 appendDistPerms ps1 ps2) >>> implMoveUpM cur_perms (mbDistPermsToProxies ps1) x (mbDistPermsToProxies ps2) _ -> + + implTraceM (\i -> sep [PP.fillSep [PP.pretty @@ -6720,3 +6690,62 @@ proveVarsImplVarEVars mb_ps = 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 + + +-------------------------------------------------------------------------------- +-- Error handling and debugging + +data ImplError where + FatalError :: (PPInfo -> PP.Doc ann) -> ImplError + NoFrameInScopeError :: ImplError + ArrayStepError :: ImplError + MuUnfoldError :: ImplError + FunctionPermissionError :: ImplError + PartialSubstitutionError :: (PPInfo -> PP.Doc ann) -> ImplError + +class ErrorPretty a where + ppErrorFn :: a -> PPInfo -> String + +instance ErrorPretty ImplError where + ppErrorFn (FatalError f) pp = renderDoc $ f pp + ppErrorFn NoFrameInScopeError _ = "No LLVM frame in scope" + ppErrorFn ArrayStepError _ = "Error proving array permissions" + ppErrorFn MuUnfoldError _ = + "Tried to unfold a mu on the left after unfolding on the right" + ppErrorFn FunctionPermissionError _ = + "Could not find function permission" + +-- | 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 + +implFailM' :: NuMatchingAny1 r => ImplError -> ImplM vars s r ps_any ps a +implFailM' err = + use implStateFailPrefix >>>= \prefix -> + uses implStatePPInfo (ppErrorFn err) >>>= \doc -> + let msg = prefix <> doc + in implTraceM (const $ pretty msg) >>> implApplyImpl1 (Impl1_Fail msg) 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 = + implTraceM (\i -> + sep [pretty f <> colon <+> pretty "Could not prove", + ppImpl i x p mb_p]) >>>= + implFailM + +-- | Emit debugging output using the current 'PPInfo' if the 'implStateDoTrace' +-- flag is set +implTraceM :: (PPInfo -> PP.Doc ann) -> ImplM vars s r ps ps String +implTraceM f = + do do_trace <- use implStateDoTrace + doc <- uses implStatePPInfo f + let str = renderDoc doc + fn do_trace str (pure str) + where + fn True = trace + fn False = const id \ No newline at end of file diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index c35dfc5164..92bff90ae2 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -2055,15 +2055,15 @@ translateSimplImpl :: Proxy ps -> Mb ctx (SimplImpl ps_in ps_out) -> translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of [nuMP| SImpl_Drop _ _ |] -> withPermStackM (\(xs :>: _) -> xs) (\(ps :>: _) -> ps) m - + [nuMP| SImpl_Copy x _ |] -> withPermStackM (:>: translateVar x) (\(ps :>: p) -> ps :>: p :>: p) m - + [nuMP| SImpl_Swap _ _ _ _ |] -> withPermStackM (\(xs :>: x :>: y) -> xs :>: y :>: x) (\(pctx :>: px :>: py) -> pctx :>: py :>: px) m - + [nuMP| SImpl_MoveUp (mb_ps1 :: DistPerms ps1) (_mb_x :: ExprVar a) _ (mb_ps2 :: DistPerms ps2) |] -> let ps1 = mbRAssignProxies mb_ps1 @@ -2083,7 +2083,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of (pctx1, pctx2) = RL.split ps1 ps2 pctx12 in RL.append pctx0 $ RL.append (pctx1 :>: ptrans) pctx2) m - + [nuMP| SImpl_MoveDown mb_ps1 (mb_x :: ExprVar a) _ mb_ps2 |] | prx_a <- mbLift $ fmap (const (Proxy :: Proxy a)) mb_x , ps1 <- mbRAssignProxies mb_ps1 @@ -2108,7 +2108,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of (\(ps :>: p_top) -> ps :>: PTrans_Term (mbMap2 ValPerm_Or p1 p2) (leftTrans tp1 tp2 p_top)) m - + [nuMP| SImpl_IntroOrR _ p1 p2 |] -> do tp1 <- translate p1 tp2 <- translate p2 @@ -2116,7 +2116,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of (\(ps :>: p_top) -> ps :>: PTrans_Term (mbMap2 ValPerm_Or p1 p2) (rightTrans tp1 tp2 p_top)) m - + [nuMP| SImpl_IntroExists _ e p |] -> do let tp = mbExprType e tp_trans <- translateClosed tp @@ -2127,12 +2127,12 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of withPermStackM id ((:>: PTrans_Term (fmap ValPerm_Exists p) sigma_trm) . RL.tail) m - + [nuMP| SImpl_Cast _ _ _ |] -> withPermStackM RL.tail (\(pctx :>: _ :>: ptrans) -> pctx :>: ptrans) m - + [nuMP| SImpl_CastPerm (x::ExprVar a) eqp |] -> do ttrans <- translate $ fmap (distPermsHeadPerm . simplImplOut) mb_simpl let prxs_a = MNil :>: (Proxy :: Proxy a) @@ -2145,34 +2145,34 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of (_ :>: ptrans, _) = RL.split prxs_a prxs1 pctx2 in pctx1 :>: typeTransF ttrans (transTerms ptrans)) m - + [nuMP| SImpl_IntroEqRefl x |] -> withPermStackM (:>: translateVar x) (:>: PTrans_Eq (fmap PExpr_Var x)) m - + [nuMP| SImpl_InvertEq x y |] -> withPermStackM ((:>: translateVar y) . RL.tail) ((:>: PTrans_Eq (fmap PExpr_Var x)) . RL.tail) m - + [nuMP| SImpl_InvTransEq _ mb_y _ |] -> withPermStackM RL.tail ((:>: PTrans_Eq (fmap PExpr_Var mb_y)) . RL.tail . RL.tail) m - + [nuMP| SImpl_CopyEq _ _ |] -> withPermStackM (\(vars :>: var) -> (vars :>: var :>: var)) (\(pctx :>: ptrans) -> (pctx :>: ptrans :>: ptrans)) m - + [nuMP| SImpl_LLVMWordEq _ _ e |] -> withPermStackM RL.tail (\(pctx :>: _ :>: _) -> (pctx :>: PTrans_Eq (fmap PExpr_LLVMWord e))) m - + [nuMP| SImpl_IntroConj x |] -> withPermStackM (:>: translateVar x) (:>: PTrans_True) m - + [nuMP| SImpl_ExtractConj x _ mb_i |] -> withPermStackM (:>: translateVar x) (\(pctx :>: ptrans) -> @@ -2184,7 +2184,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of else error "translateSimplImpl: SImpl_ExtractConj: index out of bounds") m - + [nuMP| SImpl_CopyConj x _ mb_i |] -> withPermStackM (:>: translateVar x) (\(pctx :>: ptrans) -> @@ -2193,7 +2193,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of if i < length ps then pctx :>: PTrans_Conj [ps !! i] :>: ptrans else error "translateSimplImpl: SImpl_CopyConj: index out of bounds") m - + [nuMP| SImpl_InsertConj _ _ _ i |] -> withPermStackM RL.tail (\(pctx :>: ptransi :>: ptrans) -> @@ -2201,7 +2201,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of pi = unPTransConj1 "translateSimplImpl: SImpl_InsertConj" ptransi in pctx :>: PTrans_Conj (take (mbLift i) ps ++ pi : drop (mbLift i) ps)) m - + [nuMP| SImpl_AppendConjs _ _ _ |] -> withPermStackM RL.tail (\(pctx :>: ptrans1 :>: ptrans2) -> @@ -2209,7 +2209,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of ps2 = unPTransConj "translateSimplImpl: SImpl_AppendConjs" ptrans2 in pctx :>: PTrans_Conj (ps1 ++ ps2)) m - + [nuMP| SImpl_SplitConjs x _ mb_i |] -> let i = mbLift mb_i in withPermStackM (:>: translateVar x) @@ -2217,13 +2217,13 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of let ps = unPTransConj "translateSimplImpl: SImpl_SplitConjs" ptrans in pctx :>: PTrans_Conj (take i ps) :>: PTrans_Conj (drop i ps)) m - + [nuMP| SImpl_IntroStructTrue x prxs |] -> withPermStackM (:>: translateVar x) (\pctx -> pctx :>: PTrans_Conj [APTrans_Struct $ RL.map (const PTrans_True) (mbRAssign prxs)]) m - + [nuMP| SImpl_StructEqToPerm _ exprs |] -> withPermStackM id (\(pctx :>: _) -> @@ -2231,19 +2231,19 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of RL.map (PTrans_Eq . getCompose) (mbRAssign $ fmap exprsToRAssign exprs)]) m - + [nuMP| SImpl_StructPermToEq _ exprs |] -> withPermStackM id (\(pctx :>: _) -> pctx :>: PTrans_Eq (fmap PExpr_Struct exprs)) m - + [nuMP| SImpl_IntroStructField _ _ memb _ |] -> withPermStackM RL.tail (\(pctx :>: PTrans_Conj [APTrans_Struct pctx_str] :>: ptrans) -> pctx :>: PTrans_Conj [APTrans_Struct $ RL.set (mbLift memb) ptrans pctx_str]) m - + [nuMP| SImpl_ConstFunPerm x _ mb_fun_perm ident |] -> withPermStackM ((:>: translateVar x) . RL.tail) ((:>: PTrans_Term (fmap (ValPerm_Conj1 @@ -2251,37 +2251,37 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of mbLift ident)) . RL.tail) m - + [nuMP| SImpl_CastLLVMWord _ _ e2 |] -> withPermStackM RL.tail ((:>: PTrans_Eq (fmap PExpr_LLVMWord e2)) . RL.tail . RL.tail) m - + [nuMP| SImpl_InvertLLVMOffsetEq mb_x mb_off mb_y |] -> withPermStackM ((:>: translateVar mb_y) . RL.tail) ((:>: PTrans_Eq (mbMap2 (\x off -> PExpr_LLVMOffset x $ bvNegate off) mb_x mb_off)) . RL.tail) m - + [nuMP| SImpl_OffsetLLVMWord _ mb_e mb_off mb_x |] -> withPermStackM ((:>: translateVar mb_x) . RL.tail . RL.tail) ((:>: PTrans_Eq (mbMap2 (\e off -> PExpr_LLVMWord $ bvAdd e off) mb_e mb_off)) . RL.tail . RL.tail) m - + [nuMP| SImpl_CastLLVMPtr _ _ off _ |] -> withPermStackM RL.tail (\(pctx :>: _ :>: ptrans) -> pctx :>: offsetLLVMPermTrans (fmap bvNegate off) ptrans) m - + [nuMP| SImpl_CastLLVMFree _ _ e2 |] -> withPermStackM RL.tail ((:>: PTrans_Conj [APTrans_LLVMFree e2]) . RL.tail . RL.tail) m - + [nuMP| SImpl_CastLLVMFieldOffset _ mb_fld mb_off |] -> withPermStackM RL.tail (\(pctx :>: _ :>: ptrans) -> @@ -2293,13 +2293,13 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of mb_fld mb_off) ptrans']) m - + [nuMP| SImpl_IntroLLVMFieldContents x _ mb_fld |] -> withPermStackM ((:>: translateVar x) . RL.tail . RL.tail) (\(pctx :>: _ :>: ptrans) -> pctx :>: PTrans_Conj [APTrans_LLVMField mb_fld ptrans]) m - + [nuMP| SImpl_DemoteLLVMFieldRW _ mb_fld |] -> withPermStackM id (\(pctx :>: ptrans) -> @@ -2311,7 +2311,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of (fmap (\fld -> fld { llvmFieldRW = PExpr_Read }) mb_fld) ptrans']) m - + [nuMP| SImpl_LLVMArrayCopy _ mb_ap mb_sub_ap |] -> do let _w = natVal2 mb_ap sub_ap_tp_trans <- translate mb_sub_ap @@ -2331,7 +2331,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of rng_trans {- mb_sub_borrows -} prop_transs] :>: ptrans_array) m - + [nuMP| SImpl_LLVMArrayBorrow _ mb_ap mb_sub_ap |] -> do sub_ap_tp_trans <- translate mb_sub_ap let mb_rng = mbMap2 llvmSubArrayRange mb_ap mb_sub_ap @@ -2362,7 +2362,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of PTrans_Conj [sub_array_trans] :>: PTrans_Conj [APTrans_LLVMArray array_trans']) m - + [nuMP| SImpl_LLVMArrayReturn _ mb_ap mb_ret_ap |] -> do (_ :>: ptrans_sub_array :>: ptrans_array) <- itiPermStack <$> ask let mb_cell = @@ -2388,7 +2388,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of (\(pctx :>: _ :>: _) -> pctx :>: PTrans_Conj [APTrans_LLVMArray array_trans']) m - + [nuMP| SImpl_LLVMArrayAppend _ mb_ap1 mb_ap2 |] -> withPermStackM RL.tail (\(pctx :>: ptrans_array1 :>: ptrans_array2) -> @@ -2418,8 +2418,8 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of llvmArrayTransTerm array_trans2] } in pctx :>: PTrans_Conj [APTrans_LLVMArray array_trans_out]) m - - + + [nuMP| SImpl_LLVMArrayRearrange _ _ mb_ap2 |] -> do ap2_tp_trans <- translate mb_ap2 withPermStackM id @@ -2428,13 +2428,13 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of PTrans_Conj [APTrans_LLVMArray $ typeTransF ap2_tp_trans [transTerm1 ptrans_array]]) m - + [nuMP| SImpl_LLVMArrayToField _ _ _ |] -> do ttrans <- translate $ fmap (distPermsHeadPerm . simplImplOut) mb_simpl withPermStackM id (\(pctx :>: _) -> pctx :>: typeTransF ttrans []) m - + [nuMP| SImpl_LLVMArrayEmpty x mb_ap |] -> do (w_term, _, elem_tp, ap_tp_trans) <- translateLLVMArrayPerm mb_ap let arr_term = @@ -2445,7 +2445,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of pctx :>: PTrans_Conj [APTrans_LLVMArray $ typeTransF ap_tp_trans [arr_term]]) m - + [nuMP| SImpl_LLVMArrayOneCell _ mb_ap |] -> do (w_term, len_term, elem_tp, ap_tp_trans) <- translateLLVMArrayPerm mb_ap withPermStackM id @@ -2456,8 +2456,8 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of pctx :>: PTrans_Conj [APTrans_LLVMArray $ typeTransF ap_tp_trans [arr_term]]) m - - + + [nuMP| SImpl_LLVMArrayIndexCopy _ _ mb_ix |] -> do (_ :>: ptrans_array :>: ptrans_props) <- itiPermStack <$> ask let arr_trans = @@ -2472,7 +2472,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of (\(pctx :>: _ :>: _) -> pctx :>: PTrans_Conj [fld_ptrans] :>: ptrans_array) m - + [nuMP| SImpl_LLVMArrayIndexBorrow _ mb_ap mb_ix |] -> do (_ :>: ptrans_array :>: ptrans_props) <- itiPermStack <$> ask let arr_trans = @@ -2494,7 +2494,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of pctx :>: PTrans_Conj [fld_ptrans] :>: PTrans_Conj [APTrans_LLVMArray arr_trans']) m - + [nuMP| SImpl_LLVMArrayIndexReturn _ mb_ap mb_ix |] -> do (_ :>: ptrans_fld :>: ptrans_array) <- itiPermStack <$> ask let aptrans_fld = case ptrans_fld of @@ -2516,28 +2516,28 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of (\(pctx :>: _ :>: _) -> pctx :>: PTrans_Conj [APTrans_LLVMArray arr_trans']) m - + [nuMP| SImpl_LLVMArrayContents _ _ _ _ _ |] -> error "FIXME HERE: translateSimplImpl: SImpl_LLVMArrayContents unhandled" - + [nuMP| SImpl_LLVMFieldIsPtr x _ |] -> withPermStackM (:>: translateVar x) (\(pctx :>: ptrans_fld) -> pctx :>: PTrans_Conj [APTrans_IsLLVMPtr] :>: ptrans_fld) m - + [nuMP| SImpl_LLVMArrayIsPtr x _ |] -> withPermStackM (:>: translateVar x) (\(pctx :>: ptrans_array) -> pctx :>: PTrans_Conj [APTrans_IsLLVMPtr] :>: ptrans_array) m - + [nuMP| SImpl_LLVMBlockIsPtr x _ |] -> withPermStackM (:>: translateVar x) (\(pctx :>: ptrans) -> pctx :>: PTrans_Conj [APTrans_IsLLVMPtr] :>: ptrans) m - + [nuMP| SImpl_SplitLifetime _ f args l _ ps_in ps_out |] -> do pctx_out_trans <- translate $ fmap simplImplOut mb_simpl ps_in_tp <- translate1 ps_in @@ -2561,7 +2561,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of RL.append pctx $ typeTransF pctx_out_trans (transTerms ptrans_x ++ [f_tm])) m - + [nuMP| SImpl_SubsumeLifetime _ _ ps_in1 ps_out1 ps_in2 ps_out2 |] -> do pctx_out_trans <- translate $ fmap simplImplOut mb_simpl ps_in1_tp <- translate1 ps_in1 @@ -2584,7 +2584,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of transTerm1 ptrans_l1, transTerm1 ptrans_l2]]) m - + [nuMP| SImpl_WeakenLifetime _ _ _ _ _ |] -> do pctx_out_trans <- translate $ fmap simplImplOut mb_simpl withPermStackM RL.tail @@ -2594,7 +2594,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of -- ptrans_x to pctx_out_trans RL.append pctx (typeTransF pctx_out_trans $ transTerms ptrans_x)) m - + [nuMP| SImpl_MapLifetime l ps_in ps_out ps_in' ps_out' ps1 ps2 impl_in impl_out |] -> -- First, translate the output permissions and all of the perm lists @@ -2605,7 +2605,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of ps_out'_trans <- translate ps_out' -- ps1_trans <- translate ps1 -- ps2_trans <- translate ps2 - + -- Next, split out the various input permissions from the rest of the pctx let prxs1 = mbRAssignProxies ps1 let prxs2 = mbRAssignProxies ps2 @@ -2613,22 +2613,22 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of pctx <- itiPermStack <$> ask let (pctx_ps, pctx12 :>: ptrans_l) = RL.split ps0 prxs_in pctx let (pctx1, pctx2) = RL.split prxs1 prxs2 pctx12 - + -- Also split out the input variables and replace them with the ps_out vars pctx_vars <- itiPermStackVars <$> ask let (vars_ps, vars12 :>: _) = RL.split ps0 prxs_in pctx_vars let (vars1, vars2) = RL.split prxs1 prxs2 vars12 let vars_out = vars_ps :>: translateVar l - + -- Now build the output lowned function by composing the input lowned -- function with the translations of the implications on inputs and outputs let fromJustOrError (Just x) = x fromJustOrError Nothing = error "translateSimplImpl: SImpl_MapLifetime" ps_in'_vars = - RL.map (translateVar . getCompose) $ mbRAssign $ + RL.map (translateVar . getCompose) $ mbRAssign $ fmap (fromJustOrError . lownedPermsVars) ps_in' ps_out_vars = - RL.map (translateVar . getCompose) $ mbRAssign $ + RL.map (translateVar . getCompose) $ mbRAssign $ fmap (fromJustOrError . lownedPermsVars) ps_out impl_in_tm <- translateCurryLocalPermImpl "Error mapping lifetime input perms:" impl_in @@ -2645,23 +2645,23 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of (globalOpenTerm "Prelude.composeM") [transTerm1 ps_in_trans, transTerm1 ps_out_trans, transTerm1 ps_out'_trans, transTerm1 ptrans_l, impl_out_tm]] - + -- Finally, update the permissions withPermStackM (\_ -> vars_out) (\_ -> RL.append pctx_ps $ typeTransF pctx_out_trans [l_res_tm]) m - + [nuMP| SImpl_EndLifetime _ ps_in ps_out |] -> -- First, translate the output permissions and the input and output types of -- the monadic function for the lifeime ownership permission do ps_out_trans <- translate ps_out let prxs_in = mbRAssignProxies ps_in :>: Proxy - + -- Next, split out the ps_in permissions from the rest of the pctx pctx <- itiPermStack <$> ask let (pctx_ps, pctx_in :>: ptrans_l) = RL.split ps0 prxs_in pctx - + -- Also split out the ps_in variables and replace them with the ps_out vars pctx_vars <- itiPermStackVars <$> ask let (ps_vars, _ :>: _) = RL.split ps0 prxs_in pctx_vars @@ -2670,7 +2670,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of let vars_out = RL.append ps_vars $ RL.map (translateVar . getCompose) $ mbRAssign $ fmap (fromJustHelper . lownedPermsVars) ps_out - + -- Now we apply the lifetime ownerhip function to ps_in and bind its output -- in the rest of the computation applyMultiTransM (return $ globalOpenTerm "Prelude.bindM") @@ -2682,36 +2682,36 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of (\_ -> vars_out) (\_ -> RL.append pctx_ps pctx_out) m] - + [nuMP| SImpl_LCurrentRefl l |] -> withPermStackM (:>: translateVar l) (:>: PTrans_Conj [APTrans_LCurrent $ fmap PExpr_Var l]) m - + [nuMP| SImpl_LCurrentTrans _l1 _l2 l3 |] -> withPermStackM RL.tail ((:>: PTrans_Conj [APTrans_LCurrent l3]) . RL.tail . RL.tail) m - + [nuMP| SImpl_DemoteLLVMBlockRW _ _ |] -> do ttrans <- translate $ fmap (distPermsHeadPerm . simplImplOut) mb_simpl withPermStackM id (\(pctx :>: ptrans) -> pctx :>: typeTransF ttrans (transTerms ptrans)) m - + [nuMP| SImpl_IntroLLVMBlockEmpty x _ |] -> do ttrans <- translate $ fmap (distPermsHeadPerm . simplImplOut) mb_simpl withPermStackM (:>: translateVar x) (\pctx -> pctx :>: typeTransF ttrans [unitOpenTerm]) m - + [nuMP| SImpl_CoerceLLVMBlockEmpty _ _ |] -> do ttrans <- translate $ fmap (distPermsHeadPerm . simplImplOut) mb_simpl withPermStackM id (\(pctx :>: _) -> pctx :>: typeTransF ttrans [unitOpenTerm]) m - + [nuMP| SImpl_ElimLLVMBlockToBytes _ mb_bp |] -> do let w = natVal2 mb_bp let w_term = natOpenTerm w @@ -2724,7 +2724,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of [w_term, len_term, unitTypeOpenTerm, unitOpenTerm] in pctx :>: typeTransF ttrans [arr_term]) m - + [nuMP| SImpl_IntroLLVMBlockSeqEmpty _ _ |] -> do ttrans <- translate $ fmap (distPermsHeadPerm . simplImplOut) mb_simpl withPermStackM id @@ -2732,14 +2732,14 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of pctx :>: typeTransF ttrans [pairOpenTerm (transTerm1 ptrans) unitOpenTerm]) m - + [nuMP| SImpl_ElimLLVMBlockSeqEmpty _ _ |] -> do ttrans <- translate $ fmap (distPermsHeadPerm . simplImplOut) mb_simpl withPermStackM id (\(pctx :>: ptrans) -> pctx :>: typeTransF ttrans [pairLeftOpenTerm (transTerm1 ptrans)]) m - + -- Intro for a recursive named shape applies the fold function [nuMP| SImpl_IntroLLVMBlockNamed _ bp nmsh |] | [nuMP| RecShapeBody _ _ fold_id _ |] <- mbMatch $ fmap namedShapeBody nmsh @@ -2751,7 +2751,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of withPermStackM id (\(pctx :>: _) -> pctx :>: typeTransF ttrans [t]) m - + -- Intro for a defined named shape (the other case) is a no-op | [nuMP| DefinedShapeBody _ |] <- mbMatch $ fmap namedShapeBody nmsh -> do ttrans <- translate $ fmap (distPermsHeadPerm . simplImplOut) mb_simpl @@ -2761,7 +2761,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of m | otherwise -> fail "translateSimplImpl: SImpl_IntroLLVMBlockNamed, unknown named shape" - + [nuMP| SImpl_ElimLLVMBlockNamed _ bp nmsh |] -- Elim for a recursive named shape applies the fold function | [nuMP| RecShapeBody _ _ _ unfold_id |] <- mbMatch $ fmap namedShapeBody nmsh @@ -2773,7 +2773,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of withPermStackM id (\(pctx :>: _) -> pctx :>: typeTransF ttrans [t]) m - + -- Intro for a defined named shape (the other case) is a no-op | [nuMP| DefinedShapeBody _ |] <- mbMatch $ fmap namedShapeBody nmsh -> do ttrans <- translate $ fmap (distPermsHeadPerm . simplImplOut) mb_simpl @@ -2783,35 +2783,35 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of m | otherwise -> fail "translateSimplImpl: ElimLLVMBlockNamed, unknown named shape" - + [nuMP| SImpl_IntroLLVMBlockFromEq _ _ _ |] -> do ttrans <- translate $ fmap (distPermsHeadPerm . simplImplOut) mb_simpl withPermStackM RL.tail (\(pctx :>: _ :>: ptrans) -> pctx :>: typeTransF ttrans [transTerm1 ptrans]) m - + [nuMP| SImpl_IntroLLVMBlockPtr _ _ _ _ |] -> do ttrans <- translate $ fmap (distPermsHeadPerm . simplImplOut) mb_simpl withPermStackM id (\(pctx :>: ptrans) -> pctx :>: typeTransF ttrans (transTerms ptrans)) m - + [nuMP| SImpl_ElimLLVMBlockPtr _ _ _ _ |] -> do ttrans <- translate $ fmap (distPermsHeadPerm . simplImplOut) mb_simpl withPermStackM id (\(pctx :>: ptrans) -> pctx :>: typeTransF ttrans (transTerms ptrans)) m - + [nuMP| SImpl_IntroLLVMBlockField _ _ |] -> do ttrans <- translate $ fmap (distPermsHeadPerm . simplImplOut) mb_simpl withPermStackM id (\(pctx :>: ptrans) -> pctx :>: typeTransF ttrans [transTupleTerm ptrans]) m - + [nuMP| SImpl_ElimLLVMBlockField _ _ _ |] -> do let mb_ps = fmap ((\case ValPerm_Conj ps -> ps _ -> error "translateSimplImpl: SImpl_ElimLLVMBlockField, VPerm_Conj required" @@ -2824,21 +2824,21 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of PTrans_Conj [typeTransF (tupleTypeTrans ttrans1) [transTerm1 ptrans], typeTransF ttrans2 [unitOpenTerm]]) m - + [nuMP| SImpl_IntroLLVMBlockArray _ _ |] -> do ttrans <- translate $ fmap (distPermsHeadPerm . simplImplOut) mb_simpl withPermStackM id (\(pctx :>: ptrans) -> pctx :>: typeTransF ttrans [transTerm1 ptrans]) m - + [nuMP| SImpl_ElimLLVMBlockArray _ _ |] -> do ttrans <- translate $ fmap (distPermsHeadPerm . simplImplOut) mb_simpl withPermStackM id (\(pctx :>: ptrans) -> pctx :>: typeTransF ttrans [transTerm1 ptrans]) m - + [nuMP| SImpl_IntroLLVMBlockSeq _ _ _ _ |] -> do ttrans <- translate $ fmap (distPermsHeadPerm . simplImplOut) mb_simpl withPermStackM RL.tail @@ -2847,7 +2847,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of pairOpenTerm (transTerm1 ptrans1) (transTerm1 ptrans2) in pctx :>: typeTransF ttrans [pair_term]) m - + [nuMP| SImpl_ElimLLVMBlockSeq _ _ _ |] -> do ttrans <- translate $ fmap (distPermsHeadPerm . simplImplOut) mb_simpl withPermStackM id @@ -2855,31 +2855,31 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of pctx :>: typeTransF ttrans [pairLeftOpenTerm (transTerm1 ptrans), pairRightOpenTerm (transTerm1 ptrans)]) m - + [nuMP| SImpl_IntroLLVMBlockOr _ _ _ |] -> do ttrans <- translate $ fmap (distPermsHeadPerm . simplImplOut) mb_simpl withPermStackM id (\(pctx :>: ptrans) -> pctx :>: typeTransF ttrans [transTerm1 ptrans]) m - + [nuMP| SImpl_ElimLLVMBlockOr _ _ _ |] -> do ttrans <- translate $ fmap (distPermsHeadPerm . simplImplOut) mb_simpl withPermStackM id (\(pctx :>: ptrans) -> pctx :>: typeTransF ttrans [transTerm1 ptrans]) m - + [nuMP| SImpl_IntroLLVMBlockEx _ _ |] -> do ttrans <- translate $ fmap (distPermsHeadPerm . simplImplOut) mb_simpl withPermStackM id (\(pctx :>: ptrans) -> pctx :>: typeTransF ttrans [transTerm1 ptrans]) m - + [nuMP| SImpl_ElimLLVMBlockEx _ _ |] -> do ttrans <- translate $ fmap (distPermsHeadPerm . simplImplOut) mb_simpl withPermStackM id (\(pctx :>: ptrans) -> pctx :>: typeTransF ttrans [transTerm1 ptrans]) m - + [nuMP| SImpl_FoldNamed _ (NamedPerm_Rec rp) args _ |] -> do args_trans <- translate args ttrans <- translate $ fmap (distPermsHeadPerm . simplImplOut) mb_simpl @@ -2891,7 +2891,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of (transTerms args_trans ++ transTerms ptrans_x)]) m - + [nuMP| SImpl_UnfoldNamed _ (NamedPerm_Rec rp) args _ |] -> do args_trans <- translate args ttrans <- translate $ fmap (distPermsHeadPerm . simplImplOut) mb_simpl @@ -2904,7 +2904,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of (transTerms args_trans ++ [transTerm1 ptrans_x])]) m - + [nuMP| SImpl_FoldNamed _ (NamedPerm_Defined dp) args off |] -> do folded_trans <- translate (mbMap2 ValPerm_Named (fmap definedPermName dp) args @@ -2913,7 +2913,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of (\(pctx :>: ptrans) -> pctx :>: typeTransF folded_trans (transTerms ptrans)) m - + [nuMP| SImpl_UnfoldNamed _ (NamedPerm_Defined dp) args off |] -> do unfolded_trans <- translate (mbMap2 unfoldDefinedPerm dp args `mbApply` off) @@ -2921,48 +2921,48 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of (\(pctx :>: ptrans) -> pctx :>: typeTransF unfolded_trans (transTerms ptrans)) m - + {- [nuMP| SImpl_Mu _ _ _ _ |] -> error "FIXME HERE: SImpl_Mu: translation not yet implemented" -} - + [nuMP| SImpl_NamedToConj _ _ _ _ |] -> do tp_trans <- translate $ fmap (distPermsHeadPerm . simplImplOut) mb_simpl withPermStackM id (\(pctx :>: ptrans) -> pctx :>: typeTransF tp_trans (transTerms ptrans)) m - + [nuMP| SImpl_NamedFromConj _ _ _ _ |] -> do tp_trans <- translate $ fmap (distPermsHeadPerm . simplImplOut) mb_simpl withPermStackM id (\(pctx :>: ptrans) -> pctx :>: typeTransF tp_trans (transTerms ptrans)) m - + [nuMP| SImpl_NamedArgAlways _ _ _ _ _ _ |] -> do tp_trans <- translate $ fmap (distPermsHeadPerm . simplImplOut) mb_simpl withPermStackM id (\(pctx :>: ptrans) -> pctx :>: typeTransF tp_trans (transTerms ptrans)) m - + [nuMP| SImpl_NamedArgCurrent _ _ _ _ _ _ |] -> do tp_trans <- translate $ fmap (distPermsHeadPerm . simplImplOut) mb_simpl withPermStackM RL.tail (\(pctx :>: ptrans :>: _) -> pctx :>: typeTransF tp_trans (transTerms ptrans)) m - + [nuMP| SImpl_NamedArgWrite _ _ _ _ _ _ |] -> do tp_trans <- translate $ fmap (distPermsHeadPerm . simplImplOut) mb_simpl withPermStackM id (\(pctx :>: ptrans) -> pctx :>: typeTransF tp_trans (transTerms ptrans)) m - + [nuMP| SImpl_NamedArgRead _ _ _ _ _ |] -> do tp_trans <- translate $ fmap (distPermsHeadPerm . simplImplOut) mb_simpl withPermStackM id (\(pctx :>: ptrans) -> pctx :>: typeTransF tp_trans (transTerms ptrans)) m - + [nuMP| SImpl_ReachabilityTrans _ rp args _ y e |] -> do args_trans <- translate $ mbMap2 PExprs_Cons args e y_trans <- translate y @@ -3061,7 +3061,7 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl -- Impl1_Catch, if one exists, or the SAW errorM function otherwise ([nuMP| Impl1_Fail str |], _) -> tell [mbLift str] >> mzero - + ([nuMP| Impl1_Catch |], [nuMP| (MbPermImpls_Cons _ (MbPermImpls_Cons _ _ mb_impl1) mb_impl2) |]) -> pitmCatching (translatePermImpl prx $ mbCombine RL.typeCtxProxies mb_impl1) >>= \maybe_trans1 -> @@ -3074,7 +3074,7 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl (\catchpoint -> trans1 $ ImplFailContTerm catchpoint) (Nothing, Just trans2) -> return trans2 (_, Nothing) -> pitmMaybeRet maybe_trans1 - + -- A push moves the given permission from x to the top of the perm stack ([nuMP| Impl1_Push x p |], _) -> translatePermImplUnary mb_impls $ \m -> @@ -3082,7 +3082,7 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl ptrans <- getVarPermM x setVarPermM x (PTrans_True) (withPermStackM (:>: translateVar x) (:>: ptrans) m) - + -- A pop moves the given permission from the top of the perm stack to x ([nuMP| Impl1_Pop x p |], _) -> translatePermImplUnary mb_impls $ \m -> @@ -3091,7 +3091,7 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl const ValPerm_True) ptrans <- getTopPermM setVarPermM x ptrans (withPermStackM RL.tail RL.tail m) - + -- If both branches of an or elimination fail, the whole thing fails; otherwise, -- an or elimination performs a pattern-match on an Either ([nuMP| Impl1_ElimOr x p1 p2 |], @@ -3115,7 +3115,7 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl withPermStackM id ((:>: ptrans) . RL.tail) $ forceImplTrans maybe_trans2 k) (transTupleTerm top_ptrans) - + -- An existential elimination performs a pattern-match on a Sigma ([nuMP| Impl1_ElimExists x p |], _) -> translatePermImplUnary mb_impls $ \m -> @@ -3130,7 +3130,7 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl inExtTransM etrans $ withPermStackM id ((:>: ptrans) . RL.tail) m) (transTerm1 top_ptrans) - + -- A SimplImpl is translated using translateSimplImpl ([nuMP| Impl1_Simpl simpl mb_prx |], _) -> let prx' = mbLift mb_prx in @@ -3139,14 +3139,14 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl translateSimplImpl prx' simpl $ do () <- assertPermStackTopEqM "SimplImpl out" prx' (fmap simplImplOut simpl) m - + -- A let binding becomes a let binding ([nuMP| Impl1_LetBind _ e |], _) -> translatePermImplUnary mb_impls $ \m -> do etrans <- translate e inExtTransM etrans $ withPermStackM (:>: Member_Base) (:>: PTrans_Eq (extMb e)) m - + ([nuMP| Impl1_ElimStructField x _ _ memb |], _) -> translatePermImplUnary mb_impls $ \m -> do etrans_x <- translate x @@ -3161,7 +3161,7 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl RL.set (mbLift memb) (PTrans_Eq mb_y) pctx_str] :>: RL.get (mbLift memb) pctx_str) m - + ([nuMP| Impl1_ElimLLVMFieldContents _ mb_fld |], _) -> translatePermImplUnary mb_impls $ \m -> inExtTransM ETrans_LLVM $ @@ -3180,7 +3180,7 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl fmap (const $ nu PExpr_Var) mb_fld)] :>: ptrans') m - + ([nuMP| Impl1_ElimLLVMBlockToEq _ mb_bp |], _) -> translatePermImplUnary mb_impls $ \m -> inExtTransM ETrans_LLVMBlock $ @@ -3198,7 +3198,7 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl pctx :>: typeTransF tp_trans1 [unitOpenTerm] :>: typeTransF tp_trans2 [transTerm1 ptrans]) m - + ([nuMP| Impl1_BeginLifetime |], _) -> translatePermImplUnary mb_impls $ \m -> inExtTransM ETrans_Lifetime $ @@ -3208,7 +3208,7 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl applyOpenTermMulti (globalOpenTerm "Prelude.returnM") [unitTypeOpenTerm, x] withPermStackM (:>: Member_Base) (:>: typeTransF tp_trans [id_fun]) m - + -- If e1 and e2 are already equal, short-circuit the proof construction and then -- elimination ([nuMP| Impl1_TryProveBVProp x prop@(BVProp_Eq e1 e2) _ |], _) @@ -3220,12 +3220,12 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl withPermStackM (:>: translateVar x) (:>: PTrans_Conj [APTrans_BVProp (BVPropTrans prop pf)]) m - + -- If e1 and e2 are definitely not equal, treat this as a fail ([nuMP| Impl1_TryProveBVProp _ (BVProp_Eq e1 e2) prop_str |], _) | not $ mbLift (mbMap2 bvCouldEqual e1 e2) -> tell [mbLift prop_str] >> mzero - + -- Otherwise, insert an equality test with proof construction. Note that, as -- with all TryProveBVProps, if the test fails and there is no failure -- continuation, we insert just the proposition failure string using @@ -3245,7 +3245,7 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl trans k) , applyMultiTransM (return $ globalOpenTerm "Prelude.bvEqWithProof") [ return (natOpenTerm $ natVal2 prop) , translate1 e1, translate1 e2]] - + -- For an inequality test, we don't need a proof, so just insert an if ([nuMP| Impl1_TryProveBVProp x prop@(BVProp_Neq e1 e2) prop_str |], [nuMP| MbPermImpls_Cons _ _ mb_impl' |]) -> @@ -3260,7 +3260,7 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl , withPermStackM (:>: translateVar x) (:>: PTrans_Conj [APTrans_BVProp (BVPropTrans prop unitOpenTerm)]) $ trans k] - + {- ([nuMP| Impl1_TryProveBVProp x prop@(BVProp_ULt e1 e2) _ |], [nuMP| MbPermImpls_Cons _ mb_impl' |]) @@ -3271,7 +3271,7 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl globalOpenTerm "Prelude.True"]))) (translate $ mbCombine mb_impl') -} - + ([nuMP| Impl1_TryProveBVProp x prop@(BVProp_ULt e1 e2) prop_str |], [nuMP| MbPermImpls_Cons _ _ mb_impl' |]) -> translatePermImpl prx (mbCombine RL.typeCtxProxies mb_impl') >>= \trans -> @@ -3287,7 +3287,7 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl , applyMultiTransM (return $ globalOpenTerm "Prelude.bvultWithProof") [ return (natOpenTerm $ natVal2 prop), translate1 e1, translate1 e2] ] - + {- ([nuMP| Impl1_TryProveBVProp x prop@(BVProp_ULeq e1 e2) _ |], [nuMP| MbPermImpls_Cons _ mb_impl' |]) @@ -3298,7 +3298,7 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl globalOpenTerm "Prelude.True"]))) (translate $ mbCombine mb_impl') -} - + ([nuMP| Impl1_TryProveBVProp x prop@(BVProp_ULeq e1 e2) prop_str |], [nuMP| MbPermImpls_Cons _ _ mb_impl' |]) -> translatePermImpl prx (mbCombine RL.typeCtxProxies mb_impl') >>= \trans -> @@ -3314,8 +3314,8 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl , applyMultiTransM (return $ globalOpenTerm "Prelude.bvuleWithProof") [ return (natOpenTerm $ natVal2 prop), translate1 e1, translate1 e2] ] - - + + ([nuMP| Impl1_TryProveBVProp x prop@(BVProp_ULeq_Diff e1 e2 e3) prop_str |], [nuMP| MbPermImpls_Cons _ _ mb_impl' |]) -> translatePermImpl prx (mbCombine RL.typeCtxProxies mb_impl') >>= \trans -> @@ -3441,9 +3441,9 @@ instance (PermCheckExtC ext, TransInfo info) => ETrans_Term <$> applyMultiTransM (return $ globalOpenTerm "Prelude.bvEq") [translate w, translateRWV e1, translateRWV e2] - + [nuMP| EmptyApp |] -> return ETrans_Unit - + -- Booleans [nuMP| BoolLit True |] -> return $ ETrans_Term $ globalOpenTerm "Prelude.True" @@ -3465,7 +3465,7 @@ instance (PermCheckExtC ext, TransInfo info) => ETrans_Term <$> applyMultiTransM (return $ globalOpenTerm "Prelude.xor") [translateRWV e1, translateRWV e2] - + -- Natural numbers [nuMP| Expr.NatLit n |] -> return $ ETrans_Term $ natOpenTerm $ mbLift n @@ -3498,11 +3498,11 @@ instance (PermCheckExtC ext, TransInfo info) => ETrans_Term <$> applyMultiTransM (return $ globalOpenTerm "Prelude.modNat") [translateRWV e1, translateRWV e2] - + -- Function handles: the expression part of a function handle has no -- computational content [nuMP| HandleLit _ |] -> return ETrans_Fun - + -- Bitvectors [nuMP| BVLit w mb_bv |] -> return $ ETrans_Term $ bvLitOpenTerm (mbLift w) $ mbLift mb_bv @@ -3639,12 +3639,12 @@ instance (PermCheckExtC ext, TransInfo info) => (applyMultiTransM (return $ globalOpenTerm "Prelude.bvEq") [translate mb_w, translateRWV e, return (bvLitOpenTerm w (BV.zero w))]) - + -- Strings [nuMP| Expr.StringLit (UnicodeLiteral text) |] -> return $ ETrans_Term $ stringLitOpenTerm $ mbLift text - + -- Everything else is an error _ -> error ("Unhandled expression form: " ++ @@ -3779,12 +3779,12 @@ translateStmt loc mb_stmt m = case mbMatch mb_stmt of let ptrans = exprOutPerm e inExtTransM etrans $ withPermStackM (:>: Member_Base) (:>: extPermTrans ptrans) m - + [nuMP| TypedSetRegPermExpr _ e |] -> do etrans <- tpTransM $ translate e inExtTransM etrans $ withPermStackM (:>: Member_Base) (:>: PTrans_Eq (extMb e)) m - + [nuMP| stmt@(TypedCall _freg fun_perm _ gexprs args) |] -> do f_trans <- getTopPermM let f = case f_trans of @@ -3819,14 +3819,14 @@ translateStmt loc mb_stmt m = case mbMatch mb_stmt of (const pctx) m) ret_val] - + -- FIXME HERE: figure out why these asserts always translate to ite True [nuMP| TypedAssert e _ |] -> applyMultiTransM (return $ globalOpenTerm "Prelude.ite") [compReturnTypeM, translate1 e, m, mkErrorCompM ("Failed Assert at " ++ renderDoc (ppShortFileName (plSourceLoc loc)))] - + [nuMP| TypedLLVMStmt stmt |] -> translateLLVMStmt stmt m @@ -3840,31 +3840,31 @@ translateLLVMStmt mb_stmt m = case mbMatch mb_stmt of inExtTransM ETrans_LLVM $ withPermStackM (:>: Member_Base) (:>: (PTrans_Eq $ extMb $ fmap (PExpr_LLVMWord . PExpr_Var) x)) m - + [nuMP| AssertLLVMWord reg _ |] -> inExtTransM (ETrans_Term $ natOpenTerm 0) $ withPermStackM ((:>: Member_Base) . RL.tail) ((:>: (PTrans_Eq $ fmap (const $ PExpr_Nat 0) $ extMb reg)) . RL.tail) m - + [nuMP| AssertLLVMPtr _ |] -> inExtTransM ETrans_Unit $ withPermStackM RL.tail RL.tail m - + [nuMP| DestructLLVMWord _ e |] -> translate e >>= \etrans -> inExtTransM etrans $ withPermStackM ((:>: Member_Base) . RL.tail) ((:>: (PTrans_Eq $ extMb e)) . RL.tail) m - + [nuMP| OffsetLLVMValue x off |] -> inExtTransM ETrans_LLVM $ withPermStackM (:>: Member_Base) (:>: (PTrans_Eq $ extMb $ mbMap2 PExpr_LLVMOffset (fmap typedRegVar x) off)) m - + [nuMP| TypedLLVMLoad _ (mb_fp :: LLVMFieldPerm w sz) (_ :: DistPerms ps) cur_perms |] -> let prx_l = mbLifetimeCurrentPermsProxies cur_perms @@ -3888,7 +3888,7 @@ translateLLVMStmt mb_stmt m = case mbMatch mb_stmt of fmap (const $ nu $ \ret -> PExpr_Var ret) mb_fp)] :>: p_ret) pctx_l) m - + [nuMP| TypedLLVMStore _ (mb_fp :: LLVMFieldPerm w sz) mb_e (_ :: DistPerms ps) cur_perms |] -> let prx_l = mbLifetimeCurrentPermsProxies cur_perms @@ -3906,7 +3906,7 @@ translateLLVMStmt mb_stmt m = case mbMatch mb_stmt of (PTrans_Eq $ extMb mb_e)]) pctx_l) m - + [nuMP| TypedLLVMAlloca _ (mb_fperm :: LLVMFramePerm w) mb_sz |] -> let sz = mbLift mb_sz w :: Proxy w = Proxy in @@ -3921,18 +3921,18 @@ translateLLVMStmt mb_stmt m = case mbMatch mb_stmt of \(_ :>: ret) fperm -> (PExpr_Var ret, sz):fperm] :>: typeTransF ptrans_tp []) m - + [nuMP| TypedLLVMCreateFrame |] -> withKnownNat ?ptrWidth $ inExtTransM ETrans_LLVMFrame $ withPermStackM (:>: Member_Base) (:>: PTrans_Conj [APTrans_LLVMFrame $ fmap (const []) (extMb mb_stmt)]) m - + [nuMP| TypedLLVMDeleteFrame _ _ _ |] -> inExtTransM ETrans_Unit $ withPermStackM (const MNil) (const MNil) m - + [nuMP| TypedLLVMLoadHandle _ tp _ |] -> inExtTransM ETrans_Fun $ withPermStackM ((:>: Member_Base) . RL.tail) @@ -3942,7 +3942,7 @@ translateLLVMStmt mb_stmt m = case mbMatch mb_stmt of _ -> error ("translateLLVMStmt: TypedLLVMLoadHandle: " ++ "unexpected function permission type")) m - + [nuMP| TypedLLVMResolveGlobal gsym (p :: ValuePerm (LLVMPointerType w))|] -> withKnownNat ?ptrWidth $ inExtTransM ETrans_LLVM $ @@ -3955,7 +3955,7 @@ translateLLVMStmt mb_stmt m = case mbMatch mb_stmt of ++ globalSymbolName (mbLift gsym)) Just (_, ts) -> withPermStackM (:>: Member_Base) (:>: typeTransF ptrans ts) m - + [nuMP| TypedLLVMIte _ mb_r1 _ _ |] -> inExtTransM ETrans_LLVM $ do b <- translate1 $ extMb mb_r1 @@ -4284,14 +4284,30 @@ someCFGAndPermPtrPerm (SomeCFGAndPerm _ _ _ fun_perm) = tcTranslateCFGTupleFun :: HasPtrWidth w => PermEnv -> EndianForm -> [SomeCFGAndPerm LLVM] -> - (OpenTerm, OpenTerm) + (OpenTerm, [SomeTypedCFG LLVM], OpenTerm) tcTranslateCFGTupleFun env endianness cfgs_and_perms = - let lrts = map (someCFGAndPermLRT env) cfgs_and_perms in - let lrts_tm = + let lrts = map (someCFGAndPermLRT env) cfgs_and_perms + + lrts_tm = foldr (\lrt lrts' -> ctorOpenTerm "Prelude.LRT_Cons" [lrt,lrts']) (ctorOpenTerm "Prelude.LRT_Nil" []) - lrts in - (lrts_tm ,) $ + lrts + + fakeEnv = withKnownNat ?ptrWidth $ + permEnvAddGlobalSyms env $ + map (\cfg_and_perm -> + PermEnvGlobalEntry + (someCFGAndPermSym cfg_and_perm) + (someCFGAndPermPtrPerm cfg_and_perm) + [error "TODO: put something here"]) + cfgs_and_perms + + tcfgs = map (\cfg_and_perms -> + case cfg_and_perms of + SomeCFGAndPerm _ _ cfg fun_perm -> + SomeTypedCFG $ tcCFG ?ptrWidth fakeEnv endianness fun_perm cfg) cfgs_and_perms + in + (lrts_tm , tcfgs, ) $ lambdaOpenTermMulti (zip (map (pack . someCFGAndPermToName) cfgs_and_perms) (map (applyOpenTerm @@ -4341,9 +4357,9 @@ tcTranslateAddCFGs :: HasPtrWidth w => SharedContext -> ModuleName -> PermEnv -> EndianForm -> [SomeCFGAndPerm LLVM] -> - IO PermEnv + IO (PermEnv, [SomeTypedCFG LLVM]) tcTranslateAddCFGs sc mod_name env endianness cfgs_and_perms = - do let (lrts, tup_fun) = + do let (lrts, tcfgs, tup_fun) = tcTranslateCFGTupleFun env endianness cfgs_and_perms let tup_fun_ident = mkSafeIdent mod_name (someCFGAndPermToName (head cfgs_and_perms) @@ -4352,7 +4368,7 @@ tcTranslateAddCFGs sc mod_name env endianness cfgs_and_perms = applyOpenTerm (globalOpenTerm "Prelude.lrtTupleType") lrts tup_fun_tm <- completeOpenTerm sc $ applyOpenTermMulti (globalOpenTerm "Prelude.multiFixM") [lrts, tup_fun] - scInsertDef sc mod_name tup_fun_ident tup_fun_tp tup_fun_tm + scInsertDef sc mod_name tup_fun_ident tup_fun_tp tup_fun_tm new_entries <- zipWithM (\cfg_and_perm i -> @@ -4368,7 +4384,7 @@ tcTranslateAddCFGs sc mod_name env endianness cfgs_and_perms = (someCFGAndPermPtrPerm cfg_and_perm) [globalOpenTerm ident]) cfgs_and_perms [0 ..] - 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 c15dd7e25a..2c0e69d93a 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs @@ -458,7 +458,7 @@ data TypedLLVMStmt ret ps_in ps_out where -- Type: -- > ps, x:ptr((rw,0) |-> p), cur_ps -- > -o ps, x:ptr((rw,0) |-> eq(ret)), ret:p, cur_ps - TypedLLVMLoad :: + TypedLLVMLoad :: (HasPtrWidth w, 1 <= sz, KnownNat sz) => !(TypedReg (LLVMPointerType w)) -> !(LLVMFieldPerm w sz) -> @@ -530,7 +530,7 @@ data TypedLLVMStmt ret ps_in ps_out where -- referred to by a function pointer, assuming we know it has one: -- -- Type: @x:llvm_funptr(p) -o ret:p@ - TypedLLVMLoadHandle :: + TypedLLVMLoadHandle :: HasPtrWidth w => !(TypedReg (LLVMPointerType w)) -> !(TypeRepr (FunctionHandleType cargs ret)) -> @@ -1315,7 +1315,7 @@ entryByID entryID = (\blk -> (blk ^. typedBlockEntries) !! entryIndex entryID) (\blk e -> over typedBlockEntries (replaceNth (entryIndex entryID) e) blk) --- | Build an empty 'TypedBlock' +-- | Build an empty 'TypedBlock' emptyBlockOfSort :: Assignment CtxRepr cblocks -> TypedBlockSort -> Block ext cblocks ret cargs -> TypedBlock TCPhase ext (CtxCtxToRList @@ -1537,6 +1537,10 @@ data TypedCFG , tpcfgEntryID :: !(TypedEntryID blocks inits) } +data SomeTypedCFG ext where + SomeTypedCFG :: PermCheckExtC ext => + TypedCFG ext blocks ghosts inits ret -> SomeTypedCFG ext + -- | Get the input permissions for a 'CFG' tpcfgInputPerms :: TypedCFG ext blocks ghosts inits ret -> MbValuePerms (ghosts :++: inits) @@ -1831,7 +1835,7 @@ runPermCheckM entryID args ghosts mb_perms_in m = let (tops_args, ghosts_ns) = RL.split Proxy ghosts_prxs ns (tops_ns, args_ns) = RL.split Proxy args_prxs tops_args st = emptyPermCheckState (distPermSet perms_in) tops_ns entryID in - + let go x = runGenStateContT x st (\_ () -> pure ()) in go $ setVarTypes "top" tops_ns stTopCtx >>> @@ -2447,7 +2451,7 @@ ppCruRegAndPerms ctx r = -- their permissions, the variables in those permissions etc., as in -- 'varPermsTransFreeVars' getRelevantPerms :: [SomeName CrucibleType] -> - PermCheckM ext cblocks blocks tops ret r ps r ps + PermCheckM ext cblocks blocks tops ret r ps r ps (Some DistPerms) getRelevantPerms (namesListToNames -> SomeRAssign ns) = gets stCurPerms >>>= \perms -> @@ -2758,7 +2762,7 @@ tcEmitStmt' ctx loc (CallHandle ret freg_untyped _args_ctx args_untyped) = _ -> pure Nothing _ -> pure []) >>>= \maybe_fun_perms -> (stmtEmbedImplM $ foldr1WithDefault implCatchM - (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 -> @@ -3863,4 +3867,4 @@ tcCFG w env endianness fun_perm cfg = use (stBlockMap . member tpBlkID) >>= (visitBlock >=> assign (stBlockMap . member tpBlkID))) >> - main_loop nodes + main_loop nodes \ No newline at end of file diff --git a/src/SAWScript/HeapsterBuiltins.hs b/src/SAWScript/HeapsterBuiltins.hs index 23f9bbfed9..7f791cb2c8 100644 --- a/src/SAWScript/HeapsterBuiltins.hs +++ b/src/SAWScript/HeapsterBuiltins.hs @@ -43,6 +43,7 @@ module SAWScript.HeapsterBuiltins , heapster_print_fun_trans , heapster_export_coq , heapster_parse_test + , heapster_dump_ide_info ) where import Data.Maybe @@ -106,6 +107,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 SAWScript.Prover.Exporter import Verifier.SAW.Translation.Coq @@ -338,7 +340,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 @@ -548,7 +550,7 @@ heapster_define_reachability_perm _bic _opts henv _ -> Fail.fail "Incorrect type for last argument of reachability perm" let args_ctx = appendParsedCtx pre_args_ctx last_args_ctx let args = parsedCtxCtx args_ctx - trans_tp <- liftIO $ + trans_tp <- liftIO $ translateCompleteTypeInCtx sc env args (nus (cruCtxProxies args) $ const $ ValuePermRepr tp) trans_tp_ident <- parseAndInsDef henv nm trans_tp trans_tp_str @@ -876,7 +878,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 -> @@ -911,10 +913,11 @@ heapster_typecheck_mut_funs_rename _bic _opts henv fn_names_and_perms = fromString nm) nm_to cfg fun_perm) sc <- getSharedContext let saw_modname = heapsterEnvSAWModule henv - env' <- liftIO $ + (env', tcfgs) <- liftIO $ let ?ptrWidth = w in tcTranslateAddCFGs sc saw_modname env endianness some_cfgs_and_perms liftIO $ writeIORef (heapsterEnvPermEnvRef henv) env' + liftIO $ modifyIORef (heapsterEnvTCFGs henv) (\old -> map Some tcfgs ++ old) heapster_typecheck_fun :: BuiltinContext -> Options -> HeapsterEnv -> @@ -932,7 +935,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 () @@ -977,3 +980,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 \ No newline at end of file diff --git a/src/SAWScript/Interpreter.hs b/src/SAWScript/Interpreter.hs index 29537ab238..5b086d30b5 100644 --- a/src/SAWScript/Interpreter.hs +++ b/src/SAWScript/Interpreter.hs @@ -3205,6 +3205,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 c11b50c8ae..8ca7e9b6e6 100644 --- a/src/SAWScript/Value.hs +++ b/src/SAWScript/Value.hs @@ -110,6 +110,7 @@ import Lang.Crucible.LLVM.ArraySizeProfile import What4.ProgramLoc (ProgramLoc(..)) import Verifier.SAW.Heapster.Permissions +import Verifier.SAW.Heapster.TypedCrucible (SomeTypedCFG(..)) -- Values ---------------------------------------------------------------------- @@ -182,8 +183,10 @@ data HeapsterEnv = HeapsterEnv { -- ^ The SAW module containing all our Heapster definitions heapsterEnvPermEnvRef :: IORef PermEnv, -- ^ The current permissions environment - heapsterEnvLLVMModules :: [Some CMSLLVM.LLVMModule] + 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 } showHeapsterEnv :: HeapsterEnv -> String From bfd05669e581095ed6919c1c1a68140af6132349 Mon Sep 17 00:00:00 2001 From: Karl Smeltzer Date: Mon, 28 Jun 2021 15:44:44 -0700 Subject: [PATCH 02/28] clean up additional implication errors --- .../src/Verifier/SAW/Heapster/Implication.hs | 125 +++++++++--------- 1 file changed, 62 insertions(+), 63 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs b/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs index 833c59c693..47b01d7378 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs @@ -2714,10 +2714,7 @@ partialSubstForceM mb_e caller = case partialSubst psubst mb_e of Just e -> pure e Nothing -> - implFailM' $ PartialSubstitutionError - (\i -> sep [pretty ("Incomplete susbtitution in " ++ caller ++ - " for: "), - permPretty i mb_e]) + implFailM' $ PartialSubstitutionError caller mb_e -- | Modify the current partial substitution modifyPSubst :: (PartialSubst vars -> PartialSubst vars) -> @@ -3666,7 +3663,7 @@ implEndLifetimeM :: NuMatchingAny1 r => Proxy ps -> ExprVar LifetimeType -> implEndLifetimeM ps l ps_in ps_out@(lownedPermsToDistPerms -> Just dps_out) = implSimplM ps (SImpl_EndLifetime l ps_in ps_out) >>> recombinePermsPartial ps dps_out -implEndLifetimeM _ _ _ _ = implFailM "implEndLifetimeM: lownedPermsToDistPerms" +implEndLifetimeM _ _ _ _ = implFailM' $ LifetimeError EndLifetimeError -- | Save a permission for later by splitting it into part that is in the @@ -3962,9 +3959,7 @@ implElimLLVMBlock x bp@(LLVMBlockPerm { llvmBlockShape = PExpr_ExShape _mb_sh }) = implSimplM Proxy (SImpl_ElimLLVMBlockEx x bp) implElimLLVMBlock _ bp = - implTraceM (\i -> pretty "Could not eliminate permission" <+> - permPretty i (Perm_LLVMBlock bp)) >>>= - implFailM + implFailM' $ MemBlockError bp -- | Eliminate a @memblock@ permission on the top of the stack and recombine it, -- if this is possible; otherwise fail @@ -3993,9 +3988,7 @@ 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 + implFailM' $ LifetimeError (LifetimeCurrentError l) -- | Prove the permissions represented by a 'LifetimeCurrentPerms' proveLifetimeCurrent :: NuMatchingAny1 r => LifetimeCurrentPerms ps_l -> @@ -4205,16 +4198,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 @@ -4251,7 +4234,7 @@ 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 = implFailM' $ EqualityProofError perms mb instance ProveEq (LLVMBlockPerm w) where proveEq bp mb_bp = @@ -4325,7 +4308,7 @@ 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 -> implFailM' $ EqualityProofError e mb_e -- To prove x=e, try to see if x:eq(e') and proceed by transitivity (PExpr_Var x, _) -> @@ -4333,7 +4316,7 @@ proveEqH psubst e mb_e = case (e, mbMatch mb_e) of Just e' -> proveEq e' mb_e >>= \eqp2 -> pure (someEqProofTrans (someEqProofPerm x e' True) eqp2) - Nothing -> proveEqFail e mb_e + Nothing -> implFailM' $ EqualityProofError e mb_e -- To prove e=x, try to see if x:eq(e') and proceed by transitivity (_, [nuMP| PExpr_Var z |]) @@ -4342,7 +4325,7 @@ proveEqH psubst e mb_e = case (e, mbMatch mb_e) of Just e' -> proveEq e (fmap (const e') mb_e) >>= \eqp -> pure (someEqProofTrans eqp (someEqProofPerm x e' False)) - Nothing -> proveEqFail e mb_e + Nothing -> implFailM' $ EqualityProofError e mb_e -- FIXME: if proving word(e1)=word(e2) for ground e2, we could add an assertion -- that e1=e2 using a BVProp_Eq @@ -4362,7 +4345,7 @@ 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 + _ -> implFailM' $ EqualityProofError e mb_e -- | Build a proof on the top of the stack that @x:eq(e)@. Assume that all @x@ @@ -5967,7 +5950,7 @@ proveVarAtomicImpl x ps mb_p = case mbMatch mb_p of lownedPermsToDistPerms ps_inR', lownedPermsToDistPerms ps_outR') of (Just dps_inL, Just dps_outL, Just dps_inR, Just dps_outR) -> pure (dps_inL, dps_outL, dps_inR, dps_outR) - _ -> implFailM "proveVarAtomicImpl: lownedPermsToDistPerms") + _ -> 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 -> @@ -6100,12 +6083,7 @@ proveVarConjImpl x ps mb_ps = mb_ps' mb_p) "proveVarConjImpl") >>>= \(ps',p) -> implInsertConjM x p ps' i Nothing -> - implTraceM - (\i -> - sep [PP.fillSep [PP.pretty - "Could not determine enough variables to prove permissions:", - permPretty i (fmap ValPerm_Conj mb_ps)]]) >>>= - implFailM + implFailM' $ InsufficientVariablesError (fmap ValPerm_Conj mb_ps) ---------------------------------------------------------------------- @@ -6429,11 +6407,7 @@ proveExVarImpl _ mb_x mb_p@(mbMatch -> [nuMP| ValPerm_Conj [Perm_LLVMFrame _] |] -- 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 + implFailM' $ ExistentialError mb_x mb_p ---------------------------------------------------------------------- @@ -6587,14 +6561,7 @@ proveVarsImplAppendInt ps = proveVarsImplAppendInt (mbMap2 appendDistPerms ps1 ps2) >>> implMoveUpM cur_perms (mbDistPermsToProxies ps1) x (mbDistPermsToProxies ps2) _ -> - - - implTraceM - (\i -> - sep [PP.fillSep [PP.pretty - "Could not determine enough variables to prove permissions:", - permPretty i ps]]) >>>= - implFailM + implFailM' $ InsufficientVariablesError ps -- | Prove a list of existentially-quantified distinguished permissions and put -- those proofs onto the stack. This is the same as 'proveVarsImplAppendInt' @@ -6696,12 +6663,23 @@ proveVarImpl x mb_p = proveVarsImplAppend $ fmap (distPerms1 x) mb_p -- Error handling and debugging data ImplError where - FatalError :: (PPInfo -> PP.Doc ann) -> ImplError - NoFrameInScopeError :: ImplError - ArrayStepError :: ImplError - MuUnfoldError :: ImplError - FunctionPermissionError :: ImplError - PartialSubstitutionError :: (PPInfo -> PP.Doc ann) -> ImplError + FatalError :: (PPInfo -> PP.Doc ann) -> ImplError + NoFrameInScopeError :: ImplError + ArrayStepError :: ImplError + MuUnfoldError :: ImplError + FunctionPermissionError :: ImplError + PartialSubstitutionError :: PermPretty p => String -> p -> ImplError + LifetimeError :: LifetimeErrorType -> ImplError + MemBlockError :: (1 <= w, KnownNat w) => LLVMBlockPerm w -> ImplError + EqualityProofError :: (PermPretty e, PermPretty mb_e) => e -> mb_e -> ImplError + InsufficientVariablesError :: PermPretty p => p -> ImplError + ExistentialError :: (PermPretty x, PermPretty p) => x -> p -> ImplError + ImplVariableError :: (PPInfo -> PP.Doc ann) -> ImplError + +data LifetimeErrorType where + EndLifetimeError :: LifetimeErrorType + ImplicationLifetimeError :: LifetimeErrorType + LifetimeCurrentError :: PermPretty p => p -> LifetimeErrorType class ErrorPretty a where ppErrorFn :: a -> PPInfo -> String @@ -6714,14 +6692,35 @@ instance ErrorPretty ImplError where "Tried to unfold a mu on the left after unfolding on the right" ppErrorFn FunctionPermissionError _ = "Could not find function permission" + ppErrorFn (PartialSubstitutionError caller mb_e) pp = renderDoc $ + sep [pretty ("Incomplete susbtitution in " ++ caller ++ " for: "), + permPretty pp mb_e] + ppErrorFn (LifetimeError EndLifetimeError) _ = + "implEndLifetimeM: lownedPermsToDistPerms" + ppErrorFn (LifetimeError ImplicationLifetimeError) _ = + "proveVarAtomicImpl: lownedPermsToDistPerms" + ppErrorFn (LifetimeError (LifetimeCurrentError l)) pp = renderDoc $ + pretty "Could not prove lifetime is current:" <+> + permPretty pp l + ppErrorFn (MemBlockError bp) pp = renderDoc $ + pretty "Could not eliminate permission" <+> + permPretty pp (Perm_LLVMBlock bp) + ppErrorFn (EqualityProofError e mb_e) pp = renderDoc $ + sep [pretty "proveEq" <> colon <+> pretty "Could not prove", + sep [permPretty pp e <+> + pretty "=" <+> permPretty pp mb_e]] + ppErrorFn (InsufficientVariablesError ps) pp = renderDoc $ + sep [PP.fillSep [PP.pretty + "Could not determine enough variables to prove permissions:", + permPretty pp ps]] + ppErrorFn (ExistentialError mb_x mb_p) pp = renderDoc $ + pretty "proveExVarImpl: existential variable" <+> + permPretty pp mb_x <+> + pretty "not resolved when trying to prove:" <> softline <> + permPretty pp mb_p + ppErrorFn (ImplVariableError f) pp = renderDoc $ f pp -- | 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 - implFailM' :: NuMatchingAny1 r => ImplError -> ImplM vars s r ps_any ps a implFailM' err = use implStateFailPrefix >>>= \prefix -> @@ -6733,10 +6732,9 @@ implFailM' err = 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 + implFailM' $ ImplVariableError (\i -> + sep [pretty f <> colon <+> pretty "Could not prove", + ppImpl i x p mb_p]) -- | Emit debugging output using the current 'PPInfo' if the 'implStateDoTrace' -- flag is set @@ -6748,4 +6746,5 @@ implTraceM f = fn do_trace str (pure str) where fn True = trace - fn False = const id \ No newline at end of file + fn False = const id + From 49f72e4b9063316a658b03e6186d7632b78533c8 Mon Sep 17 00:00:00 2001 From: Karl Smeltzer Date: Tue, 29 Jun 2021 11:48:18 -0700 Subject: [PATCH 03/28] add structure to stmt fail in line with impl fail --- .../src/Verifier/SAW/Heapster/Implication.hs | 114 ++++++------ .../Verifier/SAW/Heapster/TypedCrucible.hs | 170 +++++++++++------- 2 files changed, 166 insertions(+), 118 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs b/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs index 47b01d7378..23ef109537 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs @@ -2714,7 +2714,7 @@ partialSubstForceM mb_e caller = case partialSubst psubst mb_e of Just e -> pure e Nothing -> - implFailM' $ PartialSubstitutionError caller mb_e + implFailM $ PartialSubstitutionError caller mb_e -- | Modify the current partial substitution modifyPSubst :: (PartialSubst vars -> PartialSubst vars) -> @@ -2780,7 +2780,7 @@ implRecFlagCaseM m1 m2 = implSetRecRecurseRightM :: NuMatchingAny1 r => ImplM vars s r ps ps () implSetRecRecurseRightM = use implStateRecRecurseFlag >>= \case - RecLeft -> implFailM' MuUnfoldError + RecLeft -> implFailM MuUnfoldError _ -> implStateRecRecurseFlag .= RecRight -- | Set the recursive recursion flag to indicate recursion on the left, or fail @@ -2789,7 +2789,7 @@ implSetRecRecurseLeftM :: NuMatchingAny1 r => ImplM vars s r ps ps () implSetRecRecurseLeftM = use implStateRecRecurseFlag >>= \case RecRight -> - implFailM' MuUnfoldError + implFailM MuUnfoldError _ -> implStateRecRecurseFlag .= RecLeft -- | Look up the 'NamedPerm' structure for a named permssion @@ -3208,7 +3208,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 () @@ -3663,7 +3663,7 @@ implEndLifetimeM :: NuMatchingAny1 r => Proxy ps -> ExprVar LifetimeType -> implEndLifetimeM ps l ps_in ps_out@(lownedPermsToDistPerms -> Just dps_out) = implSimplM ps (SImpl_EndLifetime l ps_in ps_out) >>> recombinePermsPartial ps dps_out -implEndLifetimeM _ _ _ _ = implFailM' $ LifetimeError EndLifetimeError +implEndLifetimeM _ _ _ _ = implFailM $ LifetimeError EndLifetimeError -- | Save a permission for later by splitting it into part that is in the @@ -3959,7 +3959,7 @@ implElimLLVMBlock x bp@(LLVMBlockPerm { llvmBlockShape = PExpr_ExShape _mb_sh }) = implSimplM Proxy (SImpl_ElimLLVMBlockEx x bp) implElimLLVMBlock _ bp = - implFailM' $ MemBlockError bp + implFailM $ MemBlockError bp -- | Eliminate a @memblock@ permission on the top of the stack and recombine it, -- if this is possible; otherwise fail @@ -3988,7 +3988,7 @@ getLifetimeCurrentPerms (PExpr_Var l) = case some_cur_perms of Some cur_perms -> pure $ Some $ CurrentTransPerms cur_perms l _ -> - implFailM' $ LifetimeError (LifetimeCurrentError l) + implFailM $ LifetimeError (LifetimeCurrentError l) -- | Prove the permissions represented by a 'LifetimeCurrentPerms' proveLifetimeCurrent :: NuMatchingAny1 r => LifetimeCurrentPerms ps_l -> @@ -4234,7 +4234,7 @@ 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 = implFailM' $ EqualityProofError perms mb + proveEq perms mb = implFailM $ EqualityProofError perms mb instance ProveEq (LLVMBlockPerm w) where proveEq bp mb_bp = @@ -4308,7 +4308,7 @@ 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 -> implFailM' $ EqualityProofError e mb_e + Nothing -> implFailM $ EqualityProofError e mb_e -- To prove x=e, try to see if x:eq(e') and proceed by transitivity (PExpr_Var x, _) -> @@ -4316,7 +4316,7 @@ proveEqH psubst e mb_e = case (e, mbMatch mb_e) of Just e' -> proveEq e' mb_e >>= \eqp2 -> pure (someEqProofTrans (someEqProofPerm x e' True) eqp2) - Nothing -> implFailM' $ EqualityProofError e mb_e + Nothing -> implFailM $ EqualityProofError e mb_e -- To prove e=x, try to see if x:eq(e') and proceed by transitivity (_, [nuMP| PExpr_Var z |]) @@ -4325,7 +4325,7 @@ proveEqH psubst e mb_e = case (e, mbMatch mb_e) of Just e' -> proveEq e (fmap (const e') mb_e) >>= \eqp -> pure (someEqProofTrans eqp (someEqProofPerm x e' False)) - Nothing -> implFailM' $ EqualityProofError e mb_e + Nothing -> implFailM $ EqualityProofError e mb_e -- FIXME: if proving word(e1)=word(e2) for ground e2, we could add an assertion -- that e1=e2 using a BVProp_Eq @@ -4345,7 +4345,7 @@ proveEqH psubst e mb_e = case (e, mbMatch mb_e) of -- FIXME: add cases to prove struct(es1)=struct(es2) -- Otherwise give up! - _ -> implFailM' $ EqualityProofError e mb_e + _ -> implFailM $ EqualityProofError e mb_e -- | Build a proof on the top of the stack that @x:eq(e)@. Assume that all @x@ @@ -5005,7 +5005,7 @@ proveVarLLVMArray_ArrayStep x ps ap i ap_lhs -- Otherwise we don't know what to do so we fail proveVarLLVMArray_ArrayStep _x _ps _ap _i _ap_lhs = - implFailM' ArrayStepError + implFailM ArrayStepError ---------------------------------------------------------------------- @@ -5950,7 +5950,7 @@ proveVarAtomicImpl x ps mb_p = case mbMatch mb_p of lownedPermsToDistPerms ps_inR', lownedPermsToDistPerms ps_outR') of (Just dps_inL, Just dps_outL, Just dps_inR, Just dps_outR) -> pure (dps_inL, dps_outL, dps_inR, dps_outR) - _ -> implFailM' $ LifetimeError ImplicationLifetimeError) + _ -> 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 -> @@ -6083,7 +6083,7 @@ proveVarConjImpl x ps mb_ps = mb_ps' mb_p) "proveVarConjImpl") >>>= \(ps',p) -> implInsertConjM x p ps' i Nothing -> - implFailM' $ InsufficientVariablesError (fmap ValPerm_Conj mb_ps) + implFailM $ InsufficientVariablesError (fmap ValPerm_Conj mb_ps) ---------------------------------------------------------------------- @@ -6403,11 +6403,11 @@ proveExVarImpl _ mb_x mb_p@(mbMatch -> [nuMP| ValPerm_Conj [Perm_LLVMFrame _] |] getVarVarM memb >>>= \n' -> proveVarImplInt n' mb_p >>> pure n' Nothing -> - implFailM' NoFrameInScopeError + implFailM NoFrameInScopeError -- Otherwise we fail proveExVarImpl _ mb_x mb_p = - implFailM' $ ExistentialError mb_x mb_p + implFailM $ ExistentialError mb_x mb_p ---------------------------------------------------------------------- @@ -6561,7 +6561,7 @@ proveVarsImplAppendInt ps = proveVarsImplAppendInt (mbMap2 appendDistPerms ps1 ps2) >>> implMoveUpM cur_perms (mbDistPermsToProxies ps1) x (mbDistPermsToProxies ps2) _ -> - implFailM' $ InsufficientVariablesError ps + implFailM $ InsufficientVariablesError ps -- | Prove a list of existentially-quantified distinguished permissions and put -- those proofs onto the stack. This is the same as 'proveVarsImplAppendInt' @@ -6682,49 +6682,49 @@ data LifetimeErrorType where LifetimeCurrentError :: PermPretty p => p -> LifetimeErrorType class ErrorPretty a where - ppErrorFn :: a -> PPInfo -> String + ppError :: a -> PPInfo -> String instance ErrorPretty ImplError where - ppErrorFn (FatalError f) pp = renderDoc $ f pp - ppErrorFn NoFrameInScopeError _ = "No LLVM frame in scope" - ppErrorFn ArrayStepError _ = "Error proving array permissions" - ppErrorFn MuUnfoldError _ = - "Tried to unfold a mu on the left after unfolding on the right" - ppErrorFn FunctionPermissionError _ = - "Could not find function permission" - ppErrorFn (PartialSubstitutionError caller mb_e) pp = renderDoc $ - sep [pretty ("Incomplete susbtitution in " ++ caller ++ " for: "), - permPretty pp mb_e] - ppErrorFn (LifetimeError EndLifetimeError) _ = - "implEndLifetimeM: lownedPermsToDistPerms" - ppErrorFn (LifetimeError ImplicationLifetimeError) _ = - "proveVarAtomicImpl: lownedPermsToDistPerms" - ppErrorFn (LifetimeError (LifetimeCurrentError l)) pp = renderDoc $ - pretty "Could not prove lifetime is current:" <+> - permPretty pp l - ppErrorFn (MemBlockError bp) pp = renderDoc $ - pretty "Could not eliminate permission" <+> - permPretty pp (Perm_LLVMBlock bp) - ppErrorFn (EqualityProofError e mb_e) pp = renderDoc $ - sep [pretty "proveEq" <> colon <+> pretty "Could not prove", - sep [permPretty pp e <+> - pretty "=" <+> permPretty pp mb_e]] - ppErrorFn (InsufficientVariablesError ps) pp = renderDoc $ - sep [PP.fillSep [PP.pretty - "Could not determine enough variables to prove permissions:", - permPretty pp ps]] - ppErrorFn (ExistentialError mb_x mb_p) pp = renderDoc $ - pretty "proveExVarImpl: existential variable" <+> - permPretty pp mb_x <+> - pretty "not resolved when trying to prove:" <> softline <> - permPretty pp mb_p - ppErrorFn (ImplVariableError f) pp = renderDoc $ f pp + ppError (FatalError f) pp = renderDoc $ f pp + 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 mb_e) pp = renderDoc $ + sep [pretty ("Incomplete susbtitution in " ++ caller ++ " for: "), + permPretty pp mb_e] + ppError (LifetimeError EndLifetimeError) _ = + "implEndLifetimeM: lownedPermsToDistPerms" + ppError (LifetimeError ImplicationLifetimeError) _ = + "proveVarAtomicImpl: lownedPermsToDistPerms" + ppError (LifetimeError (LifetimeCurrentError l)) pp = renderDoc $ + pretty "Could not prove lifetime is current:" <+> + permPretty pp l + ppError (MemBlockError bp) pp = renderDoc $ + pretty "Could not eliminate permission" <+> + permPretty pp (Perm_LLVMBlock bp) + ppError (EqualityProofError e mb_e) pp = renderDoc $ + sep [pretty "proveEq" <> colon <+> pretty "Could not prove", + sep [permPretty pp e <+> + pretty "=" <+> permPretty pp mb_e]] + ppError (InsufficientVariablesError ps) pp = renderDoc $ + sep [PP.fillSep [PP.pretty + "Could not determine enough variables to prove permissions:", + permPretty pp ps]] + ppError (ExistentialError mb_x mb_p) pp = renderDoc $ + pretty "proveExVarImpl: existential variable" <+> + permPretty pp mb_x <+> + pretty "not resolved when trying to prove:" <> softline <> + permPretty pp mb_p + ppError (ImplVariableError f) pp = renderDoc $ f pp -- | Terminate the current proof branch with a failure -implFailM' :: NuMatchingAny1 r => ImplError -> ImplM vars s r ps_any ps a -implFailM' err = +implFailM :: NuMatchingAny1 r => ImplError -> ImplM vars s r ps_any ps a +implFailM err = use implStateFailPrefix >>>= \prefix -> - uses implStatePPInfo (ppErrorFn err) >>>= \doc -> + uses implStatePPInfo (ppError err) >>>= \doc -> let msg = prefix <> doc in implTraceM (const $ pretty msg) >>> implApplyImpl1 (Impl1_Fail msg) MNil @@ -6732,7 +6732,7 @@ implFailM' err = 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 = - implFailM' $ ImplVariableError (\i -> + implFailM $ ImplVariableError (\i -> sep [pretty f <> colon <+> pretty "Could not prove", ppImpl i x p mb_p]) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs b/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs index 2c0e69d93a..9b92ef1ab9 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs @@ -1962,11 +1962,7 @@ 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]) + stmtFailM $ AtomicPermError r p -- | Like 'getAtomicOrWordLLVMPerms', but fail if an equality permission to a @@ -1982,11 +1978,8 @@ 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)]) + stmtFailM $ AtomicPermError r (ValPerm_Eq $ PExpr_LLVMWord e) + data SomeExprVarFrame where SomeExprVarFrame :: @@ -2057,32 +2050,6 @@ setVarTypes _ _ CruCtxNil = pure () setVarTypes str (xs :>: x) (CruCtxCons tps tp) = setVarTypes str xs tps >>> setVarType str x tp --- | 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) - --- | Emit debugging output using the current 'PPInfo' -stmtTraceM :: (PPInfo -> Doc ()) -> - PermCheckM ext cblocks blocks tops ret r ps r ps String -stmtTraceM f = - do doc <- f <$> permGetPPInfo - let str = renderDoc doc - trace str (pure str) - --- | Failure in the statement permission-checking monad -stmtFailM :: (PPInfo -> Doc ()) -> PermCheckM ext cblocks blocks tops ret r1 ps1 - (TypedStmtSeq ext blocks tops ret 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' = @@ -2320,9 +2287,7 @@ 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)) + stmtFailM $ RegisterConversionError x tp1 tp2 -- | Extract the bitvector of size @sz@ at offset @off@ from a larger bitvector @@ -2762,7 +2727,7 @@ tcEmitStmt' ctx loc (CallHandle ret freg_untyped _args_ctx args_untyped) = _ -> pure Nothing _ -> pure []) >>>= \maybe_fun_perms -> (stmtEmbedImplM $ foldr1WithDefault implCatchM - (implFailM' FunctionPermissionError) + (implFailM FunctionPermissionError) (mapMaybe (fmap pure) maybe_fun_perms)) >>>= \some_fun_perm -> case some_fun_perm of SomeFunPerm fun_perm -> @@ -2786,7 +2751,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 loc (TypedAssert (tcReg ctx reg) (tcReg ctx msg)) tcEmitStmt' _ _ _ = error "tcEmitStmt: unsupported statement" @@ -2811,8 +2776,7 @@ tcEmitLLVMSetExpr ctx loc (LLVM_PointerExpr w blk_reg off_reg) = emitLLVMStmt knownRepr loc (ConstructLLVMWord toff_reg) >>>= \x -> stmtRecombinePerms >>> pure (addCtxName ctx x) - _ -> stmtFailM (\i -> pretty "LLVM_PointerExpr: Non-zero pointer block: " - <> permPretty i tblk_reg) + _ -> stmtFailM $ NonZeroPointerBlockError 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 @@ -2905,14 +2869,15 @@ 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 loc (TypedSetRegPermExpr knownRepr $ - PExpr_String err_str) >>>= \(_ :>: str_var) -> + PExpr_String (renderDoc err_msg)) >>>= \(_ :>: str_var) -> stmtRecombinePerms >>> emitStmt CruCtxNil loc (TypedAssert tcond_reg $ TypedReg str_var) >>>= \_ -> @@ -2924,7 +2889,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 @@ -3096,14 +3061,11 @@ 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) + stmtFailM $ AllocaError (AllocaNonConstantError sz_treg) (Just fp, p, _) -> - stmtFailM (\i -> pretty "LLVM_Alloca: expected LLVM frame perm for " - <+> permPretty i fp <> pretty ", found perm" - <+> permPretty i p) + stmtFailM $ AllocaError (AllocaFramePermError fp 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 _ _) = @@ -3131,7 +3093,7 @@ tcEmitLLVMStmt _arch ctx loc (LLVM_PopFrame _) = 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) = @@ -3161,7 +3123,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) = @@ -3173,8 +3135,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) = @@ -3327,9 +3288,7 @@ 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]) + stmtFailM $ PointerComparisonError x1 x2 tcEmitLLVMStmt _arch _ctx _loc stmt = error ("tcEmitLLVMStmt: unimplemented statement - " ++ show (ppApp (\_ -> mempty) stmt)) @@ -3867,4 +3826,93 @@ tcCFG w env endianness fun_perm cfg = use (stBlockMap . member tpBlkID) >>= (visitBlock >=> assign (stBlockMap . member tpBlkID))) >> - main_loop nodes \ No newline at end of file + main_loop nodes + +-------------------------------------------------------------------------------- +-- Error handling and logging + +data StmtError where + AtomicPermError :: (PermPretty r, PermPretty p) => r -> p -> StmtError + RegisterConversionError + :: (PermPretty x, Show tp1, Show tp2) + => x -> tp1 -> tp2 -> StmtError + FailedAssertionError :: StmtError + NonZeroPointerBlockError :: (PermPretty tblk_reg) => tblk_reg -> StmtError + UndefinedBehaviorError :: Doc () -> StmtError + X86ExprError :: StmtError + AllocaError :: AllocaErrorType -> StmtError + PopFrameError :: StmtError + LoadHandleError :: StmtError + ResolveGlobalError :: GlobalSymbol -> StmtError + PointerComparisonError :: (PermPretty x1, PermPretty x2) => x1 -> x2 -> StmtError + +data AllocaErrorType where + AllocaNonConstantError :: PermPretty sz_treg => sz_treg -> AllocaErrorType + AllocaFramePermError + :: (PermPretty fp, PermPretty p) + => fp -> p -> AllocaErrorType + AllocaFramePtrError :: AllocaErrorType + +instance ErrorPretty StmtError where + ppError (AtomicPermError r p) pp = renderDoc $ + sep [pretty "getAtomicOrWordLLVMPerms:", + pretty "Needed atomic permissions for" <+> permPretty pp r, + pretty "but found" <+> + permPretty pp p] + ppError (RegisterConversionError x tp1 tp2) pp = renderDoc $ + pretty "Could not cast" <+> permPretty pp x <+> + pretty "from" <+> pretty (show tp1) <+> + pretty "to" <+> pretty (show tp2) + ppError FailedAssertionError _ = "Failed assertion" + ppError (NonZeroPointerBlockError tblk_reg) pp = renderDoc $ + pretty "LLVM_PointerExpr: Non-zero pointer block: " <> + permPretty pp tblk_reg + ppError (UndefinedBehaviorError doc) _ = renderDoc doc + ppError X86ExprError _ = "X86Expr not supported" + ppError (AllocaError (AllocaNonConstantError sz_treg)) pp = renderDoc $ + pretty "LLVM_Alloca: non-constant size for" <+> + permPretty pp sz_treg + ppError (AllocaError (AllocaFramePermError fp p)) pp = renderDoc $ + pretty "LLVM_Alloca: expected LLVM frame perm for " <+> + permPretty pp fp <> pretty ", found perm" <+> + permPretty pp 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) pp = renderDoc $ + sep [pretty "Could not compare LLVM pointer values", + permPretty pp x1, pretty "and", permPretty pp 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) + +-- | Emit debugging output using the current 'PPInfo' +stmtTraceM :: (PPInfo -> Doc ()) -> + PermCheckM ext cblocks blocks tops ret r ps r ps String +stmtTraceM f = + do doc <- f <$> permGetPPInfo + let str = renderDoc doc + trace str (pure str) + +-- | 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 (\i -> err_prefix <> line <> + pretty "Type-checking failure:" <> softline <> + pretty (ppError err i)) >>>= \str -> + gabortM (return $ TypedImplStmt $ AnnotPermImpl str $ + PermImpl_Step (Impl1_Fail "") MbPermImpls_Nil) From 716a2e1a9912a17ac11ed9c04da7d41ec1868188 Mon Sep 17 00:00:00 2001 From: Karl Smeltzer Date: Wed, 7 Jul 2021 16:24:21 -0700 Subject: [PATCH 04/28] redesign error message types, pipe through to log --- .../src/Verifier/SAW/Heapster/IDESupport.hs | 2 +- .../src/Verifier/SAW/Heapster/Implication.hs | 312 ++++++++++++------ .../Verifier/SAW/Heapster/ImplicationError.hs | 0 .../src/Verifier/SAW/Heapster/Permissions.hs | 4 +- .../Verifier/SAW/Heapster/SAWTranslation.hs | 4 +- .../Verifier/SAW/Heapster/TypedCrucible.hs | 100 +++--- 6 files changed, 276 insertions(+), 146 deletions(-) create mode 100644 heapster-saw/src/Verifier/SAW/Heapster/ImplicationError.hs diff --git a/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs b/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs index f68a644e36..8763bf6e92 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs @@ -120,7 +120,7 @@ instance ExtractLogEntries (PermImpl1 ps_in ps_outs) where extractLogEntries (Impl1_Fail err) = -- The error message is available further up the stack, so we just leave it -- empty here - reader $ \(_, loc) -> [LogError (snd $ ppLoc loc) err] + reader $ \(_, loc) -> [LogError (snd $ ppLoc loc) (ppError err)] extractLogEntries _ = return [] instance ExtractLogEntries diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs b/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs index 23ef109537..f0ee32830e 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs @@ -66,6 +66,7 @@ import GHC.Stack import Debug.Trace + ---------------------------------------------------------------------- -- * Equality Proofs ---------------------------------------------------------------------- @@ -299,6 +300,72 @@ 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 + -- -> ExprVar tp -> ValuePerm tp -> CruCtx vars + -- -> Some DistPerms -> Mb vars (ValuePerm tp) + -> ImplError + +data LifetimeErrorType where + EndLifetimeError :: LifetimeErrorType + ImplicationLifetimeError :: LifetimeErrorType + LifetimeCurrentError :: PP.Doc ann -> LifetimeErrorType + +instance Liftable ImplError where + mbLift e = case mbMatch e of + [nuMP| GeneralError doc |] -> + GeneralError (mbLift doc) + [nuMP| NoFrameInScopeError |] -> + NoFrameInScopeError + [nuMP| ArrayStepError |] -> + ArrayStepError + [nuMP| MuUnfoldError |] -> + MuUnfoldError + [nuMP| FunctionPermissionError |] -> + FunctionPermissionError + [nuMP| PartialSubstitutionError str err |] -> + PartialSubstitutionError (mbLift str) (mbLift err) + [nuMP| LifetimeError le |] -> + LifetimeError $ mbLift le + [nuMP| MemBlockError doc |] -> + MemBlockError $ mbLift doc + [nuMP| EqualityProofError lhs rhs |] -> + EqualityProofError (mbLift lhs) (mbLift rhs) + [nuMP| InsufficientVariablesError doc |] -> + InsufficientVariablesError $ mbLift doc + [nuMP| ExistentialError doc1 doc2 |] -> + ExistentialError (mbLift doc1) (mbLift doc2) + [nuMP| ImplVariableError doc f |] -> + ImplVariableError (mbLift doc) (mbLift f) + +instance Liftable LifetimeErrorType where + mbLift e = case mbMatch e of + [nuMP| EndLifetimeError |] -> EndLifetimeError + [nuMP| ImplicationLifetimeError |] -> ImplicationLifetimeError + [nuMP| LifetimeCurrentError doc |] -> LifetimeCurrentError $ mbLift doc + +-- 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 ---------------------------------------------------------------------- @@ -1129,7 +1196,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: @@ -1274,16 +1341,6 @@ idLocalPermImpl = LocalPermImpl $ PermImpl_Done $ LocalImplRet Refl -- type IsLLVMPointerTypeList w ps = RAssign ((:~:) (LLVMPointerType w)) ps -$(mkNuMatching [t| forall a. EqPerm a |]) -$(mkNuMatching [t| forall ps a. NuMatching a => EqProofStep ps a |]) -$(mkNuMatching [t| forall ps a. NuMatching a => EqProof ps a |]) -$(mkNuMatching [t| forall ps_in ps_out. SimplImpl ps_in ps_out |]) -$(mkNuMatching [t| forall ps_in ps_outs. PermImpl1 ps_in ps_outs |]) -$(mkNuMatching [t| forall r bs_pss. NuMatchingAny1 r => MbPermImpls r bs_pss |]) -$(mkNuMatching [t| forall r ps. NuMatchingAny1 r => PermImpl r ps |]) -$(mkNuMatching [t| forall ps_in ps_out. LocalPermImpl ps_in ps_out |]) -$(mkNuMatching [t| forall ps ps'. LocalImplRet ps ps' |]) - instance NuMatchingAny1 EqPerm where nuMatchingAny1Proof = nuMatchingProof @@ -1346,8 +1403,8 @@ permImplStep (Impl1_ElimOr _ _ _) (MbPermImpls_Cons _ (MbPermImpls_Cons _ MbPermImpls_Nil (matchMbImplFail -> Just msg1)) (matchMbImplFail -> Just msg2)) = - PermImpl_Step (Impl1_Fail - (msg1 ++ "\n\n--------------------\n\n" ++ msg2)) + PermImpl_Step (Impl1_Fail $ GeneralError $ pretty + (msg1 ++ "\n\n--------------------\n\n" ++ msg2)) MbPermImpls_Nil -- Default case: just apply PermImpl_Step @@ -1363,7 +1420,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 @@ -1387,7 +1444,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 msg) _ |] -> Just $ ppError $ mbLift msg _ -> Nothing -- | Pattern-matchin an implication inside a binding to see if it is a catch @@ -1415,7 +1472,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 @@ -2711,10 +2770,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 -> - implFailM $ PartialSubstitutionError caller mb_e + 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) -> @@ -2921,6 +2981,45 @@ implSetNameTypes (ns :>: n) (CruCtxCons tps tp) = implStatePerms %= initVarPerm 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 ev (ValPerm_Eq pe) = permExprContainsVar ev pe +permContainsVar ev (ValPerm_Or l r) = permContainsVar ev l || permContainsVar ev r +permContainsVar ev (ValPerm_Exists vp) = mbLift $ fmap (permContainsVar ev) vp +permContainsVar ev (ValPerm_Named _ pe _) = + or $ RL.mapToList (permExprContainsVar ev) pe +permContainsVar _ (ValPerm_Var _ _) = False +permContainsVar ev (ValPerm_Conj as) = any atomicHelper as + where + atomicHelper :: AtomicPerm a -> Bool + atomicHelper (Perm_NamedConj _ perms _) = + or $ RL.mapToList (permExprContainsVar ev) perms + atomicHelper _ = False + + +permExprContainsVar :: ExprVar a -> PermExpr b -> Bool +permExprContainsVar ev1 (PExpr_Var ev2) = case testEquality ev1 ev2 of + Just Refl -> ev1 == ev2 + Nothing -> False +permExprContainsVar _ _ = False + +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 ---------------------------------------------------------------------- -- * The Permission Implication Rules as Monadic Operations @@ -3959,7 +4058,8 @@ implElimLLVMBlock x bp@(LLVMBlockPerm { llvmBlockShape = PExpr_ExShape _mb_sh }) = implSimplM Proxy (SImpl_ElimLLVMBlockEx x bp) implElimLLVMBlock _ bp = - implFailM $ MemBlockError bp + use implStatePPInfo >>>= \ppinfo -> + implFailM $ MemBlockError $ permPretty ppinfo (Perm_LLVMBlock bp) -- | Eliminate a @memblock@ permission on the top of the stack and recombine it, -- if this is possible; otherwise fail @@ -3988,7 +4088,8 @@ getLifetimeCurrentPerms (PExpr_Var l) = case some_cur_perms of Some cur_perms -> pure $ Some $ CurrentTransPerms cur_perms l _ -> - implFailM $ LifetimeError (LifetimeCurrentError l) + use implStatePPInfo >>>= \ppinfo -> + implFailM $ LifetimeError (LifetimeCurrentError $ permPretty ppinfo l) -- | Prove the permissions represented by a 'LifetimeCurrentPerms' proveLifetimeCurrent :: NuMatchingAny1 r => LifetimeCurrentPerms ps_l -> @@ -4234,7 +4335,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 = implFailM $ EqualityProofError 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 = @@ -4308,7 +4413,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 -> implFailM $ EqualityProofError e mb_e + Nothing -> + use implStatePPInfo >>>= \ppinfo -> + implFailM $ EqualityProofError + (permPretty ppinfo e) + (permPretty ppinfo mb_e) -- To prove x=e, try to see if x:eq(e') and proceed by transitivity (PExpr_Var x, _) -> @@ -4316,7 +4425,11 @@ proveEqH psubst e mb_e = case (e, mbMatch mb_e) of Just e' -> proveEq e' mb_e >>= \eqp2 -> pure (someEqProofTrans (someEqProofPerm x e' True) eqp2) - Nothing -> implFailM $ EqualityProofError 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 |]) @@ -4325,7 +4438,11 @@ proveEqH psubst e mb_e = case (e, mbMatch mb_e) of Just e' -> proveEq e (fmap (const e') mb_e) >>= \eqp -> pure (someEqProofTrans eqp (someEqProofPerm x e' False)) - Nothing -> implFailM $ EqualityProofError 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 @@ -4345,7 +4462,10 @@ proveEqH psubst e mb_e = case (e, mbMatch mb_e) of -- FIXME: add cases to prove struct(es1)=struct(es2) -- Otherwise give up! - _ -> implFailM $ EqualityProofError 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)@. Assume that all @x@ @@ -6083,7 +6203,9 @@ proveVarConjImpl x ps mb_ps = mb_ps' mb_p) "proveVarConjImpl") >>>= \(ps',p) -> implInsertConjM x p ps' i Nothing -> - implFailM $ InsufficientVariablesError (fmap ValPerm_Conj mb_ps) + use implStatePPInfo >>>= \ppinfo -> + implFailM $ InsufficientVariablesError $ + permPretty ppinfo (fmap ValPerm_Conj mb_ps) ---------------------------------------------------------------------- @@ -6407,7 +6529,10 @@ proveExVarImpl _ mb_x mb_p@(mbMatch -> [nuMP| ValPerm_Conj [Perm_LLVMFrame _] |] -- Otherwise we fail proveExVarImpl _ mb_x mb_p = - implFailM $ ExistentialError mb_x mb_p + use implStatePPInfo >>>= \ppinfo -> + implFailM $ ExistentialError + (permPretty ppinfo mb_x) + (permPretty ppinfo mb_p) ---------------------------------------------------------------------- @@ -6561,7 +6686,9 @@ proveVarsImplAppendInt ps = proveVarsImplAppendInt (mbMap2 appendDistPerms ps1 ps2) >>> implMoveUpM cur_perms (mbDistPermsToProxies ps1) x (mbDistPermsToProxies ps2) _ -> - implFailM $ InsufficientVariablesError ps + use implStatePPInfo >>>= \ppinfo -> + implFailM $ InsufficientVariablesError $ + permPretty ppinfo ps -- | Prove a list of existentially-quantified distinguished permissions and put -- those proofs onto the stack. This is the same as 'proveVarsImplAppendInt' @@ -6659,82 +6786,22 @@ proveVarImpl :: NuMatchingAny1 r => ExprVar a -> Mb vars (ValuePerm a) -> proveVarImpl x mb_p = proveVarsImplAppend $ fmap (distPerms1 x) mb_p --------------------------------------------------------------------------------- --- Error handling and debugging - -data ImplError where - FatalError :: (PPInfo -> PP.Doc ann) -> ImplError - NoFrameInScopeError :: ImplError - ArrayStepError :: ImplError - MuUnfoldError :: ImplError - FunctionPermissionError :: ImplError - PartialSubstitutionError :: PermPretty p => String -> p -> ImplError - LifetimeError :: LifetimeErrorType -> ImplError - MemBlockError :: (1 <= w, KnownNat w) => LLVMBlockPerm w -> ImplError - EqualityProofError :: (PermPretty e, PermPretty mb_e) => e -> mb_e -> ImplError - InsufficientVariablesError :: PermPretty p => p -> ImplError - ExistentialError :: (PermPretty x, PermPretty p) => x -> p -> ImplError - ImplVariableError :: (PPInfo -> PP.Doc ann) -> ImplError - -data LifetimeErrorType where - EndLifetimeError :: LifetimeErrorType - ImplicationLifetimeError :: LifetimeErrorType - LifetimeCurrentError :: PermPretty p => p -> LifetimeErrorType - -class ErrorPretty a where - ppError :: a -> PPInfo -> String - -instance ErrorPretty ImplError where - ppError (FatalError f) pp = renderDoc $ f pp - 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 mb_e) pp = renderDoc $ - sep [pretty ("Incomplete susbtitution in " ++ caller ++ " for: "), - permPretty pp mb_e] - ppError (LifetimeError EndLifetimeError) _ = - "implEndLifetimeM: lownedPermsToDistPerms" - ppError (LifetimeError ImplicationLifetimeError) _ = - "proveVarAtomicImpl: lownedPermsToDistPerms" - ppError (LifetimeError (LifetimeCurrentError l)) pp = renderDoc $ - pretty "Could not prove lifetime is current:" <+> - permPretty pp l - ppError (MemBlockError bp) pp = renderDoc $ - pretty "Could not eliminate permission" <+> - permPretty pp (Perm_LLVMBlock bp) - ppError (EqualityProofError e mb_e) pp = renderDoc $ - sep [pretty "proveEq" <> colon <+> pretty "Could not prove", - sep [permPretty pp e <+> - pretty "=" <+> permPretty pp mb_e]] - ppError (InsufficientVariablesError ps) pp = renderDoc $ - sep [PP.fillSep [PP.pretty - "Could not determine enough variables to prove permissions:", - permPretty pp ps]] - ppError (ExistentialError mb_x mb_p) pp = renderDoc $ - pretty "proveExVarImpl: existential variable" <+> - permPretty pp mb_x <+> - pretty "not resolved when trying to prove:" <> softline <> - permPretty pp mb_p - ppError (ImplVariableError f) pp = renderDoc $ f pp - -- | 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 -> - uses implStatePPInfo (ppError err) >>>= \doc -> - let msg = prefix <> doc - in implTraceM (const $ pretty msg) >>> implApplyImpl1 (Impl1_Fail msg) MNil + 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 = - implFailM $ ImplVariableError (\i -> - sep [pretty f <> colon <+> pretty "Could not prove", - ppImpl i x p mb_p]) + use implStatePPInfo >>>= \ppinfo -> + -- use implStateVars >>>= \ctx -> + -- findPermsContainingVar x >>>= \distperms -> + implFailM $ ImplVariableError + (ppImpl ppinfo x p mb_p) f -- | Emit debugging output using the current 'PPInfo' if the 'implStateDoTrace' -- flag is set @@ -6748,3 +6815,54 @@ implTraceM f = fn True = trace fn False = const id + +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) = renderDoc $ + sep [ pretty f <> colon <+> pretty "Could not prove" + , doc ] + + +$(mkNuMatching [t| forall a. EqPerm a |]) +$(mkNuMatching [t| forall ps a. NuMatching a => EqProofStep ps a |]) +$(mkNuMatching [t| forall ps a. NuMatching a => EqProof ps a |]) +$(mkNuMatching [t| forall ps_in ps_out. SimplImpl ps_in ps_out |]) +$(mkNuMatching [t| LifetimeErrorType |]) +$(mkNuMatching [t| ImplError |]) +$(mkNuMatching [t| forall ps_in ps_outs. PermImpl1 ps_in ps_outs |]) +$(mkNuMatching [t| forall r bs_pss. NuMatchingAny1 r => MbPermImpls r bs_pss |]) +$(mkNuMatching [t| forall r ps. NuMatchingAny1 r => PermImpl r ps |]) +$(mkNuMatching [t| forall ps_in ps_out. LocalPermImpl ps_in ps_out |]) +$(mkNuMatching [t| forall ps ps'. LocalImplRet ps ps' |]) 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/Permissions.hs b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs index 08150c4a56..6684cab4c2 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs @@ -2792,8 +2792,8 @@ $(mkNuMatching [t| forall ps. LifetimeCurrentPerms ps |]) instance NuMatchingAny1 LOwnedPerm where nuMatchingAny1Proof = nuMatchingProof -instance NuMatchingAny1 DistPerms where - nuMatchingAny1Proof = nuMatchingProof +-- instance NuMatchingAny1 DistPerms where +-- nuMatchingAny1Proof = nuMatchingProof instance Liftable RWModality where mbLift mb_rw = case mbMatch mb_rw of diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 92bff90ae2..790e5cc79f 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -3059,8 +3059,8 @@ translatePermImpl1 :: ImplTranslateF r ext blocks tops ret => 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 |], _) -> - tell [mbLift str] >> mzero + ([nuMP| Impl1_Fail err |], _) -> + tell [ppError $ mbLift err] >> mzero ([nuMP| Impl1_Catch |], [nuMP| (MbPermImpls_Cons _ (MbPermImpls_Cons _ _ mb_impl1) mb_impl2) |]) -> diff --git a/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs b/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs index 9b92ef1ab9..236c61ffe0 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs @@ -1962,7 +1962,8 @@ getAtomicOrWordLLVMPerms r = recombinePerm x p) >>> pure (Left e_word) _ -> - stmtFailM $ AtomicPermError r p + permGetPPInfo >>>= \ppinfo -> + stmtFailM $ AtomicPermError (permPretty ppinfo r) (permPretty ppinfo p) -- | Like 'getAtomicOrWordLLVMPerms', but fail if an equality permission to a @@ -1978,7 +1979,10 @@ getAtomicLLVMPerms r = case eith of Right ps -> pure ps Left e -> - stmtFailM $ AtomicPermError r (ValPerm_Eq $ PExpr_LLVMWord e) + permGetPPInfo >>>= \ppinfo -> + stmtFailM $ AtomicPermError + (permPretty ppinfo r) + (permPretty ppinfo (ValPerm_Eq $ PExpr_LLVMWord e)) data SomeExprVarFrame where @@ -2287,7 +2291,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 $ RegisterConversionError x tp1 tp2 + permGetPPInfo >>>= \ppinfo -> + stmtFailM $ RegisterConversionError (permPretty ppinfo x) tp1 tp2 -- | Extract the bitvector of size @sz@ at offset @off@ from a larger bitvector @@ -2776,7 +2781,9 @@ tcEmitLLVMSetExpr ctx loc (LLVM_PointerExpr w blk_reg off_reg) = emitLLVMStmt knownRepr loc (ConstructLLVMWord toff_reg) >>>= \x -> stmtRecombinePerms >>> pure (addCtxName ctx x) - _ -> stmtFailM $ NonZeroPointerBlockError 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 @@ -3061,9 +3068,13 @@ tcEmitLLVMStmt _arch ctx loc (LLVM_Alloca w _ sz_reg _ _) = stmtRecombinePerms >>> pure (addCtxName ctx y) (_, _, Nothing) -> - stmtFailM $ AllocaError (AllocaNonConstantError sz_treg) + permGetPPInfo >>>= \ppinfo -> + stmtFailM $ AllocaError (AllocaNonConstantError $ permPretty ppinfo sz_treg) (Just fp, p, _) -> - stmtFailM $ AllocaError (AllocaFramePermError fp p) + permGetPPInfo >>>= \ppinfo -> + stmtFailM $ AllocaError $ AllocaFramePermError + (permPretty ppinfo fp) + (permPretty ppinfo p) (Nothing, _, _) -> stmtFailM $ AllocaError AllocaFramePtrError @@ -3288,7 +3299,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 $ PointerComparisonError x1 x2 + permGetPPInfo >>>= \ppinfo -> + stmtFailM $ PointerComparisonError + (permPretty ppinfo x1) + (permPretty ppinfo x2) tcEmitLLVMStmt _arch _ctx _loc stmt = error ("tcEmitLLVMStmt: unimplemented statement - " ++ show (ppApp (\_ -> mempty) stmt)) @@ -3832,62 +3846,60 @@ tcCFG w env endianness fun_perm cfg = -- Error handling and logging data StmtError where - AtomicPermError :: (PermPretty r, PermPretty p) => r -> p -> StmtError + AtomicPermError :: Doc ann -> Doc ann -> StmtError RegisterConversionError - :: (PermPretty x, Show tp1, Show tp2) - => x -> tp1 -> tp2 -> StmtError + :: (Show tp1, Show tp2) + => Doc ann -> tp1 -> tp2 -> StmtError FailedAssertionError :: StmtError - NonZeroPointerBlockError :: (PermPretty tblk_reg) => tblk_reg -> StmtError + NonZeroPointerBlockError :: Doc ann -> StmtError UndefinedBehaviorError :: Doc () -> StmtError X86ExprError :: StmtError AllocaError :: AllocaErrorType -> StmtError PopFrameError :: StmtError LoadHandleError :: StmtError ResolveGlobalError :: GlobalSymbol -> StmtError - PointerComparisonError :: (PermPretty x1, PermPretty x2) => x1 -> x2 -> StmtError + PointerComparisonError :: Doc ann -> Doc ann -> StmtError data AllocaErrorType where - AllocaNonConstantError :: PermPretty sz_treg => sz_treg -> AllocaErrorType - AllocaFramePermError - :: (PermPretty fp, PermPretty p) - => fp -> p -> AllocaErrorType + AllocaNonConstantError :: Doc ann -> AllocaErrorType + AllocaFramePermError :: Doc ann -> Doc ann -> AllocaErrorType AllocaFramePtrError :: AllocaErrorType instance ErrorPretty StmtError where - ppError (AtomicPermError r p) pp = renderDoc $ + ppError (AtomicPermError r p) = renderDoc $ sep [pretty "getAtomicOrWordLLVMPerms:", - pretty "Needed atomic permissions for" <+> permPretty pp r, - pretty "but found" <+> - permPretty pp p] - ppError (RegisterConversionError x tp1 tp2) pp = renderDoc $ - pretty "Could not cast" <+> permPretty pp x <+> + 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) pp = renderDoc $ - pretty "LLVM_PointerExpr: Non-zero pointer block: " <> - permPretty pp tblk_reg - ppError (UndefinedBehaviorError doc) _ = renderDoc doc - ppError X86ExprError _ = "X86Expr not supported" - ppError (AllocaError (AllocaNonConstantError sz_treg)) pp = renderDoc $ + 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" <+> - permPretty pp sz_treg - ppError (AllocaError (AllocaFramePermError fp p)) pp = renderDoc $ + sz_treg + ppError (AllocaError (AllocaFramePermError fp p)) = renderDoc $ pretty "LLVM_Alloca: expected LLVM frame perm for " <+> - permPretty pp fp <> pretty ", found perm" <+> - permPretty pp p - ppError (AllocaError AllocaFramePtrError) _ = + fp <> pretty ", found perm" <+> p + ppError (AllocaError AllocaFramePtrError) = "LLVM_Alloca: no frame pointer set" - ppError PopFrameError _ = + ppError PopFrameError = "LLVM_PopFrame: no frame perms" - ppError LoadHandleError _ = + ppError LoadHandleError = "LLVM_LoadHandle: no function pointer perms" - ppError (ResolveGlobalError gsym) _ = + ppError (ResolveGlobalError gsym) = "LLVM_ResolveGlobal: no perms for global " ++ globalSymbolName gsym - ppError (PointerComparisonError x1 x2) pp = renderDoc $ - sep [pretty "Could not compare LLVM pointer values", - permPretty pp x1, pretty "and", permPretty pp x2] + ppError (PointerComparisonError x1 x2) = renderDoc $ + sep [ pretty "Could not compare LLVM pointer values" + , x1, pretty "and", x2 ] -- | Get the current 'PPInfo' @@ -3911,8 +3923,8 @@ stmtFailM :: StmtError -> PermCheckM ext cblocks blocks tops ret r1 ps1 (TypedStmtSeq ext blocks tops ret ps2) ps2 a stmtFailM err = getErrorPrefix >>>= \err_prefix -> - stmtTraceM (\i -> err_prefix <> line <> - pretty "Type-checking failure:" <> softline <> - pretty (ppError err i)) >>>= \str -> + stmtTraceM (const $ err_prefix <> line <> + pretty "Type-checking failure:" <> softline <> + pretty (ppError err)) >>>= \str -> gabortM (return $ TypedImplStmt $ AnnotPermImpl str $ - PermImpl_Step (Impl1_Fail "") MbPermImpls_Nil) + PermImpl_Step (Impl1_Fail $ GeneralError (pretty "")) MbPermImpls_Nil) From 9283f0e24281833e1f9c8b0d43f6e78707e801e1 Mon Sep 17 00:00:00 2001 From: Karl Smeltzer Date: Thu, 8 Jul 2021 11:57:12 -0700 Subject: [PATCH 05/28] fix default heapster environments missing ioref --- src/SAWScript/HeapsterBuiltins.hs | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/src/SAWScript/HeapsterBuiltins.hs b/src/SAWScript/HeapsterBuiltins.hs index 7f791cb2c8..cb59eeaf26 100644 --- a/src/SAWScript/HeapsterBuiltins.hs +++ b/src/SAWScript/HeapsterBuiltins.hs @@ -260,10 +260,12 @@ heapster_init_env _bic _opts mod_str llvm_filename = liftIO $ scLoadModule sc (insImport (const True) preludeMod $ emptyModule saw_mod_name) perm_env_ref <- liftIO $ newIORef heapster_default_env + tcfg_ref <- liftIO $ newIORef [] return $ HeapsterEnv { heapsterEnvSAWModule = saw_mod_name, heapsterEnvPermEnvRef = perm_env_ref, - heapsterEnvLLVMModules = [llvm_mod] + heapsterEnvLLVMModules = [llvm_mod], + heapsterEnvTCFGs = tcfg_ref } load_sawcore_from_file :: BuiltinContext -> Options -> String -> TopLevel () @@ -280,10 +282,12 @@ heapster_init_env_from_file _bic _opts mod_filename llvm_filename = (saw_mod, saw_mod_name) <- readModuleFromFile mod_filename liftIO $ tcInsertModule sc saw_mod perm_env_ref <- liftIO $ newIORef heapster_default_env + tcfg_ref <- liftIO $ newIORef [] return $ HeapsterEnv { heapsterEnvSAWModule = saw_mod_name, heapsterEnvPermEnvRef = perm_env_ref, - heapsterEnvLLVMModules = [llvm_mod] + heapsterEnvLLVMModules = [llvm_mod], + heapsterEnvTCFGs = tcfg_ref } heapster_init_env_for_files :: BuiltinContext -> Options -> String -> [String] -> @@ -294,10 +298,12 @@ heapster_init_env_for_files _bic _opts mod_filename llvm_filenames = (saw_mod, saw_mod_name) <- readModuleFromFile mod_filename liftIO $ tcInsertModule sc saw_mod perm_env_ref <- liftIO $ newIORef heapster_default_env + tcfg_ref <- liftIO $ newIORef [] return $ HeapsterEnv { heapsterEnvSAWModule = saw_mod_name, heapsterEnvPermEnvRef = perm_env_ref, - heapsterEnvLLVMModules = llvm_mods + heapsterEnvLLVMModules = llvm_mods, + heapsterEnvTCFGs = tcfg_ref } -- | Look up the CFG associated with a symbol name in a Heapster environment @@ -986,4 +992,4 @@ 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 \ No newline at end of file + io $ HIDE.printIDEInfo penv tcfgs filename emptyPPInfo From 1e427a4ce291d369398d780b27d886e5fd897002 Mon Sep 17 00:00:00 2001 From: Karl Smeltzer Date: Fri, 9 Jul 2021 15:36:26 -0700 Subject: [PATCH 06/28] carry more information through on most common implication error --- .../src/Verifier/SAW/Heapster/Implication.hs | 78 ++++++++++--------- .../src/Verifier/SAW/Heapster/Permissions.hs | 4 + .../Verifier/SAW/Heapster/SAWTranslation.hs | 2 +- 3 files changed, 48 insertions(+), 36 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs b/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs index f0ee32830e..edf6d0bff4 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs @@ -318,8 +318,8 @@ data ImplError where ExistentialError :: Doc ann -> Doc ann -> ImplError ImplVariableError :: Doc ann -> String - -- -> ExprVar tp -> ValuePerm tp -> CruCtx vars - -- -> Some DistPerms -> Mb vars (ValuePerm tp) + -> (Doc ann, ExprVar tp) -> (Doc ann, ValuePerm tp) -> CruCtx vars + -> Some DistPerms -> ImplError data LifetimeErrorType where @@ -327,33 +327,28 @@ data LifetimeErrorType where ImplicationLifetimeError :: LifetimeErrorType LifetimeCurrentError :: PP.Doc ann -> LifetimeErrorType -instance Liftable ImplError where - mbLift e = case mbMatch e of - [nuMP| GeneralError doc |] -> - GeneralError (mbLift doc) - [nuMP| NoFrameInScopeError |] -> - NoFrameInScopeError - [nuMP| ArrayStepError |] -> - ArrayStepError - [nuMP| MuUnfoldError |] -> - MuUnfoldError - [nuMP| FunctionPermissionError |] -> - FunctionPermissionError - [nuMP| PartialSubstitutionError str err |] -> - PartialSubstitutionError (mbLift str) (mbLift err) - [nuMP| LifetimeError le |] -> - LifetimeError $ mbLift le - [nuMP| MemBlockError doc |] -> - MemBlockError $ mbLift doc - [nuMP| EqualityProofError lhs rhs |] -> - EqualityProofError (mbLift lhs) (mbLift rhs) - [nuMP| InsufficientVariablesError doc |] -> - InsufficientVariablesError $ mbLift doc - [nuMP| ExistentialError doc1 doc2 |] -> - ExistentialError (mbLift doc1) (mbLift doc2) - [nuMP| ImplVariableError doc f |] -> - ImplVariableError (mbLift doc) (mbLift f) - +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 sdp |] -> do + x' <- genSubst s x + p' <- genSubst s p + case mbMatch sdp of + [nuMP| Some mb_dps |] -> do + dp <- genSubst s mb_dps + return $ ImplVariableError (mbLift doc) (mbLift f) (mbLift xdoc, x') (mbLift pdoc, p') (mbLift ctx) (Some dp) + instance Liftable LifetimeErrorType where mbLift e = case mbMatch e of [nuMP| EndLifetimeError |] -> EndLifetimeError @@ -1444,7 +1439,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 $ ppError $ 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 @@ -2537,7 +2532,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 @@ -6798,10 +6793,23 @@ 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 >>>= \distperms -> + use implStateVars >>>= \ctx -> + findPermsContainingVar x >>>= \distperms -> implFailM $ ImplVariableError - (ppImpl ppinfo x p mb_p) f + (ppImpl ppinfo x p mb_p) + f + (permPretty ppinfo x, x) + (permPretty ppinfo p, p) + ctx + distperms + + -- ImplVariableError + -- :: Doc ann -> String + -- -> ExprVar tp -> ValuePerm tp -> CruCtx vars + -- -> Some DistPerms -> Mb vars (ValuePerm tp) + -- -> ImplError + + -- | Emit debugging output using the current 'PPInfo' if the 'implStateDoTrace' -- flag is set @@ -6850,7 +6858,7 @@ instance ErrorPretty ImplError where docx <+> pretty "not resolved when trying to prove:" <> softline <> docp - ppError (ImplVariableError doc f) = renderDoc $ + ppError (ImplVariableError doc f ev vp ctx dp) = renderDoc $ sep [ pretty f <> colon <+> pretty "Could not prove" , doc ] diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs index 6684cab4c2..de355f80e6 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs @@ -4786,6 +4786,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 = diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 790e5cc79f..3dfddcb8f3 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -3060,7 +3060,7 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl -- A failure translates to a call to the catch handler, which is the most recent -- Impl1_Catch, if one exists, or the SAW errorM function otherwise ([nuMP| Impl1_Fail err |], _) -> - tell [ppError $ mbLift err] >> mzero + tell [mbLift $ fmap ppError err] >> mzero ([nuMP| Impl1_Catch |], [nuMP| (MbPermImpls_Cons _ (MbPermImpls_Cons _ _ mb_impl1) mb_impl2) |]) -> From 6fef67a278b310ac750f75700104df0bb2ead1f9 Mon Sep 17 00:00:00 2001 From: Karl Smeltzer Date: Fri, 9 Jul 2021 15:43:35 -0700 Subject: [PATCH 07/28] remove Some from error constructor --- .../src/Verifier/SAW/Heapster/Implication.hs | 60 +++++++++++-------- 1 file changed, 35 insertions(+), 25 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs b/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs index edf6d0bff4..dd65a6ef49 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs @@ -319,7 +319,7 @@ data ImplError where ImplVariableError :: Doc ann -> String -> (Doc ann, ExprVar tp) -> (Doc ann, ValuePerm tp) -> CruCtx vars - -> Some DistPerms + -> DistPerms ps -> ImplError data LifetimeErrorType where @@ -330,24 +330,33 @@ data LifetimeErrorType where 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 sdp |] -> do + [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 - case mbMatch sdp of - [nuMP| Some mb_dps |] -> do - dp <- genSubst s mb_dps - return $ ImplVariableError (mbLift doc) (mbLift f) (mbLift xdoc, x') (mbLift pdoc, p') (mbLift ctx) (Some dp) + dp <- genSubst s mb_dp + return $ ImplVariableError (mbLift doc) (mbLift f) (mbLift xdoc, x') (mbLift pdoc, p') (mbLift ctx) dp instance Liftable LifetimeErrorType where mbLift e = case mbMatch e of @@ -6794,14 +6803,15 @@ implFailVarM :: NuMatchingAny1 r => String -> ExprVar tp -> ValuePerm tp -> implFailVarM f x p mb_p = use implStatePPInfo >>>= \ppinfo -> use implStateVars >>>= \ctx -> - findPermsContainingVar x >>>= \distperms -> - implFailM $ ImplVariableError - (ppImpl ppinfo x p mb_p) - f - (permPretty ppinfo x, x) - (permPretty ppinfo p, p) - ctx - distperms + findPermsContainingVar x >>>= \case + (Some distperms) -> + implFailM $ ImplVariableError + (ppImpl ppinfo x p mb_p) + f + (permPretty ppinfo x, x) + (permPretty ppinfo p, p) + ctx + distperms -- ImplVariableError -- :: Doc ann -> String From e2c9cd6bced00be9b9a7ed52e6b7c706866eb8d7 Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Tue, 27 Jul 2021 17:13:00 -0700 Subject: [PATCH 08/28] Export valueperms in full json detail --- .../src/Verifier/SAW/Heapster/IDESupport.hs | 67 ++++----- .../src/Verifier/SAW/Heapster/JSONExport.hs | 134 ++++++++++++++++++ src/SAWScript/HeapsterBuiltins.hs | 2 +- 3 files changed, 169 insertions(+), 34 deletions(-) create mode 100644 heapster-saw/src/Verifier/SAW/Heapster/JSONExport.hs diff --git a/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs b/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs index 8763bf6e92..d9c3e1f4c9 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs @@ -15,10 +15,9 @@ module Verifier.SAW.Heapster.IDESupport where import Control.Monad.Reader +import Control.Monad.Writer import Data.Aeson ( encodeFile, ToJSON ) -import Data.Bifunctor import Data.Binding.Hobbits -import Data.Binding.Hobbits.MonadBind import Data.Maybe import Data.Parameterized.Some (Some (..)) import qualified Data.Text as T @@ -34,6 +33,8 @@ import Verifier.SAW.Heapster.CruUtil import Verifier.SAW.Heapster.Implication import Verifier.SAW.Heapster.Permissions import Verifier.SAW.Heapster.TypedCrucible +import Verifier.SAW.Heapster.JSONExport(ppToJson) +import Data.Aeson (Value) import Debug.Trace @@ -45,7 +46,10 @@ printIDEInfo _penv tcfgs file ppinfo = encodeFile file $ IDELog (runWithLoc ppinfo tcfgs) -type ExtractionM = Reader (PPInfo, ProgramLoc) +type ExtractionM = ReaderT (PPInfo, ProgramLoc) (Writer [LogEntry]) + +emit :: LogEntry -> ExtractionM () +emit entry = tell [entry] -- | 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 @@ -53,6 +57,7 @@ type ExtractionM = Reader (PPInfo, ProgramLoc) data LogEntry = LogEntry { leLocation :: String + , leExport :: Value , lePermissions :: String } | LogError @@ -65,7 +70,7 @@ instance NuMatching LogEntry where nuMatchingProof = unsafeMbTypeRepr instance Liftable LogEntry where mbLift mb = case mbMatch mb of - [nuMP| LogEntry x y |] -> LogEntry (mbLift x) (mbLift y) + [nuMP| LogEntry x y z |] -> LogEntry (mbLift x) (mbLift y) (mbLift z) [nuMP| LogError x y |] -> LogError (mbLift x) (mbLift y) -- | A complete IDE info dump log, which is just a sequence of entries. Once @@ -77,36 +82,31 @@ instance ToJSON IDELog class ExtractLogEntries a where - extractLogEntries :: a -> ExtractionM [LogEntry] + extractLogEntries :: a -> ExtractionM () instance (PermCheckExtC ext) => ExtractLogEntries (TypedEntry TransPhase ext blocks tops ret args ghosts) where extractLogEntries te = do let loc = trace "typed entry loc" (mbLift $ fmap getFirstProgramLocTS (typedEntryBody te)) - errors <- withLoc loc $ + withLoc loc $ mbExtractLogEntries undefined (typedEntryBody te) - entryEntries <- mbExtractLogEntries undefined (typedEntryPermsIn te) - return $ trace "te entries" entryEntries <> trace "errors" errors + mbExtractLogEntries undefined (typedEntryPermsIn te) instance ExtractLogEntries (ValuePerms ctx) where - extractLogEntries vps = do - (ppi, loc) <- ask - return $ foldValuePerms (handlePerm ppi (snd $ ppLoc loc)) [] vps - where - handlePerm - :: PPInfo -> String -> [LogEntry] -> ValuePerm ctx' -> [LogEntry] - handlePerm ppi loc rest perm = - let permStr = permPrettyString ppi perm - in LogEntry loc permStr : rest + extractLogEntries vps = + do (ppi, loc) <- ask + let loc' = snd (ppLoc loc) + let strs = foldValuePerms (\xs vp -> (ppToJson ppi vp, permPrettyString ppi vp) : xs) [] vps + tell [LogEntry loc' export str | (export, str) <- strs] instance ExtractLogEntries (TypedStmtSeq ext blocks tops ret ps_in) where - extractLogEntries (TypedImplStmt (AnnotPermImpl str pimpl)) = + extractLogEntries (TypedImplStmt (AnnotPermImpl _str pimpl)) = -- fmap (setErrorMsg str) <$> extractLogEntries pimpl extractLogEntries pimpl extractLogEntries (TypedConsStmt loc _ _ rest) = do withLoc loc $ mbExtractLogEntries undefined rest - extractLogEntries (TypedTermStmt _ _) = return [] + extractLogEntries (TypedTermStmt _ _) = pure () instance ExtractLogEntries (PermImpl (TypedStmtSeq ext blocks tops ret) ps_in) where @@ -120,16 +120,16 @@ instance ExtractLogEntries (PermImpl1 ps_in ps_outs) where extractLogEntries (Impl1_Fail err) = -- The error message is available further up the stack, so we just leave it -- empty here - reader $ \(_, loc) -> [LogError (snd $ ppLoc loc) (ppError err)] - extractLogEntries _ = return [] + do (_, loc) <- ask + emit (LogError (snd (ppLoc loc)) (ppError err)) + extractLogEntries _ = pure () instance ExtractLogEntries (MbPermImpls (TypedStmtSeq ext blocks tops ret) ps_outs) where extractLogEntries (MbPermImpls_Cons ctx mbpis pis) = do - pisEntries <- mbExtractLogEntries ctx pis - mbpisEntries <- extractLogEntries mbpis - return $ pisEntries <> mbpisEntries - extractLogEntries MbPermImpls_Nil = return [] + mbExtractLogEntries ctx pis + extractLogEntries mbpis + extractLogEntries MbPermImpls_Nil = pure () instance (PermCheckExtC ext) => ExtractLogEntries (TypedCFG ext blocks ghosts inits ret) where @@ -138,25 +138,26 @@ instance (PermCheckExtC ext) instance (PermCheckExtC ext) => ExtractLogEntries (TypedBlockMap TransPhase ext blocks tops ret) where extractLogEntries tbm = - fmap concat $ sequence $ RL.mapToList extractLogEntries tbm + sequence_ $ RL.mapToList extractLogEntries tbm instance (PermCheckExtC ext) => ExtractLogEntries (TypedBlock TransPhase ext blocks tops ret args) where - extractLogEntries tb = fmap concat $ mapM helper $ _typedBlockEntries tb + extractLogEntries tb = mapM_ helper $ _typedBlockEntries tb where helper :: (PermCheckExtC ext) => Some (TypedEntry TransPhase ext blocks tops ret args) - -> ExtractionM [LogEntry] + -> ExtractionM () helper ste = case ste of Some te -> extractLogEntries te + mbExtractLogEntries - :: ExtractLogEntries a => CruCtx ctx -> Mb ctx a -> ExtractionM [LogEntry] + :: ExtractLogEntries a => CruCtx ctx -> Mb ctx a -> ExtractionM () mbExtractLogEntries ctx mb_a = - fmap mbLift $ strongMbM $ flip nuMultiWithElim1 mb_a $ \ns a -> - local (first $ ppInfoAddTypedExprNames ctx ns) $ - extractLogEntries a + ReaderT $ \(ppi, loc) -> + tell $ mbLift $ flip nuMultiWithElim1 mb_a $ \ns x -> + execWriter $ runReaderT (extractLogEntries x) (ppInfoAddTypedExprNames ctx ns ppi, loc) ppInfoAddTypedExprNames :: CruCtx ctx @@ -186,7 +187,7 @@ runWithLoc ppi = runWithLocHelper ppi' sstcfg = case trace "runWith Helper Case" sstcfg of Some (SomeTypedCFG tcfg) -> do let env = trace "runWithLocHelper" (ppi', getFirstProgramLoc tcfg) - runReader (trace "calling extract" extractLogEntries tcfg) env + execWriter (runReaderT (trace "calling extract" extractLogEntries tcfg) env) getFirstProgramLoc :: PermCheckExtC ext 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..47c0cea13b --- /dev/null +++ b/heapster-saw/src/Verifier/SAW/Heapster/JSONExport.hs @@ -0,0 +1,134 @@ +{-# Language TemplateHaskell #-} +{-# Language PolyKinds #-} +{-# Language GADTs #-} +{-# Language RankNTypes #-} +{-# Language OverloadedStrings #-} +{-# Language FlexibleContexts #-} +{-# Language DataKinds #-} +{-# Language PatternSynonyms #-} +{-# OPTIONS_GHC -Wno-orphans #-} +module Verifier.SAW.Heapster.JSONExport where + +import Data.Aeson ( defaultOptions, ToJSON(toJSON), Value(String), object ) +import Data.Aeson.TH ( deriveToJSON, mkToJSON ) +import Data.Binding.Hobbits +import Data.BitVector.Sized ( BV, pattern BV ) +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.Reflection ( give, Given(given) ) +import Data.Type.RList ( mapToList ) +import Lang.Crucible.FunctionHandle ( FnHandle ) +import Lang.Crucible.LLVM.Bytes ( Bytes ) +import Lang.Crucible.Types +import Verifier.SAW.Heapster.CruUtil ( CruCtx ) +import Verifier.SAW.Heapster.Permissions +import Verifier.SAW.Name ( Ident ) +import What4.FunctionName ( FunctionName ) + +deriveToJSON defaultOptions ''NamedPermName +deriveToJSON defaultOptions ''FnHandle +deriveToJSON defaultOptions ''NameSortRepr +deriveToJSON defaultOptions ''BoolRepr +deriveToJSON defaultOptions ''TypeRepr +deriveToJSON defaultOptions ''NatRepr +deriveToJSON defaultOptions ''SymbolRepr +deriveToJSON defaultOptions ''FloatInfoRepr +deriveToJSON defaultOptions ''FloatPrecisionRepr +deriveToJSON defaultOptions ''StringInfoRepr +deriveToJSON defaultOptions ''BaseTypeRepr +deriveToJSON defaultOptions ''NameReachConstr +deriveToJSON defaultOptions ''CruCtx + +-- Work-around for avoiding QuantifiedConstraints +class ToJSONf f where toJSONf :: f a -> Value +instance ToJSONf (FnHandle a) where toJSONf = toJSON +instance ToJSONf TypeRepr where toJSONf = toJSON +instance ToJSONf BaseTypeRepr where toJSONf = toJSON +instance Given PPInfo => ToJSONf PermExpr where toJSONf = toJSON +instance Given PPInfo => ToJSONf LOwnedPerm where toJSONf = toJSON +instance Given PPInfo => ToJSONf ValuePerm where toJSONf = toJSON +instance Given PPInfo => ToJSONf (Name :: CrucibleType -> Type) where toJSONf = toJSON + +instance Given PPInfo => ToJSON (LLVMArrayBorrow a) where + toJSON = $(mkToJSON defaultOptions ''LLVMArrayBorrow) +instance Given PPInfo => ToJSON (LLVMArrayField a) where + toJSON = $(mkToJSON defaultOptions ''LLVMArrayField) +instance Given PPInfo => ToJSON (NamedShape a b c) where + toJSON = $(mkToJSON defaultOptions ''NamedShape) +instance Given PPInfo => ToJSON (NamedShapeBody a b c) where + toJSON = $(mkToJSON defaultOptions ''NamedShapeBody) +instance Given PPInfo => ToJSON (AtomicPerm a) where + toJSON = $(mkToJSON defaultOptions ''AtomicPerm) +instance Given PPInfo => ToJSON (BVProp a) where + toJSON = $(mkToJSON defaultOptions ''BVProp) +instance Given PPInfo => ToJSON (PermOffset a) where + toJSON = $(mkToJSON defaultOptions ''PermOffset) +instance Given PPInfo => ToJSON (BVFactor a) where + toJSON = $(mkToJSON defaultOptions ''BVFactor) +instance Given PPInfo => ToJSON (FunPerm a b c) where + toJSON = $(mkToJSON defaultOptions ''FunPerm) +instance Given PPInfo => ToJSON (LLVMFieldShape a) where + toJSON = $(mkToJSON defaultOptions ''LLVMFieldShape) +instance Given PPInfo => ToJSON (LLVMFieldPerm a b) where + toJSON = $(mkToJSON defaultOptions ''LLVMFieldPerm) +instance Given PPInfo => ToJSON (LLVMBlockPerm a) where + toJSON = $(mkToJSON defaultOptions ''LLVMBlockPerm) +instance Given PPInfo => ToJSON (LLVMArrayIndex a) where + toJSON = $(mkToJSON defaultOptions ''LLVMArrayIndex) +instance Given PPInfo => ToJSON (BVRange a) where + toJSON = $(mkToJSON defaultOptions ''BVRange) +instance Given PPInfo => ToJSON (LLVMArrayPerm a) where + toJSON = $(mkToJSON defaultOptions ''LLVMArrayPerm) +instance Given PPInfo => ToJSON (LOwnedPerm a) where + toJSON = $(mkToJSON defaultOptions ''LOwnedPerm) +instance Given PPInfo => ToJSON (ValuePerm x) where + toJSON = $(mkToJSON defaultOptions ''ValuePerm) +instance Given PPInfo => ToJSON (PermExpr x) where + toJSON = $(mkToJSON defaultOptions ''PermExpr) + +instance ToJSON RWModality where + toJSON Read = String "Read" + toJSON Write = String "Write" + +instance ToJSON Bytes where + toJSON = toJSON . show + +instance ToJSON Ident where + toJSON = toJSON . show + +instance ToJSON FunctionName where + toJSON = toJSON . show + +instance ToJSON (BV n) where + toJSON (BV n) = toJSON n + +instance ToJSON (Nonce a b) where + toJSON = toJSON . indexValue + +instance ToJSONf f => ToJSON (RAssign f xs) where + toJSON x = toJSON (mapToList toJSONf x) + +instance Given PPInfo => ToJSON (Name (t :: CrucibleType)) where + toJSON x = toJSON (permPrettyString given x) + +instance ToJSONf f => ToJSON (Assignment f xs) where + toJSON x = toJSON (toListFC toJSONf x) + +instance (Given PPInfo, ToJSON b) => ToJSON (Mb (a :: RList CrucibleType) b) where + toJSON mb = mbLift $ flip nuMultiWithElim1 mb $ \names body -> + object [ + ("arguments", toJSON names), + ("body", toJSON body) + ] + +instance NuMatching Value where + nuMatchingProof = unsafeMbTypeRepr + +instance Liftable Value where + mbLift = unClosed . mbLift . fmap unsafeClose + +ppToJson :: PPInfo -> ValuePerm x -> Value +ppToJson ppi x = give ppi (toJSON x) diff --git a/src/SAWScript/HeapsterBuiltins.hs b/src/SAWScript/HeapsterBuiltins.hs index 9fac57e091..81ab26f06a 100644 --- a/src/SAWScript/HeapsterBuiltins.hs +++ b/src/SAWScript/HeapsterBuiltins.hs @@ -1076,7 +1076,7 @@ heapster_parse_test _bic _opts _some_lm@(Some lm) fn_name 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_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) From b59adb92ca80e3e814134b138757b2296ddfe450 Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Wed, 28 Jul 2021 12:39:35 -0700 Subject: [PATCH 09/28] Avoid generating orphan ToJSON instances and using Given --- heapster-saw/heapster-saw.cabal | 5 +- .../src/Verifier/SAW/Heapster/Implication.hs | 2 +- .../src/Verifier/SAW/Heapster/JSONExport.hs | 233 ++++++++++-------- 3 files changed, 137 insertions(+), 103 deletions(-) diff --git a/heapster-saw/heapster-saw.cabal b/heapster-saw/heapster-saw.cabal index fae38a45d9..90a7e4f4bf 100644 --- a/heapster-saw/heapster-saw.cabal +++ b/heapster-saw/heapster-saw.cabal @@ -37,7 +37,9 @@ library filepath, language-rust, hobbits ^>= 1.4, - aeson ^>= 1.5 + aeson ^>= 1.5, + th-abstraction, + template-haskell hs-source-dirs: src build-tool-depends: alex:alex, @@ -50,6 +52,7 @@ library Verifier.SAW.Heapster.IRTTranslation Verifier.SAW.Heapster.Lexer Verifier.SAW.Heapster.Located + 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/Implication.hs b/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs index 959d363dca..0c89e17c06 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs @@ -6903,7 +6903,7 @@ instance ErrorPretty ImplError where docx <+> pretty "not resolved when trying to prove:" <> softline <> docp - ppError (ImplVariableError doc f ev vp ctx dp) = renderDoc $ + ppError (ImplVariableError doc f _ev _vp _ctx _dp) = renderDoc $ sep [ pretty f <> colon <+> pretty "Could not prove" , doc ] diff --git a/heapster-saw/src/Verifier/SAW/Heapster/JSONExport.hs b/heapster-saw/src/Verifier/SAW/Heapster/JSONExport.hs index 47c0cea13b..bc7d11ab17 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/JSONExport.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/JSONExport.hs @@ -3,14 +3,16 @@ {-# Language GADTs #-} {-# Language RankNTypes #-} {-# Language OverloadedStrings #-} -{-# Language FlexibleContexts #-} +{-# Language FlexibleContexts, FlexibleInstances, DefaultSignatures #-} {-# Language DataKinds #-} {-# Language PatternSynonyms #-} +{-# Language ParallelListComp #-} {-# OPTIONS_GHC -Wno-orphans #-} + module Verifier.SAW.Heapster.JSONExport where -import Data.Aeson ( defaultOptions, ToJSON(toJSON), Value(String), object ) -import Data.Aeson.TH ( deriveToJSON, mkToJSON ) +import Control.Monad +import Data.Aeson ( ToJSON(toJSON), Value(..), object ) import Data.Binding.Hobbits import Data.BitVector.Sized ( BV, pattern BV ) import Data.Kind (Type) @@ -18,112 +20,19 @@ import Data.Parameterized.BoolRepr ( BoolRepr ) import Data.Parameterized.Context ( Assignment ) import Data.Parameterized.Nonce (Nonce, indexValue) import Data.Parameterized.TraversableFC ( FoldableFC(toListFC) ) -import Data.Reflection ( give, Given(given) ) +import Data.Text (Text) import Data.Type.RList ( mapToList ) +import GHC.Natural import Lang.Crucible.FunctionHandle ( FnHandle ) import Lang.Crucible.LLVM.Bytes ( Bytes ) 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.Permissions import Verifier.SAW.Name ( Ident ) import What4.FunctionName ( FunctionName ) -deriveToJSON defaultOptions ''NamedPermName -deriveToJSON defaultOptions ''FnHandle -deriveToJSON defaultOptions ''NameSortRepr -deriveToJSON defaultOptions ''BoolRepr -deriveToJSON defaultOptions ''TypeRepr -deriveToJSON defaultOptions ''NatRepr -deriveToJSON defaultOptions ''SymbolRepr -deriveToJSON defaultOptions ''FloatInfoRepr -deriveToJSON defaultOptions ''FloatPrecisionRepr -deriveToJSON defaultOptions ''StringInfoRepr -deriveToJSON defaultOptions ''BaseTypeRepr -deriveToJSON defaultOptions ''NameReachConstr -deriveToJSON defaultOptions ''CruCtx - --- Work-around for avoiding QuantifiedConstraints -class ToJSONf f where toJSONf :: f a -> Value -instance ToJSONf (FnHandle a) where toJSONf = toJSON -instance ToJSONf TypeRepr where toJSONf = toJSON -instance ToJSONf BaseTypeRepr where toJSONf = toJSON -instance Given PPInfo => ToJSONf PermExpr where toJSONf = toJSON -instance Given PPInfo => ToJSONf LOwnedPerm where toJSONf = toJSON -instance Given PPInfo => ToJSONf ValuePerm where toJSONf = toJSON -instance Given PPInfo => ToJSONf (Name :: CrucibleType -> Type) where toJSONf = toJSON - -instance Given PPInfo => ToJSON (LLVMArrayBorrow a) where - toJSON = $(mkToJSON defaultOptions ''LLVMArrayBorrow) -instance Given PPInfo => ToJSON (LLVMArrayField a) where - toJSON = $(mkToJSON defaultOptions ''LLVMArrayField) -instance Given PPInfo => ToJSON (NamedShape a b c) where - toJSON = $(mkToJSON defaultOptions ''NamedShape) -instance Given PPInfo => ToJSON (NamedShapeBody a b c) where - toJSON = $(mkToJSON defaultOptions ''NamedShapeBody) -instance Given PPInfo => ToJSON (AtomicPerm a) where - toJSON = $(mkToJSON defaultOptions ''AtomicPerm) -instance Given PPInfo => ToJSON (BVProp a) where - toJSON = $(mkToJSON defaultOptions ''BVProp) -instance Given PPInfo => ToJSON (PermOffset a) where - toJSON = $(mkToJSON defaultOptions ''PermOffset) -instance Given PPInfo => ToJSON (BVFactor a) where - toJSON = $(mkToJSON defaultOptions ''BVFactor) -instance Given PPInfo => ToJSON (FunPerm a b c) where - toJSON = $(mkToJSON defaultOptions ''FunPerm) -instance Given PPInfo => ToJSON (LLVMFieldShape a) where - toJSON = $(mkToJSON defaultOptions ''LLVMFieldShape) -instance Given PPInfo => ToJSON (LLVMFieldPerm a b) where - toJSON = $(mkToJSON defaultOptions ''LLVMFieldPerm) -instance Given PPInfo => ToJSON (LLVMBlockPerm a) where - toJSON = $(mkToJSON defaultOptions ''LLVMBlockPerm) -instance Given PPInfo => ToJSON (LLVMArrayIndex a) where - toJSON = $(mkToJSON defaultOptions ''LLVMArrayIndex) -instance Given PPInfo => ToJSON (BVRange a) where - toJSON = $(mkToJSON defaultOptions ''BVRange) -instance Given PPInfo => ToJSON (LLVMArrayPerm a) where - toJSON = $(mkToJSON defaultOptions ''LLVMArrayPerm) -instance Given PPInfo => ToJSON (LOwnedPerm a) where - toJSON = $(mkToJSON defaultOptions ''LOwnedPerm) -instance Given PPInfo => ToJSON (ValuePerm x) where - toJSON = $(mkToJSON defaultOptions ''ValuePerm) -instance Given PPInfo => ToJSON (PermExpr x) where - toJSON = $(mkToJSON defaultOptions ''PermExpr) - -instance ToJSON RWModality where - toJSON Read = String "Read" - toJSON Write = String "Write" - -instance ToJSON Bytes where - toJSON = toJSON . show - -instance ToJSON Ident where - toJSON = toJSON . show - -instance ToJSON FunctionName where - toJSON = toJSON . show - -instance ToJSON (BV n) where - toJSON (BV n) = toJSON n - -instance ToJSON (Nonce a b) where - toJSON = toJSON . indexValue - -instance ToJSONf f => ToJSON (RAssign f xs) where - toJSON x = toJSON (mapToList toJSONf x) - -instance Given PPInfo => ToJSON (Name (t :: CrucibleType)) where - toJSON x = toJSON (permPrettyString given x) - -instance ToJSONf f => ToJSON (Assignment f xs) where - toJSON x = toJSON (toListFC toJSONf x) - -instance (Given PPInfo, ToJSON b) => ToJSON (Mb (a :: RList CrucibleType) b) where - toJSON mb = mbLift $ flip nuMultiWithElim1 mb $ \names body -> - object [ - ("arguments", toJSON names), - ("body", toJSON body) - ] - instance NuMatching Value where nuMatchingProof = unsafeMbTypeRepr @@ -131,4 +40,126 @@ instance Liftable Value where mbLift = unClosed . mbLift . fmap unsafeClose ppToJson :: PPInfo -> ValuePerm x -> Value -ppToJson ppi x = give ppi (toJSON x) +ppToJson = jsonExport + +class JsonExport a where + jsonExport :: PPInfo -> a -> Value + default jsonExport :: ToJSON a => PPInfo -> a -> Value + jsonExport _ = toJSON + +instance JsonExport (Name (t :: CrucibleType)) where + jsonExport ppi x = toJSON (permPrettyString ppi x) + +instance JsonExport1 f => JsonExport (Assignment f x) where + jsonExport ppi x = toJSON (toListFC (jsonExport1 ppi) x) + +instance JsonExport1 f => JsonExport (RAssign f x) where + jsonExport ppi x = toJSON (mapToList (jsonExport1 ppi) x) + +instance JsonExport b => JsonExport (Mb (a :: RList CrucibleType) b) where + jsonExport ppi mb = mbLift $ flip nuMultiWithElim1 mb $ \names body -> + object [ + ("tag", "Mb"), + ("arguments", jsonExport ppi names), + ("body", jsonExport ppi body) + ] + +instance JsonExport (Nonce a b) where + jsonExport _ = toJSON . indexValue + +instance JsonExport Bytes where + jsonExport _ = toJSON . show + +instance JsonExport Ident where + jsonExport _ = toJSON . show + +instance JsonExport FunctionName where + jsonExport _ = toJSON . show + +instance JsonExport a => JsonExport (Maybe a) where + jsonExport _ Nothing = Null + jsonExport ppi (Just x) = jsonExport ppi x + +instance (JsonExport a, JsonExport b) => JsonExport (a,b) where + jsonExport ppi (x,y) = toJSON (jsonExport ppi x, jsonExport ppi y) + +instance JsonExport a => JsonExport [a] where + jsonExport ppi xs = toJSON (jsonExport ppi <$> xs) + +instance JsonExport RWModality where + jsonExport _ Read = String "Read" + jsonExport _ Write = String "Write" + +instance JsonExport (BV n) where + jsonExport _ (BV n) = toJSON n + +instance JsonExport Natural +instance JsonExport Integer +instance JsonExport Int +instance JsonExport Bool +instance JsonExport Text +instance {-# OVERLAPPING #-} JsonExport String + + +class JsonExport1 f where + jsonExport1 :: PPInfo -> f a -> Value + default jsonExport1 :: JsonExport (f a) => PPInfo -> f a -> Value + jsonExport1 = jsonExport + +instance JsonExport1 BaseTypeRepr +instance JsonExport1 TypeRepr +instance JsonExport1 (Name :: CrucibleType -> Type) +instance JsonExport1 LOwnedPerm +instance JsonExport1 PermExpr +instance JsonExport1 ValuePerm + + +let newNames :: String -> Int -> TH.Q [TH.Name] + newNames base n = forM [0..n-1] $ \i -> TH.newName (base ++ show i) + + -- build :: String -> TH.ConstructorVariant -> [TH.ExpQ] -> TH.ExpQ + -- Record, use record field names as JSON field names + build 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 + build tag _ [] = [| [("tag", tag)] |] + + -- One field, just report that field + build tag _ [x] = [| [("tag", tag), ("contents", $x)] |] + + -- Multiple fields, report them as a list + build tag _ xs = [| [("tag", tag), ("contents", toJSON $(TH.listE xs))] |] + + generateJsonExport n = + do info <- TH.reifyDatatype n + tVars <- newNames "a" (length (TH.datatypeInstTypes info)) + let t = foldl TH.AppT (TH.ConT n) (TH.VarT <$> tVars) + [d| instance JsonExport $(pure t) where + jsonExport _ppi x = $( + TH.caseE [|x|] [ + do fieldVars <- newNames "x" (length (TH.constructorFields con)) + TH.match + (TH.conP (TH.constructorName con) (TH.varP <$> fieldVars)) + (TH.normalB [| object + $(build + (TH.nameBase (TH.constructorName con)) + (TH.constructorVariant con) + [ [| jsonExport _ppi $(TH.varE v) |] | v <- fieldVars ]) |]) + [] + | con <- TH.datatypeCons info ]) |] + + typesNeeded = + [''AtomicPerm, ''BaseTypeRepr, ''BoolRepr, ''BVFactor, ''BVProp, + ''BVRange, ''CruCtx, ''FloatInfoRepr, ''FloatPrecisionRepr, + ''FnHandle, ''FunPerm, ''LLVMArrayBorrow, ''LLVMArrayField, + ''LLVMArrayIndex, ''LLVMArrayPerm, ''LLVMBlockPerm, ''LLVMFieldPerm, + ''LLVMFieldShape, ''LOwnedPerm, ''NamedPermName, ''NamedShape, + ''NamedShapeBody, ''NameReachConstr, ''NameSortRepr, ''NatRepr, + ''PermExpr, ''PermOffset, ''StringInfoRepr, ''SymbolRepr, ''TypeRepr, + ''ValuePerm] + + in concat <$> traverse generateJsonExport typesNeeded + From 65ae7dd4edd6cc0b96662e0f8443339d117097a5 Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Wed, 28 Jul 2021 12:59:17 -0700 Subject: [PATCH 10/28] refine jsonexport instances --- .../src/Verifier/SAW/Heapster/JSONExport.hs | 17 +++++------------ 1 file changed, 5 insertions(+), 12 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/JSONExport.hs b/heapster-saw/src/Verifier/SAW/Heapster/JSONExport.hs index bc7d11ab17..7807ff73e9 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/JSONExport.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/JSONExport.hs @@ -22,7 +22,7 @@ import Data.Parameterized.Nonce (Nonce, indexValue) import Data.Parameterized.TraversableFC ( FoldableFC(toListFC) ) import Data.Text (Text) import Data.Type.RList ( mapToList ) -import GHC.Natural +import GHC.Natural (Natural) import Lang.Crucible.FunctionHandle ( FnHandle ) import Lang.Crucible.LLVM.Bytes ( Bytes ) import Lang.Crucible.Types @@ -59,8 +59,7 @@ instance JsonExport1 f => JsonExport (RAssign f x) where instance JsonExport b => JsonExport (Mb (a :: RList CrucibleType) b) where jsonExport ppi mb = mbLift $ flip nuMultiWithElim1 mb $ \names body -> object [ - ("tag", "Mb"), - ("arguments", jsonExport ppi names), + ("args", jsonExport ppi names), ("body", jsonExport ppi body) ] @@ -86,10 +85,6 @@ instance (JsonExport a, JsonExport b) => JsonExport (a,b) where instance JsonExport a => JsonExport [a] where jsonExport ppi xs = toJSON (jsonExport ppi <$> xs) -instance JsonExport RWModality where - jsonExport _ Read = String "Read" - jsonExport _ Write = String "Write" - instance JsonExport (BV n) where jsonExport _ (BV n) = toJSON n @@ -100,7 +95,6 @@ instance JsonExport Bool instance JsonExport Text instance {-# OVERLAPPING #-} JsonExport String - class JsonExport1 f where jsonExport1 :: PPInfo -> f a -> Value default jsonExport1 :: JsonExport (f a) => PPInfo -> f a -> Value @@ -113,17 +107,16 @@ instance JsonExport1 LOwnedPerm instance JsonExport1 PermExpr instance JsonExport1 ValuePerm - let newNames :: String -> Int -> TH.Q [TH.Name] newNames base n = forM [0..n-1] $ \i -> TH.newName (base ++ show i) - -- build :: String -> TH.ConstructorVariant -> [TH.ExpQ] -> TH.ExpQ + build :: String -> TH.ConstructorVariant -> [TH.ExpQ] -> TH.ExpQ -- Record, use record field names as JSON field names build 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 build tag _ [] = [| [("tag", tag)] |] @@ -159,7 +152,7 @@ let newNames :: String -> Int -> TH.Q [TH.Name] ''LLVMFieldShape, ''LOwnedPerm, ''NamedPermName, ''NamedShape, ''NamedShapeBody, ''NameReachConstr, ''NameSortRepr, ''NatRepr, ''PermExpr, ''PermOffset, ''StringInfoRepr, ''SymbolRepr, ''TypeRepr, - ''ValuePerm] + ''ValuePerm, ''RWModality] in concat <$> traverse generateJsonExport typesNeeded From 931d8023e3376371bfbd8d4fbca6a46f1a2fba92 Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Wed, 28 Jul 2021 16:30:20 -0700 Subject: [PATCH 11/28] Document JSONExport --- .../src/Verifier/SAW/Heapster/JSONExport.hs | 156 ++++++++++-------- 1 file changed, 89 insertions(+), 67 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/JSONExport.hs b/heapster-saw/src/Verifier/SAW/Heapster/JSONExport.hs index 7807ff73e9..9fd4930a5e 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/JSONExport.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/JSONExport.hs @@ -1,26 +1,27 @@ -{-# Language TemplateHaskell #-} -{-# Language PolyKinds #-} -{-# Language GADTs #-} -{-# Language RankNTypes #-} -{-# Language OverloadedStrings #-} -{-# Language FlexibleContexts, FlexibleInstances, DefaultSignatures #-} -{-# Language DataKinds #-} -{-# Language PatternSynonyms #-} -{-# Language ParallelListComp #-} -{-# OPTIONS_GHC -Wno-orphans #-} - -module Verifier.SAW.Heapster.JSONExport where - -import Control.Monad +{-# 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, pattern BV ) +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 ) @@ -39,54 +40,57 @@ instance NuMatching Value where instance Liftable Value where mbLift = unClosed . mbLift . fmap unsafeClose -ppToJson :: PPInfo -> ValuePerm x -> Value -ppToJson = jsonExport +-- | 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 :: PPInfo -> a -> Value - default jsonExport :: ToJSON a => PPInfo -> a -> Value - jsonExport _ = toJSON + jsonExport :: (?ppi::PPInfo) => a -> Value + default jsonExport :: ToJSON a => (?ppi::PPInfo) => a -> Value + jsonExport = toJSON instance JsonExport (Name (t :: CrucibleType)) where - jsonExport ppi x = toJSON (permPrettyString ppi x) + jsonExport = toJSON . permPrettyString ?ppi instance JsonExport1 f => JsonExport (Assignment f x) where - jsonExport ppi x = toJSON (toListFC (jsonExport1 ppi) x) + jsonExport = toJSON . toListFC jsonExport1 instance JsonExport1 f => JsonExport (RAssign f x) where - jsonExport ppi x = toJSON (mapToList (jsonExport1 ppi) x) + jsonExport = toJSON . mapToList jsonExport1 instance JsonExport b => JsonExport (Mb (a :: RList CrucibleType) b) where - jsonExport ppi mb = mbLift $ flip nuMultiWithElim1 mb $ \names body -> + jsonExport mb = mbLift $ flip nuMultiWithElim1 mb $ \names body -> object [ - ("args", jsonExport ppi names), - ("body", jsonExport ppi body) + ("args", jsonExport names), + ("body", jsonExport body) ] instance JsonExport (Nonce a b) where - jsonExport _ = toJSON . indexValue + jsonExport = toJSON . indexValue instance JsonExport Bytes where - jsonExport _ = toJSON . show + jsonExport = toJSON . show -- Show instance is pretty instance JsonExport Ident where - jsonExport _ = toJSON . show + jsonExport = toJSON . show -- Show instance is pretty instance JsonExport FunctionName where - jsonExport _ = toJSON . show + jsonExport = toJSON . show -- Show instance is pretty instance JsonExport a => JsonExport (Maybe a) where - jsonExport _ Nothing = Null - jsonExport ppi (Just x) = jsonExport ppi x + jsonExport = maybe Null jsonExport instance (JsonExport a, JsonExport b) => JsonExport (a,b) where - jsonExport ppi (x,y) = toJSON (jsonExport ppi x, jsonExport ppi y) + jsonExport (x,y) = toJSON (jsonExport x, jsonExport y) instance JsonExport a => JsonExport [a] where - jsonExport ppi xs = toJSON (jsonExport ppi <$> xs) + jsonExport xs = toJSON (jsonExport <$> xs) instance JsonExport (BV n) where - jsonExport _ (BV n) = toJSON n + jsonExport = toJSON . asUnsigned instance JsonExport Natural instance JsonExport Integer @@ -95,9 +99,10 @@ instance JsonExport Bool instance JsonExport Text instance {-# OVERLAPPING #-} JsonExport String +-- | 'JsonExport' lifted to work on types with higher kinds class JsonExport1 f where - jsonExport1 :: PPInfo -> f a -> Value - default jsonExport1 :: JsonExport (f a) => PPInfo -> f a -> Value + jsonExport1 :: (?ppi::PPInfo) => f a -> Value + default jsonExport1 :: JsonExport (f a) => (?ppi::PPInfo) => f a -> Value jsonExport1 = jsonExport instance JsonExport1 BaseTypeRepr @@ -107,43 +112,60 @@ instance JsonExport1 LOwnedPerm instance JsonExport1 PermExpr instance JsonExport1 ValuePerm -let newNames :: String -> Int -> TH.Q [TH.Name] - newNames base n = forM [0..n-1] $ \i -> TH.newName (base ++ show i) - - build :: String -> TH.ConstructorVariant -> [TH.ExpQ] -> TH.ExpQ - -- Record, use record field names as JSON field names - build tag (TH.RecordConstructor fieldNames) xs = +-- 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 - build tag _ [] = [| [("tag", tag)] |] - - -- One field, just report that field - build tag _ [x] = [| [("tag", tag), ("contents", $x)] |] - - -- Multiple fields, report them as a list - build tag _ xs = [| [("tag", tag), ("contents", toJSON $(TH.listE xs))] |] - + 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 - tVars <- newNames "a" (length (TH.datatypeInstTypes info)) - let t = foldl TH.AppT (TH.ConT n) (TH.VarT <$> tVars) - [d| instance JsonExport $(pure t) where - jsonExport _ppi x = $( - TH.caseE [|x|] [ - do fieldVars <- newNames "x" (length (TH.constructorFields con)) - TH.match - (TH.conP (TH.constructorName con) (TH.varP <$> fieldVars)) - (TH.normalB [| object - $(build - (TH.nameBase (TH.constructorName con)) - (TH.constructorVariant con) - [ [| jsonExport _ppi $(TH.varE v) |] | v <- fieldVars ]) |]) - [] - | con <- TH.datatypeCons info ]) |] + 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, @@ -154,5 +176,5 @@ let newNames :: String -> Int -> TH.Q [TH.Name] ''PermExpr, ''PermOffset, ''StringInfoRepr, ''SymbolRepr, ''TypeRepr, ''ValuePerm, ''RWModality] - in concat <$> traverse generateJsonExport typesNeeded + in traverse generateJsonExport typesNeeded From 2ad2225e9ce65fce995745f60f67709f2a808d6a Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Fri, 30 Jul 2021 10:08:25 -0700 Subject: [PATCH 12/28] Remove need for passing undefined --- .../src/Verifier/SAW/Heapster/IDESupport.hs | 35 ++++++------------- 1 file changed, 10 insertions(+), 25 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs b/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs index d9c3e1f4c9..4e47489640 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs @@ -11,7 +11,6 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} - module Verifier.SAW.Heapster.IDESupport where import Control.Monad.Reader @@ -89,9 +88,8 @@ instance (PermCheckExtC ext) (TypedEntry TransPhase ext blocks tops ret args ghosts) where extractLogEntries te = do let loc = trace "typed entry loc" (mbLift $ fmap getFirstProgramLocTS (typedEntryBody te)) - withLoc loc $ - mbExtractLogEntries undefined (typedEntryBody te) - mbExtractLogEntries undefined (typedEntryPermsIn te) + withLoc loc (mbExtractLogEntries (typedEntryBody te)) + mbExtractLogEntries (typedEntryPermsIn te) instance ExtractLogEntries (ValuePerms ctx) where extractLogEntries vps = @@ -105,7 +103,7 @@ instance ExtractLogEntries (TypedStmtSeq ext blocks tops ret ps_in) where -- fmap (setErrorMsg str) <$> extractLogEntries pimpl extractLogEntries pimpl extractLogEntries (TypedConsStmt loc _ _ rest) = do - withLoc loc $ mbExtractLogEntries undefined rest + withLoc loc $ mbExtractLogEntries rest extractLogEntries (TypedTermStmt _ _) = pure () instance ExtractLogEntries @@ -126,8 +124,8 @@ instance ExtractLogEntries (PermImpl1 ps_in ps_outs) where instance ExtractLogEntries (MbPermImpls (TypedStmtSeq ext blocks tops ret) ps_outs) where - extractLogEntries (MbPermImpls_Cons ctx mbpis pis) = do - mbExtractLogEntries ctx pis + extractLogEntries (MbPermImpls_Cons _ mbpis pis) = do + mbExtractLogEntries pis extractLogEntries mbpis extractLogEntries MbPermImpls_Nil = pure () @@ -142,29 +140,16 @@ instance (PermCheckExtC ext) instance (PermCheckExtC ext) => ExtractLogEntries (TypedBlock TransPhase ext blocks tops ret args) where - extractLogEntries tb = mapM_ helper $ _typedBlockEntries tb - where - helper - :: (PermCheckExtC ext) - => Some (TypedEntry TransPhase ext blocks tops ret args) - -> ExtractionM () - helper ste = case ste of - Some te -> extractLogEntries te + extractLogEntries tb = + mapM_ (\(Some te) -> extractLogEntries te) $ _typedBlockEntries tb mbExtractLogEntries - :: ExtractLogEntries a => CruCtx ctx -> Mb ctx a -> ExtractionM () -mbExtractLogEntries ctx mb_a = + :: ExtractLogEntries a => Mb (ctx :: RList CrucibleType) a -> ExtractionM () +mbExtractLogEntries mb_a = ReaderT $ \(ppi, loc) -> tell $ mbLift $ flip nuMultiWithElim1 mb_a $ \ns x -> - execWriter $ runReaderT (extractLogEntries x) (ppInfoAddTypedExprNames ctx ns ppi, loc) - -ppInfoAddTypedExprNames - :: CruCtx ctx - -> RAssign Name (tps :: RList CrucibleType) - -> PPInfo - -> PPInfo -ppInfoAddTypedExprNames _ = ppInfoAddExprNames "x" + execWriter $ runReaderT (extractLogEntries x) (ppInfoAddExprNames "x" ns ppi, loc) typedStmtOutCtx :: TypedStmt ext rets ps_in ps_next -> CruCtx rets typedStmtOutCtx = error "FIXME: write typedStmtOutCtx" From ce3313ba442dbfe41d181c5c8f2f1287ec7fb5cb Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Fri, 30 Jul 2021 11:10:32 -0700 Subject: [PATCH 13/28] JSONExport support for PermImpls --- .../src/Verifier/SAW/Heapster/JSONExport.hs | 28 ++++++++++++++++++- 1 file changed, 27 insertions(+), 1 deletion(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/JSONExport.hs b/heapster-saw/src/Verifier/SAW/Heapster/JSONExport.hs index 9fd4930a5e..cf4b21e75f 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/JSONExport.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/JSONExport.hs @@ -30,6 +30,7 @@ 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 ) @@ -80,6 +81,9 @@ instance JsonExport Ident where 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 @@ -92,6 +96,23 @@ instance JsonExport a => JsonExport [a] where 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 @@ -111,6 +132,8 @@ instance JsonExport1 (Name :: CrucibleType -> Type) instance JsonExport1 LOwnedPerm instance JsonExport1 PermExpr instance JsonExport1 ValuePerm +instance JsonExport1 VarAndPerm +instance JsonExport1 Proxy -- This code generates generic JSON generation instances for -- algebraic data types. @@ -174,7 +197,10 @@ let fields :: String -> TH.ConstructorVariant -> [TH.ExpQ] -> TH.ExpQ ''LLVMFieldShape, ''LOwnedPerm, ''NamedPermName, ''NamedShape, ''NamedShapeBody, ''NameReachConstr, ''NameSortRepr, ''NatRepr, ''PermExpr, ''PermOffset, ''StringInfoRepr, ''SymbolRepr, ''TypeRepr, - ''ValuePerm, ''RWModality] + ''ValuePerm, ''RWModality, ''PermImpl1, ''Member, ''SimplImpl, + ''VarAndPerm, ''LocalPermImpl, ''LifetimeFunctor, ''NamedPerm, + ''RecPerm, ''OpaquePerm, ''DefinedPerm, ''ReachMethods, ''MbPermImpls + ] in traverse generateJsonExport typesNeeded From df114c16afb0e1e233bf454a05eeaf014a311958 Mon Sep 17 00:00:00 2001 From: Karl Smeltzer Date: Thu, 12 Aug 2021 13:12:25 -0700 Subject: [PATCH 14/28] export entrypoint and caller ID information --- .../src/Verifier/SAW/Heapster/IDESupport.hs | 68 +++++++++++++------ 1 file changed, 49 insertions(+), 19 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs b/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs index 4e47489640..07853b7d8f 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs @@ -35,8 +35,6 @@ import Verifier.SAW.Heapster.TypedCrucible import Verifier.SAW.Heapster.JSONExport(ppToJson) import Data.Aeson (Value) -import Debug.Trace - -- | The entry point for dumping a Heapster environment to a file for IDE -- consumption. @@ -56,6 +54,8 @@ emit entry = tell [entry] data LogEntry = LogEntry { leLocation :: String + , leEntryId :: LogEntryID + , leCallers :: [LogEntryID] , leExport :: Value , lePermissions :: String } @@ -69,9 +69,22 @@ instance NuMatching LogEntry where nuMatchingProof = unsafeMbTypeRepr instance Liftable LogEntry where mbLift mb = case mbMatch mb of - [nuMP| LogEntry x y z |] -> LogEntry (mbLift x) (mbLift y) (mbLift z) + [nuMP| LogEntry v w x y z |] -> LogEntry (mbLift v) (mbLift w) (mbLift x) (mbLift y) (mbLift z) [nuMP| LogError x y |] -> LogError (mbLift x) (mbLift y) + +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 { @@ -87,16 +100,18 @@ instance (PermCheckExtC ext) => ExtractLogEntries (TypedEntry TransPhase ext blocks tops ret args ghosts) where extractLogEntries te = do - let loc = trace "typed entry loc" (mbLift $ fmap getFirstProgramLocTS (typedEntryBody te)) + let loc = mbLift $ fmap getFirstProgramLocTS (typedEntryBody te) withLoc loc (mbExtractLogEntries (typedEntryBody te)) - mbExtractLogEntries (typedEntryPermsIn te) + let entryId = mkLogEntryID $ typedEntryID te + let callers = callerIDs $ typedEntryCallers te + mbValPermEntries entryId callers (typedEntryPermsIn te) + +mkLogEntryID :: TypedEntryID blocks args -> LogEntryID +mkLogEntryID = uncurry LogEntryID . entryIDIndices -instance ExtractLogEntries (ValuePerms ctx) where - extractLogEntries vps = - do (ppi, loc) <- ask - let loc' = snd (ppLoc loc) - let strs = foldValuePerms (\xs vp -> (ppToJson ppi vp, permPrettyString ppi vp) : xs) [] vps - tell [LogEntry loc' export str | (export, str) <- strs] +callerIDs :: [Some (TypedCallSite phase blocks tops args ghosts)] -> [LogEntryID] +callerIDs = map $ \(Some tcs) -> case typedCallSiteID tcs of + TypedCallSiteID tei _ _ _ -> mkLogEntryID tei instance ExtractLogEntries (TypedStmtSeq ext blocks tops ret ps_in) where extractLogEntries (TypedImplStmt (AnnotPermImpl _str pimpl)) = @@ -116,8 +131,6 @@ instance ExtractLogEntries instance ExtractLogEntries (PermImpl1 ps_in ps_outs) where extractLogEntries (Impl1_Fail err) = - -- The error message is available further up the stack, so we just leave it - -- empty here do (_, loc) <- ask emit (LogError (snd (ppLoc loc)) (ppError err)) extractLogEntries _ = pure () @@ -141,9 +154,9 @@ instance (PermCheckExtC ext) instance (PermCheckExtC ext) => ExtractLogEntries (TypedBlock TransPhase ext blocks tops ret args) where extractLogEntries tb = + -- block here mapM_ (\(Some te) -> extractLogEntries te) $ _typedBlockEntries tb - mbExtractLogEntries :: ExtractLogEntries a => Mb (ctx :: RList CrucibleType) a -> ExtractionM () mbExtractLogEntries mb_a = @@ -151,6 +164,24 @@ mbExtractLogEntries mb_a = tell $ mbLift $ flip nuMultiWithElim1 mb_a $ \ns x -> execWriter $ runReaderT (extractLogEntries x) (ppInfoAddExprNames "x" ns ppi, loc) +-- TODO: The next two functions are a hack, and we should probably rethink how +-- this is architected a bit. They don't fit into the type signature of +-- `ExtractLogEntries` currently because we push down the extra information +-- about the entrypoint IDs which we need wherever `LogEntry`s are created. + +mbValPermEntries :: LogEntryID -> [LogEntryID] -> Mb ctx (ValuePerms ctx) -> ExtractionM () +mbValPermEntries entryId callers mb_vp = + ReaderT $ \(ppi, loc) -> + tell $ mbLift $ flip nuMultiWithElim1 mb_vp $ \ns vp -> + execWriter $ runReaderT (valPermEntries entryId callers vp) (ppInfoAddExprNames "x" ns ppi, loc) + +valPermEntries :: LogEntryID -> [LogEntryID] -> ValuePerms ctx -> ExtractionM () +valPermEntries entryId callers vps = do + (ppi, loc) <- ask + let loc' = snd (ppLoc loc) + let strs = foldValuePerms (\xs vp -> (ppToJson ppi vp, permPrettyString ppi vp) : xs) [] vps + tell [LogEntry loc' entryId callers export str | (export, str) <- strs] + typedStmtOutCtx :: TypedStmt ext rets ps_in ps_next -> CruCtx rets typedStmtOutCtx = error "FIXME: write typedStmtOutCtx" @@ -165,20 +196,19 @@ setErrorMsg msg le@LogEntry {} = runWithLoc :: PPInfo -> [Some SomeTypedCFG] -> [LogEntry] runWithLoc ppi = - trace "runWithLoc" concatMap (runWithLocHelper ppi) where runWithLocHelper :: PPInfo -> Some SomeTypedCFG -> [LogEntry] - runWithLocHelper ppi' sstcfg = case trace "runWith Helper Case" sstcfg of + runWithLocHelper ppi' sstcfg = case sstcfg of Some (SomeTypedCFG tcfg) -> do - let env = trace "runWithLocHelper" (ppi', getFirstProgramLoc tcfg) - execWriter (runReaderT (trace "calling extract" extractLogEntries tcfg) env) + let env = (ppi', getFirstProgramLoc tcfg) + execWriter (runReaderT (extractLogEntries tcfg) env) getFirstProgramLoc :: PermCheckExtC ext => TypedCFG ext blocks ghosts inits ret -> ProgramLoc getFirstProgramLoc tcfg = - case trace "getFirstProgramLoc" listToMaybe $ catMaybes $ + case listToMaybe $ catMaybes $ RL.mapToList getFirstProgramLocBM $ tpcfgBlockMap tcfg of Just pl -> pl _ -> error "Unable to get initial program location" From 887570856fcdbef40a33bb876874e6b6a506a5d6 Mon Sep 17 00:00:00 2001 From: Karl Smeltzer Date: Thu, 12 Aug 2021 14:56:25 -0700 Subject: [PATCH 15/28] cleanup imports, 80 char columns --- .../src/Verifier/SAW/Heapster/IDESupport.hs | 51 ++++++++++++++----- 1 file changed, 37 insertions(+), 14 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs b/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs index 07853b7d8f..78ae3425ce 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs @@ -14,26 +14,42 @@ module Verifier.SAW.Heapster.IDESupport where import Control.Monad.Reader + ( MonadReader (ask, local), + ReaderT (..), + ) import Control.Monad.Writer -import Data.Aeson ( encodeFile, ToJSON ) + ( MonadWriter (tell), + Writer, + execWriter, + ) +import Data.Aeson (ToJSON, Value, encodeFile) import Data.Binding.Hobbits -import Data.Maybe + ( Liftable (..), + Mb, + NuMatching (..), + RList, + mbMatch, + nuMP, + nuMultiWithElim1, + unsafeMbTypeRepr, + ) +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.Types -import What4.FunctionName ( FunctionName(functionName) ) +import GHC.Generics (Generic) +import Lang.Crucible.Types (CrucibleType) +import What4.FunctionName (FunctionName (functionName)) import What4.ProgramLoc - ( Position(InternalPos, SourcePos, BinaryPos, OtherPos), - ProgramLoc(..) ) + ( Position (BinaryPos, InternalPos, OtherPos, SourcePos), + ProgramLoc (..), + ) import Verifier.SAW.Heapster.CruUtil import Verifier.SAW.Heapster.Implication import Verifier.SAW.Heapster.Permissions import Verifier.SAW.Heapster.TypedCrucible import Verifier.SAW.Heapster.JSONExport(ppToJson) -import Data.Aeson (Value) -- | The entry point for dumping a Heapster environment to a file for IDE @@ -69,7 +85,8 @@ 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| LogEntry v w x y z |] -> + LogEntry (mbLift v) (mbLift w) (mbLift x) (mbLift y) (mbLift z) [nuMP| LogError x y |] -> LogError (mbLift x) (mbLift y) @@ -154,7 +171,6 @@ instance (PermCheckExtC ext) instance (PermCheckExtC ext) => ExtractLogEntries (TypedBlock TransPhase ext blocks tops ret args) where extractLogEntries tb = - -- block here mapM_ (\(Some te) -> extractLogEntries te) $ _typedBlockEntries tb mbExtractLogEntries @@ -162,24 +178,31 @@ mbExtractLogEntries mbExtractLogEntries mb_a = ReaderT $ \(ppi, loc) -> tell $ mbLift $ flip nuMultiWithElim1 mb_a $ \ns x -> - execWriter $ runReaderT (extractLogEntries x) (ppInfoAddExprNames "x" ns ppi, loc) + execWriter $ runReaderT (extractLogEntries x) + (ppInfoAddExprNames "x" ns ppi, loc) -- TODO: The next two functions are a hack, and we should probably rethink how -- this is architected a bit. They don't fit into the type signature of -- `ExtractLogEntries` currently because we push down the extra information -- about the entrypoint IDs which we need wherever `LogEntry`s are created. -mbValPermEntries :: LogEntryID -> [LogEntryID] -> Mb ctx (ValuePerms ctx) -> ExtractionM () +mbValPermEntries + :: LogEntryID + -> [LogEntryID] + -> Mb ctx (ValuePerms ctx) + -> ExtractionM () mbValPermEntries entryId callers mb_vp = ReaderT $ \(ppi, loc) -> tell $ mbLift $ flip nuMultiWithElim1 mb_vp $ \ns vp -> - execWriter $ runReaderT (valPermEntries entryId callers vp) (ppInfoAddExprNames "x" ns ppi, loc) + execWriter $ runReaderT (valPermEntries entryId callers vp) + (ppInfoAddExprNames "x" ns ppi, loc) valPermEntries :: LogEntryID -> [LogEntryID] -> ValuePerms ctx -> ExtractionM () valPermEntries entryId callers vps = do (ppi, loc) <- ask let loc' = snd (ppLoc loc) - let strs = foldValuePerms (\xs vp -> (ppToJson ppi vp, permPrettyString ppi vp) : xs) [] vps + let strs = foldValuePerms (\xs vp -> + (ppToJson ppi vp, permPrettyString ppi vp) : xs) [] vps tell [LogEntry loc' entryId callers export str | (export, str) <- strs] typedStmtOutCtx :: TypedStmt ext rets ps_in ps_next -> CruCtx rets From 5f12cc470a55e4f173ddac00bf465ea8b3fe07bd Mon Sep 17 00:00:00 2001 From: Karl Smeltzer Date: Thu, 12 Aug 2021 15:09:46 -0700 Subject: [PATCH 16/28] heapster: export function name for IDE --- .../src/Verifier/SAW/Heapster/IDESupport.hs | 42 ++++++++++++------- 1 file changed, 27 insertions(+), 15 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs b/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs index 78ae3425ce..67648acb4f 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs @@ -38,6 +38,7 @@ 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 @@ -59,7 +60,7 @@ printIDEInfo _penv tcfgs file ppinfo = encodeFile file $ IDELog (runWithLoc ppinfo tcfgs) -type ExtractionM = ReaderT (PPInfo, ProgramLoc) (Writer [LogEntry]) +type ExtractionM = ReaderT (PPInfo, ProgramLoc, String) (Writer [LogEntry]) emit :: LogEntry -> ExtractionM () emit entry = tell [entry] @@ -72,12 +73,14 @@ data LogEntry { leLocation :: String , leEntryId :: LogEntryID , leCallers :: [LogEntryID] + , leFunctionName :: String , leExport :: Value , lePermissions :: String } | LogError { lerrLocation :: String , lerrError :: String + , lerrFunctionName :: String } deriving (Generic, Show) instance ToJSON LogEntry @@ -85,9 +88,11 @@ 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 |] -> LogError (mbLift x) (mbLift y) + [nuMP| LogEntry u v w x y z |] -> + LogEntry (mbLift u) (mbLift v) (mbLift w) + (mbLift x) (mbLift y) (mbLift z) + [nuMP| LogError x y z |] -> + LogError (mbLift x) (mbLift y) (mbLift z) data LogEntryID = LogEntryID @@ -148,8 +153,8 @@ instance ExtractLogEntries instance ExtractLogEntries (PermImpl1 ps_in ps_outs) where extractLogEntries (Impl1_Fail err) = - do (_, loc) <- ask - emit (LogError (snd (ppLoc loc)) (ppError err)) + do (_, loc, fname) <- ask + emit (LogError (snd (ppLoc loc)) (ppError err) fname) extractLogEntries _ = pure () instance ExtractLogEntries @@ -176,10 +181,10 @@ instance (PermCheckExtC ext) mbExtractLogEntries :: ExtractLogEntries a => Mb (ctx :: RList CrucibleType) a -> ExtractionM () mbExtractLogEntries mb_a = - ReaderT $ \(ppi, loc) -> + ReaderT $ \(ppi, loc, fname) -> tell $ mbLift $ flip nuMultiWithElim1 mb_a $ \ns x -> execWriter $ runReaderT (extractLogEntries x) - (ppInfoAddExprNames "x" ns ppi, loc) + (ppInfoAddExprNames "x" ns ppi, loc, fname) -- TODO: The next two functions are a hack, and we should probably rethink how -- this is architected a bit. They don't fit into the type signature of @@ -192,29 +197,32 @@ mbValPermEntries -> Mb ctx (ValuePerms ctx) -> ExtractionM () mbValPermEntries entryId callers mb_vp = - ReaderT $ \(ppi, loc) -> + ReaderT $ \(ppi, loc, fname) -> tell $ mbLift $ flip nuMultiWithElim1 mb_vp $ \ns vp -> execWriter $ runReaderT (valPermEntries entryId callers vp) - (ppInfoAddExprNames "x" ns ppi, loc) + (ppInfoAddExprNames "x" ns ppi, loc, fname) valPermEntries :: LogEntryID -> [LogEntryID] -> ValuePerms ctx -> ExtractionM () valPermEntries entryId callers vps = do - (ppi, loc) <- ask + (ppi, loc, fname) <- ask let loc' = snd (ppLoc loc) let strs = foldValuePerms (\xs vp -> (ppToJson ppi vp, permPrettyString ppi vp) : xs) [] vps - tell [LogEntry loc' entryId callers export str | (export, str) <- strs] + tell [LogEntry loc' entryId callers fname export str | (export, str) <- strs] 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, _) -> (ppinfo, loc)) +withLoc loc = local (\(ppinfo, _, fname) -> (ppinfo, loc, fname)) setErrorMsg :: String -> LogEntry -> LogEntry setErrorMsg msg le@LogError {} = le { lerrError = msg } setErrorMsg msg le@LogEntry {} = - LogError { lerrError = msg, lerrLocation = leLocation le} + LogError { lerrError = msg + , lerrLocation = leLocation le + , lerrFunctionName = leFunctionName le + } runWithLoc :: PPInfo -> [Some SomeTypedCFG] -> [LogEntry] @@ -224,9 +232,13 @@ runWithLoc ppi = runWithLocHelper :: PPInfo -> Some SomeTypedCFG -> [LogEntry] runWithLocHelper ppi' sstcfg = case sstcfg of Some (SomeTypedCFG tcfg) -> do - let env = (ppi', getFirstProgramLoc tcfg) + let env = (ppi', getFirstProgramLoc tcfg, getFunctionName tcfg) execWriter (runReaderT (extractLogEntries tcfg) env) +getFunctionName :: TypedCFG ext blocks ghosts inits ret -> String +getFunctionName tcfg = case tpcfgHandle tcfg of + TypedFnHandle _ handle -> show $ handleName handle + getFirstProgramLoc :: PermCheckExtC ext => TypedCFG ext blocks ghosts inits ret -> ProgramLoc From cb7c57c1a028de660c88480e1eaad26bc57f7ba3 Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Thu, 19 Aug 2021 10:17:34 -0700 Subject: [PATCH 17/28] heapster-saw: LogEntry with names and structure --- .../src/Verifier/SAW/Heapster/CruUtil.hs | 10 ++ .../src/Verifier/SAW/Heapster/IDESupport.hs | 76 ++++++++------- .../Verifier/SAW/Heapster/TypedCrucible.hs | 96 ++++++++++++------- 3 files changed, 115 insertions(+), 67 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/CruUtil.hs b/heapster-saw/src/Verifier/SAW/Heapster/CruUtil.hs index 6f9c36aab7..4ef922a0f2 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/CruUtil.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/CruUtil.hs @@ -23,6 +23,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 @@ -564,6 +565,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/IDESupport.hs b/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs index 67648acb4f..e931ae60df 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs @@ -11,6 +11,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PolyKinds #-} module Verifier.SAW.Heapster.IDESupport where import Control.Monad.Reader @@ -51,7 +52,10 @@ import Verifier.SAW.Heapster.Implication import Verifier.SAW.Heapster.Permissions import Verifier.SAW.Heapster.TypedCrucible import Verifier.SAW.Heapster.JSONExport(ppToJson) - +import Data.Aeson (Value) +import Data.Type.RList (mapRAssign) +import Data.Functor.Constant +import Control.Monad.Writer -- | The entry point for dumping a Heapster environment to a file for IDE -- consumption. @@ -65,6 +69,9 @@ 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. @@ -74,26 +81,31 @@ data LogEntry , leEntryId :: LogEntryID , leCallers :: [LogEntryID] , leFunctionName :: String - , leExport :: Value - , lePermissions :: 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 u v w x y z |] -> - LogEntry (mbLift u) (mbLift v) (mbLift w) - (mbLift x) (mbLift y) (mbLift z) + [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 @@ -126,7 +138,15 @@ instance (PermCheckExtC ext) withLoc loc (mbExtractLogEntries (typedEntryBody te)) let entryId = mkLogEntryID $ typedEntryID te let callers = callerIDs $ typedEntryCallers te - mbValPermEntries entryId callers (typedEntryPermsIn te) + (ppi, _, fname) <- ask + let loc' = snd (ppLoc loc) + let f :: + (Pair (Constant String) ValuePerm) x -> + Constant (String, String, Value) x + f (Pair (Constant name) vp) = Constant (name, permPrettyString ppi vp, ppToJson ppi vp) + let inputs = mbLift + $ fmap (RL.toList . mapRAssign f . zipRAssign (typedEntryNames te)) (typedEntryPermsIn te) + tell [LogEntry loc' entryId callers fname inputs] mkLogEntryID :: TypedEntryID blocks args -> LogEntryID mkLogEntryID = uncurry LogEntryID . entryIDIndices @@ -135,6 +155,12 @@ 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 @@ -155,7 +181,10 @@ instance ExtractLogEntries (PermImpl1 ps_in ps_outs) where extractLogEntries (Impl1_Fail err) = do (_, loc, fname) <- ask emit (LogError (snd (ppLoc loc)) (ppError err) fname) - extractLogEntries _ = pure () + -- 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 @@ -186,30 +215,6 @@ mbExtractLogEntries mb_a = execWriter $ runReaderT (extractLogEntries x) (ppInfoAddExprNames "x" ns ppi, loc, fname) --- TODO: The next two functions are a hack, and we should probably rethink how --- this is architected a bit. They don't fit into the type signature of --- `ExtractLogEntries` currently because we push down the extra information --- about the entrypoint IDs which we need wherever `LogEntry`s are created. - -mbValPermEntries - :: LogEntryID - -> [LogEntryID] - -> Mb ctx (ValuePerms ctx) - -> ExtractionM () -mbValPermEntries entryId callers mb_vp = - ReaderT $ \(ppi, loc, fname) -> - tell $ mbLift $ flip nuMultiWithElim1 mb_vp $ \ns vp -> - execWriter $ runReaderT (valPermEntries entryId callers vp) - (ppInfoAddExprNames "x" ns ppi, loc, fname) - -valPermEntries :: LogEntryID -> [LogEntryID] -> ValuePerms ctx -> ExtractionM () -valPermEntries entryId callers vps = do - (ppi, loc, fname) <- ask - let loc' = snd (ppLoc loc) - let strs = foldValuePerms (\xs vp -> - (ppToJson ppi vp, permPrettyString ppi vp) : xs) [] vps - tell [LogEntry loc' entryId callers fname export str | (export, str) <- strs] - typedStmtOutCtx :: TypedStmt ext rets ps_in ps_next -> CruCtx rets typedStmtOutCtx = error "FIXME: write typedStmtOutCtx" @@ -218,13 +223,16 @@ 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) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs b/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs index a5abef6448..f68c3a8517 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs @@ -82,6 +82,7 @@ import Verifier.SAW.Heapster.Permissions import Verifier.SAW.Heapster.Widening import Debug.Trace +import Data.Type.RList (mapRAssign) ---------------------------------------------------------------------- @@ -339,7 +340,6 @@ instance Closable (TypedCallSiteID blocks args vars) where instance Liftable (TypedCallSiteID blocks args vars) where mbLift = unClosed . mbLift . fmap toClosed - ---------------------------------------------------------------------- -- * Typed Crucible Statements ---------------------------------------------------------------------- @@ -1175,6 +1175,8 @@ data TypedEntry phase ext blocks tops ret args ghosts = typedEntryCallers :: ![Some (TypedCallSite phase blocks tops args ghosts)], -- | The ghost variables for this entrypoint typedEntryGhosts :: !(CruCtx ghosts), + -- + typedEntryNames :: !(TransData phase (RAssign (Constant String) ((tops :++: args) :++: ghosts))), -- | The input permissions for this entrypoint typedEntryPermsIn :: !(MbValuePerms ((tops :++: args) :++: ghosts)), -- | The output permissions for the function (cached locally) @@ -1205,16 +1207,18 @@ completeTypedEntry :: completeTypedEntry (TypedEntry { .. }) | Just body <- typedEntryBody , Just callers <- mapM (traverseF completeTypedCallSite) typedEntryCallers - = Just $ TypedEntry { typedEntryBody = body, typedEntryCallers = callers, .. } + , Just names <- typedEntryNames + = Just $ TypedEntry { typedEntryBody = body, typedEntryCallers = callers, typedEntryNames = names, .. } completeTypedEntry _ = Nothing -- | Build an entrypoint from a call site, using that call site's permissions as -- the entyrpoint input permissions -singleCallSiteEntry :: TypedCallSiteID blocks args vars -> - CruCtx tops -> CruCtx args -> TypeRepr ret -> - MbValuePerms ((tops :++: args) :++: vars) -> - MbValuePerms (tops :> ret) -> - TypedEntry TCPhase ext blocks tops ret args vars +singleCallSiteEntry :: + TypedCallSiteID blocks args vars -> + CruCtx tops -> CruCtx args -> TypeRepr ret -> + MbValuePerms ((tops :++: args) :++: vars) -> + MbValuePerms (tops :> ret) -> + TypedEntry TCPhase ext blocks tops ret args vars singleCallSiteEntry siteID tops args ret perms_in perms_out = TypedEntry { @@ -1222,6 +1226,7 @@ singleCallSiteEntry siteID tops args ret perms_in perms_out = typedEntryArgs = args, typedEntryRet = ret, typedEntryCallers = [Some $ idTypedCallSite siteID tops args perms_in], typedEntryGhosts = callSiteVars siteID, + typedEntryNames = Nothing, typedEntryPermsIn = perms_in, typedEntryPermsOut = perms_out, typedEntryBody = Nothing } @@ -1345,6 +1350,7 @@ emptyBlockForPerms names cblocks blk tops ret ghosts perms_in perms_out typedEntryID = TypedEntryID blockID 0, typedEntryTops = tops, typedEntryArgs = args, typedEntryRet = ret, typedEntryCallers = [], typedEntryGhosts = ghosts, + typedEntryNames = Nothing, typedEntryPermsIn = perms_in, typedEntryPermsOut = perms_out, typedEntryBody = Nothing }] names @@ -3867,27 +3873,46 @@ tcBlockEntryBody :: Block ext cblocks ret args -> TypedEntry TCPhase ext blocks tops ret (CtxToRList args) ghosts -> TopPermCheckM ext cblocks blocks tops ret - (Mb ((tops :++: CtxToRList args) :++: ghosts) + (RAssign (Constant String) ((tops :++: CtxToRList args) :++: ghosts), + Mb ((tops :++: CtxToRList args) :++: ghosts) (TypedStmtSeq ext blocks tops ret ((tops :++: CtxToRList args) :++: ghosts))) tcBlockEntryBody names blk entry@(TypedEntry {..}) = - runPermCheckM names typedEntryID typedEntryArgs typedEntryGhosts typedEntryPermsIn $ - \tops_ns args_ns ghosts_ns perms -> - let ctx = mkCtxTrans (blockInputs blk) args_ns - ns = RL.append (RL.append tops_ns args_ns) ghosts_ns in - stmtTraceM (\i -> - pretty "Type-checking block" <+> pretty (blockID blk) <> - comma <+> pretty "entrypoint" <+> pretty (entryIndex typedEntryID) - <> line <> - pretty "Input types:" - <> align (permPretty i $ - RL.map2 VarAndType ns $ cruCtxToTypes $ - typedEntryAllArgs entry) - <> line <> - pretty "Input perms:" - <> align (permPretty i perms)) >>> - stmtRecombinePerms >>> - tcEmitStmtSeq names ctx (blk ^. blockStmts) + do mbNs <- mkNs + stmts <- mkStmts + pure (mbLift mbNs,stmts) + where + mkNs = + runPermCheckM names typedEntryID typedEntryArgs typedEntryGhosts typedEntryPermsIn $ + \tops_ns args_ns ghosts_ns _ -> + permGetPPInfo >>>= \ppi -> + let tops = mapRAssign (Constant . show . permPretty ppi) tops_ns + args = mapRAssign (Constant . show . permPretty ppi) args_ns + ghosts = mapRAssign (Constant . show . permPretty ppi) ghosts_ns + ns = rappend (rappend tops args) ghosts + in traceShow ("ns", RL.toList ns) $ gmapRet (>> pure ns) + + mkStmts = + runPermCheckM names typedEntryID typedEntryArgs typedEntryGhosts typedEntryPermsIn $ + \tops_ns args_ns ghosts_ns perms -> + let ctx = mkCtxTrans (blockInputs blk) args_ns + ns = RL.append (RL.append tops_ns args_ns) ghosts_ns in + stmtTraceM (\i -> + pretty "Type-checking block" <+> pretty (blockID blk) <> + comma <+> pretty "entrypoint" <+> pretty (entryIndex typedEntryID) + <> line <> + pretty "Input types:" + <> align (permPretty i $ + RL.map2 VarAndType ns $ cruCtxToTypes $ + typedEntryAllArgs entry) + <> line <> + pretty "Input perms:" + <> align (permPretty i perms)) >>> + 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 @@ -3949,18 +3974,22 @@ visitCallSite (TypedEntry {..}) site@(TypedCallSite {..}) -- | Widen the permissions held by all callers of an entrypoint to compute new, -- weaker input permissions that can hopefully be satisfied by them -widenEntry :: PermCheckExtC ext => - TypedEntry TCPhase ext blocks tops ret args ghosts -> - Some (TypedEntry TCPhase ext blocks tops ret args) +widenEntry :: + forall ext blocks tops ret args ghosts. + PermCheckExtC ext => + TypedEntry TCPhase ext blocks tops ret args ghosts -> + Some (TypedEntry TCPhase ext blocks tops ret args) widenEntry (TypedEntry {..}) = case foldl1' (widen 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, + typedEntryNames = 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 @@ -4003,9 +4032,10 @@ visitEntry names can_widen blk entry = -- is no reason to re-type-check the body, so just update the callers return $ Some $ entry { typedEntryCallers = callers } else - do body <- maybe (tcBlockEntryBody names blk entry) return (typedEntryBody entry) + do (ns, body) <- maybe (tcBlockEntryBody names blk entry) return ((,) <$> typedEntryNames entry <*> typedEntryBody entry) return $ Some $ entry { typedEntryCallers = callers, - typedEntryBody = Just body } + typedEntryBody = Just body, + typedEntryNames = Just ns } -- | Visit a block by visiting all its entrypoints From e768f1fdfeb58dc574ae7c8b7b10c8c3f17e7bb9 Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Thu, 19 Aug 2021 17:19:46 -0700 Subject: [PATCH 18/28] Incorporate names from bindings in JsonExport --- heapster-saw/src/Verifier/SAW/Heapster/JSONExport.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/JSONExport.hs b/heapster-saw/src/Verifier/SAW/Heapster/JSONExport.hs index cf4b21e75f..5e8103488b 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/JSONExport.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/JSONExport.hs @@ -62,8 +62,10 @@ instance JsonExport1 f => JsonExport (Assignment f x) where 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) From 51665d7d4ccf84ac9b09a81491889ac1f0fc802f Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Mon, 23 Aug 2021 11:53:21 -0700 Subject: [PATCH 19/28] Update PPInfo while exporting --- .../src/Verifier/SAW/Heapster/GenMonad.hs | 12 +++++- .../src/Verifier/SAW/Heapster/IDESupport.hs | 37 ++++++++++++------- .../Verifier/SAW/Heapster/TypedCrucible.hs | 5 +-- 3 files changed, 35 insertions(+), 19 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/GenMonad.hs b/heapster-saw/src/Verifier/SAW/Heapster/GenMonad.hs index 7ac7aa75b6..5d906a8451 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/GenMonad.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/GenMonad.hs @@ -8,17 +8,18 @@ module Verifier.SAW.Heapster.GenMonad ( -- * Core definitions GenStateContT(..), (>>>=), (>>>), -- * Continuation operations - gcaptureCC, gmapRet, gabortM, gparallel, gopenBinding, + gcaptureCC, gmapRet, gabortM, gparallel, startBinding, gopenBinding, -- * 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 -- | The generalized state-continuation monad newtype GenStateContT s1 r1 s2 r2 m a = GenStateContT { @@ -107,6 +108,13 @@ 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) +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) + 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 index e931ae60df..6b83e873c5 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs @@ -18,11 +18,6 @@ import Control.Monad.Reader ( MonadReader (ask, local), ReaderT (..), ) -import Control.Monad.Writer - ( MonadWriter (tell), - Writer, - execWriter, - ) import Data.Aeson (ToJSON, Value, encodeFile) import Data.Binding.Hobbits ( Liftable (..), @@ -33,6 +28,7 @@ import Data.Binding.Hobbits nuMP, nuMultiWithElim1, unsafeMbTypeRepr, + Name, ) import Data.Maybe (catMaybes, listToMaybe, mapMaybe) import Data.Parameterized.Some (Some (..)) @@ -52,10 +48,11 @@ import Verifier.SAW.Heapster.Implication import Verifier.SAW.Heapster.Permissions import Verifier.SAW.Heapster.TypedCrucible import Verifier.SAW.Heapster.JSONExport(ppToJson) -import Data.Aeson (Value) 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 -- | The entry point for dumping a Heapster environment to a file for IDE -- consumption. @@ -140,12 +137,24 @@ instance (PermCheckExtC ext) let callers = callerIDs $ typedEntryCallers te (ppi, _, fname) <- ask let loc' = snd (ppLoc loc) - let f :: - (Pair (Constant String) ValuePerm) x -> - Constant (String, String, Value) x - f (Pair (Constant name) vp) = Constant (name, permPrettyString ppi vp, ppToJson ppi vp) - let inputs = mbLift - $ fmap (RL.toList . mapRAssign f . zipRAssign (typedEntryNames te)) (typedEntryPermsIn te) + + let insertNames :: + RL.RAssign Name (x :: RList CrucibleType) -> + RL.RAssign (Constant String) x -> + NameMap (StringF :: CrucibleType -> *)-> + NameMap (StringF :: CrucibleType -> *) + insertNames RL.MNil RL.MNil m = m + insertNames (ns RL.:>: n) (xs RL.:>: Constant 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 (typedEntryNames te) (ppExprNames ppi) } + f :: + (Pair (Constant String) ValuePerm) x -> + Constant (String, String, Value) x + f (Pair (Constant name) vp) = Constant (name, permPrettyString ppi' vp, ppToJson ppi' vp) + in RL.toList (mapRAssign f (zipRAssign (typedEntryNames te) body)) tell [LogEntry loc' entryId callers fname inputs] mkLogEntryID :: TypedEntryID blocks args -> LogEntryID @@ -212,8 +221,8 @@ mbExtractLogEntries mbExtractLogEntries mb_a = ReaderT $ \(ppi, loc, fname) -> tell $ mbLift $ flip nuMultiWithElim1 mb_a $ \ns x -> - execWriter $ runReaderT (extractLogEntries x) - (ppInfoAddExprNames "x" ns ppi, loc, fname) + let ppi' = ppInfoAddExprNames "x" ns ppi in + execWriter $ runReaderT (extractLogEntries x) (ppi', loc, fname) typedStmtOutCtx :: TypedStmt ext rets ps_in ps_next -> CruCtx rets typedStmtOutCtx = error "FIXME: write typedStmtOutCtx" diff --git a/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs b/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs index bbd63740e2..691772578b 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs @@ -2532,9 +2532,8 @@ emitStmt :: StmtPermCheckM ext cblocks blocks tops ret ps_out ps_in (RAssign Name rets) emitStmt tps names loc stmt = - gopenBinding - ((TypedConsStmt loc stmt (cruCtxProxies tps) <$>) . strongMbM) - (mbPure (cruCtxProxies tps) ()) >>>= \(ns, ()) -> + let pxys = cruCtxProxies tps in + startBinding pxys (fmap (TypedConsStmt loc stmt pxys) . strongMbM) >>>= \ns -> setVarTypes Nothing names ns tps >>> gmodify (modifySTCurPerms (applyTypedStmt stmt ns)) >>> pure ns From dc70b935df7ce39d0adb152dda255ceaaeb46314 Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Fri, 27 Aug 2021 08:31:57 -0700 Subject: [PATCH 20/28] checkpoint --- .../src/Verifier/SAW/Heapster/GenMonad.hs | 20 +- .../src/Verifier/SAW/Heapster/IDESupport.hs | 41 ++-- .../src/Verifier/SAW/Heapster/NamedMb.hs | 77 ++++++++ .../src/Verifier/SAW/Heapster/Permissions.hs | 67 +++++-- .../Verifier/SAW/Heapster/SAWTranslation.hs | 7 +- .../Verifier/SAW/Heapster/TypedCrucible.hs | 176 +++++++++++++----- 6 files changed, 313 insertions(+), 75 deletions(-) create mode 100644 heapster-saw/src/Verifier/SAW/Heapster/NamedMb.hs diff --git a/heapster-saw/src/Verifier/SAW/Heapster/GenMonad.hs b/heapster-saw/src/Verifier/SAW/Heapster/GenMonad.hs index 5d906a8451..54bde8429e 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/GenMonad.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/GenMonad.hs @@ -8,7 +8,7 @@ module Verifier.SAW.Heapster.GenMonad ( -- * Core definitions GenStateContT(..), (>>>=), (>>>), -- * Continuation operations - gcaptureCC, gmapRet, gabortM, gparallel, startBinding, gopenBinding, + gcaptureCC, gmapRet, gabortM, gparallel, startBinding, startBinding', gopenBinding, gopenBinding', -- * State operations gmodify, -- * Transformations @@ -20,6 +20,7 @@ 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 { @@ -108,6 +109,16 @@ 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) +gopenBinding' :: + (Mb' ctx (m b1) -> m r2) -> + Mb' ctx b2 -> + GenStateContT s b1 s r2 m (RAssign Name ctx, b2) +gopenBinding' f_ret mb_a = + gcaptureCC \k -> + f_ret $ flip nuMultiWithElim1' mb_a $ \names a -> + k (names, a) + -- | Name-binding in the generalized continuation monad (FIXME: explain) startBinding :: RAssign Proxy ctx -> @@ -115,6 +126,13 @@ startBinding :: 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) +startBinding' :: + RAssign StringF 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) + 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 index 6b83e873c5..82f6d25e7a 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs @@ -53,6 +53,7 @@ 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. @@ -131,30 +132,30 @@ instance (PermCheckExtC ext) => ExtractLogEntries (TypedEntry TransPhase ext blocks tops ret args ghosts) where extractLogEntries te = do - let loc = mbLift $ fmap getFirstProgramLocTS (typedEntryBody te) - withLoc loc (mbExtractLogEntries (typedEntryBody te)) + let loc = mbLift' $ 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 (Constant String) x -> + RL.RAssign StringF x -> NameMap (StringF :: CrucibleType -> *)-> NameMap (StringF :: CrucibleType -> *) insertNames RL.MNil RL.MNil m = m - insertNames (ns RL.:>: n) (xs RL.:>: Constant name) 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 (typedEntryNames te) (ppExprNames ppi) } + let ppi' = ppi { ppExprNames = insertNames ns debugNames (ppExprNames ppi) } f :: - (Pair (Constant String) ValuePerm) x -> + (Pair StringF ValuePerm) x -> Constant (String, String, Value) x - f (Pair (Constant name) vp) = Constant (name, permPrettyString ppi' vp, ppToJson ppi' vp) - in RL.toList (mapRAssign f (zipRAssign (typedEntryNames te) body)) + 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 @@ -175,7 +176,7 @@ instance ExtractLogEntries (TypedStmtSeq ext blocks tops ret ps_in) where -- fmap (setErrorMsg str) <$> extractLogEntries pimpl extractLogEntries pimpl extractLogEntries (TypedConsStmt loc _ _ rest) = do - withLoc loc $ mbExtractLogEntries rest + withLoc loc $ mb'ExtractLogEntries rest extractLogEntries (TypedTermStmt _ _) = pure () instance ExtractLogEntries @@ -197,8 +198,8 @@ instance ExtractLogEntries (PermImpl1 ps_in ps_outs) where instance ExtractLogEntries (MbPermImpls (TypedStmtSeq ext blocks tops ret) ps_outs) where - extractLogEntries (MbPermImpls_Cons _ mbpis pis) = do - mbExtractLogEntries pis + extractLogEntries (MbPermImpls_Cons ctx mbpis pis) = do + mbExtractLogEntries ctx pis extractLogEntries mbpis extractLogEntries MbPermImpls_Nil = pure () @@ -217,11 +218,19 @@ instance (PermCheckExtC ext) mapM_ (\(Some te) -> extractLogEntries te) $ _typedBlockEntries tb mbExtractLogEntries - :: ExtractLogEntries a => Mb (ctx :: RList CrucibleType) a -> ExtractionM () -mbExtractLogEntries mb_a = + :: 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' = ppInfoAddExprNames "x" ns ppi in + let ppi' = ppInfoAddTypedExprNames ctx ns ppi in + execWriter $ runReaderT (extractLogEntries x) (ppi', loc, fname) + +mb'ExtractLogEntries + :: ExtractLogEntries a => Mb' (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 @@ -278,7 +287,7 @@ getFirstProgramLocBM block = -> Maybe ProgramLoc helper ste = case ste of Some TypedEntry { typedEntryBody = stmts } -> - Just $ mbLift $ fmap getFirstProgramLocTS stmts + Just $ mbLift' $ 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 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..ca7f1ed131 --- /dev/null +++ b/heapster-saw/src/Verifier/SAW/Heapster/NamedMb.hs @@ -0,0 +1,77 @@ +{-# 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 + +newtype StringF a = StringF { unStringF :: String } + +type Binding' c = Mb' (RNil :> c) + +data Mb' ctx a = Mb' + { _mbNames :: RAssign StringF ctx + , _mbBinding :: Mb ctx a + } + deriving Functor + +mbBinding :: Lens (Mb' ctx a) (Mb' ctx b) (Mb ctx a) (Mb ctx b) +mbBinding f x = Mb' (_mbNames x) <$> f (_mbBinding x) + +nuMulti' :: RAssign StringF ctx -> (RAssign Name ctx -> b) -> Mb' ctx b +nuMulti' tps f = Mb' + { _mbNames = tps + , _mbBinding = nuMulti (mapRAssign (const Proxy) tps) f + } + +nuMultiWithElim1' :: (RAssign Name ctx -> arg -> b) -> Mb' ctx arg -> Mb' ctx b +nuMultiWithElim1' k = over mbBinding (nuMultiWithElim1 k) + + +strongMbM' :: MonadStrongBind m => Mb' ctx (m a) -> m (Mb' ctx a) +strongMbM' = traverseOf mbBinding strongMbM + +mbM' :: (MonadBind m, NuMatching a) => Mb' ctx (m a) -> m (Mb' ctx a) +mbM' = traverseOf mbBinding mbM + +mbSwap' :: RAssign Proxy ctx -> Mb' ctx' (Mb' ctx a) -> Mb' ctx (Mb' ctx' a) +mbSwap' p (Mb' names' body') = + Mb' + { _mbNames = mbLift (_mbNames <$> body') + , _mbBinding = Mb' names' <$> mbSwap p (_mbBinding <$> body') + } + +mbSink :: RAssign Proxy ctx -> Mb ctx' (Mb' ctx a) -> Mb' ctx (Mb ctx' a) +mbSink p m = + Mb' + { _mbNames = mbLift (_mbNames <$> m) + , _mbBinding = mbSwap p (_mbBinding <$> m) + } + +mbLift' :: Liftable a => Mb' ctx a -> a +mbLift' = views mbBinding mbLift + +elimEmptyMb' :: Mb' RNil a -> a +elimEmptyMb' = views mbBinding elimEmptyMb + +emptyMb' :: a -> Mb' RNil a +emptyMb' = Mb' MNil . emptyMb + +mkNuMatching [t| forall a. StringF a |] +instance NuMatchingAny1 StringF where + nuMatchingAny1Proof = nuMatchingProof + +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 => Mb' ctx a |] diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs index 3e12a46dfe..71183d1907 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs @@ -79,6 +79,7 @@ import Lang.Crucible.LLVM.Bytes import Lang.Crucible.CFG.Core import Verifier.SAW.Term.Functor (Ident) import Verifier.SAW.OpenTerm +import Verifier.SAW.Heapster.NamedMb import Verifier.SAW.Heapster.CruUtil @@ -137,8 +138,6 @@ foldMapWithDefault comb def f l = foldr1WithDefault comb def $ map f l -- * Pretty-printing ---------------------------------------------------------------------- -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" @@ -175,16 +174,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) -> @@ -193,12 +200,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 @@ -313,15 +341,15 @@ instance PermPrettyF VarAndType where permPrettyExprMb :: PermPretty a => - (RAssign (Constant (Doc ann)) ctx -> PermPPM (Doc ann) -> PermPPM (Doc ann)) -> - Mb (ctx :: RList CrucibleType) a -> PermPPM (Doc ann) + (RAssign (Constant (Doc ann)) ctx -> PermPPM (Doc ann) -> PermPPM (Doc ann)) -> + Mb (ctx :: RList CrucibleType) a -> PermPPM (Doc ann) permPrettyExprMb f mb = fmap mbLift $ strongMbM $ flip nuMultiWithElim1 mb $ \ns a -> - local (ppInfoAddExprNames "z" ns) $ + local (ppInfoAddExprNames "x" ns) $ do docs <- traverseRAssign (\n -> Constant <$> permPrettyM n) ns f docs $ permPrettyM a -instance PermPretty a => PermPretty (Mb (ctx :: RList CrucibleType) a) where +instance (PermPretty a) => PermPretty (Mb (ctx :: RList CrucibleType) a) where permPrettyM = permPrettyExprMb $ \docs ppm -> (\pp -> PP.group (ppEncList True (RL.toList docs) <> @@ -4932,6 +4960,23 @@ genSubstMb :: s ctx' -> Mb ctx' (Mb ctx a) -> m (Mb ctx a) genSubstMb p s mbmb = mbM (fmap (genSubst s) (mbSwap p mbmb)) + +instance {-# INCOHERENT #-} (Given (RAssign Proxy ctx), Substable s a m, NuMatching a) => Substable s (Mb' ctx a) m where + genSubst = genSubstMb' given + +instance {-# INCOHERENT #-} (Substable s a m, NuMatching a) => Substable s (Mb' RNil a) m where + genSubst = genSubstMb' RL.typeCtxProxies + +instance {-# INCOHERENT #-} (Substable s a m, NuMatching a) => Substable s (Binding' c a) m where + genSubst = genSubstMb' RL.typeCtxProxies + +genSubstMb' :: + Substable s a m => + NuMatching a => + RAssign Proxy ctx -> + s ctx' -> Mb ctx' (Mb' ctx a) -> m (Mb' ctx a) +genSubstMb' p s mbmb = mbM' (fmap (genSubst s) (mbSink p mbmb)) + instance SubstVar s m => Substable s (Member ctx a) m where genSubst _ mb_memb = return $ mbLift mb_memb diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 095d849089..622586c624 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -77,6 +77,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 import Debug.Trace @@ -3798,7 +3799,7 @@ translateCallEntry nm entry_trans mb_tops_args mb_ghosts = -- If not, continue by translating entry, setting the variable -- permission map to empty (as in the beginning of a block) clearVarPermsM $ translate $ - fmap (\s -> varSubst s $ typedEntryBody entry) mb_s + fmap (\s -> varSubst s $ _mbBinding $ typedEntryBody entry) mb_s instance PermCheckExtC ext => @@ -4084,7 +4085,7 @@ instance PermCheckExtC ext => 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 => @@ -4214,7 +4215,7 @@ translateEntryBody mapTrans entry = lambdaPermCtx (typedEntryPermsIn entry) $ \pctx -> do retType <- translateEntryRetType entry impTransM (RL.members pctx) pctx mapTrans retType $ translate $ - typedEntryBody entry + _mbBinding $ typedEntryBody entry -- | Translate all the entrypoints in a 'TypedBlockMap' that correspond to -- letrec-bound functions to SAW core functions as in 'translateEntryBody' diff --git a/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs b/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs index 691772578b..a46ddc6652 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs @@ -50,7 +50,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) @@ -80,9 +79,9 @@ 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 Debug.Trace -import Data.Type.RList (mapRAssign) ---------------------------------------------------------------------- @@ -761,7 +760,7 @@ data TypedStmtSeq ext blocks tops ret ps_in where TypedConsStmt :: !ProgramLoc -> !(TypedStmt ext rets ps_in ps_next) -> !(RAssign Proxy rets) -> - !(Mb rets (TypedStmtSeq ext blocks tops ret ps_next)) -> + !(Mb' rets (TypedStmtSeq ext blocks tops ret ps_next)) -> TypedStmtSeq ext blocks tops ret ps_in -- | Typed version of 'TermStmt', which terminates the current block @@ -1204,19 +1203,18 @@ data TypedEntry phase ext blocks tops ret args ghosts = typedEntryCallers :: ![Some (TypedCallSite phase blocks tops args ghosts)], -- | The ghost variables for this entrypoint typedEntryGhosts :: !(CruCtx ghosts), - -- - typedEntryNames :: !(TransData phase (RAssign (Constant String) ((tops :++: args) :++: ghosts))), -- | The input permissions for this entrypoint typedEntryPermsIn :: !(MbValuePerms ((tops :++: args) :++: ghosts)), -- | The output permissions for the function (cached locally) typedEntryPermsOut :: !(MbValuePerms (tops :> ret)), -- | The type-checked body of the entrypoint typedEntryBody :: !(TransData phase - (Mb ((tops :++: args) :++: ghosts) + (Mb' ((tops :++: args) :++: ghosts) (TypedStmtSeq ext blocks tops ret ((tops :++: args) :++: ghosts)))) } + -- | Test if an entrypoint has in-degree greater than 1 typedEntryHasMultiInDegree :: TypedEntry phase ext blocks tops ret args ghosts -> Bool @@ -1236,8 +1234,7 @@ completeTypedEntry :: completeTypedEntry (TypedEntry { .. }) | Just body <- typedEntryBody , Just callers <- mapM (traverseF completeTypedCallSite) typedEntryCallers - , Just names <- typedEntryNames - = Just $ TypedEntry { typedEntryBody = body, typedEntryCallers = callers, typedEntryNames = names, .. } + = Just $ TypedEntry { typedEntryBody = body, typedEntryCallers = callers, .. } completeTypedEntry _ = Nothing -- | Build an entrypoint from a call site, using that call site's permissions as @@ -1255,7 +1252,6 @@ singleCallSiteEntry siteID tops args ret perms_in perms_out = typedEntryArgs = args, typedEntryRet = ret, typedEntryCallers = [Some $ idTypedCallSite siteID tops args perms_in], typedEntryGhosts = callSiteVars siteID, - typedEntryNames = Nothing, typedEntryPermsIn = perms_in, typedEntryPermsOut = perms_out, typedEntryBody = Nothing } @@ -1379,7 +1375,6 @@ emptyBlockForPerms names cblocks blk tops ret ghosts perms_in perms_out typedEntryID = TypedEntryID blockID 0, typedEntryTops = tops, typedEntryArgs = args, typedEntryRet = ret, typedEntryCallers = [], typedEntryGhosts = ghosts, - typedEntryNames = Nothing, typedEntryPermsIn = perms_in, typedEntryPermsOut = perms_out, typedEntryBody = Nothing }] names @@ -1944,25 +1939,73 @@ runPermCheckM :: DistPerms ((tops :++: args) :++: ghosts) -> PermCheckM ext cblocks blocks tops ret () ps_out r ((tops :++: args) :++: ghosts) ()) -> - TopPermCheckM ext cblocks blocks tops ret (Mb ((tops :++: args) :++: ghosts) r) + TopPermCheckM ext cblocks blocks tops ret (Mb' ((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 $ strongMbM' $ + flip nuMultiWithElim1' (Mb' 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 + + allocateDebugNames (Just "top") (noNames' topCtx) topCtx >>>= \topDbgs -> + allocateDebugNames (Just "local") arg_names argCtx >>>= \argDbgs -> + allocateDebugNames (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 @@ -2237,6 +2280,65 @@ setVarTypes str (ds :>: Constant d) (ns :>: n) (CruCtxCons ts t) = do setVarTypes str ds ns ts setVarType str d n t +-- | Remember the type of a free variable, and ensure that it has a permission +setVarType' :: + ExprVar a -> -- ^ The Hobbits variable itself + TypeRepr a -> -- ^ The type of the variable + PermCheckM ext cblocks blocks tops ret r ps r ps () +setVarType' x tp = + modify $ \st -> + st { stCurPerms = initVarPerm x (stCurPerms st), + stVarTypes = NameMap.insert x tp (stVarTypes st) } + +-- | Remember the types of a sequence of free variables +setVarTypes' :: + RAssign Name tps -> + CruCtx tps -> + PermCheckM ext cblocks blocks tops ret r ps r ps () +setVarTypes' MNil CruCtxNil = pure () +setVarTypes' (ns :>: n) (CruCtxCons ts t) = + do setVarTypes' ns ts + setVarType' n t + +allocateDebugNames :: + Maybe String -> -- ^ The bsae 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) +allocateDebugNames _ MNil _ = pure MNil +allocateDebugNames base (ds :>: Constant dbg) (CruCtxCons ts tp) = + do outs <- allocateDebugNames base ds ts + out <- state $ \st -> + case ppInfoAllocateName str (stPPInfo st) of + (ppi, str') -> (str', st { stPPInfo = ppi }) + pure (outs :>: StringF out) + where + str = + case (base,dbg) of + (_,Just d) -> "C[" ++ d ++ "]" + (Just b,_) -> b ++ "_" ++ typeBaseName tp + (Nothing,Nothing) -> typeBaseName tp + +allocateDebugNames' :: + Maybe String -> -- ^ The bsae 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 + -- | 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' = @@ -2533,8 +2635,10 @@ emitStmt :: (RAssign Name rets) emitStmt tps names loc stmt = let pxys = cruCtxProxies tps in - startBinding pxys (fmap (TypedConsStmt loc stmt pxys) . strongMbM) >>>= \ns -> - setVarTypes Nothing names ns tps >>> + allocateDebugNames Nothing names tps >>>= \debugs -> + startBinding' debugs (fmap (TypedConsStmt loc stmt pxys) . strongMbM') >>>= \ns -> + modify (\st -> st { stPPInfo = ppInfoApplyAllocation ns debugs (stPPInfo st)}) >>> + setVarTypes' ns tps >>> gmodify (modifySTCurPerms (applyTypedStmt stmt ns)) >>> pure ns @@ -3918,26 +4022,10 @@ tcBlockEntryBody :: Block ext cblocks ret args -> TypedEntry TCPhase ext blocks tops ret (CtxToRList args) ghosts -> TopPermCheckM ext cblocks blocks tops ret - (RAssign (Constant String) ((tops :++: CtxToRList args) :++: ghosts), - Mb ((tops :++: CtxToRList args) :++: ghosts) + (Mb' ((tops :++: CtxToRList args) :++: ghosts) (TypedStmtSeq ext blocks tops ret ((tops :++: CtxToRList args) :++: ghosts))) tcBlockEntryBody names blk entry@(TypedEntry {..}) = - do mbNs <- mkNs - stmts <- mkStmts - pure (mbLift mbNs,stmts) - where - mkNs = - runPermCheckM names typedEntryID typedEntryArgs typedEntryGhosts typedEntryPermsIn $ - \tops_ns args_ns ghosts_ns _ -> - permGetPPInfo >>>= \ppi -> - let tops = mapRAssign (Constant . show . permPretty ppi) tops_ns - args = mapRAssign (Constant . show . permPretty ppi) args_ns - ghosts = mapRAssign (Constant . show . permPretty ppi) ghosts_ns - ns = rappend (rappend tops args) ghosts - in traceShow ("ns", RL.toList ns) $ gmapRet (>> pure ns) - - mkStmts = - runPermCheckM names typedEntryID typedEntryArgs typedEntryGhosts typedEntryPermsIn $ + runPermCheckM names typedEntryID typedEntryArgs typedEntryGhosts typedEntryPermsIn $ \tops_ns args_ns ghosts_ns perms -> let ctx = mkCtxTrans (blockInputs blk) args_ns ns = RL.append (RL.append tops_ns args_ns) ghosts_ns in @@ -3971,7 +4059,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 perms_out = give (cruCtxProxies ghosts) $ @@ -4035,7 +4123,7 @@ widenEntry (TypedEntry {..}) = Some $ TypedEntry { typedEntryCallers = callers, typedEntryGhosts = ghosts, typedEntryPermsIn = perms_in, typedEntryBody = Nothing, - typedEntryNames = 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 @@ -4078,10 +4166,10 @@ visitEntry names can_widen blk entry = -- is no reason to re-type-check the body, so just update the callers return $ Some $ entry { typedEntryCallers = callers } else - do (ns, body) <- maybe (tcBlockEntryBody names blk entry) return ((,) <$> typedEntryNames entry <*> typedEntryBody entry) + do body <- maybe (tcBlockEntryBody names blk entry) return (typedEntryBody entry) return $ Some $ entry { typedEntryCallers = callers, - typedEntryBody = Just body, - typedEntryNames = Just ns } + typedEntryBody = Just body + } -- | Visit a block by visiting all its entrypoints From f0c77472c0e1fd0d7648723078c73b7e38982e67 Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Fri, 27 Aug 2021 10:18:01 -0700 Subject: [PATCH 21/28] Use types to generate names for pretty permissions where possible --- .../src/Verifier/SAW/Heapster/Permissions.hs | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs index 71183d1907..abf0b475ca 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs @@ -349,6 +349,16 @@ permPrettyExprMb f mb = do docs <- traverseRAssign (\n -> Constant <$> permPrettyM n) ns f docs $ permPrettyM a +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 -> @@ -891,7 +901,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 $ nest 2 $ sep [pretty "exsh" <+> pp_n <> dot, pp] permPrettyM (PExpr_ValPerm p) = permPrettyM p @@ -2592,7 +2602,7 @@ 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 -> + 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 From e6349492a839f8923c9d19d38e98620d6baeeba0 Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Sat, 28 Aug 2021 10:04:23 -0700 Subject: [PATCH 22/28] Checkpoint --- .../src/Verifier/SAW/Heapster/IDESupport.hs | 42 ++++---------- .../src/Verifier/SAW/Heapster/Implication.hs | 58 ++++++++++--------- .../src/Verifier/SAW/Heapster/JSONExport.hs | 11 +++- .../src/Verifier/SAW/Heapster/NamedMb.hs | 12 ++-- .../src/Verifier/SAW/Heapster/Permissions.hs | 28 +++++++-- .../Verifier/SAW/Heapster/SAWTranslation.hs | 24 ++++---- 6 files changed, 93 insertions(+), 82 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs b/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs index 82f6d25e7a..8a63e3d92f 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs @@ -20,16 +20,6 @@ import Control.Monad.Reader ) 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 @@ -51,8 +41,6 @@ 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 @@ -133,26 +121,18 @@ instance (PermCheckExtC ext) (TypedEntry TransPhase ext blocks tops ret args ghosts) where extractLogEntries te = do let loc = mbLift' $ fmap getFirstProgramLocTS (typedEntryBody te) - withLoc loc (mb'ExtractLogEntries (typedEntryBody te)) + withLoc loc (nmbExtractLogEntries (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 + let inputs = mbLift $ flip nuMultiWithElim1 (typedEntryPermsIn te) $ \ns body -> - let ppi' = ppi { ppExprNames = insertNames ns debugNames (ppExprNames ppi) } - f :: - (Pair StringF ValuePerm) x -> + let ppi' = ppInfoApplyAllocation ns debugNames 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)) @@ -176,7 +156,7 @@ instance ExtractLogEntries (TypedStmtSeq ext blocks tops ret ps_in) where -- fmap (setErrorMsg str) <$> extractLogEntries pimpl extractLogEntries pimpl extractLogEntries (TypedConsStmt loc _ _ rest) = do - withLoc loc $ mb'ExtractLogEntries rest + withLoc loc $ nmbExtractLogEntries rest extractLogEntries (TypedTermStmt _ _) = pure () instance ExtractLogEntries @@ -198,8 +178,8 @@ instance ExtractLogEntries (PermImpl1 ps_in ps_outs) where instance ExtractLogEntries (MbPermImpls (TypedStmtSeq ext blocks tops ret) ps_outs) where - extractLogEntries (MbPermImpls_Cons ctx mbpis pis) = do - mbExtractLogEntries ctx pis + extractLogEntries (MbPermImpls_Cons _ mbpis pis) = do + nmbExtractLogEntries pis extractLogEntries mbpis extractLogEntries MbPermImpls_Nil = pure () @@ -225,9 +205,9 @@ mbExtractLogEntries ctx mb_a = let ppi' = ppInfoAddTypedExprNames ctx ns ppi in execWriter $ runReaderT (extractLogEntries x) (ppi', loc, fname) -mb'ExtractLogEntries +nmbExtractLogEntries :: ExtractLogEntries a => Mb' (ctx :: RList CrucibleType) a -> ExtractionM () -mb'ExtractLogEntries mb_a = +nmbExtractLogEntries mb_a = ReaderT $ \(ppi, loc, fname) -> tell $ mbLift $ flip nuMultiWithElim1 (_mbBinding mb_a) $ \ns x -> let ppi' = ppInfoApplyAllocation ns (_mbNames mb_a) ppi in @@ -313,7 +293,7 @@ getFirstProgramLocMBPI getFirstProgramLocMBPI MbPermImpls_Nil = error "Error finding program location for IDE log" getFirstProgramLocMBPI (MbPermImpls_Cons _ _ pis) = - mbLift $ fmap getFirstProgramLocPI pis + mbLift' $ fmap getFirstProgramLocPI pis -- | Print a `ProgramLoc` in a way that is useful for an IDE, i.e., machine -- readable diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs b/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs index e1bb017c26..f85aa523c2 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs @@ -62,6 +62,7 @@ import Data.Binding.Hobbits import Verifier.SAW.Heapster.CruUtil import Verifier.SAW.Heapster.Permissions import Verifier.SAW.Heapster.GenMonad +import Verifier.SAW.Heapster.NamedMb import GHC.Stack import Debug.Trace @@ -1360,7 +1361,7 @@ data MbPermImpls r bs_pss where MbPermImpls_Nil :: MbPermImpls r RNil MbPermImpls_Cons :: CruCtx bs -> !(MbPermImpls r bs_pss) -> - !(Mb bs (PermImpl r ps)) -> + !(Mb' bs (PermImpl r ps)) -> MbPermImpls r (bs_pss :> '(bs,ps)) -- | A local implication, from an input to an output permission set @@ -1408,7 +1409,7 @@ permImplStep impl1@(Impl1_Fail _) mb_impls = PermImpl_Step impl1 mb_impls -- Catch --> call the permImplCatch function permImplStep Impl1_Catch ((MbPermImpls_Cons _ (MbPermImpls_Cons _ _ mb_pimpl1) mb_pimpl2)) = - permImplCatch (elimEmptyMb mb_pimpl1) (elimEmptyMb mb_pimpl2) + permImplCatch (elimEmptyMb' mb_pimpl1) (elimEmptyMb' mb_pimpl2) -- Unary rules applied to failure --> failures -- @@ -1437,8 +1438,8 @@ permImplStep impl1@(Impl1_TryProveBVProp _ _ _) mb_impls = -- An or elimination fails if both branches fail permImplStep (Impl1_ElimOr _ _ _) (MbPermImpls_Cons _ (MbPermImpls_Cons _ MbPermImpls_Nil - (matchMbImplFail -> Just msg1)) - (matchMbImplFail -> Just msg2)) = + (matchMbImplFail . _mbBinding -> Just msg1)) + (matchMbImplFail . _mbBinding -> Just msg2)) = PermImpl_Step (Impl1_Fail $ GeneralError $ pretty (msg1 ++ "\n\n--------------------\n\n" ++ msg2)) MbPermImpls_Nil @@ -1455,7 +1456,7 @@ permImplStepUnary :: NuMatchingAny1 r => MbPermImpls r (RNil :> '(bs, ps_out)) -> PermImpl r ps_in -- If the continuation implication is a failure, percolate it up -permImplStepUnary _ (MbPermImpls_Cons _ _ (matchMbImplFail -> Just msg)) = +permImplStepUnary _ (MbPermImpls_Cons _ _ (matchMbImplFail . _mbBinding -> Just msg)) = PermImpl_Step (Impl1_Fail $ GeneralError $ pretty msg) MbPermImpls_Nil -- If the continuation implication is a catch with a failure on the right-hand @@ -1483,6 +1484,7 @@ matchMbImplFail mb_impl = case mbMatch mb_impl of [nuMP| PermImpl_Step (Impl1_Fail err) _ |] -> Just $ mbLift $ fmap ppError err _ -> Nothing +{- -- | Pattern-matchin an implication inside a binding to see if it is a catch -- whose right-hand side is just a failure, all without requiring a -- 'NuMatchingAny1' constraint on the @r@ variable @@ -1493,9 +1495,10 @@ matchMbImplCatchFail mb_impl = case mbMatch mb_impl of [nuMP| PermImpl_Step Impl1_Catch (MbPermImpls_Cons _ (MbPermImpls_Cons _ _ mb_impl1) mb_impl2) |] - | Just msg <- matchMbImplFail (mbCombine RL.typeCtxProxies mb_impl2) -> + | Just msg <- matchMbImplFail $ _mbBidning (mbCombine RL.typeCtxProxies mb_impl2) -> Just (mbCombine RL.typeCtxProxies mb_impl1, msg) _ -> Nothing + -} -- | Produce a branching proof tree that performs the first implication and, if -- that one fails, falls back on the second. If 'pruneFailingBranches' is set, @@ -1516,12 +1519,12 @@ permImplCatch pimpl1@(PermImpl_Step (Impl1_Fail _) _) pimpl2 = permImplCatch (PermImpl_Step Impl1_Catch (MbPermImpls_Cons _ (MbPermImpls_Cons _ _ mb_pimpl_1a) mb_pimpl_1b)) pimpl2 = - permImplCatch (elimEmptyMb mb_pimpl_1a) $ - permImplCatch (elimEmptyMb mb_pimpl_1b) pimpl2 + permImplCatch (elimEmptyMb' mb_pimpl_1a) $ + permImplCatch (elimEmptyMb' mb_pimpl_1b) pimpl2 permImplCatch pimpl1 pimpl2 = PermImpl_Step Impl1_Catch $ - MbPermImpls_Cons knownRepr (MbPermImpls_Cons knownRepr MbPermImpls_Nil $ emptyMb pimpl1) $ - emptyMb pimpl2 + MbPermImpls_Cons knownRepr (MbPermImpls_Cons knownRepr MbPermImpls_Nil $ emptyMb' pimpl1) $ + emptyMb' pimpl2 -- | Test if a 'PermImpl' "succeeds", meaning there is at least one non-failing @@ -1534,40 +1537,40 @@ permImplSucceeds (PermImpl_Done _) = 2 permImplSucceeds (PermImpl_Step (Impl1_Fail _) _) = 0 permImplSucceeds (PermImpl_Step Impl1_Catch (MbPermImpls_Cons _ (MbPermImpls_Cons _ _ mb_impl1) mb_impl2)) = - max (mbLift $ fmap permImplSucceeds mb_impl1) - (mbLift $ fmap permImplSucceeds mb_impl2) + max (mbLift' $ fmap permImplSucceeds mb_impl1) + (mbLift' $ fmap permImplSucceeds mb_impl2) permImplSucceeds (PermImpl_Step (Impl1_Push _ _) (MbPermImpls_Cons _ _ mb_impl)) = - mbLift $ fmap permImplSucceeds mb_impl + mbLift' $ fmap permImplSucceeds mb_impl permImplSucceeds (PermImpl_Step (Impl1_Pop _ _) (MbPermImpls_Cons _ _ mb_impl)) = - mbLift $ fmap permImplSucceeds mb_impl + mbLift' $ fmap permImplSucceeds mb_impl permImplSucceeds (PermImpl_Step (Impl1_ElimOr _ _ _) (MbPermImpls_Cons _ (MbPermImpls_Cons _ _ mb_impl1) mb_impl2)) = - max (mbLift (fmap permImplSucceeds mb_impl1)) - (mbLift (fmap permImplSucceeds mb_impl2)) + max (mbLift' (fmap permImplSucceeds mb_impl1)) + (mbLift' (fmap permImplSucceeds mb_impl2)) permImplSucceeds (PermImpl_Step (Impl1_ElimExists _ _) (MbPermImpls_Cons _ _ mb_impl)) = - mbLift $ fmap permImplSucceeds mb_impl + mbLift' $ fmap permImplSucceeds mb_impl permImplSucceeds (PermImpl_Step (Impl1_Simpl _ _) (MbPermImpls_Cons _ _ mb_impl)) = - mbLift $ fmap permImplSucceeds mb_impl + mbLift' $ fmap permImplSucceeds mb_impl permImplSucceeds (PermImpl_Step (Impl1_LetBind _ _) (MbPermImpls_Cons _ _ mb_impl)) = - mbLift $ fmap permImplSucceeds mb_impl + mbLift' $ fmap permImplSucceeds mb_impl permImplSucceeds (PermImpl_Step (Impl1_ElimStructField _ _ _ _) (MbPermImpls_Cons _ _ mb_impl)) = - mbLift $ fmap permImplSucceeds mb_impl + mbLift' $ fmap permImplSucceeds mb_impl permImplSucceeds (PermImpl_Step (Impl1_ElimLLVMFieldContents _ _) (MbPermImpls_Cons _ _ mb_impl)) = - mbLift $ fmap permImplSucceeds mb_impl + mbLift' $ fmap permImplSucceeds mb_impl permImplSucceeds (PermImpl_Step (Impl1_ElimLLVMBlockToEq _ _) (MbPermImpls_Cons _ _ mb_impl)) = - mbLift $ fmap permImplSucceeds mb_impl + mbLift' $ fmap permImplSucceeds mb_impl permImplSucceeds (PermImpl_Step Impl1_BeginLifetime (MbPermImpls_Cons _ _ mb_impl)) = - mbLift $ fmap permImplSucceeds mb_impl + mbLift' $ fmap permImplSucceeds mb_impl permImplSucceeds (PermImpl_Step (Impl1_TryProveBVProp _ _ _) (MbPermImpls_Cons _ _ mb_impl)) = - mbLift $ fmap permImplSucceeds mb_impl + mbLift' $ fmap permImplSucceeds mb_impl -- | Test if a 'PermImpl' fails, meaning 'permImplSucceeds' returns 0 permImplFails :: PermImpl r ps -> Bool @@ -2648,7 +2651,7 @@ instance (NuMatchingAny1 r, SubstVar PermVarSubst m, [nuMP| MbPermImpls_Nil |] -> return MbPermImpls_Nil [nuMP| MbPermImpls_Cons mpx mb_impl mb_impls' |] -> let px = mbLift mpx in - MbPermImpls_Cons px <$> genSubst s mb_impl <*> genSubstMb (cruCtxProxies px) s mb_impls' + MbPermImpls_Cons px <$> genSubst s mb_impl <*> genSubstMb' (cruCtxProxies px) s mb_impls' -- FIXME: shouldn't need the SubstVar PermVarSubst m assumption... instance SubstVar PermVarSubst m => @@ -3075,11 +3078,12 @@ implApplyImpl1 impl1 mb_ms = (State (Closed s)) a helper MbPermSets_Nil _ = gabortM (return MbPermImpls_Nil) helper (MbPermSets_Cons mbperms ctx mbperm) (args :>: Impl1Cont f) = - gparallel (\m1 m2 -> MbPermImpls_Cons ctx <$> m1 <*> m2) + state (\s -> s & implStatePPInfo %%~ ppInfoAllocateTypedExprNames ctx) >>>= \n -> + gparallel (\m1 m2 -> MbPermImpls_Cons ctx <$> m1 <*> (Mb' n <$> m2)) (helper mbperms args) (gopenBinding strongMbM mbperm >>>= \(ns, perms') -> gmodify (set implStatePerms perms' . - over implStatePPInfo (ppInfoAddTypedExprNames ctx ns)) >>> + over implStatePPInfo (ppInfoApplyAllocation ns n)) >>> implSetNameTypes ns ctx >>> f ns) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/JSONExport.hs b/heapster-saw/src/Verifier/SAW/Heapster/JSONExport.hs index 5e8103488b..6169ec73d0 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/JSONExport.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/JSONExport.hs @@ -32,6 +32,7 @@ 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.Heapster.NamedMb import Verifier.SAW.Name ( Ident ) import What4.FunctionName ( FunctionName ) @@ -63,7 +64,7 @@ instance JsonExport1 f => JsonExport (RAssign f x) where jsonExport = toJSON . mapToList jsonExport1 -instance JsonExport b => JsonExport (Mb (a :: RList CrucibleType) b) where +instance JsonExport a => JsonExport (Mb (ctx :: RList CrucibleType) a) where jsonExport mb = mbLift $ flip nuMultiWithElim1 mb $ \names body -> let ?ppi = ppInfoAddExprNames "x" names ?ppi in object [ @@ -71,6 +72,14 @@ instance JsonExport b => JsonExport (Mb (a :: RList CrucibleType) b) where ("body", jsonExport body) ] +instance JsonExport a => JsonExport (Mb' (ctx :: RList CrucibleType) a) where + jsonExport mb = mbLift $ flip nuMultiWithElim1 (_mbBinding mb) $ \names body -> + let ?ppi = ppInfoApplyAllocation names (_mbNames mb) ?ppi in + object [ + ("args", jsonExport names), + ("body", jsonExport body) + ] + instance JsonExport (Nonce a b) where jsonExport = toJSON . indexValue diff --git a/heapster-saw/src/Verifier/SAW/Heapster/NamedMb.hs b/heapster-saw/src/Verifier/SAW/Heapster/NamedMb.hs index ca7f1ed131..93128b7ee1 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/NamedMb.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/NamedMb.hs @@ -32,8 +32,7 @@ nuMulti' tps f = Mb' } nuMultiWithElim1' :: (RAssign Name ctx -> arg -> b) -> Mb' ctx arg -> Mb' ctx b -nuMultiWithElim1' k = over mbBinding (nuMultiWithElim1 k) - +nuMultiWithElim1' = over mbBinding . nuMultiWithElim1 strongMbM' :: MonadStrongBind m => Mb' ctx (m a) -> m (Mb' ctx a) strongMbM' = traverseOf mbBinding strongMbM @@ -42,11 +41,7 @@ mbM' :: (MonadBind m, NuMatching a) => Mb' ctx (m a) -> m (Mb' ctx a) mbM' = traverseOf mbBinding mbM mbSwap' :: RAssign Proxy ctx -> Mb' ctx' (Mb' ctx a) -> Mb' ctx (Mb' ctx' a) -mbSwap' p (Mb' names' body') = - Mb' - { _mbNames = mbLift (_mbNames <$> body') - , _mbBinding = Mb' names' <$> mbSwap p (_mbBinding <$> body') - } +mbSwap' p (Mb' names' body') = Mb' names' <$> mbSink p body' mbSink :: RAssign Proxy ctx -> Mb ctx' (Mb' ctx a) -> Mb' ctx (Mb ctx' a) mbSink p m = @@ -55,6 +50,9 @@ mbSink p m = , _mbBinding = mbSwap p (_mbBinding <$> m) } +mbCombine' :: RAssign Proxy c2 -> Mb' c1 (Mb' c2 a) -> Mb' (c1 :++: c2) a +mbCombine' = undefined + mbLift' :: Liftable a => Mb' ctx a -> a mbLift' = views mbBinding mbLift diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs index abf0b475ca..4b831ff26f 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs @@ -219,6 +219,16 @@ ppInfoAddTypedExprNames _ MNil info = info ppInfoAddTypedExprNames (CruCtxCons tps tp) (ns :>: n) info = ppInfoAddTypedExprNames tps ns $ ppInfoAddExprName (typeBaseName tp) n info +-- | Add a sequence of variables to a 'PPInfo' using their 'typeBaseName's +ppInfoAllocateTypedExprNames :: + CruCtx tps -> PPInfo -> (RAssign StringF tps, PPInfo) +ppInfoAllocateTypedExprNames CruCtxNil info = (MNil, info) +ppInfoAllocateTypedExprNames (CruCtxCons tps tp) ppi = + case ppInfoAllocateName (typeBaseName tp) ppi of + (ppi1, str) -> + case ppInfoAllocateTypedExprNames tps ppi1 of + (ns', ppi2) -> (ns' :>: StringF str, ppi2) + ppInfoApplyAllocation :: RAssign Name (tps :: RList CrucibleType) -> RAssign StringF tps -> @@ -4970,6 +4980,18 @@ genSubstMb :: s ctx' -> Mb ctx' (Mb ctx a) -> m (Mb ctx a) genSubstMb p s mbmb = mbM (fmap (genSubst s) (mbSwap p mbmb)) +genSubstMb' :: + Substable s a m => + NuMatching a => + RAssign Proxy ctx -> + s ctx' -> Mb ctx' (Mb' ctx a) -> m (Mb' ctx a) +genSubstMb' p s mbmb = mbM' (fmap (genSubst s) (swapHelper p mbmb)) + +swapHelper :: RAssign Proxy b -> Mb a (Mb' b c) -> Mb' b (Mb a c) +swapHelper p m = Mb' ns (mbSwap p bs) + where + ns = mbLift (fmap _mbNames m) + bs = fmap _mbBinding m instance {-# INCOHERENT #-} (Given (RAssign Proxy ctx), Substable s a m, NuMatching a) => Substable s (Mb' ctx a) m where genSubst = genSubstMb' given @@ -4980,12 +5002,6 @@ instance {-# INCOHERENT #-} (Substable s a m, NuMatching a) => Substable s (Mb' instance {-# INCOHERENT #-} (Substable s a m, NuMatching a) => Substable s (Binding' c a) m where genSubst = genSubstMb' RL.typeCtxProxies -genSubstMb' :: - Substable s a m => - NuMatching a => - RAssign Proxy ctx -> - s ctx' -> Mb ctx' (Mb' ctx a) -> m (Mb' ctx a) -genSubstMb' p s mbmb = mbM' (fmap (genSubst s) (mbSink p mbmb)) instance SubstVar s m => Substable s (Member ctx a) m where genSubst _ mb_memb = return $ mbLift mb_memb diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 622586c624..091eca5f50 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -3103,7 +3103,7 @@ translatePermImplUnary :: PermImplTransM (ImplFailCont -> ImpTransM ext blocks tops ret ps ctx OpenTerm) translatePermImplUnary (mbMatch -> [nuMP| MbPermImpls_Cons _ _ mb_impl |]) f = - translatePermImpl Proxy (mbCombine RL.typeCtxProxies mb_impl) >>= \trans -> + translatePermImpl Proxy (mbCombine RL.typeCtxProxies (fmap _mbBinding mb_impl)) >>= \trans -> return $ \k -> f $ trans k @@ -3124,9 +3124,11 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl ([nuMP| Impl1_Catch |], [nuMP| (MbPermImpls_Cons _ (MbPermImpls_Cons _ _ mb_impl1) mb_impl2) |]) -> pitmCatching (translatePermImpl prx $ - mbCombine RL.typeCtxProxies mb_impl1) >>= \(mtrans1,hasf1) -> + mbCombine RL.typeCtxProxies $ + fmap _mbBinding mb_impl1) >>= \(mtrans1,hasf1) -> pitmCatching (translatePermImpl prx $ - mbCombine RL.typeCtxProxies mb_impl2) >>= \(mtrans2,hasf2) -> + mbCombine RL.typeCtxProxies $ + fmap _mbBinding mb_impl2) >>= \(mtrans2,hasf2) -> (if hasf1 == HasFailures && hasf2 == HasFailures then tell ([],HasFailures) else return ()) >> case (mtrans1, hasf1, mtrans2, hasf2) of @@ -3163,9 +3165,11 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl ([nuMP| Impl1_ElimOr x p1 p2 |], [nuMP| (MbPermImpls_Cons _ (MbPermImpls_Cons _ _ mb_impl1) mb_impl2) |]) -> pitmCatching (translatePermImpl prx $ - mbCombine RL.typeCtxProxies mb_impl1) >>= \(mtrans1,hasf1) -> + mbCombine RL.typeCtxProxies $ + fmap _mbBinding mb_impl1) >>= \(mtrans1,hasf1) -> pitmCatching (translatePermImpl prx $ - mbCombine RL.typeCtxProxies mb_impl2) >>= \(mtrans2,hasf2) -> + mbCombine RL.typeCtxProxies $ + fmap _mbBinding mb_impl2) >>= \(mtrans2,hasf2) -> tell ([],hasf1 <> hasf2) >> case (mtrans1, mtrans2) of (Nothing, Nothing) -> mzero @@ -3302,7 +3306,7 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl -- considered just an assertion and not a failure ([nuMP| Impl1_TryProveBVProp x prop@(BVProp_Eq e1 e2) prop_str |], [nuMP| MbPermImpls_Cons _ _ mb_impl' |]) -> - translatePermImpl prx (mbCombine RL.typeCtxProxies mb_impl') >>= \trans -> + translatePermImpl prx (mbCombine RL.typeCtxProxies $ fmap _mbBinding mb_impl') >>= \trans -> return $ \k -> do prop_tp_trans <- translate prop applyMultiTransM (return $ globalOpenTerm "Prelude.maybe") @@ -3318,7 +3322,7 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl -- For an inequality test, we don't need a proof, so just insert an if ([nuMP| Impl1_TryProveBVProp x prop@(BVProp_Neq e1 e2) prop_str |], [nuMP| MbPermImpls_Cons _ _ mb_impl' |]) -> - translatePermImpl prx (mbCombine RL.typeCtxProxies mb_impl') >>= \trans -> + translatePermImpl prx (mbCombine RL.typeCtxProxies $ fmap _mbBinding mb_impl') >>= \trans -> return $ \k -> let w = natVal2 prop in applyMultiTransM (return $ globalOpenTerm "Prelude.ite") @@ -3343,7 +3347,7 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl ([nuMP| Impl1_TryProveBVProp x prop@(BVProp_ULt e1 e2) prop_str |], [nuMP| MbPermImpls_Cons _ _ mb_impl' |]) -> - translatePermImpl prx (mbCombine RL.typeCtxProxies mb_impl') >>= \trans -> + translatePermImpl prx (mbCombine RL.typeCtxProxies $ fmap _mbBinding mb_impl') >>= \trans -> return $ \k -> do prop_tp_trans <- translate prop applyMultiTransM (return $ globalOpenTerm "Prelude.maybe") @@ -3370,7 +3374,7 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl ([nuMP| Impl1_TryProveBVProp x prop@(BVProp_ULeq e1 e2) prop_str |], [nuMP| MbPermImpls_Cons _ _ mb_impl' |]) -> - translatePermImpl prx (mbCombine RL.typeCtxProxies mb_impl') >>= \trans -> + translatePermImpl prx (mbCombine RL.typeCtxProxies $ fmap _mbBinding mb_impl') >>= \trans -> return $ \k -> do prop_tp_trans <- translate prop applyMultiTransM (return $ globalOpenTerm "Prelude.maybe") @@ -3387,7 +3391,7 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl ([nuMP| Impl1_TryProveBVProp x prop@(BVProp_ULeq_Diff e1 e2 e3) prop_str |], [nuMP| MbPermImpls_Cons _ _ mb_impl' |]) -> - translatePermImpl prx (mbCombine RL.typeCtxProxies mb_impl') >>= \trans -> + translatePermImpl prx (mbCombine RL.typeCtxProxies $ fmap _mbBinding mb_impl') >>= \trans -> return $ \k -> do prop_tp_trans <- translate prop applyMultiTransM (return $ globalOpenTerm "Prelude.maybe") From b284fc49ee44b5b2b39c84f783ac0dc166ccc38c Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Sat, 28 Aug 2021 10:15:23 -0700 Subject: [PATCH 23/28] Checkpoint --- .../src/Verifier/SAW/Heapster/IDESupport.hs | 8 -- .../Verifier/SAW/Heapster/TypedCrucible.hs | 76 +++++-------------- 2 files changed, 18 insertions(+), 66 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs b/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs index 8a63e3d92f..c588d35bc5 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs @@ -197,14 +197,6 @@ instance (PermCheckExtC ext) 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) - nmbExtractLogEntries :: ExtractLogEntries a => Mb' (ctx :: RList CrucibleType) a -> ExtractionM () nmbExtractLogEntries mb_a = diff --git a/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs b/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs index a46ddc6652..89869ae569 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs @@ -1959,9 +1959,9 @@ runPermCheckM names entryID args ghosts mb_perms_in m = st = st1 { stPPInfo = ppi } in let go x = runGenStateContT x st (\_ () -> pure ()) in go $ - setVarTypes' tops_ns stTopCtx >>> - setVarTypes' args_ns args >>> - setVarTypes' ghosts_ns ghosts >>> + 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 @@ -2251,77 +2251,37 @@ getVarTypes (xs :>: x) = CruCtxCons <$> getVarTypes xs <*> getVarType x -- | 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 + ExprVar a {- ^ The Hobbits variable itself -} -> + TypeRepr a {- ^ The type of the variable -} -> PermCheckM ext cblocks blocks tops ret r ps r ps () -setVarType maybe_str dbg x tp = - let str' = - case (maybe_str,dbg) of - (_,Just d) -> "C[" ++ d ++ "]" - (Just str,_) -> str ++ "_" ++ typeBaseName tp - (Nothing,Nothing) -> typeBaseName tp - in - modify $ \st -> - st { stCurPerms = initVarPerm x (stCurPerms st), - stVarTypes = NameMap.insert x tp (stVarTypes st), - stPPInfo = ppInfoAddExprName str' x (stPPInfo 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 ret 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 - --- | Remember the type of a free variable, and ensure that it has a permission -setVarType' :: - ExprVar a -> -- ^ The Hobbits variable itself - TypeRepr a -> -- ^ The type of the variable - PermCheckM ext cblocks blocks tops ret r ps r ps () -setVarType' x tp = +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' :: +setVarTypes :: RAssign Name tps -> CruCtx tps -> PermCheckM ext cblocks blocks tops ret r ps r ps () -setVarTypes' MNil CruCtxNil = pure () -setVarTypes' (ns :>: n) (CruCtxCons ts t) = - do setVarTypes' ns ts - setVarType' n t +setVarTypes MNil CruCtxNil = pure () +setVarTypes (ns :>: n) (CruCtxCons ts t) = + do setVarTypes ns ts + setVarType n t allocateDebugNames :: - Maybe String -> -- ^ The bsae name of the variable (e.g., "top", "arg", etc.) + Maybe String {- ^ The bsae 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) -allocateDebugNames _ MNil _ = pure MNil -allocateDebugNames base (ds :>: Constant dbg) (CruCtxCons ts tp) = - do outs <- allocateDebugNames base ds ts - out <- state $ \st -> - case ppInfoAllocateName str (stPPInfo st) of - (ppi, str') -> (str', st { stPPInfo = ppi }) - pure (outs :>: StringF out) - where - str = - case (base,dbg) of - (_,Just d) -> "C[" ++ d ++ "]" - (Just b,_) -> b ++ "_" ++ typeBaseName tp - (Nothing,Nothing) -> typeBaseName tp +allocateDebugNames base ds tps = + state $ \s -> + case allocateDebugNames' base ds tps (stPPInfo s) of + (r, info) -> (r, s{ stPPInfo = info}) allocateDebugNames' :: - Maybe String -> -- ^ The bsae name of the variable (e.g., "top", "arg", etc.) + Maybe String {- ^ The bsae name of the variable (e.g., "top", "arg", etc.) -} -> RAssign (Constant (Maybe String)) tps -> CruCtx tps -> PPInfo -> @@ -2638,7 +2598,7 @@ emitStmt tps names loc stmt = allocateDebugNames Nothing names tps >>>= \debugs -> startBinding' debugs (fmap (TypedConsStmt loc stmt pxys) . strongMbM') >>>= \ns -> modify (\st -> st { stPPInfo = ppInfoApplyAllocation ns debugs (stPPInfo st)}) >>> - setVarTypes' ns tps >>> + setVarTypes ns tps >>> gmodify (modifySTCurPerms (applyTypedStmt stmt ns)) >>> pure ns From 491c38f3fbcc2b14756db78c7ab179197631c980 Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Mon, 30 Aug 2021 13:31:05 -0700 Subject: [PATCH 24/28] Update cabal file --- heapster-saw/heapster-saw.cabal | 1 + .../src/Verifier/SAW/Heapster/Permissions.hs | 13 ------------- 2 files changed, 1 insertion(+), 13 deletions(-) diff --git a/heapster-saw/heapster-saw.cabal b/heapster-saw/heapster-saw.cabal index 90a7e4f4bf..8e2c4e2ee6 100644 --- a/heapster-saw/heapster-saw.cabal +++ b/heapster-saw/heapster-saw.cabal @@ -58,6 +58,7 @@ library Verifier.SAW.Heapster.Permissions Verifier.SAW.Heapster.PermParser Verifier.SAW.Heapster.NamePropagation + Verifier.SAW.Heapster.NamedMb Verifier.SAW.Heapster.RustTypes Verifier.SAW.Heapster.SAWTranslation Verifier.SAW.Heapster.Token diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs index 4b831ff26f..5e5042e096 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs @@ -200,19 +200,6 @@ 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 From 3d0ae00b27fd14e69a6dea90bd1c0262780e4f59 Mon Sep 17 00:00:00 2001 From: Karl Smeltzer Date: Tue, 31 Aug 2021 13:48:19 -0700 Subject: [PATCH 25/28] user the error prefix when logging errors for IDE --- .../src/Verifier/SAW/Heapster/IDESupport.hs | 39 ++++++++++++------- .../Verifier/SAW/Heapster/TypedCrucible.hs | 7 ++-- 2 files changed, 30 insertions(+), 16 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs b/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs index c588d35bc5..aa947ad058 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs @@ -49,8 +49,15 @@ printIDEInfo :: PermEnv -> [Some SomeTypedCFG] -> FilePath -> PPInfo -> IO () printIDEInfo _penv tcfgs file ppinfo = encodeFile file $ IDELog (runWithLoc ppinfo tcfgs) +data ExtractionInfo = ExtractionInfo { + eiPPInfo :: PPInfo, + eiLoc :: ProgramLoc, + eiFnName :: String, + eiErrorPrefix :: String +} + +type ExtractionM = ReaderT ExtractionInfo (Writer [LogEntry]) -type ExtractionM = ReaderT (PPInfo, ProgramLoc, String) (Writer [LogEntry]) emit :: LogEntry -> ExtractionM () emit entry = tell [entry] @@ -124,7 +131,7 @@ instance (PermCheckExtC ext) withLoc loc (nmbExtractLogEntries (typedEntryBody te)) let entryId = mkLogEntryID $ typedEntryID te let callers = callerIDs $ typedEntryCallers te - (ppi, _, fname) <- ask + ExtractionInfo { eiPPInfo = ppi, eiFnName = fname } <- ask let loc' = snd (ppLoc loc) let debugNames = _mbNames (typedEntryBody te) let inputs = mbLift @@ -152,8 +159,8 @@ 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 (TypedImplStmt (AnnotPermImpl str pimpl)) = + local (\eiinfo -> eiinfo { eiErrorPrefix = str }) $ extractLogEntries pimpl extractLogEntries (TypedConsStmt loc _ _ rest) = do withLoc loc $ nmbExtractLogEntries rest @@ -169,11 +176,11 @@ instance ExtractLogEntries instance ExtractLogEntries (PermImpl1 ps_in ps_outs) where extractLogEntries (Impl1_Fail err) = - do (_, loc, fname) <- ask - emit (LogError (snd (ppLoc loc)) (ppError err) fname) + do ExtractionInfo { eiLoc = loc, eiFnName = fname, eiErrorPrefix = prefix } <- ask + emit (LogError (snd (ppLoc loc)) (prefix ++ "\n" ++ ppError err) fname) -- The error message is available further up the stack, so we just leave it extractLogEntries impl = - do (ppi, loc, fname) <- ask + do ExtractionInfo { eiPPInfo = ppi, eiLoc = loc, eiFnName = fname } <- ask emit (LogImpl (snd (ppLoc loc)) (ppToJson ppi impl) fname) instance ExtractLogEntries @@ -200,19 +207,20 @@ instance (PermCheckExtC ext) nmbExtractLogEntries :: ExtractLogEntries a => Mb' (ctx :: RList CrucibleType) a -> ExtractionM () nmbExtractLogEntries mb_a = - ReaderT $ \(ppi, loc, fname) -> + ReaderT $ \einfo -> 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) + let ppi' = ppInfoApplyAllocation ns (_mbNames mb_a) (eiPPInfo einfo) in + execWriter $ runReaderT (extractLogEntries x) + (einfo { eiPPInfo = ppi' }) 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)) +withLoc loc = local $ \einfo -> einfo { eiLoc = loc } setErrorMsg :: String -> LogEntry -> LogEntry -setErrorMsg msg le@LogError {} = le { lerrError = msg } +setErrorMsg msg le@LogError {} = le { lerrError = msg <> lerrError le } setErrorMsg msg le@LogImpl {} = LogError { lerrError = msg , lerrLocation = limplLocation le @@ -230,7 +238,12 @@ runWithLoc ppi = runWithLocHelper :: PPInfo -> Some SomeTypedCFG -> [LogEntry] runWithLocHelper ppi' sstcfg = case sstcfg of Some (SomeTypedCFG tcfg) -> do - let env = (ppi', getFirstProgramLoc tcfg, getFunctionName tcfg) + let env = ExtractionInfo { + eiPPInfo = ppi', + eiLoc = getFirstProgramLoc tcfg, + eiFnName = getFunctionName tcfg, + eiErrorPrefix = "" + } execWriter (runReaderT (extractLogEntries tcfg) env) getFunctionName :: TypedCFG ext blocks ghosts inits ret -> String diff --git a/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs b/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs index 89869ae569..92158ef367 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs @@ -2724,9 +2724,10 @@ setErrorPrefix names loc stmt_pp ctx regs = ppCruRegsAndTopsPerms names ctx regs >>>= \(regs_pp, perms_pp) -> let prefix = PP.sep - [PP.group (pretty "At" <+> ppShortFileName (plSourceLoc loc) - <+> parens stmt_pp), - PP.group (pretty "Regs:" <+> regs_pp), + [ + -- PP.group (pretty "At" <+> ppShortFileName (plSourceLoc loc) + -- <+> parens stmt_pp), + -- PP.group (pretty "Regs:" <+> regs_pp), PP.group (pretty "Input perms:" <+> perms_pp)] in gmodify $ \st -> st { stErrPrefix = Just prefix } From 4e4cc4ba17f403cf4ac2b71356b80b1ee9883dea Mon Sep 17 00:00:00 2001 From: Karl Smeltzer Date: Tue, 31 Aug 2021 14:01:10 -0700 Subject: [PATCH 26/28] revert commented error prefix code --- heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs b/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs index 92158ef367..89869ae569 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs @@ -2724,10 +2724,9 @@ setErrorPrefix names loc stmt_pp ctx regs = ppCruRegsAndTopsPerms names ctx regs >>>= \(regs_pp, perms_pp) -> let prefix = PP.sep - [ - -- PP.group (pretty "At" <+> ppShortFileName (plSourceLoc loc) - -- <+> parens stmt_pp), - -- PP.group (pretty "Regs:" <+> regs_pp), + [PP.group (pretty "At" <+> ppShortFileName (plSourceLoc loc) + <+> parens stmt_pp), + PP.group (pretty "Regs:" <+> regs_pp), PP.group (pretty "Input perms:" <+> perms_pp)] in gmodify $ \st -> st { stErrPrefix = Just prefix } From f60e26b8a17b1824a9829771303e31c0e4ed8220 Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Tue, 31 Aug 2021 14:01:40 -0700 Subject: [PATCH 27/28] Change Mb' to NMb --- .../src/Verifier/SAW/Heapster/GenMonad.hs | 10 ++-- .../src/Verifier/SAW/Heapster/IDESupport.hs | 8 +-- .../src/Verifier/SAW/Heapster/Implication.hs | 44 ++++++++-------- .../src/Verifier/SAW/Heapster/JSONExport.hs | 2 +- .../src/Verifier/SAW/Heapster/NamedMb.hs | 51 +++++++++---------- .../src/Verifier/SAW/Heapster/Permissions.hs | 30 +++++------ .../Verifier/SAW/Heapster/TypedCrucible.hs | 14 ++--- 7 files changed, 78 insertions(+), 81 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/GenMonad.hs b/heapster-saw/src/Verifier/SAW/Heapster/GenMonad.hs index 54bde8429e..3c58fc32a5 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/GenMonad.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/GenMonad.hs @@ -111,12 +111,12 @@ gopenBinding f_ret mb_a = -- | Name-binding in the generalized continuation monad (FIXME: explain) gopenBinding' :: - (Mb' ctx (m b1) -> m r2) -> - Mb' ctx b2 -> + (NMb ctx (m b1) -> m r2) -> + NMb ctx b2 -> GenStateContT s b1 s r2 m (RAssign Name ctx, b2) gopenBinding' f_ret mb_a = gcaptureCC \k -> - f_ret $ flip nuMultiWithElim1' mb_a $ \names a -> + f_ret $ flip nuMultiWithElim1N mb_a $ \names a -> k (names, a) -- | Name-binding in the generalized continuation monad (FIXME: explain) @@ -129,9 +129,9 @@ startBinding tps f_ret = gcaptureCC (f_ret . nuMulti tps) -- | Name-binding in the generalized continuation monad (FIXME: explain) startBinding' :: RAssign StringF ctx -> - (Mb' ctx (m r1) -> m r2) -> + (NMb ctx (m r1) -> m r2) -> GenStateContT s r1 s r2 m (RAssign Name ctx) -startBinding' tps f_ret = gcaptureCC (f_ret . nuMulti' tps) +startBinding' tps f_ret = gcaptureCC (f_ret . nuMultiN tps) addReader :: GenStateContT s1 r1 s2 r2 m a -> GenStateContT s1 r1 s2 r2 (ReaderT e m) a addReader (GenStateContT m) = diff --git a/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs b/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs index c588d35bc5..eb8a4242a9 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs @@ -120,7 +120,7 @@ instance (PermCheckExtC ext) => ExtractLogEntries (TypedEntry TransPhase ext blocks tops ret args ghosts) where extractLogEntries te = do - let loc = mbLift' $ fmap getFirstProgramLocTS (typedEntryBody te) + let loc = nmbLift $ fmap getFirstProgramLocTS (typedEntryBody te) withLoc loc (nmbExtractLogEntries (typedEntryBody te)) let entryId = mkLogEntryID $ typedEntryID te let callers = callerIDs $ typedEntryCallers te @@ -198,7 +198,7 @@ instance (PermCheckExtC ext) mapM_ (\(Some te) -> extractLogEntries te) $ _typedBlockEntries tb nmbExtractLogEntries - :: ExtractLogEntries a => Mb' (ctx :: RList CrucibleType) a -> ExtractionM () + :: ExtractLogEntries a => NMb (ctx :: RList CrucibleType) a -> ExtractionM () nmbExtractLogEntries mb_a = ReaderT $ \(ppi, loc, fname) -> tell $ mbLift $ flip nuMultiWithElim1 (_mbBinding mb_a) $ \ns x -> @@ -259,7 +259,7 @@ getFirstProgramLocBM block = -> Maybe ProgramLoc helper ste = case ste of Some TypedEntry { typedEntryBody = stmts } -> - Just $ mbLift' $ fmap getFirstProgramLocTS stmts + Just $ nmbLift $ 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 @@ -285,7 +285,7 @@ getFirstProgramLocMBPI getFirstProgramLocMBPI MbPermImpls_Nil = error "Error finding program location for IDE log" getFirstProgramLocMBPI (MbPermImpls_Cons _ _ pis) = - mbLift' $ fmap getFirstProgramLocPI pis + nmbLift $ fmap getFirstProgramLocPI pis -- | Print a `ProgramLoc` in a way that is useful for an IDE, i.e., machine -- readable diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs b/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs index f85aa523c2..b3882e1b03 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs @@ -1361,7 +1361,7 @@ data MbPermImpls r bs_pss where MbPermImpls_Nil :: MbPermImpls r RNil MbPermImpls_Cons :: CruCtx bs -> !(MbPermImpls r bs_pss) -> - !(Mb' bs (PermImpl r ps)) -> + !(NMb bs (PermImpl r ps)) -> MbPermImpls r (bs_pss :> '(bs,ps)) -- | A local implication, from an input to an output permission set @@ -1409,7 +1409,7 @@ permImplStep impl1@(Impl1_Fail _) mb_impls = PermImpl_Step impl1 mb_impls -- Catch --> call the permImplCatch function permImplStep Impl1_Catch ((MbPermImpls_Cons _ (MbPermImpls_Cons _ _ mb_pimpl1) mb_pimpl2)) = - permImplCatch (elimEmptyMb' mb_pimpl1) (elimEmptyMb' mb_pimpl2) + permImplCatch (elimEmptyNMb mb_pimpl1) (elimEmptyNMb mb_pimpl2) -- Unary rules applied to failure --> failures -- @@ -1519,12 +1519,12 @@ permImplCatch pimpl1@(PermImpl_Step (Impl1_Fail _) _) pimpl2 = permImplCatch (PermImpl_Step Impl1_Catch (MbPermImpls_Cons _ (MbPermImpls_Cons _ _ mb_pimpl_1a) mb_pimpl_1b)) pimpl2 = - permImplCatch (elimEmptyMb' mb_pimpl_1a) $ - permImplCatch (elimEmptyMb' mb_pimpl_1b) pimpl2 + permImplCatch (elimEmptyNMb mb_pimpl_1a) $ + permImplCatch (elimEmptyNMb mb_pimpl_1b) pimpl2 permImplCatch pimpl1 pimpl2 = PermImpl_Step Impl1_Catch $ - MbPermImpls_Cons knownRepr (MbPermImpls_Cons knownRepr MbPermImpls_Nil $ emptyMb' pimpl1) $ - emptyMb' pimpl2 + MbPermImpls_Cons knownRepr (MbPermImpls_Cons knownRepr MbPermImpls_Nil $ emptyNMb pimpl1) $ + emptyNMb pimpl2 -- | Test if a 'PermImpl' "succeeds", meaning there is at least one non-failing @@ -1537,40 +1537,40 @@ permImplSucceeds (PermImpl_Done _) = 2 permImplSucceeds (PermImpl_Step (Impl1_Fail _) _) = 0 permImplSucceeds (PermImpl_Step Impl1_Catch (MbPermImpls_Cons _ (MbPermImpls_Cons _ _ mb_impl1) mb_impl2)) = - max (mbLift' $ fmap permImplSucceeds mb_impl1) - (mbLift' $ fmap permImplSucceeds mb_impl2) + max (nmbLift $ fmap permImplSucceeds mb_impl1) + (nmbLift $ fmap permImplSucceeds mb_impl2) permImplSucceeds (PermImpl_Step (Impl1_Push _ _) (MbPermImpls_Cons _ _ mb_impl)) = - mbLift' $ fmap permImplSucceeds mb_impl + nmbLift $ fmap permImplSucceeds mb_impl permImplSucceeds (PermImpl_Step (Impl1_Pop _ _) (MbPermImpls_Cons _ _ mb_impl)) = - mbLift' $ fmap permImplSucceeds mb_impl + nmbLift $ fmap permImplSucceeds mb_impl permImplSucceeds (PermImpl_Step (Impl1_ElimOr _ _ _) (MbPermImpls_Cons _ (MbPermImpls_Cons _ _ mb_impl1) mb_impl2)) = - max (mbLift' (fmap permImplSucceeds mb_impl1)) - (mbLift' (fmap permImplSucceeds mb_impl2)) + max (nmbLift (fmap permImplSucceeds mb_impl1)) + (nmbLift (fmap permImplSucceeds mb_impl2)) permImplSucceeds (PermImpl_Step (Impl1_ElimExists _ _) (MbPermImpls_Cons _ _ mb_impl)) = - mbLift' $ fmap permImplSucceeds mb_impl + nmbLift $ fmap permImplSucceeds mb_impl permImplSucceeds (PermImpl_Step (Impl1_Simpl _ _) (MbPermImpls_Cons _ _ mb_impl)) = - mbLift' $ fmap permImplSucceeds mb_impl + nmbLift $ fmap permImplSucceeds mb_impl permImplSucceeds (PermImpl_Step (Impl1_LetBind _ _) (MbPermImpls_Cons _ _ mb_impl)) = - mbLift' $ fmap permImplSucceeds mb_impl + nmbLift $ fmap permImplSucceeds mb_impl permImplSucceeds (PermImpl_Step (Impl1_ElimStructField _ _ _ _) (MbPermImpls_Cons _ _ mb_impl)) = - mbLift' $ fmap permImplSucceeds mb_impl + nmbLift $ fmap permImplSucceeds mb_impl permImplSucceeds (PermImpl_Step (Impl1_ElimLLVMFieldContents _ _) (MbPermImpls_Cons _ _ mb_impl)) = - mbLift' $ fmap permImplSucceeds mb_impl + nmbLift $ fmap permImplSucceeds mb_impl permImplSucceeds (PermImpl_Step (Impl1_ElimLLVMBlockToEq _ _) (MbPermImpls_Cons _ _ mb_impl)) = - mbLift' $ fmap permImplSucceeds mb_impl + nmbLift $ fmap permImplSucceeds mb_impl permImplSucceeds (PermImpl_Step Impl1_BeginLifetime (MbPermImpls_Cons _ _ mb_impl)) = - mbLift' $ fmap permImplSucceeds mb_impl + nmbLift $ fmap permImplSucceeds mb_impl permImplSucceeds (PermImpl_Step (Impl1_TryProveBVProp _ _ _) (MbPermImpls_Cons _ _ mb_impl)) = - mbLift' $ fmap permImplSucceeds mb_impl + nmbLift $ fmap permImplSucceeds mb_impl -- | Test if a 'PermImpl' fails, meaning 'permImplSucceeds' returns 0 permImplFails :: PermImpl r ps -> Bool @@ -2651,7 +2651,7 @@ instance (NuMatchingAny1 r, SubstVar PermVarSubst m, [nuMP| MbPermImpls_Nil |] -> return MbPermImpls_Nil [nuMP| MbPermImpls_Cons mpx mb_impl mb_impls' |] -> let px = mbLift mpx in - MbPermImpls_Cons px <$> genSubst s mb_impl <*> genSubstMb' (cruCtxProxies px) s mb_impls' + MbPermImpls_Cons px <$> genSubst s mb_impl <*> genSubstNMb (cruCtxProxies px) s mb_impls' -- FIXME: shouldn't need the SubstVar PermVarSubst m assumption... instance SubstVar PermVarSubst m => @@ -3079,7 +3079,7 @@ implApplyImpl1 impl1 mb_ms = helper MbPermSets_Nil _ = gabortM (return MbPermImpls_Nil) helper (MbPermSets_Cons mbperms ctx mbperm) (args :>: Impl1Cont f) = state (\s -> s & implStatePPInfo %%~ ppInfoAllocateTypedExprNames ctx) >>>= \n -> - gparallel (\m1 m2 -> MbPermImpls_Cons ctx <$> m1 <*> (Mb' n <$> m2)) + gparallel (\m1 m2 -> MbPermImpls_Cons ctx <$> m1 <*> (NMb n <$> m2)) (helper mbperms args) (gopenBinding strongMbM mbperm >>>= \(ns, perms') -> gmodify (set implStatePerms perms' . diff --git a/heapster-saw/src/Verifier/SAW/Heapster/JSONExport.hs b/heapster-saw/src/Verifier/SAW/Heapster/JSONExport.hs index 6169ec73d0..19714178eb 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/JSONExport.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/JSONExport.hs @@ -72,7 +72,7 @@ instance JsonExport a => JsonExport (Mb (ctx :: RList CrucibleType) a) where ("body", jsonExport body) ] -instance JsonExport a => JsonExport (Mb' (ctx :: RList CrucibleType) a) where +instance JsonExport a => JsonExport (NMb (ctx :: RList CrucibleType) a) where jsonExport mb = mbLift $ flip nuMultiWithElim1 (_mbBinding mb) $ \names body -> let ?ppi = ppInfoApplyAllocation names (_mbNames mb) ?ppi in object [ diff --git a/heapster-saw/src/Verifier/SAW/Heapster/NamedMb.hs b/heapster-saw/src/Verifier/SAW/Heapster/NamedMb.hs index 93128b7ee1..c8df4cd018 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/NamedMb.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/NamedMb.hs @@ -14,53 +14,50 @@ import Control.Lens newtype StringF a = StringF { unStringF :: String } -type Binding' c = Mb' (RNil :> c) +type Binding' c = NMb (RNil :> c) -data Mb' ctx a = Mb' +data NMb ctx a = NMb { _mbNames :: RAssign StringF ctx , _mbBinding :: Mb ctx a } deriving Functor -mbBinding :: Lens (Mb' ctx a) (Mb' ctx b) (Mb ctx a) (Mb ctx b) -mbBinding f x = Mb' (_mbNames x) <$> f (_mbBinding x) +mbBinding :: Lens (NMb ctx a) (NMb ctx b) (Mb ctx a) (Mb ctx b) +mbBinding f x = NMb (_mbNames x) <$> f (_mbBinding x) -nuMulti' :: RAssign StringF ctx -> (RAssign Name ctx -> b) -> Mb' ctx b -nuMulti' tps f = Mb' +nuMultiN :: RAssign StringF ctx -> (RAssign Name ctx -> b) -> NMb ctx b +nuMultiN tps f = NMb { _mbNames = tps , _mbBinding = nuMulti (mapRAssign (const Proxy) tps) f } -nuMultiWithElim1' :: (RAssign Name ctx -> arg -> b) -> Mb' ctx arg -> Mb' ctx b -nuMultiWithElim1' = over mbBinding . nuMultiWithElim1 +nuMultiWithElim1N :: (RAssign Name ctx -> arg -> b) -> NMb ctx arg -> NMb ctx b +nuMultiWithElim1N = over mbBinding . nuMultiWithElim1 -strongMbM' :: MonadStrongBind m => Mb' ctx (m a) -> m (Mb' ctx a) -strongMbM' = traverseOf mbBinding strongMbM +strongNMbM :: MonadStrongBind m => NMb ctx (m a) -> m (NMb ctx a) +strongNMbM = traverseOf mbBinding strongMbM -mbM' :: (MonadBind m, NuMatching a) => Mb' ctx (m a) -> m (Mb' ctx a) -mbM' = traverseOf mbBinding mbM +nmbM :: (MonadBind m, NuMatching a) => NMb ctx (m a) -> m (NMb ctx a) +nmbM = traverseOf mbBinding mbM -mbSwap' :: RAssign Proxy ctx -> Mb' ctx' (Mb' ctx a) -> Mb' ctx (Mb' ctx' a) -mbSwap' p (Mb' names' body') = Mb' names' <$> mbSink p body' +nmbSwap :: RAssign Proxy ctx -> NMb ctx' (NMb ctx a) -> NMb ctx (NMb ctx' a) +nmbSwap p (NMb names' body') = NMb names' <$> nmbSink p body' -mbSink :: RAssign Proxy ctx -> Mb ctx' (Mb' ctx a) -> Mb' ctx (Mb ctx' a) -mbSink p m = - Mb' +nmbSink :: RAssign Proxy ctx -> Mb ctx' (NMb ctx a) -> NMb ctx (Mb ctx' a) +nmbSink p m = + NMb { _mbNames = mbLift (_mbNames <$> m) , _mbBinding = mbSwap p (_mbBinding <$> m) } -mbCombine' :: RAssign Proxy c2 -> Mb' c1 (Mb' c2 a) -> Mb' (c1 :++: c2) a -mbCombine' = undefined +nmbLift :: Liftable a => NMb ctx a -> a +nmbLift = views mbBinding mbLift -mbLift' :: Liftable a => Mb' ctx a -> a -mbLift' = views mbBinding mbLift +elimEmptyNMb :: NMb RNil a -> a +elimEmptyNMb = views mbBinding elimEmptyMb -elimEmptyMb' :: Mb' RNil a -> a -elimEmptyMb' = views mbBinding elimEmptyMb - -emptyMb' :: a -> Mb' RNil a -emptyMb' = Mb' MNil . emptyMb +emptyNMb :: a -> NMb RNil a +emptyNMb = NMb MNil . emptyMb mkNuMatching [t| forall a. StringF a |] instance NuMatchingAny1 StringF where @@ -72,4 +69,4 @@ instance Liftable (StringF a) where instance LiftableAny1 StringF where mbLiftAny1 = mbLift -mkNuMatching [t| forall ctx a. NuMatching a => Mb' ctx a |] +mkNuMatching [t| forall ctx a. NuMatching a => NMb ctx a |] diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs index 5e5042e096..9716d3aaf2 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs @@ -4426,7 +4426,7 @@ distPermsTail = -- | The lens for the nth permission in a 'DistPerms' stack nthVarPerm :: Member ps a -> ExprVar a -> Lens' (DistPerms ps) (ValuePerm a) nthVarPerm Member_Base x = distPermsHead x -nthVarPerm (Member_Step memb') x = distPermsTail . nthVarPerm memb' x +nthVarPerm (Member_Step meNMb) x = distPermsTail . nthVarPerm meNMb x -- | Test if a permission can be copied, i.e., whether @p -o p*p@. This is true -- iff @p@ does not contain any 'Write' modalities, any frame permissions, or @@ -4967,27 +4967,27 @@ genSubstMb :: s ctx' -> Mb ctx' (Mb ctx a) -> m (Mb ctx a) genSubstMb p s mbmb = mbM (fmap (genSubst s) (mbSwap p mbmb)) -genSubstMb' :: +genSubstNMb :: Substable s a m => NuMatching a => RAssign Proxy ctx -> - s ctx' -> Mb ctx' (Mb' ctx a) -> m (Mb' ctx a) -genSubstMb' p s mbmb = mbM' (fmap (genSubst s) (swapHelper p mbmb)) + s ctx' -> Mb ctx' (NMb ctx a) -> m (NMb ctx a) +genSubstNMb p s mbmb = nmbM (fmap (genSubst s) (swapHelper p mbmb)) -swapHelper :: RAssign Proxy b -> Mb a (Mb' b c) -> Mb' b (Mb a c) -swapHelper p m = Mb' ns (mbSwap p bs) +swapHelper :: RAssign Proxy b -> Mb a (NMb b c) -> NMb b (Mb a c) +swapHelper p m = NMb ns (mbSwap p bs) where ns = mbLift (fmap _mbNames m) bs = fmap _mbBinding m -instance {-# INCOHERENT #-} (Given (RAssign Proxy ctx), Substable s a m, NuMatching a) => Substable s (Mb' ctx a) m where - genSubst = genSubstMb' given +instance {-# INCOHERENT #-} (Given (RAssign Proxy ctx), Substable s a m, NuMatching a) => Substable s (NMb ctx a) m where + genSubst = genSubstNMb given -instance {-# INCOHERENT #-} (Substable s a m, NuMatching a) => Substable s (Mb' RNil a) m where - genSubst = genSubstMb' RL.typeCtxProxies +instance {-# INCOHERENT #-} (Substable s a m, NuMatching a) => Substable s (NMb RNil a) m where + genSubst = genSubstNMb RL.typeCtxProxies instance {-# INCOHERENT #-} (Substable s a m, NuMatching a) => Substable s (Binding' c a) m where - genSubst = genSubstMb' RL.typeCtxProxies + genSubst = genSubstNMb RL.typeCtxProxies instance SubstVar s m => Substable s (Member ctx a) m where @@ -5626,8 +5626,8 @@ instance AbstractVars (Name (a :: CrucibleType)) where abstractPEVars ns1 ns2 (n :: Name a) | Just memb <- memberElem n ns2 = return ( $(mkClosed - [| \prxs1 prxs2 memb' -> - nuMulti prxs1 (const $ nuMulti prxs2 (RL.get memb')) |]) + [| \prxs1 prxs2 meNMb -> + nuMulti prxs1 (const $ nuMulti prxs2 (RL.get meNMb)) |]) `clApply` closedProxies ns1 `clApply` closedProxies ns2 `clApply` toClosed memb) abstractPEVars _ _ _ = Nothing @@ -5636,9 +5636,9 @@ instance AbstractVars (Name (a :: Type)) where abstractPEVars ns1 ns2 (n :: Name a) | Just memb <- memberElem n ns1 = return ( $(mkClosed - [| \prxs1 prxs2 memb' -> + [| \prxs1 prxs2 meNMb -> nuMulti prxs1 $ \ns -> - nuMulti prxs2 (const $ RL.get memb' ns) |]) + nuMulti prxs2 (const $ RL.get meNMb ns) |]) `clApply` closedProxies ns1 `clApply` closedProxies ns2 `clApply` toClosed memb) abstractPEVars _ _ _ = Nothing diff --git a/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs b/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs index 89869ae569..4f84814a84 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs @@ -760,7 +760,7 @@ data TypedStmtSeq ext blocks tops ret ps_in where TypedConsStmt :: !ProgramLoc -> !(TypedStmt ext rets ps_in ps_next) -> !(RAssign Proxy rets) -> - !(Mb' rets (TypedStmtSeq ext blocks tops ret ps_next)) -> + !(NMb rets (TypedStmtSeq ext blocks tops ret ps_next)) -> TypedStmtSeq ext blocks tops ret ps_in -- | Typed version of 'TermStmt', which terminates the current block @@ -1209,7 +1209,7 @@ data TypedEntry phase ext blocks tops ret args ghosts = typedEntryPermsOut :: !(MbValuePerms (tops :> ret)), -- | The type-checked body of the entrypoint typedEntryBody :: !(TransData phase - (Mb' ((tops :++: args) :++: ghosts) + (NMb ((tops :++: args) :++: ghosts) (TypedStmtSeq ext blocks tops ret ((tops :++: args) :++: ghosts)))) } @@ -1939,7 +1939,7 @@ runPermCheckM :: DistPerms ((tops :++: args) :++: ghosts) -> PermCheckM ext cblocks blocks tops ret () ps_out r ((tops :++: args) :++: ghosts) ()) -> - TopPermCheckM ext cblocks blocks tops ret (Mb' ((tops :++: args) :++: ghosts) r) + TopPermCheckM ext cblocks blocks tops ret (NMb ((tops :++: args) :++: ghosts) r) runPermCheckM names entryID args ghosts mb_perms_in m = get >>= \(TopPermCheckState {..}) -> let args_prxs = cruCtxProxies args @@ -1951,8 +1951,8 @@ runPermCheckM names entryID args ghosts mb_perms_in m = z <- state (allocateDebugNames' (Just "ghost") (noNames' ghosts) ghosts) pure (x `rappend` y `rappend` z) in - liftInnerToTopM $ strongMbM' $ - flip nuMultiWithElim1' (Mb' dbgs (mbValuePermsToDistPerms mb_perms_in)) $ \ns perms_in -> + liftInnerToTopM $ strongNMbM $ + flip nuMultiWithElim1N (NMb dbgs (mbValuePermsToDistPerms mb_perms_in)) $ \ns perms_in -> let (tops_args, ghosts_ns) = RL.split Proxy ghosts_prxs ns (tops_ns, args_ns) = RL.split Proxy args_prxs tops_args st1 = emptyPermCheckState (distPermSet perms_in) tops_ns entryID local_names @@ -2596,7 +2596,7 @@ emitStmt :: emitStmt tps names loc stmt = let pxys = cruCtxProxies tps in allocateDebugNames Nothing names tps >>>= \debugs -> - startBinding' debugs (fmap (TypedConsStmt loc stmt pxys) . strongMbM') >>>= \ns -> + startBinding' debugs (fmap (TypedConsStmt loc stmt pxys) . strongNMbM) >>>= \ns -> modify (\st -> st { stPPInfo = ppInfoApplyAllocation ns debugs (stPPInfo st)}) >>> setVarTypes ns tps >>> gmodify (modifySTCurPerms (applyTypedStmt stmt ns)) >>> @@ -3982,7 +3982,7 @@ tcBlockEntryBody :: Block ext cblocks ret args -> TypedEntry TCPhase ext blocks tops ret (CtxToRList args) ghosts -> TopPermCheckM ext cblocks blocks tops ret - (Mb' ((tops :++: CtxToRList args) :++: ghosts) + (NMb ((tops :++: CtxToRList args) :++: ghosts) (TypedStmtSeq ext blocks tops ret ((tops :++: CtxToRList args) :++: ghosts))) tcBlockEntryBody names blk entry@(TypedEntry {..}) = runPermCheckM names typedEntryID typedEntryArgs typedEntryGhosts typedEntryPermsIn $ From 24d71221905fe7f4e4aa39447330322367d2352d Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Tue, 31 Aug 2021 14:24:03 -0700 Subject: [PATCH 28/28] Comments and more consistent naming --- .../src/Verifier/SAW/Heapster/IDESupport.hs | 6 +-- .../src/Verifier/SAW/Heapster/Implication.hs | 6 +-- .../src/Verifier/SAW/Heapster/JSONExport.hs | 4 +- .../src/Verifier/SAW/Heapster/NamedMb.hs | 43 +++++++++++++------ .../src/Verifier/SAW/Heapster/Permissions.hs | 6 +-- .../Verifier/SAW/Heapster/SAWTranslation.hs | 26 +++++------ .../Verifier/SAW/Heapster/TypedCrucible.hs | 2 +- 7 files changed, 54 insertions(+), 39 deletions(-) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs b/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs index de0503965a..fab9060bd9 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/IDESupport.hs @@ -133,7 +133,7 @@ instance (PermCheckExtC ext) let callers = callerIDs $ typedEntryCallers te ExtractionInfo { eiPPInfo = ppi, eiFnName = fname } <- ask let loc' = snd (ppLoc loc) - let debugNames = _mbNames (typedEntryBody te) + let debugNames = _nmbNames (typedEntryBody te) let inputs = mbLift $ flip nuMultiWithElim1 (typedEntryPermsIn te) $ \ns body -> @@ -208,8 +208,8 @@ nmbExtractLogEntries :: ExtractLogEntries a => NMb (ctx :: RList CrucibleType) a -> ExtractionM () nmbExtractLogEntries mb_a = ReaderT $ \einfo -> - tell $ mbLift $ flip nuMultiWithElim1 (_mbBinding mb_a) $ \ns x -> - let ppi' = ppInfoApplyAllocation ns (_mbNames mb_a) (eiPPInfo einfo) in + tell $ mbLift $ flip nuMultiWithElim1 (_nmbBinding mb_a) $ \ns x -> + let ppi' = ppInfoApplyAllocation ns (_nmbNames mb_a) (eiPPInfo einfo) in execWriter $ runReaderT (extractLogEntries x) (einfo { eiPPInfo = ppi' }) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs b/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs index b3882e1b03..768add6c98 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs @@ -1438,8 +1438,8 @@ permImplStep impl1@(Impl1_TryProveBVProp _ _ _) mb_impls = -- An or elimination fails if both branches fail permImplStep (Impl1_ElimOr _ _ _) (MbPermImpls_Cons _ (MbPermImpls_Cons _ MbPermImpls_Nil - (matchMbImplFail . _mbBinding -> Just msg1)) - (matchMbImplFail . _mbBinding -> Just msg2)) = + (matchMbImplFail . _nmbBinding -> Just msg1)) + (matchMbImplFail . _nmbBinding -> Just msg2)) = PermImpl_Step (Impl1_Fail $ GeneralError $ pretty (msg1 ++ "\n\n--------------------\n\n" ++ msg2)) MbPermImpls_Nil @@ -1456,7 +1456,7 @@ permImplStepUnary :: NuMatchingAny1 r => MbPermImpls r (RNil :> '(bs, ps_out)) -> PermImpl r ps_in -- If the continuation implication is a failure, percolate it up -permImplStepUnary _ (MbPermImpls_Cons _ _ (matchMbImplFail . _mbBinding -> Just msg)) = +permImplStepUnary _ (MbPermImpls_Cons _ _ (matchMbImplFail . _nmbBinding -> Just msg)) = PermImpl_Step (Impl1_Fail $ GeneralError $ pretty msg) MbPermImpls_Nil -- If the continuation implication is a catch with a failure on the right-hand diff --git a/heapster-saw/src/Verifier/SAW/Heapster/JSONExport.hs b/heapster-saw/src/Verifier/SAW/Heapster/JSONExport.hs index 19714178eb..2a9dff8d3c 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/JSONExport.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/JSONExport.hs @@ -73,8 +73,8 @@ instance JsonExport a => JsonExport (Mb (ctx :: RList CrucibleType) a) where ] instance JsonExport a => JsonExport (NMb (ctx :: RList CrucibleType) a) where - jsonExport mb = mbLift $ flip nuMultiWithElim1 (_mbBinding mb) $ \names body -> - let ?ppi = ppInfoApplyAllocation names (_mbNames mb) ?ppi in + jsonExport mb = mbLift $ flip nuMultiWithElim1 (_nmbBinding mb) $ \names body -> + let ?ppi = ppInfoApplyAllocation names (_nmbNames mb) ?ppi in object [ ("args", jsonExport names), ("body", jsonExport body) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/NamedMb.hs b/heapster-saw/src/Verifier/SAW/Heapster/NamedMb.hs index c8df4cd018..c6d4042f2b 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/NamedMb.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/NamedMb.hs @@ -14,48 +14,63 @@ import Control.Lens newtype StringF a = StringF { unStringF :: String } -type Binding' c = NMb (RNil :> c) +type NBinding c = NMb (RNil :> c) +-- | Named version of 'Mb' data NMb ctx a = NMb - { _mbNames :: RAssign StringF ctx - , _mbBinding :: Mb ctx a + { _nmbNames :: RAssign StringF ctx + , _nmbBinding :: Mb ctx a } deriving Functor -mbBinding :: Lens (NMb ctx a) (NMb ctx b) (Mb ctx a) (Mb ctx b) -mbBinding f x = NMb (_mbNames x) <$> f (_mbBinding x) +-- | Lens for accessing 'NMb' underlying 'Mb' +nmbBinding :: Lens (NMb ctx a) (NMb ctx b) (Mb ctx a) (Mb ctx b) +nmbBinding f x = NMb (_nmbNames x) <$> f (_nmbBinding x) +-- | 'Lens' for accessing 'NMb' debug names. +nmbNames :: Lens' (NMb ctx a) (RAssign StringF ctx) +nmbNames f x = (\n -> NMb n (_nmbBinding x)) <$> f (_nmbNames x) + +-- | Named version of 'nuMulti' nuMultiN :: RAssign StringF ctx -> (RAssign Name ctx -> b) -> NMb ctx b nuMultiN tps f = NMb - { _mbNames = tps - , _mbBinding = nuMulti (mapRAssign (const Proxy) tps) f + { _nmbNames = tps + , _nmbBinding = nuMulti (mapRAssign (const Proxy) tps) f } +-- | Named version of 'nuMultiWithElem1' nuMultiWithElim1N :: (RAssign Name ctx -> arg -> b) -> NMb ctx arg -> NMb ctx b -nuMultiWithElim1N = over mbBinding . nuMultiWithElim1 +nuMultiWithElim1N = over nmbBinding . nuMultiWithElim1 +-- | Named version of 'strongMbM' strongNMbM :: MonadStrongBind m => NMb ctx (m a) -> m (NMb ctx a) -strongNMbM = traverseOf mbBinding strongMbM +strongNMbM = traverseOf nmbBinding strongMbM +-- | Named version of 'mbM' nmbM :: (MonadBind m, NuMatching a) => NMb ctx (m a) -> m (NMb ctx a) -nmbM = traverseOf mbBinding mbM +nmbM = traverseOf nmbBinding mbM +-- | Named version of 'mbSwap' nmbSwap :: RAssign Proxy ctx -> NMb ctx' (NMb ctx a) -> NMb ctx (NMb ctx' a) nmbSwap p (NMb names' body') = NMb names' <$> nmbSink p body' +-- | Variant of 'mbSwap' that works with a mix of 'NMb' and 'Mb' nmbSink :: RAssign Proxy ctx -> Mb ctx' (NMb ctx a) -> NMb ctx (Mb ctx' a) nmbSink p m = NMb - { _mbNames = mbLift (_mbNames <$> m) - , _mbBinding = mbSwap p (_mbBinding <$> m) + { _nmbNames = mbLift (_nmbNames <$> m) + , _nmbBinding = mbSwap p (_nmbBinding <$> m) } +-- | Named version of 'mbLift' nmbLift :: Liftable a => NMb ctx a -> a -nmbLift = views mbBinding mbLift +nmbLift = views nmbBinding mbLift +-- | Named version of 'elimEmptyMb' elimEmptyNMb :: NMb RNil a -> a -elimEmptyNMb = views mbBinding elimEmptyMb +elimEmptyNMb = views nmbBinding elimEmptyMb +-- | Named version of 'emptyMb' emptyNMb :: a -> NMb RNil a emptyNMb = NMb MNil . emptyMb diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs index 9716d3aaf2..6ebf62849c 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs @@ -4977,8 +4977,8 @@ genSubstNMb p s mbmb = nmbM (fmap (genSubst s) (swapHelper p mbmb)) swapHelper :: RAssign Proxy b -> Mb a (NMb b c) -> NMb b (Mb a c) swapHelper p m = NMb ns (mbSwap p bs) where - ns = mbLift (fmap _mbNames m) - bs = fmap _mbBinding m + ns = mbLift (fmap _nmbNames m) + bs = fmap _nmbBinding m instance {-# INCOHERENT #-} (Given (RAssign Proxy ctx), Substable s a m, NuMatching a) => Substable s (NMb ctx a) m where genSubst = genSubstNMb given @@ -4986,7 +4986,7 @@ instance {-# INCOHERENT #-} (Given (RAssign Proxy ctx), Substable s a m, NuMatch instance {-# INCOHERENT #-} (Substable s a m, NuMatching a) => Substable s (NMb RNil a) m where genSubst = genSubstNMb RL.typeCtxProxies -instance {-# INCOHERENT #-} (Substable s a m, NuMatching a) => Substable s (Binding' c a) m where +instance {-# INCOHERENT #-} (Substable s a m, NuMatching a) => Substable s (NBinding c a) m where genSubst = genSubstNMb RL.typeCtxProxies diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index 678909ae84..c5bcbf310d 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -3133,7 +3133,7 @@ translatePermImplUnary :: PermImplTransM (ImplFailCont -> ImpTransM ext blocks tops ret ps ctx OpenTerm) translatePermImplUnary (mbMatch -> [nuMP| MbPermImpls_Cons _ _ mb_impl |]) f = - translatePermImpl Proxy (mbCombine RL.typeCtxProxies (fmap _mbBinding mb_impl)) >>= \trans -> + translatePermImpl Proxy (mbCombine RL.typeCtxProxies (fmap _nmbBinding mb_impl)) >>= \trans -> return $ \k -> f $ trans k @@ -3155,10 +3155,10 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl [nuMP| (MbPermImpls_Cons _ (MbPermImpls_Cons _ _ mb_impl1) mb_impl2) |]) -> pitmCatching (translatePermImpl prx $ mbCombine RL.typeCtxProxies $ - fmap _mbBinding mb_impl1) >>= \(mtrans1,hasf1) -> + fmap _nmbBinding mb_impl1) >>= \(mtrans1,hasf1) -> pitmCatching (translatePermImpl prx $ mbCombine RL.typeCtxProxies $ - fmap _mbBinding mb_impl2) >>= \(mtrans2,hasf2) -> + fmap _nmbBinding mb_impl2) >>= \(mtrans2,hasf2) -> (if hasf1 == HasFailures && hasf2 == HasFailures then tell ([],HasFailures) else return ()) >> case (mtrans1, hasf1, mtrans2, hasf2) of @@ -3196,10 +3196,10 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl [nuMP| (MbPermImpls_Cons _ (MbPermImpls_Cons _ _ mb_impl1) mb_impl2) |]) -> pitmCatching (translatePermImpl prx $ mbCombine RL.typeCtxProxies $ - fmap _mbBinding mb_impl1) >>= \(mtrans1,hasf1) -> + fmap _nmbBinding mb_impl1) >>= \(mtrans1,hasf1) -> pitmCatching (translatePermImpl prx $ mbCombine RL.typeCtxProxies $ - fmap _mbBinding mb_impl2) >>= \(mtrans2,hasf2) -> + fmap _nmbBinding mb_impl2) >>= \(mtrans2,hasf2) -> tell ([],hasf1 <> hasf2) >> case (mtrans1, mtrans2) of (Nothing, Nothing) -> mzero @@ -3336,7 +3336,7 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl -- considered just an assertion and not a failure ([nuMP| Impl1_TryProveBVProp x prop@(BVProp_Eq e1 e2) prop_str |], [nuMP| MbPermImpls_Cons _ _ mb_impl' |]) -> - translatePermImpl prx (mbCombine RL.typeCtxProxies $ fmap _mbBinding mb_impl') >>= \trans -> + translatePermImpl prx (mbCombine RL.typeCtxProxies $ fmap _nmbBinding mb_impl') >>= \trans -> return $ \k -> do prop_tp_trans <- translate prop applyMultiTransM (return $ globalOpenTerm "Prelude.maybe") @@ -3352,7 +3352,7 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl -- For an inequality test, we don't need a proof, so just insert an if ([nuMP| Impl1_TryProveBVProp x prop@(BVProp_Neq e1 e2) prop_str |], [nuMP| MbPermImpls_Cons _ _ mb_impl' |]) -> - translatePermImpl prx (mbCombine RL.typeCtxProxies $ fmap _mbBinding mb_impl') >>= \trans -> + translatePermImpl prx (mbCombine RL.typeCtxProxies $ fmap _nmbBinding mb_impl') >>= \trans -> return $ \k -> let w = natVal2 prop in applyMultiTransM (return $ globalOpenTerm "Prelude.ite") @@ -3377,7 +3377,7 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl ([nuMP| Impl1_TryProveBVProp x prop@(BVProp_ULt e1 e2) prop_str |], [nuMP| MbPermImpls_Cons _ _ mb_impl' |]) -> - translatePermImpl prx (mbCombine RL.typeCtxProxies $ fmap _mbBinding mb_impl') >>= \trans -> + translatePermImpl prx (mbCombine RL.typeCtxProxies $ fmap _nmbBinding mb_impl') >>= \trans -> return $ \k -> do prop_tp_trans <- translate prop applyMultiTransM (return $ globalOpenTerm "Prelude.maybe") @@ -3404,7 +3404,7 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl ([nuMP| Impl1_TryProveBVProp x prop@(BVProp_ULeq e1 e2) prop_str |], [nuMP| MbPermImpls_Cons _ _ mb_impl' |]) -> - translatePermImpl prx (mbCombine RL.typeCtxProxies $ fmap _mbBinding mb_impl') >>= \trans -> + translatePermImpl prx (mbCombine RL.typeCtxProxies $ fmap _nmbBinding mb_impl') >>= \trans -> return $ \k -> do prop_tp_trans <- translate prop applyMultiTransM (return $ globalOpenTerm "Prelude.maybe") @@ -3421,7 +3421,7 @@ translatePermImpl1 prx mb_impl mb_impls = case (mbMatch mb_impl, mbMatch mb_impl ([nuMP| Impl1_TryProveBVProp x prop@(BVProp_ULeq_Diff e1 e2 e3) prop_str |], [nuMP| MbPermImpls_Cons _ _ mb_impl' |]) -> - translatePermImpl prx (mbCombine RL.typeCtxProxies $ fmap _mbBinding mb_impl') >>= \trans -> + translatePermImpl prx (mbCombine RL.typeCtxProxies $ fmap _nmbBinding mb_impl') >>= \trans -> return $ \k -> do prop_tp_trans <- translate prop applyMultiTransM (return $ globalOpenTerm "Prelude.maybe") @@ -3833,7 +3833,7 @@ translateCallEntry nm entry_trans mb_tops_args mb_ghosts = -- If not, continue by translating entry, setting the variable -- permission map to empty (as in the beginning of a block) clearVarPermsM $ translate $ - fmap (\s -> varSubst s $ _mbBinding $ typedEntryBody entry) mb_s + fmap (\s -> varSubst s $ _nmbBinding $ typedEntryBody entry) mb_s instance PermCheckExtC ext => @@ -4119,7 +4119,7 @@ instance PermCheckExtC ext => translate mb_x = case mbMatch mb_x of [nuMP| TypedImplStmt impl_seq |] -> translate impl_seq [nuMP| TypedConsStmt loc stmt pxys mb_seq |] -> - translateStmt (mbLift loc) stmt (translate $ mbCombine (mbLift pxys) (_mbBinding <$> mb_seq)) + translateStmt (mbLift loc) stmt (translate $ mbCombine (mbLift pxys) (_nmbBinding <$> mb_seq)) [nuMP| TypedTermStmt _ term_stmt |] -> translate term_stmt instance PermCheckExtC ext => @@ -4249,7 +4249,7 @@ translateEntryBody mapTrans entry = lambdaPermCtx (typedEntryPermsIn entry) $ \pctx -> do retType <- translateEntryRetType entry impTransM (RL.members pctx) pctx mapTrans retType $ translate $ - _mbBinding $ typedEntryBody entry + _nmbBinding $ typedEntryBody entry -- | Translate all the entrypoints in a 'TypedBlockMap' that correspond to -- letrec-bound functions to SAW core functions as in 'translateEntryBody' diff --git a/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs b/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs index 4f84814a84..a6cc6caec5 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs @@ -4019,7 +4019,7 @@ proveCallSiteImpl :: ((tops :++: args) :++: vars) tops args ghosts) proveCallSiteImpl srcID destID args ghosts vars mb_perms_in mb_perms_out = - fmap (CallSiteImpl . _mbBinding) $ runPermCheckM [] srcID args vars mb_perms_in $ + fmap (CallSiteImpl . _nmbBinding) $ runPermCheckM [] srcID args vars mb_perms_in $ \tops_ns args_ns _ perms_in -> let perms_out = give (cruCtxProxies ghosts) $